david
778b05bf9f
- Mustangpeak Common Library - 1.7.0 - EasyListview - 1.7.0 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.Mustangpeak@2 60b41242-d4b9-2247-b156-4ccd40706241
5066 lines
172 KiB
ObjectPascal
5066 lines
172 KiB
ObjectPascal
unit MPCommonUtilities;
|
||
|
||
// Version 1.7.0
|
||
//
|
||
// The contents of this file are subject to the Mozilla Public License
|
||
// Version 1.1 (the "License"); you may not use this file except in compliance
|
||
// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
|
||
//
|
||
// Alternatively, you may redistribute this library, use and/or modify it under the terms of the
|
||
// GNU Lesser General Public License as published by the Free Software Foundation;
|
||
// either version 2.1 of the License, or (at your option) any later version.
|
||
// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
|
||
//
|
||
// Software distributed under the License is distributed on an "AS IS" basis,
|
||
// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the
|
||
// specific language governing rights and limitations under the License.
|
||
//
|
||
// The initial developer of this code is Jim Kueneman <jimdk@mindspring.com>
|
||
// Special thanks to the following in no particular order for their help/support/code
|
||
// Danijel Malik, Robert Lee, Werner Lehmann, Alexey Torgashin, Milan Vandrovec
|
||
//
|
||
//----------------------------------------------------------------------------
|
||
|
||
// The following are implemented in Win 95:
|
||
// EnumResourceLanguagesW
|
||
// EnumResourceNamesW
|
||
// EnumResourceTypesW
|
||
// ExtTextOutW
|
||
// FindResourceW
|
||
// FindResourceExW
|
||
// GetCharWidthW
|
||
// GetCommandLineW
|
||
// GetTextExtentPoint32W
|
||
// GetTextExtentPointW
|
||
// lstrlenW
|
||
// MessageBoxExW
|
||
// MessageBoxW
|
||
// MultiByteToWideChar
|
||
// TextOutW
|
||
// WideCharToMultiByte
|
||
|
||
{$IFDEF TNTSUPPORT}
|
||
// IMPORTANT - PLEASE READ then comment this line out.
|
||
// If using TNT you MUST include the TNT package for your specific compiler in the
|
||
// Requires section of this package. It may be possible to compile without doing
|
||
// this but you WILL eventually have strange crashes in your application that will
|
||
// be difficult to understand. The best way to do this in my opinion is to create
|
||
// a new folder in the package install directory called "Delphi_TNT" (or CBuilder_TNT)
|
||
// and copy all the files from the Delphi (or CBuilder) folder into it. Now open the
|
||
// MPCommonLibDx.dpk (or bpk) file in the "Delphi_TNT" (or CBuilder_TNT) based on your compiler
|
||
// version in a text editor. In the "Requires" section add "TNTUnicodeVcl_Rx0", where
|
||
// the "x" is the version of Delphi you are using. Open the dpk (bpk) file in your
|
||
// IDE. Select the menu option Projects>Options>Directories/Conditionals>Conditional
|
||
// and enter TNTSUPPORT. Compile the package, then open the MPCommonLibDxD.dpk (or bpk)
|
||
// and compile and press the Install button.
|
||
// Now when you update the packages you won't have to redo all this. Just install
|
||
// the update then compile the packages in the "Delphi_TNT" (or CBuilder_TNT) folders
|
||
// an you are done.
|
||
{$ENDIF}
|
||
|
||
{$B-}
|
||
|
||
{$I Compilers.inc}
|
||
{$I Options.inc}
|
||
{$I ..\Include\Debug.inc}
|
||
{$I ..\Include\Addins.inc}
|
||
|
||
interface
|
||
|
||
uses
|
||
Windows,
|
||
Messages,
|
||
SysUtils,
|
||
Classes,
|
||
Graphics,
|
||
Controls,
|
||
Forms,
|
||
Math,
|
||
ActiveX,
|
||
ShlObj,
|
||
{$IFDEF COMPILER_6_UP}
|
||
Variants,
|
||
RTLConsts,
|
||
{$ELSE}
|
||
Consts,
|
||
{$ENDIF COMPILER_6_UP}
|
||
{$IFNDEF COMPILER_6_UP}
|
||
Menus,
|
||
{$ENDIF}
|
||
{$IFDEF TNTSUPPORT}
|
||
TntSysUtils,
|
||
TntClasses,
|
||
{$ENDIF}
|
||
ShellAPI,
|
||
ComCtrls,
|
||
ComObj,
|
||
CommCtrl,
|
||
MPShellTypes,
|
||
MPResources;
|
||
|
||
const
|
||
WideNull = WideChar(#0);
|
||
WideCR = WideChar(#13);
|
||
WideLF = WideChar(#10);
|
||
WideLineSeparator = WideChar(#2028);
|
||
WideSpace = WideChar(#32);
|
||
WidePeriod = WideChar('.');
|
||
|
||
{$IFNDEF COMPILER_6_UP}
|
||
NullAsStringValue: string = '';
|
||
{$ENDIF}
|
||
|
||
Shlwapi = 'shlwapi.dll';
|
||
|
||
var
|
||
SEasyNSEMsg_Caption: WideString = 'Shell extension registration';
|
||
SEasyNSEMsg_CannotRegister: WideString = 'Cannot register shell extension.';
|
||
SEasyNSEMsg_CannotUnRegister: WideString = 'Cannot unregister shell extension.';
|
||
SEasyNSEMsg_CannotFindRegSvr: WideString = 'Unable to find RegSvr32.exe executable.';
|
||
SEasyNSEMsg_CannotFindDLL: WideString = 'Unable to find extension DLL.';
|
||
|
||
type
|
||
TCommonWideCharArray = array of WideChar;
|
||
TCommonPWideCharArray = array of PWideChar;
|
||
TCommonWideStringDynArray = array of WideString;
|
||
TCommonIntegerDynArray = array of Integer;
|
||
|
||
{$IFNDEF COMPILER_6_UP}
|
||
TValueRelationship = -1..1;
|
||
TSeekOrigin = (soBeginning, soCurrent, soEnd);
|
||
{$ENDIF}
|
||
|
||
TCommonDropEffect = (
|
||
cdeNone, // No drop effect (the circle with the slash through it
|
||
cdeCopy, // Copy the dropped object
|
||
cdeMove, // Move the dropped object
|
||
cdeLink, // Make a shortcut to the dropped object
|
||
cdeScroll // The dragging is in the middle of a scroll
|
||
);
|
||
TCommonDropEffects = set of TCommonDropEffect;
|
||
|
||
TCommonOLEDragResult = (
|
||
cdrDrop, // The drag resulted in a drop
|
||
cdrCancel, // The drag resulted in being canceled
|
||
cdrError // The drag resulted in an unknown error
|
||
);
|
||
|
||
TCommonKeyState = (
|
||
cksControl, // Control Key is down
|
||
cksLButton, // Left Mouse is down
|
||
cksMButton, // Middle Mouse is down
|
||
cksRButton, // Right Mouse is down
|
||
cksShift, // Shift Key is down
|
||
cksAlt, // Alt Key is down
|
||
cksButton // One of the mouse buttons are down
|
||
);
|
||
TCommonKeyStates = set of TCommonKeyState;
|
||
|
||
TCommonMouseButton = (
|
||
cmbNone, // No Button
|
||
cmbLeft, // Left Button
|
||
cmbRight, // Right Button
|
||
cmbMiddle // Middle Button
|
||
);
|
||
|
||
TCommonVAlignment = (
|
||
cvaTop, // The vertical alignment of the text is at the top of the object
|
||
cvaBottom, // The vertical alignment of the text is at the bottom of the object
|
||
cvaCenter // The vertical alignment of the text is at the center of the object
|
||
);
|
||
|
||
// Flags for the DrawTextWEx function
|
||
TCommonDrawTextWFlag = (
|
||
dtSingleLine, // Put Caption on one line
|
||
dtLeft, // Aligns Text Left
|
||
dtRight, // Aligns Text Right
|
||
dtCenter, // Aligns Text Center
|
||
dtTop, // Vertical Align Text to Bottom of Rect
|
||
dtBottom, // Vertical Align Text to Bottom of Rect
|
||
// Only valid with: dtSingleLine
|
||
dtVCenter, // Vertical Align Text to Center of Rect
|
||
// Only valid with: dtSingleLine
|
||
dtCalcRect, // Modifies the Rectangle to the size required for the Text does
|
||
// not draw the text. By default it does not modify the right
|
||
// edge of the rectangle, it only changes the height to fit
|
||
// the text, see dtCalcRectAdjR
|
||
dtCalcRectAdjR, // Modifies the Rectangles right edge for a best fit of the text
|
||
// Does not increase the width only shortens it,
|
||
// Only valid with: dtCalcRect
|
||
dtCalcRectAlign, // Modifies the rectangle by aligning it with the original
|
||
// rectangle based on the dtLeft, dtRight, dtCenter flag.
|
||
// In other words it ensures that if the text won't fit that
|
||
// only the end of the text is clipped. For instance if
|
||
// the text is horz centered the calculation could clip
|
||
// both ends of the text. Just using the dtCalcRectAdjR
|
||
// flag will only stretch the Right edge and the left will
|
||
// still be clipped. Using this flag will shift the rect
|
||
// to the edge of the passed rect so that the beginning
|
||
// of the text is always shown.
|
||
// Only valid with: dtCalcRect and dtCalcRectAdjR
|
||
dtEndEllipsis, // Adds a "..." to the end of the string if it will not fit in
|
||
// the passed rectangle
|
||
dtWordBreak, // Breaks the passed string to best fit in the rectangle
|
||
// The default Characters to break the line are:
|
||
// WideSpace ( WideChar(#32) )
|
||
// WideCR/WideLF sequence or individually ( WideChar(#13 or #10) )
|
||
// WideLineSeparator ( WideChar(#2028) )
|
||
dtUserBreakChars, // The UserBreakChars parameters should be used for defining
|
||
// what to use to break the passed string into lines
|
||
// Only valid with: dtWordBreak
|
||
dtRTLReading, // Right to Left reading
|
||
dtNoClip // Do not clip the text in the rectangle
|
||
);
|
||
TCommonDrawTextWFlags = set of TCommonDrawTextWFlag;
|
||
|
||
// Describes the mode how to blend pixels.
|
||
TCommonBlendMode = (
|
||
cbmConstantAlpha, // apply given constant alpha
|
||
cbmPerPixelAlpha, // use alpha value of the source pixel
|
||
cbmMasterAlpha, // use alpha value of source pixel and multiply it with the constant alpha value
|
||
cbmConstantAlphaAndColor // blend the destination color with the given constant color und the constant alpha value
|
||
);
|
||
|
||
TShortenStringEllipsis = (
|
||
sseEnd, // Ellipsis on end of string
|
||
sseFront, // Ellipsis on begining of string
|
||
sseMiddle, // Ellipsis in middle of string
|
||
sseFilePathMiddle // Ellipsis is in middle of string but tries to show the entire filename
|
||
);
|
||
|
||
// RGB (red, green, blue) color given in the range [0..1] per component.
|
||
TCommonRGB = record
|
||
R, G, B: Double;
|
||
end;
|
||
|
||
// Hue, luminance, saturation color with all three components in the range [0..1]
|
||
// (so hue's 0..360<EFBFBD> is normalized to 0..1).
|
||
TCommonHLS = record
|
||
H, L, S: Double;
|
||
end;
|
||
|
||
// Enhanced library loading functions that reference counts the loading to make
|
||
// sure that libraries are freed when using cool controls in COM applications
|
||
function CommonLoadLibrary(LibraryName: string): THandle;
|
||
function CommonUnloadLibrary(LibraryName: string): Boolean;
|
||
procedure CommonUnloadAllLibraries;
|
||
|
||
function FlipReverseCopyRect(const Flip, Reverse: Boolean; const Bitmap: TBitmap): TBitmap; overload;
|
||
procedure FlipReverseCopyRect(const Flip, Reverse: Boolean; R: TRect; const Canvas: TCanvas); overload;
|
||
|
||
procedure DrawRadioButton(Canvas: TCanvas; Pos: TPoint; Size: Integer; clBackground, clHotBkGnd,
|
||
clLeftOuter, clRightOuter, clLeftInner, clRightInner: TColor; Checked, Enabled, Hot: Boolean);
|
||
procedure DrawCheckBox(Canvas: TCanvas; Pos: TPoint; Size: Integer; clBackground, clHotBkGnd,
|
||
clLeftOuter, clRightOuter, clLeftInner, clRightInner: TColor; Checked, Enabled, Hot: Boolean);
|
||
function CheckBounds(Size: Integer): TRect;
|
||
|
||
|
||
|
||
{$IFNDEF COMPILER_6_UP}
|
||
function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString;
|
||
function VarToWideStr(const V: Variant): WideString;
|
||
function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string;
|
||
function CompareTime(const A, B: TDateTime): TValueRelationship;
|
||
function WideCompareText(S1, S2: WideString): Integer;
|
||
function ExcludeTrailingBackslash(Path: WideString): WideString;
|
||
function IncludeTrailingBackslash(Path: WideString): WideString;
|
||
function GUIDToString(const GUID: TGUID): string;
|
||
{$ENDIF}
|
||
|
||
function AbsRect(ARect: TRect): TRect;
|
||
function AddContextMenuItem(Menu: HMenu; ACaption: WideString; Index: Integer;
|
||
MenuID: UINT = $FFFF; hSubMenu: UINT = 0; Enabled: Boolean = True;
|
||
Checked: Boolean = False; Default: Boolean = False): Integer;
|
||
function AddCommas(NumberString: WideString): WideString;
|
||
function CalcuateFolderSize(FolderPath: WideString; Recurse: Boolean): Int64;
|
||
function CenterRectHorz(OuterRect, InnerRect: TRect): TRect;
|
||
function CenterRectInRect(OuterRect, InnerRect: TRect): TRect;
|
||
function CenterRectVert(OuterRect, InnerRect: TRect): TRect;
|
||
function CommonSupports(const Instance: IUnknown; const IID: TGUID): Boolean; overload;
|
||
function CommonSupports(const Instance: IUnknown; const IID: TGUID; out Intf): Boolean; overload;
|
||
function CommonSupports(const Instance: TObject; const IID: TGUID): Boolean; overload;
|
||
function CommonSupports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; overload;
|
||
procedure CopyToNullBufferA(S: WideString; Buffer: PChar; CharCount: Cardinal);
|
||
procedure CopyToNullBufferW(S: WideString; Buffer: PWideChar; CharCount: Cardinal);
|
||
procedure CreateProcessMP(ExeFile, Parameters, InitalDir: WideString);
|
||
function DiffRectHorz(Rect1, Rect2: TRect): TRect;
|
||
function DiffRectVert(Rect1, Rect2: TRect): TRect;
|
||
{$IFNDEF COMPILER_6_UP}
|
||
function DirectoryExists(const Directory: string): Boolean;
|
||
{$ENDIF}
|
||
function DiskInDrive(C: Char): Boolean;
|
||
function DragDetectPlus(Handle: HWND; Pt: TPoint): Boolean;
|
||
function DrawTextWEx(DC: HDC; Text: WideString; var lpRect: TRect; Flags: TCommonDrawTextWFlags; MaxLineCount: Integer): Integer;
|
||
function DropEffectToStr(DropEffect: DWORD): WideString;
|
||
function EqualWndMethod(A, B: TWndMethod): Boolean;
|
||
function FileExistsW(const FileName: WideString): Boolean;
|
||
function FileIconInit(FullInit: BOOL): BOOL; stdcall;
|
||
function FindUniqueMenuID(AMenu: HMenu): Cardinal;
|
||
function GetMyDocumentsVirtualFolder: PItemIDList;
|
||
function HasMMX: Boolean;
|
||
function IncludeTrailingBackslashW(const S: WideString): WideString;
|
||
function IsAnyMouseButtonDown: Boolean;
|
||
function IsFTPPath(Path: WideString): Boolean;
|
||
function IsMappedDrivePath(const Path: WideString): Boolean;
|
||
function IsRectNull(ARect: TRect): Boolean;
|
||
function IsTextTrueType(Canvas: TCanvas): Boolean; overload;
|
||
function IsTextTrueType(DC: HDC): Boolean; overload;
|
||
function IsUNCPath(const Path: WideString): Boolean;
|
||
function IsUnicode: Boolean; // OS supports Unicode functions (basiclly means IsWinNT or XP)
|
||
function IsWin2000: Boolean;
|
||
function IsWin95_SR1: Boolean;
|
||
function IsWinME: Boolean;
|
||
function IsWinNT: Boolean;
|
||
function IsWinNT4: Boolean;
|
||
function IsWinXP: Boolean;
|
||
function IsWinXPOrUp: Boolean;
|
||
function IsWinVista: Boolean;
|
||
function IsWinVistaOrUp: Boolean;
|
||
procedure MakeFindDataW(const FindFileDataA: TWIN32FindDataA; var FindFileDataW: TWIN32FindDataW);
|
||
function ModuleFileName(PathOnly: Boolean = True): WideString;
|
||
function PIDLToPath(PIDL: PItemIDList): WideString;
|
||
function SHGetImageList(iImageList: Integer; const RefID: TGUID; out ppvOut): HRESULT; stdcall;
|
||
function ShiftStateToKeys(Keys: TShiftState): LongWord;
|
||
function ShiftStateToStr(Keys: TShiftState): WideString;
|
||
function ShortenStringEx(DC: HDC; const S: WideString; Width: Integer; RTL: Boolean; EllipsisPlacement: TShortenStringEllipsis): WideString;
|
||
function ShortenTextW(DC: hDC; TextToShorten: WideString; MaxSize: Integer): WideString;
|
||
function ShortFileName(const FileName: WideString): WideString;
|
||
function ShortPath(const Path: WideString): WideString;
|
||
function Size(cx, cy: Integer): TSize;
|
||
function SplitTextW(DC: hDC; TextToSplit: WideString; MaxWidth: Integer; var Buffer: TCommonWideCharArray; MaxSplits: Integer): Integer;
|
||
function StrRetToStr(StrRet: TStrRet; APIDL: PItemIDList): WideString;
|
||
function SystemDirectory: WideString;
|
||
function SysMenuFont: HFONT;
|
||
function SysMenuHeight: Integer;
|
||
function TextExtentW(Text: PWideChar; Canvas: TCanvas): TSize; overload;
|
||
function TextExtentW(Text: PWideChar; DC: hDC): TSize; overload;
|
||
function TextExtentW(Text: WideString; Canvas: TCanvas): TSize; overload;
|
||
function TextExtentW(Text: WideString; Font: TFont): TSize; overload;
|
||
function TextTrueExtentsW(Text: WideString; DC: HDC): TSize;
|
||
function TNTConditionallyDefined: Boolean;
|
||
function UnicodeStringLists: Boolean;
|
||
function UniqueDirName(const ADirPath: WideString): WideString;
|
||
function UniqueFileName(const AFilePath: WideString): WideString;
|
||
function VariantToCaption(const V: Variant): WideString;
|
||
function WideCreateDir(Path: WideString): Boolean;
|
||
function WideDirectoryExists(const Name: WideString): Boolean;
|
||
function WideExcludeTrailingBackslash(Path: WideString): WideString;
|
||
function WideExpandEnviromentString(EnviromentString: WideString): WideString;
|
||
function WideExtractFileDir(Path: WideString): WideString;
|
||
function WideExtractFileDrive(Path: WideString): WideString;
|
||
function WideExtractFileExt(Path: WideString): WideString;
|
||
function WideExtractFileName(Path: WideString): WideString;
|
||
function WideExtractFilePath(Path: WideString): WideString;
|
||
function WideFileExists(Path: WideString): Boolean;
|
||
function WideFindFirstFileEx(FileName: WideString; var lpFindFileData: TWIN32FindDataW; Mask: WideString; CaseSensitive: Boolean): THandle;
|
||
function WideFindFirstFileExExists: Boolean;
|
||
function WideGetCurrentDir: WideString;
|
||
function WideGetTempDir: WideString;
|
||
function WideIncludeTrailingBackslash(Path: WideString): WideString;
|
||
function WideIncrementalSearch(CompareStr, Mask: WideString): Integer;
|
||
function WideIntToStr(Value: integer): WideString;
|
||
function WideIsDrive(Drive: WideString): Boolean;
|
||
function WideIsFloppy(FileFolder: WideString): boolean;
|
||
function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean;
|
||
function WideLowerCase(const Str: WideString): WideString;
|
||
function WideMessageBox(Window: HWND; const ACaption, AMessage: WideString; uType: integer): integer;
|
||
function WideNewFolderName(ParentFolder: WideString; SuggestedFolderName: WideString = ''): WideString;
|
||
function WidePathMatchSpec(Path, Mask: WideString): Boolean;
|
||
function WidePathMatchSpecExists: Boolean;
|
||
function WideShellExecute(hWnd: HWND; Operation, FileName, Parameters, Directory: WideString; ShowCmd: Integer = SW_NORMAL): HINST;
|
||
function WideStrComp(Str1, Str2: PWideChar): Integer;
|
||
function WideStrLower(Str: PWideChar): PWideChar;
|
||
function WideStrIComp(Str1, Str2: PWideChar): Integer;
|
||
function WideStringReplace(const S, OldPattern, NewPattern: WideString; Flags: TReplaceFlags; WholeWord: Boolean = False): WideString;
|
||
function WideStripExt(AFile: WideString): WideString;
|
||
function WideStripLeadingBackslash(const S: WideString): WideString;
|
||
function WideStripRemoteComputer(const UNCPath: WideString): WideString;
|
||
function WideStripTrailingBackslash(const S: WideString; Force: Boolean = False): WideString;
|
||
function WideStrMove(Dest, Source: PWideChar; Count: Cardinal): PWideChar;
|
||
function WideStrPos(Str, SubStr: PWideChar): PWideChar;
|
||
function WideStrRScan(Str: PWideChar; Chr: WideChar): PWideChar;
|
||
function WideStrScan(Str: PWideChar; Chr: WideChar): PWideChar;
|
||
function WideUpperCase(const S: WideString): WideString;
|
||
function WindowsDirectory: WideString;
|
||
procedure AlphaBlend(Source, Destination: HDC; R: TRect; Target: TPoint; Mode: TCommonBlendMode; ConstantAlpha, Bias: Integer);
|
||
procedure ConvertBitmapEx(Image32: TBitmap; var OutImage: TBitmap; const BackGndColor: TColor);
|
||
procedure ShadowBlendBits(Bits: TBitmap; BackGndColor: TColor);
|
||
procedure FillWideChar(var Dest; count: Integer; Value: WideChar);
|
||
procedure FreeMemAndNil(var P: Pointer);
|
||
procedure LoadWideString(S: TStream; var Str: WideString);
|
||
procedure MinMax(var A, B: Integer);
|
||
procedure SaveWideString(S: TStream; Str: WideString);
|
||
procedure WideInsert(Source: WideString; var S: WideString; Index: Integer);
|
||
procedure WideShowMessage(Window: HWND; ACaption, AMessage: WideString);
|
||
procedure WideStrLCopy(Str1, Str2: PWideChar; Count: Integer);
|
||
|
||
// Rectangle functions
|
||
function ProperRect(Rect: TRect): TRect;
|
||
function RectHeight(R: TRect): Integer;
|
||
function RectToStr(R: TRect): string;
|
||
function RectToSquare(R: TRect): TRect;
|
||
function RectWidth(R: TRect): Integer;
|
||
function ContainsRect(OuterRect, InnerRect: TRect): Boolean;
|
||
function IsRectProper(Rect: TRect): Boolean;
|
||
|
||
// WideString routines (many borrowed from Mike Liscke)
|
||
function StrCopyW(Dest, Source: PWideChar): PWideChar;
|
||
|
||
function KeyDataToShiftState(KeyData: Longint): TShiftState;
|
||
function KeyToKeyStates(Keys: Word): TCommonKeyStates;
|
||
function KeyStatesToMouseButton(Keys: Word): TCommonMouseButton;
|
||
function KeyStatesToKey(Keys: TCommonKeyStates): Longword;
|
||
function DropEffectToDropEffectStates(Effect: Integer): TCommonDropEffects;
|
||
function DropEffectStatesToDropEffect(Effect: TCommonDropEffects): Integer;
|
||
function DropEffectToDropEffectState(Effect: Integer): TCommonDropEffect;
|
||
function DropEffectStateToDropEffect(Effect: TCommonDropEffect): Integer;
|
||
function KeyStateToDropEffect(Keys: TCommonKeyStates): TCommonDropEffect;
|
||
function KeyStateToMouseButton(KeyState: TCommonKeyStates): TCommonMouseButton;
|
||
|
||
// Color Functions
|
||
function RGBToHLS(const RGB: TCommonRGB): TCommonHLS;
|
||
function HLSToRGB(const HLS: TCommonHLS): TCommonRGB;
|
||
function BrightenColor(const RGB: TCommonRGB; Amount: Double): TCommonRGB;
|
||
function DarkenColor(const RGB: TCommonRGB; Amount: Double): TCommonRGB;
|
||
function MakeTRBG(Color: TColor): TCommonRGB;
|
||
function MakeTColor(RGB: TCommonRGB): TColor;
|
||
function MakeColorRef(RGB: TCommonRGB; Gamma: Double = 1): COLORREF;
|
||
procedure GammaCorrection(var RGB: TCommonRGB; Gamma: Double);
|
||
function MakeSafeColor(var RGB: TCommonRGB): Boolean;
|
||
function UpsideDownDIB(Bits: TBitmap): Boolean;
|
||
procedure FixFormFont(AFont: TFont);
|
||
|
||
// Window Manipulation
|
||
procedure ActivateTopLevelWindow(Child: HWND);
|
||
|
||
// Graphics
|
||
procedure FillGradient(X1, Y1, X2, Y2: integer; fStartColor, fStopColor: TColor;
|
||
StartPoint, EndPoint: integer; fDrawCanvas: TCanvas);
|
||
|
||
// Helpers to create a callback function out of a object method
|
||
function CreateStub(ObjectPtr: Pointer; MethodPtr: Pointer): Pointer;
|
||
procedure DisposeStub(Stub: Pointer);
|
||
|
||
{$IFNDEF COMPILER_6_UP}
|
||
function Supports(const Instance: IUnknown; const IID: TGUID): Boolean; overload;
|
||
procedure ClearMenuItems(Menu: TMenu);
|
||
{$ENDIF}
|
||
|
||
{$IFNDEF COMPILER_5_UP}
|
||
function Supports(const Instance: IUnknown; const IID: TGUID; out Intf): Boolean; overload;
|
||
function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; overload;
|
||
procedure FreeAndNil(var Obj);
|
||
|
||
type
|
||
TWMContextMenu = packed record
|
||
Msg: Cardinal;
|
||
hWnd: HWND;
|
||
case Integer of
|
||
0: (
|
||
XPos: Smallint;
|
||
YPos: Smallint);
|
||
1: (
|
||
Pos: TSmallPoint;
|
||
Result: Longint);
|
||
end;
|
||
{$ENDIF}
|
||
|
||
// ****************************************************************************
|
||
// Registration function for Shell and Namespace Extensions
|
||
// Donated by by Alexey Torgashin
|
||
// Note: we assume that paths to both RegSvr32.exe and extension DLL are ANSI (not Unicode).
|
||
// ****************************************************************************
|
||
type
|
||
TEasyNSERegMessages = set of (enseMsgShowErrors, enseMsgRegSvr);
|
||
|
||
//True to register or False to unregister
|
||
function RegUnregNSE(const AFileName: WideString; DoRegister: boolean; AMessages: TEasyNSERegMessages = [enseMsgShowErrors]): boolean;
|
||
function RegisterNSE(const AFileName: WideString; AMessages: TEasyNSERegMessages = [enseMsgShowErrors]): boolean;
|
||
function UnregisterNSE(const AFileName: WideString; AMessages: TEasyNSERegMessages = [enseMsgShowErrors]): boolean;
|
||
function ExecShellEx(const Cmd, Params, Dir: WideString; ShowCmd: integer;
|
||
DoWait: boolean): boolean;
|
||
//
|
||
// Dynamically linked Unicode functions that do not have stubs on Win9x
|
||
//
|
||
var
|
||
GetDriveTypeW_MP: function(lpRootPathName: PWideChar): UINT; stdcall;
|
||
DrawTextW_MP: function(hDC: HDC; lpString: PWideChar; nCount: Integer;
|
||
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
|
||
SHGetFileInfoW_MP: function(pszPath: PWideChar; dwFileAttributes: DWORD;
|
||
var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; stdcall;
|
||
CreateFileW_MP: function(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD;
|
||
lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD;
|
||
hTemplateFile: THandle): THandle; stdcall;
|
||
SHGetDataFromIDListW_MP: function(psf: IShellFolder; pidl: PItemIDList;
|
||
nFormat: Integer; ptr: Pointer; cb: Integer): HResult; stdcall;
|
||
FindFirstFileW_MP: function(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; stdcall;
|
||
FindNextFileW_MP: function(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; stdcall;
|
||
GetDiskFreeSpaceW_MP: function(lpRootPathName: PWideChar; var lpSectorsPerCluster,
|
||
lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; stdcall;
|
||
GetCurrentDirectoryW_MP: function(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; stdcall;
|
||
GetTempPathW_MP: function(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; stdcall;
|
||
lstrcmpiW_MP: function(lpString1, lpString2: PWideChar): Integer; stdcall;
|
||
lstrcmpW_MP: function(lpString1, lpString2: PWideChar): Integer; stdcall;
|
||
lstrcpynW_MP: function(lpString1, lpString2: PWideChar; iMaxLength: Integer): PWideChar; stdcall;
|
||
lstrcpyW_MP: function(lpString1, lpString2: PWideChar): PWideChar; stdcall;
|
||
CharLowerBuffW_MP: function(lpsz: PWideChar; cchLength: DWORD): DWORD; stdcall;
|
||
CharUpperBuffW_MP: function(lpsz: PWideChar; cchLength: DWORD): DWORD; stdcall;
|
||
CreateDirectoryW_MP: function(lpPathName: PWideChar; lpSecurityAttributes: PSecurityAttributes): BOOL; stdcall;
|
||
GetFullPathNameW_MP: function(lpFileName: PWideChar; nBufferLength: DWORD; lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; stdcall;
|
||
ShellExecuteExW_MP: function(lpExecInfo: PShellExecuteInfoW):BOOL; stdcall;
|
||
ShellExecuteW_MP: function(hWnd: HWND; Operation, FileName, Parameters, Directory: PWideChar; ShowCmd: Integer): HINST; stdcall;
|
||
FindFirstChangeNotificationW_MP: function(lpPathName: PWideChar; bWatchSubtree: BOOL; dwNotifyFilter: DWORD): THandle; stdcall;
|
||
GetCharABCWidthsW_MP: function(DC: HDC; FirstChar, LastChar: UINT; const ABCStructs): BOOL; stdcall;
|
||
GetFileAttributesW_MP: function(lpFileName: PWideChar): DWORD; stdcall;
|
||
GetSystemDirectoryW_MP: function(lpBuffer: PWideChar; uSize: UINT): UINT; stdcall;
|
||
GetWindowsDirectoryW_MP: function(lpBuffer: PWideChar; uSize: UINT): UINT; stdcall;
|
||
SetWindowTextW_MP: function(hWnd: HWND; lpString: PWideChar): BOOL; stdcall;
|
||
// Robert
|
||
SHMultiFileProperties_MP: function(pdtobj: IDataObject; dwFlags: DWORD): HResult; stdcall;
|
||
SHDoDragDrop_MP: function(wnd : HWND; dtObj : IDataObject; dsrc : IDropSource; OKEffect : DWORD; var Effect : Integer) : HResult; stdcall;
|
||
GetDiskFreeSpaceExA_MP: function(lpDirectoryName: PAnsiChar;
|
||
var lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes; lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
|
||
GetDiskFreeSpaceExW_MP: function(lpDirectoryName: PWideChar; var lpFreeBytesAvailableToCaller,
|
||
lpTotalNumberOfBytes; lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
|
||
GetNumberFormatW_MP: function(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar;
|
||
lpFormat: PNumberFmtW; lpNumberStr: PWideChar; cchNumber: Integer): Integer; stdcall;
|
||
CDefFolderMenu_Create2_MP: function(pidlFolder: PItemIdList; wnd: HWnd; cidl: uint; var apidl: PItemIdList; psf: IShellFolder; lpfn: TFNDFMCallback; nKeys: UINT; ahkeyClsKeys: PHKEY; var ppcm: IContextMenu): HRESULT; stdcall;
|
||
CDefFolderMenu_Create_MP: function(pidlFolder: PItemIdList): HRESULT; stdcall; // THIS IS NOT THE RIGHT PROTOTYPE DO NOT USE FOR TEST ONLY
|
||
RegOpenKeyW_MP: function(hKey: HKEY; lpSubKey: PWideChar; var phkResult: HKEY): Longint; stdcall;
|
||
RegOpenKeyExW_MP: function(hKey: HKEY; lpSubKey: PWideChar; ulOptions: DWORD; samDesired: REGSAM; var phkResult: HKEY): Longint; stdcall;
|
||
RegQueryValueW_MP: function(hKey: HKEY; lpSubKey: PWideChar; lpValue: PWideChar; var lpcbValue: Longint): Longint; stdcall;
|
||
WritePrivateProfileStringW_MP: function(lpAppName, lpKeyName, lpString, lpFileName: PWideChar): BOOL; stdcall;
|
||
GetPrivateProfileStringW_MP: function(lpAppName, lpKeyName, lpDefault: PWideChar; lpReturnedString: PWideChar; nSize: DWORD; lpFileName: PWideChar): DWORD; stdcall;
|
||
TryEnterCriticalSection_MP: function(var lpCriticalSection: TRTLCriticalSection): BOOL; stdcall;
|
||
CreateFontIndirectW_MP: function(const p1: TLogFontW): HFONT; stdcall;
|
||
SendMessageW_MP: function(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
|
||
InsertMenuItemW_MP: function(p1: HMENU; p2: UINT; p3: BOOL; const p4: TMenuItemInfoW): BOOL; stdcall;
|
||
SetFileAttributesW_MP: function(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; stdcall;
|
||
SystemParametersInfoW_MP: function(uiAction, uiParam: UINT; pvParam: Pointer; fWinIni: UINT): BOOL; stdcall;
|
||
SHBrowseForFolderW_MP: function(var lpbi: TBrowseInfoW): PItemIDList; stdcall;
|
||
SHGetPathFromIDListW_MP: function(pidl: PItemIDList; pszPath: PWideChar): BOOL; stdcall;
|
||
SHFileOperationW_MP: function(const lpFileOp: TSHFileOpStructW): Integer; stdcall;
|
||
PathMatchSpecA_MP: function(const pszFileParam, pszSpec: PAnsiChar): Bool; stdcall;
|
||
PathMatchSpecW_MP: function(const pszFileParam, pszSpec: PWideChar): Bool; stdcall;
|
||
CreateProcessW_MP: function(lpApplicationName: PWideChar; lpCommandLine: PWideChar;
|
||
lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
|
||
bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
|
||
lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW;
|
||
var lpProcessInformation: TProcessInformation): BOOL; stdcall;
|
||
DeleteVolumeMountPoint_MP: function(lpszVolumeMountPoint: LPCSTR): BOOL; stdcall;
|
||
GetVolumeNameForVolumeMountPoint_MP: function(lpszVolumeMountPoint: LPCSTR; lpszVolumeName: LPSTR; cchBufferLength: DWORD): BOOL; stdcall;
|
||
GetVolumePathName_MP: function(lpszFileName: LPCSTR; lpszVolumePathName: LPTSTR; cchBufferLength: DWORD): BOOL; stdcall;
|
||
SetVolumeMountPoint_MP: function(lpszVolumeMountPoint: LPCSTR; lpszVolumeName: LPCSTR): BOOL;
|
||
FindFirstVolume_MP: function(lpszVolumeName: LPTSTR; cchBufferLength: DWORD): THandle; stdcall;
|
||
FindNextVolume_MP: function(hFindVolume: THandle; lpszVolumeName: LPTSTR; cchBufferLength: DWORD): BOOL; stdcall;
|
||
FindVolumeClose_MP: function(hFindVolume: THandle): BOOL; stdcall;
|
||
FindFirstVolumeMountPoint_MP: function(lpszRootPathName: LPTSTR; lpszVolumeMountPoint: LPTSTR; cchBufferLength: DWORD): THandle stdcall;
|
||
FindNextVolumeMountPoint_MP: function(hFindVolumeMountPoint: THandle; lpszVolumeMountPoint: LPTSTR; cchBufferLength: DWORD): BOOL; stdcall;
|
||
FindVolumeMountPointClose_MP: function(hFindVolumeMountPoint: THandle): BOOL; stdcall;
|
||
SHGetKnownFolderPath_MP: function(const rfid: TGUID; dwFlags: DWord; hToken: THandle; out ppszPath: PWideChar): HRESULT; stdcall;
|
||
FindFirstFileExW_MP: function(lpFileName: PWideChar; fInfoLevelId: DWORD; var lpFindFileData: TWIN32FindDataW; fSearchOp: DWORD; lpSearchFilter: Pointer; dwAdditionalFlags: DWORD): THandle; stdcall;
|
||
FindFirstFileExA_MP: function(lpFileName: PChar; fInfoLevelId: DWORD; var lpFindFileData: TWIN32FindDataA; fSearchOp: DWORD; lpSearchFilter: Pointer; dwAdditionalFlags: DWORD): THandle; stdcall;
|
||
ExpandEnvironmentStringsW_MP: function(lpSrc: PWideChar; lpDst: PWideChar; nSize: DWORD): DWORD; stdcall;
|
||
TrackMouseEvent_MP: function(var EventTrack: TTrackMouseEvent): BOOL; stdcall;
|
||
|
||
// Usage of this flag makes the SumFolder Function not thread safe
|
||
SumFolderAbort: Boolean = False;
|
||
|
||
implementation
|
||
|
||
uses
|
||
MPCommonObjects;
|
||
|
||
type
|
||
PLibRec = ^TLibRec;
|
||
TLibRec = packed record
|
||
LibraryName: string;
|
||
ReferenceCount: Integer;
|
||
Handle: THandle;
|
||
end;
|
||
|
||
var
|
||
FLibList: TList;
|
||
PIDLMgr: TCommonPIDLManager;
|
||
Shell32Handle,
|
||
Kernel32Handle,
|
||
User32Handle,
|
||
GDI32Handle,
|
||
AdvAPI32Handle,
|
||
ShlwapiHandle: THandle;
|
||
|
||
|
||
function ShiftStateToKeys(Keys: TShiftState): LongWord;
|
||
begin
|
||
Result := 0;
|
||
if ssShift in Keys then
|
||
Result := Result or MK_SHIFT;
|
||
if ssCtrl in Keys then
|
||
Result := Result or MK_CONTROL;
|
||
if ssLeft in Keys then
|
||
Result := Result or MK_LBUTTON;
|
||
if ssRight in Keys then
|
||
Result := Result or MK_RBUTTON;
|
||
if ssMiddle in Keys then
|
||
Result := Result or MK_MBUTTON;
|
||
if ssAlt in Keys then
|
||
Result := Result or MK_ALT;
|
||
end;
|
||
|
||
function ShiftStateToStr(Keys: TShiftState): WideString;
|
||
begin
|
||
Result := '[';
|
||
if ssShift in Keys then
|
||
Result := Result + 'ssShift, ';
|
||
if ssCtrl in Keys then
|
||
Result := Result + 'ssCtrl, ';
|
||
if ssLeft in Keys then
|
||
Result := Result + 'ssLeft, ';
|
||
if ssRight in Keys then
|
||
Result := Result + 'ssRight, ';
|
||
if ssMiddle in Keys then
|
||
Result := Result + 'ssMiddle, ';
|
||
if ssAlt in Keys then
|
||
Result := Result + 'ssAlt, ';
|
||
if ssDouble in Keys then
|
||
Result := Result + 'ssDouble, ';
|
||
if Length(Result) > 1 then
|
||
SetLength(Result, Length(Result) - 2);
|
||
Result := Result + ']';
|
||
end;
|
||
|
||
function RegSvrPath: WideString;
|
||
const
|
||
ExeName: WideString = 'RegSvr32.exe';
|
||
var
|
||
Path: WideString;
|
||
begin
|
||
Result:= '';
|
||
//Look in System dir
|
||
Path := SystemDirectory + '\' + ExeName;
|
||
if FileExistsW(Path) then
|
||
Result := Path
|
||
else begin
|
||
//Look in Windows dir
|
||
Path:= WindowsDirectory + '\' + ExeName;
|
||
if FileExistsW(Path) then
|
||
Result:= Path;
|
||
end
|
||
end;
|
||
|
||
function ExecShellEx(const Cmd, Params, Dir: WideString; ShowCmd: integer; DoWait: boolean): boolean;
|
||
var
|
||
InfoA: TShellExecuteInfoA;
|
||
InfoW: TShellExecuteInfoW;
|
||
CmdA, ParamsA, DirA: string;
|
||
begin
|
||
if Assigned(ShellExecuteExW_MP) then
|
||
begin
|
||
FillChar(InfoW, SizeOf(InfoW), 0);
|
||
InfoW.cbSize := SizeOf(InfoW);
|
||
InfoW.fMask := SEE_MASK_FLAG_NO_UI or SEE_MASK_NOCLOSEPROCESS;
|
||
InfoW.lpFile := PWideChar(Cmd);
|
||
InfoW.lpParameters := PWideChar(Params);
|
||
InfoW.lpDirectory := PWideChar(Dir);
|
||
InfoW.nShow := ShowCmd;
|
||
Result := ShellExecuteExW_MP(@InfoW);
|
||
if Result and DoWait then
|
||
begin
|
||
WaitForSingleObject(InfoW.hProcess, INFINITE);
|
||
CloseHandle(InfoW.hProcess)
|
||
end;
|
||
end else
|
||
begin
|
||
CmdA := Cmd;
|
||
ParamsA := Params;
|
||
DirA := Dir;
|
||
FillChar(InfoA, SizeOf(InfoA), 0);
|
||
InfoA.cbSize := SizeOf(InfoA);
|
||
InfoA.fMask := SEE_MASK_FLAG_NO_UI or SEE_MASK_NOCLOSEPROCESS;
|
||
InfoA.lpFile := PChar(CmdA);
|
||
InfoA.lpParameters := PChar(ParamsA);
|
||
InfoA.lpDirectory := PChar(DirA);
|
||
InfoA.nShow := ShowCmd;
|
||
Result := ShellExecuteEx(@InfoA);
|
||
if Result and DoWait then
|
||
begin
|
||
WaitForSingleObject(InfoA.hProcess, INFINITE);
|
||
CloseHandle(InfoA.hProcess)
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function RegUnregNSE(const AFileName: WideString; DoRegister: boolean; AMessages: TEasyNSERegMessages = [enseMsgShowErrors]): boolean;
|
||
var
|
||
Fn, Exe, Msg: WideString;
|
||
begin
|
||
Result:= false;
|
||
|
||
if not FileExistsW(AFileName) then
|
||
begin
|
||
if enseMsgShowErrors in AMessages then
|
||
begin
|
||
if DoRegister then
|
||
Msg := SEasyNSEMsg_CannotRegister
|
||
else
|
||
Msg := SEasyNSEMsg_CannotUnRegister;
|
||
|
||
|
||
WideMessageBox(Application.Handle,
|
||
PWideChar( Msg + #13 + SEasyNSEMsg_CannotFindDLL),
|
||
PWideChar( SEasyNSEMsg_Caption),
|
||
MB_OK or MB_ICONERROR);
|
||
end;
|
||
Exit
|
||
end;
|
||
|
||
Fn := AFileName;
|
||
// If includes spaces then " " it
|
||
if Pos(' ', Fn) > 0 then
|
||
Fn := '"' + Fn + '"';
|
||
|
||
Exe := RegSvrPath;
|
||
|
||
if not FileExistsW(Exe) then
|
||
begin
|
||
if enseMsgShowErrors in AMessages then
|
||
begin
|
||
if DoRegister then
|
||
Msg := SEasyNSEMsg_CannotRegister
|
||
else
|
||
Msg := SEasyNSEMsg_CannotUnRegister;
|
||
|
||
MessageBoxW(Application.Handle,
|
||
PWideChar( Msg + #13 + SEasyNSEMsg_CannotFindRegSvr),
|
||
PWideChar( SEasyNSEMsg_Caption),
|
||
MB_OK or MB_ICONERROR);
|
||
end;
|
||
Exit
|
||
end;
|
||
|
||
if DoRegister then
|
||
Msg := '' else
|
||
Msg := '/U ';
|
||
if not (enseMsgRegSvr in AMessages) then
|
||
Msg := Msg + '/S ';
|
||
|
||
Result:= ExecShellEx(exe, Msg + Fn, '', SW_SHOW, True);
|
||
end;
|
||
|
||
function RegisterNSE(const AFileName: WideString; AMessages: TEasyNSERegMessages = [enseMsgShowErrors]): boolean;
|
||
begin
|
||
Result:= RegUnregNSE(AFileName, True, AMessages);
|
||
end;
|
||
|
||
function UnregisterNSE(const AFileName: WideString; AMessages: TEasyNSERegMessages = [enseMsgShowErrors]): boolean;
|
||
begin
|
||
Result:= RegUnregNSE(AFileName, False, AMessages);
|
||
end;
|
||
|
||
{$IFNDEF COMPILER_6_UP}
|
||
function DirectoryExists(const Directory: string): Boolean;
|
||
var
|
||
Code: Integer;
|
||
begin
|
||
Code := GetFileAttributes(PChar(Directory));
|
||
Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
|
||
end;
|
||
{$ENDIF}
|
||
|
||
{$IFNDEF COMPILER_6_UP}
|
||
function GUIDToString(const GUID: TGUID): string;
|
||
var
|
||
P: PWideChar;
|
||
begin
|
||
Result := '';
|
||
if Succeeded(StringFromCLSID(GUID, P)) then
|
||
begin
|
||
Result := P;
|
||
CoTaskMemFree(P);
|
||
end
|
||
end;
|
||
{$ENDIF}
|
||
|
||
procedure MakeFindDataW(const FindFileDataA: TWIN32FindDataA; var FindFileDataW: TWIN32FindDataW);
|
||
//
|
||
// Makes TWIN32FindDataW from a TWIN32FindDataA structure
|
||
//
|
||
var
|
||
i: Integer;
|
||
WS: WideString;
|
||
begin
|
||
FindFileDataW.dwFileAttributes := FindFileDataA.dwFileAttributes;
|
||
FindFileDataW.ftCreationTime := FindFileDataA.ftCreationTime;
|
||
FindFileDataW.ftLastAccessTime := FindFileDataA.ftLastAccessTime;
|
||
FindFileDataW.ftLastWriteTime := FindFileDataA.ftLastWriteTime;
|
||
FindFileDataW.nFileSizeHigh := FindFileDataA.nFileSizeHigh;
|
||
FindFileDataW.nFileSizeLow := FindFileDataA.nFileSizeLow;
|
||
FindFileDataW.dwReserved0 := FindFileDataA.dwReserved0;
|
||
FindFileDataW.dwReserved1 := FindFileDataA.dwReserved1;
|
||
FillChar(FindFileDataW.cAlternateFileName, SizeOf(FindFileDataW.cAlternateFileName), #0);
|
||
FillChar(FindFileDataW.cFileName, SizeOf(FindFileDataW.cFileName), #0);
|
||
i := 0;
|
||
while FindFileDataA.cAlternateFileName[i] <> #0 do
|
||
begin
|
||
WS := FindFileDataA.cAlternateFileName[i];
|
||
FindFileDataW.cAlternateFileName[i] := WS[1];
|
||
Inc(i)
|
||
end;
|
||
i := 0;
|
||
while FindFileDataA.cFileName[i] <> #0 do
|
||
begin
|
||
WS := FindFileDataA.cFileName[i];
|
||
FindFileDataW.cFileName[i] := WS[1];
|
||
Inc(i)
|
||
end
|
||
end;
|
||
|
||
function WideDirectoryExists(const Name: WideString): Boolean;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := TntSysUtils.WideDirectoryExists(Name);
|
||
{$ELSE}
|
||
Result := DirectoryExists(Name)
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function WideCreateDir(Path: WideString): Boolean;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := TntSysUtils.WideCreateDir(Path);
|
||
{$ELSE}
|
||
Result := CreateDir(Path)
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function WideExcludeTrailingBackslash(Path: WideString): WideString;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := TntSysUtils.WideExcludeTrailingBackslash(Path);
|
||
{$ELSE}
|
||
{$IFDEF COMPILER_6_UP}
|
||
{$WARN SYMBOL_PLATFORM OFF}
|
||
{$ENDIF}
|
||
Result := ExcludeTrailingBackslash(Path)
|
||
{$IFDEF COMPILER_6_UP}
|
||
{$WARN SYMBOL_PLATFORM ON}
|
||
{$ENDIF}
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function WideExpandEnviromentString(EnviromentString: WideString): WideString;
|
||
var
|
||
Length: Integer;
|
||
EnviromentStringA, ResultA: string;
|
||
begin
|
||
Result := EnviromentString;
|
||
if Assigned(ExpandEnvironmentStringsW_MP) then
|
||
begin
|
||
Length := ExpandEnvironmentStringsW_MP(PWideChar( EnviromentString), nil, 0);
|
||
if Length > 0 then
|
||
begin
|
||
SetLength(Result, Length - 1); // Includes the null
|
||
ExpandEnvironmentStringsW_MP( PWideChar( EnviromentString), PWideChar( @Result[1]), Length);
|
||
end
|
||
end else
|
||
begin
|
||
EnviromentStringA := EnviromentString;
|
||
Length := ExpandEnvironmentStringsA(PChar( EnviromentStringA), nil, 0);
|
||
if Length > 0 then
|
||
begin
|
||
SetLength(ResultA, Length - 2); // There is a magic 1 per the MSDN docs for the ANSI version
|
||
ExpandEnvironmentStringsA( PChar( EnviromentStringA), PChar( @ResultA[1]), Length);
|
||
Result := ResultA
|
||
end
|
||
end
|
||
end;
|
||
|
||
function WideExtractFilePath(Path: WideString): WideString;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := TntSysUtils.WideExtractFilePath(Path);
|
||
{$ELSE}
|
||
Result := ExtractFilePath(Path);
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function WideExtractFileName(Path: WideString): WideString;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := TntSysUtils.WideExtractFileName(Path);
|
||
{$ELSE}
|
||
Result := ExtractFileName(Path);
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function WideFileExists(Path: WideString): Boolean;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := TntSysUtils.WideFileExists(Path);
|
||
{$ELSE}
|
||
Result := FileExists(Path);
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function WideExtractFileDir(Path: WideString): WideString;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := TntSysUtils.WideExtractFileDir(Path);
|
||
{$ELSE}
|
||
Result := ExtractFileDir(Path);
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function WideExtractFileDrive(Path: WideString): WideString;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := TntSysUtils.WideExtractFileDrive(Path);
|
||
{$ELSE}
|
||
Result := ExtractFileDrive(Path);
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function WideExtractFileExt(Path: WideString): WideString;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := TntSysUtils.WideExtractFileExt(Path);
|
||
{$ELSE}
|
||
Result := ExtractFileExt(Path);
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function WideFindFirstFileEx(FileName: WideString;
|
||
var lpFindFileData: TWIN32FindDataW; Mask: WideString; CaseSensitive: Boolean): THandle;
|
||
var
|
||
CaseFlag: DWORD;
|
||
FindFileDataA: TWIN32FindDataA;
|
||
begin
|
||
Result := 0;
|
||
|
||
if CaseSensitive then
|
||
CaseFlag := FIND_FIRST_EX_CASE_SENSITIVE
|
||
else
|
||
CaseFlag := 0;
|
||
|
||
if Assigned(FindFirstFileExW_MP) then
|
||
Result := FindFirstFileExW_MP(PWideChar(WideString( FileName + '\' + Mask)), FINDEX_INFO_STANDARD, lpFindFileData, FINDEX_SEARCH_NAMEMATCH, nil, CaseFlag)
|
||
else
|
||
if Assigned(FindFirstFileExA_MP) then
|
||
begin
|
||
Result := FindFirstFileExA_MP(PChar( String( FileName + '\' + Mask)), FINDEX_INFO_STANDARD, FindFileDataA, FINDEX_SEARCH_NAMEMATCH, nil, CaseFlag);
|
||
MakeFindDataW(FindFileDataA, lpFindFileData)
|
||
end
|
||
end;
|
||
|
||
function WideFindFirstFileExExists: Boolean;
|
||
begin
|
||
Result := Assigned(FindFirstFileExA_MP) or Assigned(FindFirstFileExW_MP)
|
||
end;
|
||
|
||
procedure FixFormFont(AFont: TFont);
|
||
var
|
||
LogFont: TLogFont;
|
||
begin
|
||
if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(LogFont), @LogFont, 0) then
|
||
AFont.Handle := CreateFontIndirect(LogFont)
|
||
else
|
||
AFont.Handle := GetStockObject(DEFAULT_GUI_FONT);
|
||
end;
|
||
|
||
procedure FillGradient(X1, Y1, X2, Y2: integer; fStartColor, fStopColor: TColor;
|
||
StartPoint, EndPoint: integer; fDrawCanvas: TCanvas);
|
||
// X1, Y1, X2, Y2: TopLeft and BottomRight coordinates of fill area...
|
||
//fStartColor: color to begin the gradient fill with
|
||
//FStopColor: color to end the gradient fill with
|
||
//StartPoint: the first point between X1 and X2 to draw (useful for faster updating of
|
||
// specific areas instead of redrawing the entire gradient fill area such as progress bars)
|
||
//EndPoint: the last point between X1 and X2 to draw
|
||
//fDrawCanvas: the canvas to draw the gradient on
|
||
var
|
||
y: integer;
|
||
tmpColor: TColor;
|
||
|
||
begin
|
||
fStartColor := ColorToRGB(fStartColor);
|
||
fStopColor := ColorToRGB(fStopColor);
|
||
tmpColor := fDrawCanvas.Pen.Color;
|
||
for y := Y1 to Y2 do begin
|
||
fDrawCanvas.MoveTo(X1, y);
|
||
if (EndPoint > 0) and (y <= EndPoint) and (y >= StartPoint) then begin
|
||
fDrawCanvas.Pen.Color := RGB(Round(GetRValue(fStartColor) + (((GetRValue(fStopColor) - GetRValue(fStartColor)) / (Y2 - Y1)) *Abs(y - Y1))),
|
||
Round(GetGValue(fStartColor) + (((GetGValue(fStopColor) - GetGValue(fStartColor)) / (Y2 - Y1)) * Abs(y - Y1))),
|
||
Round(GetBValue(fStartColor) + (((GetBValue(fStopColor) - GetBValue(fStartColor)) / (y2 - Y1)) * Abs(y - Y1))));
|
||
fDrawCanvas.LineTo(X2, y);
|
||
end;
|
||
end;
|
||
fDrawCanvas.Brush.Color := tmpColor;
|
||
end;
|
||
|
||
function DropEffectToStr(DropEffect: DWORD): WideString;
|
||
begin
|
||
Result := '';
|
||
if DropEffect and DROPEFFECT_COPY <> 0 then
|
||
Result := Result + 'DROPEFFECT_COPY|';
|
||
if DropEffect and DROPEFFECT_MOVE <> 0 then
|
||
Result := Result + 'DROPEFFECT_MOVE|';
|
||
if DropEffect and DROPEFFECT_LINK <> 0 then
|
||
Result := Result + 'DROPEFFECT_LINK|';
|
||
if DropEffect and DROPEFFECT_SCROLL <> 0 then
|
||
Result := Result + 'DROPEFFECT_SCROLL|';
|
||
if Length(Result) > 0 then
|
||
SetLength(Result, Length(Result) - 1)
|
||
else
|
||
Result := '(none)';
|
||
end;
|
||
|
||
function EqualWndMethod(A, B: TWndMethod): Boolean;
|
||
begin
|
||
Result := (TMethod(A).Code = TMethod(B).Code) and
|
||
(TMethod(A).Data = TMethod(B).Data)
|
||
end;
|
||
|
||
function FindRootToken(const Path: WideString): PWideChar;
|
||
const
|
||
RootToken = WideString(':\');
|
||
begin
|
||
Result := WideStrPos(PWideChar(Path), RootToken);
|
||
end;
|
||
|
||
function ExtractFileDirW(const FileName: WideString): WideString;
|
||
var
|
||
WP: PWideChar;
|
||
begin
|
||
Result := '';
|
||
if (Length(FileName) < 3) and (Length(FileName) > 0) then
|
||
begin
|
||
if (((FileName[1] >= 'A') and (FileName[1] >= 'Z')) or
|
||
((FileName[1] >= 'a') and (FileName[1] >= 'z'))) then
|
||
begin
|
||
Result := WideString(FileName[1]) + ':\';
|
||
end
|
||
end else
|
||
begin
|
||
WP := FindRootToken(FileName);
|
||
if Assigned(WP) then
|
||
begin
|
||
{ Find the last '\' }
|
||
WP := WideStrRScan(PWideChar( FileName), WideChar( '\'));
|
||
if Assigned(WP) then
|
||
begin
|
||
{ The stripped file name leaves just the root directory }
|
||
if (Length(FileName) > 1) and ( (WP - 1)^ = ':') then
|
||
WP := WP + 1; // Tack on the '\'
|
||
SetLength(Result, WP - @FileName[1]);
|
||
WideStrMove(PWideChar(Result), PWideChar(FileName), WP - @FileName[1]);
|
||
end
|
||
end
|
||
end
|
||
end;
|
||
|
||
function DirExistsW(const FileName: PWideChar): Boolean;
|
||
var
|
||
ErrorCode: LongWord;
|
||
S: string;
|
||
begin
|
||
if FileName <> '' then
|
||
begin
|
||
if (Win32Platform = VER_PLATFORM_WIN32_NT) then
|
||
ErrorCode := GetFileAttributesW_MP(FileName)
|
||
else begin
|
||
S := FileName;
|
||
ErrorCode := GetFileAttributesA(PChar(S))
|
||
end;
|
||
Result := (Integer(ErrorCode) <> -1) and (FILE_ATTRIBUTE_DIRECTORY and ErrorCode <> 0);
|
||
end else
|
||
Result := False
|
||
end;
|
||
|
||
function FlipReverseCopyRect(const Flip, Reverse: Boolean; const Bitmap: TBitmap): TBitmap;
|
||
var
|
||
Bottom, Left, Right, Top: integer;
|
||
begin
|
||
Result := TBitmap.Create;
|
||
Result.Width := Bitmap.Width;
|
||
Result.Height := Bitmap.Height;
|
||
Result.PixelFormat := Bitmap.PixelFormat;
|
||
|
||
// Flip Top to Bottom
|
||
if Flip then
|
||
begin
|
||
// Unclear why extra "-1" is needed here.
|
||
Top := Bitmap.Height-1;
|
||
Bottom := -1
|
||
end
|
||
else begin
|
||
Top := 0;
|
||
Bottom := Bitmap.Height
|
||
end;
|
||
|
||
// Reverse Left to Right
|
||
if Reverse then
|
||
begin
|
||
// Unclear why extra "-1" is needed here.
|
||
Left := Bitmap.Width-1;
|
||
Right := -1;
|
||
end
|
||
else begin
|
||
Left := 0;
|
||
Right := Bitmap.Width;
|
||
end;
|
||
|
||
Result.Canvas.CopyRect(Rect(Left,Top, Right,Bottom),
|
||
Bitmap.Canvas,
|
||
Rect(0,0, Bitmap.Width,Bitmap.Height));
|
||
end;
|
||
|
||
procedure FlipReverseCopyRect(const Flip, Reverse: Boolean; R: TRect; const Canvas: TCanvas); overload;
|
||
var
|
||
Bottom, Left, Right, Top: integer;
|
||
begin
|
||
// Flip Top to Bottom
|
||
if Flip then
|
||
begin
|
||
// Unclear why extra "-1" is needed here.
|
||
Top := RectHeight(R)-1;
|
||
Bottom := -1
|
||
end
|
||
else begin
|
||
Top := 0;
|
||
Bottom := RectHeight(R)
|
||
end;
|
||
|
||
// Reverse Left to Right
|
||
if Reverse then
|
||
begin
|
||
// Unclear why extra "-1" is needed here.
|
||
Left := RectWidth(R)-1;
|
||
Right := -1;
|
||
end
|
||
else begin
|
||
Left := 0;
|
||
Right := RectWidth(R);
|
||
end;
|
||
|
||
Canvas.CopyRect(Rect(Left, Top, Right, Bottom),
|
||
Canvas,
|
||
Rect(0,0, RectWidth(R), RectHeight(R)));
|
||
end;
|
||
|
||
function FileExistsW(const FileName: WideString): Boolean;
|
||
var
|
||
Handle: THandle;
|
||
FindData: TWin32FindData;
|
||
FindDataW: TWin32FindDataW;
|
||
FileNameA: string;
|
||
begin
|
||
Result := True;
|
||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||
Handle := FindFirstFileW_MP(PWideChar(FileName), FindDataW)
|
||
else begin
|
||
FileNameA := FileName;
|
||
Handle := FindFirstFileA(PChar(FileNameA), FindData)
|
||
end;
|
||
if Handle <> INVALID_HANDLE_VALUE then
|
||
Windows.FindClose(Handle)
|
||
else
|
||
Result := False;
|
||
end;
|
||
|
||
function IsMappedDrivePath(const Path: WideString): Boolean;
|
||
var
|
||
WS: WideString;
|
||
begin
|
||
WS := Path;
|
||
SetLength(WS, 3);
|
||
if IsWinNT then
|
||
Result := GetDriveTypeW_MP(PWideChar(WS)) = DRIVE_REMOTE
|
||
else
|
||
Result := GetDriveType(PChar(string(WS))) = DRIVE_REMOTE;
|
||
end;
|
||
|
||
{ Searchs through the passed menu looking for an item identifer that is not }
|
||
{ currently being used. }
|
||
|
||
function FindUniqueMenuID(AMenu: HMenu): Cardinal;
|
||
|
||
|
||
function RunMenu(AMenu: HMenu; var ID: Cardinal): Boolean;
|
||
var
|
||
MenuInfoW: TMenuItemInfoW;
|
||
MenuInfoA: TMenuItemInfoA;
|
||
i, ItemCount: Integer;
|
||
Reset, IsDuplicate: Boolean;
|
||
begin
|
||
Reset := False;
|
||
IsDuplicate := False;
|
||
ItemCount := GetMenuItemCount(AMenu);
|
||
i := 0;
|
||
while (i < ItemCount) and not IsDuplicate do
|
||
begin
|
||
if IsUnicode then
|
||
begin
|
||
FillChar(MenuInfoW, SizeOf(MenuInfoW), #0);
|
||
MenuInfoW.cbSize := SizeOf(MenuInfoW);
|
||
MenuInfoW.fMask := MIIM_SUBMENU or MIIM_ID;
|
||
GetMenuItemInfoW(AMenu, i, True, MenuInfoW);
|
||
if MenuInfoW.hSubMenu <> 0 then
|
||
Reset := RunMenu(MenuInfoW.hSubMenu, ID);
|
||
IsDuplicate := MenuInfoW.wID = ID
|
||
end else
|
||
begin
|
||
FillChar(MenuInfoA, SizeOf(MenuInfoA), #0);
|
||
MenuInfoA.cbSize := SizeOf(MenuInfoA);
|
||
MenuInfoA.fMask := MIIM_SUBMENU or MIIM_ID;
|
||
GetMenuItemInfoA(AMenu, i, True, MenuInfoA);
|
||
if MenuInfoA.hSubMenu <> 0 then
|
||
Reset := RunMenu(MenuInfoA.hSubMenu, ID);
|
||
IsDuplicate := MenuInfoA.wID = ID
|
||
end;
|
||
Inc(i);
|
||
end;
|
||
Result := IsDuplicate and not Reset
|
||
end;
|
||
|
||
begin
|
||
Result := 1000;
|
||
while RunMenu(AMenu, Result) do
|
||
Inc(Result)
|
||
end;
|
||
|
||
function AddContextMenuItem(Menu: HMenu; ACaption: WideString; Index: Integer;
|
||
MenuID: UINT = $FFFF; hSubMenu: UINT = 0; Enabled: Boolean = True;
|
||
Checked: Boolean = False; Default: Boolean = False): Integer;
|
||
//
|
||
// Pass '-' for a separator
|
||
// -1 to add to the end
|
||
// if MenuID = -1 then the function will create a unique ID
|
||
// if hSubMenu > 0 then the item contain sub-items
|
||
// Returns ID of new Item
|
||
//
|
||
var
|
||
InfoA: TMenuItemInfoA;
|
||
InfoW: TMenuItemInfoW;
|
||
begin
|
||
if IsUnicode and Assigned(InsertMenuItemW_MP) then
|
||
begin
|
||
FillChar(InfoW, SizeOf(InfoW), #0);
|
||
InfoW.cbSize := SizeOf(InfoW);
|
||
InfoW.fMask := MIIM_TYPE or MIIM_ID or MIIM_STATE;
|
||
|
||
if Enabled or (ACaption = '-') then
|
||
InfoW.fState := InfoW.fState or MFS_ENABLED
|
||
else
|
||
InfoW.fState := InfoW.fState or MFS_DISABLED;
|
||
|
||
if Checked and (ACaption <> '-') then
|
||
InfoW.fState := InfoW.fState or MFS_CHECKED;
|
||
if Default and (ACaption <> '-') then
|
||
InfoW.fState := InfoW.fState or MFS_DEFAULT;
|
||
|
||
if ACaption = '-' then
|
||
InfoW.fType := MFT_SEPARATOR
|
||
else begin
|
||
InfoW.fType := MFT_STRING;
|
||
if hSubMenu > 0 then
|
||
begin
|
||
InfoW.fMask := InfoW.fMask or MIIM_SUBMENU;
|
||
InfoW.hSubMenu := hSubMenu
|
||
end
|
||
end;
|
||
InfoW.dwTypeData := PWideChar(ACaption);
|
||
InfoW.cch := Length(ACaption);
|
||
|
||
if InfoW.fType = MFT_STRING then
|
||
begin
|
||
if MenuID = $FFFF then
|
||
InfoW.wID := FindUniqueMenuID(Menu)
|
||
else
|
||
if InfoW.fMask and MIIM_SUBMENU <> 0 then
|
||
InfoW.wID := $FFFF // Sub-Item Parents don't get an unique ID
|
||
else
|
||
InfoW.wID := MenuID;
|
||
end else
|
||
InfoW.wID := $FFFF; // Separators don't get an unique ID
|
||
|
||
Result := InfoW.wID;
|
||
if Index < 0 then
|
||
InsertMenuItemW_MP(Menu, GetMenuItemCount(Menu), True, InfoW)
|
||
else
|
||
InsertMenuItemW_MP(Menu, Index, True, InfoW); // Inserts by Position
|
||
end else
|
||
begin
|
||
FillChar(InfoA, SizeOf(InfoA), #0);
|
||
InfoA.cbSize := SizeOf(InfoA);
|
||
|
||
InfoA.fMask := MIIM_TYPE or MIIM_ID or MIIM_STATE;
|
||
if Enabled or (ACaption = '-') then
|
||
InfoA.fState := InfoA.fState or MFS_ENABLED
|
||
else
|
||
InfoA.fState := InfoA.fState or MFS_DISABLED;
|
||
|
||
if Checked and (ACaption <> '-') then
|
||
InfoA.fState := InfoA.fState or MFS_CHECKED;
|
||
if Default and (ACaption <> '-') then
|
||
InfoA.fState := InfoA.fState or MFS_DEFAULT;
|
||
|
||
if ACaption = '-' then
|
||
InfoA.fType := MFT_SEPARATOR
|
||
else begin
|
||
InfoA.fType := MFT_STRING;
|
||
if hSubMenu > 0 then
|
||
begin
|
||
InfoA.fMask := InfoA.fMask or MIIM_SUBMENU;
|
||
InfoA.hSubMenu := hSubMenu
|
||
end
|
||
end;
|
||
|
||
InfoA.dwTypeData := PChar( string(ACaption));
|
||
InfoA.cch := Length(ACaption);
|
||
|
||
if InfoA.fType = MFT_STRING then
|
||
begin
|
||
if MenuID = $FFFF then
|
||
InfoA.wID := FindUniqueMenuID(Menu)
|
||
else
|
||
if InfoA.fMask and MIIM_SUBMENU <> 0 then
|
||
InfoA.wID := $FFFF // Sub-Item Parents don't get an unique ID
|
||
else
|
||
InfoA.wID := MenuID;
|
||
end else
|
||
InfoA.wID := $FFFF; // Separators don't get an unique ID
|
||
|
||
Result := InfoA.wID;
|
||
if Index < 0 then
|
||
InsertMenuItemA(Menu, GetMenuItemCount(Menu), True, InfoA)
|
||
else
|
||
InsertMenuItemA(Menu, Index, True, InfoA);
|
||
end
|
||
end;
|
||
|
||
procedure ShadowBlendBits(Bits: TBitmap; BackGndColor: TColor);
|
||
begin
|
||
if Assigned(Bits) and (Bits.PixelFormat = pf32Bit) then
|
||
begin
|
||
AlphaBlend(Bits.Canvas.Handle, Bits.Canvas.Handle,
|
||
Rect(0, 0, Bits.Width,Bits.Height), Point(0, 0),
|
||
cbmConstantAlphaAndColor, 0, ColorToRGB(BackGndColor));
|
||
ConvertBitmapEx(Bits, Bits, BackGndColor)
|
||
end
|
||
end;
|
||
|
||
|
||
procedure SumFolder(FolderPath: WideString; Recurse: Boolean; var Size: Int64);
|
||
{ Returns the size of all files within the passed folder, including all }
|
||
{ sub-folders. This is recurcive don't initialize Size to 0 in the function! }
|
||
var
|
||
Info: TWin32FindData;
|
||
InfoW: TWin32FindDataW;
|
||
FHandle: THandle;
|
||
FolderPathA: string;
|
||
begin
|
||
if IsUnicode then
|
||
begin
|
||
FHandle := FindFirstFileW_MP(PWideChar( FolderPath + '\*.*'), InfoW);
|
||
if FHandle <> INVALID_HANDLE_VALUE then
|
||
try
|
||
if Recurse and (InfoW.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0) then
|
||
begin
|
||
if (lstrcmpiW_MP(InfoW.cFileName, '.') <> 0) and (lstrcmpiW_MP(InfoW.cFileName, '..') <> 0) and
|
||
(InfoW.dwFileAttributes and FILE_ATTRIBUTE_REPARSE_POINT = 0) then
|
||
SumFolder(FolderPath + '\' + InfoW.cFileName, Recurse, Size)
|
||
end else
|
||
Size := Size + InfoW.nFileSizeHigh * MAXDWORD + InfoW.nFileSizeLow;
|
||
while FindNextFileW_MP(FHandle, InfoW) and not SumFolderAbort do
|
||
begin
|
||
if Recurse and (InfoW.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0) then
|
||
begin
|
||
if (lstrcmpiW_MP(InfoW.cFileName, '.') <> 0) and (lstrcmpiW_MP(InfoW.cFileName, '..') <> 0) and
|
||
(InfoW.dwFileAttributes and FILE_ATTRIBUTE_REPARSE_POINT = 0) then
|
||
SumFolder(FolderPath + '\' + InfoW.cFileName, Recurse, Size)
|
||
end else
|
||
Size := Size + InfoW.nFileSizeHigh * MAXDWORD + InfoW.nFileSizeLow;
|
||
end;
|
||
finally
|
||
Windows.FindClose(FHandle)
|
||
end
|
||
end else
|
||
begin
|
||
FolderPathA := FolderPath;
|
||
FHandle := FindFirstFile(PChar( FolderPathA + '\*.*'), Info);
|
||
if FHandle <> INVALID_HANDLE_VALUE then
|
||
try
|
||
if Recurse and (Info.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0) then
|
||
begin
|
||
if (lstrcmpi(Info.cFileName, '.') <> 0) and (lstrcmpi(Info.cFileName, '..') <> 0) and
|
||
(InfoW.dwFileAttributes and FILE_ATTRIBUTE_REPARSE_POINT = 0) then
|
||
SumFolder(FolderPathA + '\' + Info.cFileName, Recurse, Size)
|
||
end else
|
||
Size := Size + Info.nFileSizeHigh * MAXDWORD + Info.nFileSizeLow;
|
||
while FindNextFile(FHandle, Info) and not SumFolderAbort do
|
||
begin
|
||
if Recurse and (Info.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0) then
|
||
begin
|
||
if (lstrcmpi(Info.cFileName, '.') <> 0) and (lstrcmpi(Info.cFileName, '..') <> 0) and
|
||
(InfoW.dwFileAttributes and FILE_ATTRIBUTE_REPARSE_POINT = 0) then
|
||
SumFolder(FolderPathA + '\' + Info.cFileName, Recurse, Size)
|
||
end else
|
||
Size := Size + Info.nFileSizeHigh * MAXDWORD + Info.nFileSizeLow;
|
||
end;
|
||
finally
|
||
Windows.FindClose(FHandle)
|
||
end
|
||
end
|
||
end;
|
||
|
||
function InternalTextExtentW(Text: PWideChar; DC: HDC): TSize;
|
||
var
|
||
S: string;
|
||
begin
|
||
if IsUnicode then
|
||
GetTextExtentPoint32W(DC, PWideChar(Text), Length(Text), Result)
|
||
else begin
|
||
S := WideString( Text);
|
||
GetTextExtentPoint32(DC, PChar(S), Length(S), Result)
|
||
end;
|
||
end;
|
||
|
||
function WideStrMove(Dest, Source: PWideChar; Count: Cardinal): PWideChar;
|
||
// Copies the specified number of characters to the destination string and returns Dest
|
||
// also as result. Dest must have enough room to store at least Count characters.
|
||
asm
|
||
PUSH ESI
|
||
PUSH EDI
|
||
MOV ESI, EDX
|
||
MOV EDI, EAX
|
||
MOV EDX, ECX
|
||
CMP EDI, ESI
|
||
JG @@1
|
||
JE @@2
|
||
SHR ECX, 1
|
||
REP MOVSD
|
||
MOV ECX, EDX
|
||
AND ECX, 1
|
||
REP MOVSW
|
||
JMP @@2
|
||
|
||
@@1:
|
||
LEA ESI, [ESI + 2 * ECX - 2]
|
||
LEA EDI, [EDI + 2 * ECX - 2]
|
||
STD
|
||
AND ECX, 1
|
||
REP MOVSW
|
||
SUB EDI, 2
|
||
SUB ESI, 2
|
||
MOV ECX, EDX
|
||
SHR ECX, 1
|
||
REP MOVSD
|
||
CLD
|
||
@@2:
|
||
POP EDI
|
||
POP ESI
|
||
end;
|
||
|
||
function WideStrRScan(Str: PWideChar; Chr: WideChar): PWideChar;
|
||
// returns a pointer to the last occurance of Chr in Str
|
||
asm
|
||
PUSH EDI
|
||
MOV EDI, Str
|
||
MOV ECX, 0FFFFFFFFH
|
||
XOR AX, AX
|
||
REPNE SCASW
|
||
NOT ECX
|
||
STD
|
||
SUB EDI, 2
|
||
MOV AX, Chr
|
||
REPNE SCASW
|
||
MOV EAX, 0
|
||
JNE @@1
|
||
MOV EAX, EDI
|
||
ADD EAX, 2
|
||
@@1:
|
||
CLD
|
||
POP EDI
|
||
end;
|
||
|
||
function WideStrScan(Str: PWideChar; Chr: WideChar): PWideChar;
|
||
// returns a pointer to first occurrence of a specified character in a string
|
||
asm
|
||
PUSH EDI
|
||
PUSH EAX
|
||
MOV EDI, Str
|
||
MOV ECX, 0FFFFFFFFH
|
||
XOR AX, AX
|
||
REPNE SCASW
|
||
NOT ECX
|
||
POP EDI
|
||
MOV AX, Chr
|
||
REPNE SCASW
|
||
MOV EAX, 0
|
||
JNE @@1
|
||
MOV EAX, EDI
|
||
SUB EAX, 2
|
||
@@1:
|
||
POP EDI
|
||
end;
|
||
|
||
function WideUpperCase(const S: WideString): WideString;
|
||
begin
|
||
Result := S;
|
||
if IsUnicode then
|
||
CharUpperBuffW_MP(PWideChar(Result), Length(Result))
|
||
else
|
||
CharUpperBuffA(PChar(string(Result)), Length(Result))
|
||
end;
|
||
|
||
function LibList: TList;
|
||
begin
|
||
if not Assigned(FLibList) then
|
||
FLibList := TList.Create;
|
||
Result := FLibList
|
||
end;
|
||
|
||
function CommonLoadLibrary(LibraryName: string): THandle;
|
||
var
|
||
i: Integer;
|
||
Found: Boolean;
|
||
LibRec: PLibRec;
|
||
begin
|
||
Result := 0;
|
||
Found := False;
|
||
i := 0;
|
||
while (i < LibList.Count) and not Found do
|
||
begin
|
||
LibRec := PLibRec(LibList[i]);
|
||
if lstrcmpi(PChar(LibRec.LibraryName), PChar(LibraryName)) = 0 then
|
||
begin
|
||
Inc(LibRec.ReferenceCount);
|
||
Result := LibRec.Handle;
|
||
Found := True
|
||
end;
|
||
Inc(i)
|
||
end;
|
||
if not Found then
|
||
begin
|
||
New(LibRec);
|
||
LibRec.Handle := LoadLibrary(PChar(LibraryName));
|
||
if LibRec.Handle <> 0 then
|
||
begin
|
||
LibRec.LibraryName := LibraryName;
|
||
LibRec.ReferenceCount := 1;
|
||
LibList.Add(LibRec);
|
||
Result := LibRec.Handle
|
||
end else
|
||
Dispose(LibRec)
|
||
end
|
||
end;
|
||
|
||
function CommonUnloadLibrary(LibraryName: string): Boolean;
|
||
var
|
||
i: Integer;
|
||
LibRec: PLibRec;
|
||
begin
|
||
Result := False;
|
||
i := 0;
|
||
while (i < LibList.Count) and not Result do
|
||
begin
|
||
LibRec := PLibRec(LibList[i]);
|
||
if lstrcmpi(PChar(LibRec.LibraryName), PChar(LibraryName)) = 0 then
|
||
begin
|
||
Dec(LibRec.ReferenceCount);
|
||
FreeLibrary(LibRec.Handle);
|
||
if LibRec.ReferenceCount = 0 then
|
||
begin
|
||
LibList.Delete(i);
|
||
Dispose(LibRec);
|
||
end;
|
||
Result := True
|
||
end;
|
||
Inc(i)
|
||
end;
|
||
if LibList.Count = 0 then
|
||
FreeAndNil(FLibList)
|
||
end;
|
||
|
||
procedure CommonUnloadAllLibraries;
|
||
var
|
||
i, LibIndex: Integer;
|
||
LibRec: PLibRec;
|
||
begin
|
||
i := 0;
|
||
while i < LibList.Count do
|
||
begin
|
||
LibRec := PLibRec(LibList[i]);
|
||
for LibIndex := 0 to LibRec.ReferenceCount - 1 do
|
||
FreeLibrary(LibRec.Handle);
|
||
LibList.Delete(i);
|
||
Dispose(LibRec);
|
||
Inc(i)
|
||
end;
|
||
FreeAndNil(FLibList);
|
||
end;
|
||
|
||
procedure DrawRadioButton(Canvas: TCanvas; Pos: TPoint; Size: Integer; clBackground, clHotBkGnd,
|
||
clLeftOuter, clRightOuter, clLeftInner, clRightInner: TColor; Checked, Enabled, Hot: Boolean);
|
||
begin
|
||
MarlettFont.Size := Size;
|
||
Canvas.Brush.Style := bsClear;
|
||
Canvas.Font.Assign(MarlettFont);
|
||
|
||
// Draw the background
|
||
if Hot then
|
||
Canvas.Font.Color := clHotBkGnd
|
||
else
|
||
Canvas.Font.Color := clBackground;
|
||
Canvas.TextOut(Pos.X, Pos.Y, 'n');
|
||
|
||
Canvas.Brush.Style := bsClear;
|
||
// Draw the Outer Circle
|
||
Canvas.Font.Color := clLeftOuter;
|
||
Canvas.TextOut(Pos.X, Pos.Y, 'j');
|
||
Canvas.Font.Color := clRightOuter;
|
||
Canvas.TextOut(Pos.X, Pos.Y, 'k');
|
||
// Draw the Inner Circle
|
||
Canvas.Font.Color := clLeftInner;
|
||
Canvas.TextOut(Pos.X, Pos.Y, 'l');
|
||
Canvas.Font.Color := clRightInner;
|
||
Canvas.TextOut(Pos.X, Pos.Y, 'm');
|
||
if Checked then
|
||
begin
|
||
if Enabled then
|
||
Canvas.Font.Color := clBlack
|
||
else
|
||
Canvas.Font.Color := clBtnShadow;
|
||
Canvas.TextOut(Pos.X, Pos.Y, 'i');
|
||
end
|
||
end;
|
||
|
||
procedure DrawCheckBox(Canvas: TCanvas; Pos: TPoint; Size: Integer; clBackground, clHotBkGnd,
|
||
clLeftOuter, clRightOuter, clLeftInner, clRightInner: TColor; Checked, Enabled, Hot: Boolean);
|
||
begin
|
||
MarlettFont.Size := Size;
|
||
Canvas.Brush.Style := bsSolid;
|
||
Canvas.Font.Assign(MarlettFont);
|
||
|
||
// Draw the background
|
||
if Hot then
|
||
Canvas.Font.Color := clHotBkGnd
|
||
else
|
||
Canvas.Font.Color := clBackground;
|
||
Canvas.TextOut(Pos.X, Pos.Y, Char($67));
|
||
|
||
Canvas.Brush.Style := bsClear;
|
||
// Draw the Outer Frame
|
||
Canvas.Font.Color := clLeftOuter;
|
||
Canvas.TextOut(Pos.X, Pos.Y, Char($63));
|
||
Canvas.Font.Color := clRightOuter;
|
||
Canvas.TextOut(Pos.X, Pos.Y, Char($64));
|
||
// Draw the Inner Frame
|
||
Canvas.Font.Color := clLeftInner;
|
||
Canvas.TextOut(Pos.X, Pos.Y, Char($65));
|
||
Canvas.Font.Color := clRightInner;
|
||
Canvas.TextOut(Pos.X, Pos.Y, Char($66));
|
||
if Checked then
|
||
begin
|
||
if Enabled then
|
||
Canvas.Font.Color := clBlack
|
||
else
|
||
Canvas.Font.Color := clBtnShadow;
|
||
Canvas.TextOut(Pos.X, Pos.Y, Char($62));
|
||
end
|
||
end;
|
||
|
||
function CheckBounds(Size: Integer): TRect;
|
||
var
|
||
Canvas: TCanvas;
|
||
begin
|
||
Result := Rect(0, 0, 0, 0);
|
||
Canvas := TCanvas.Create;
|
||
try
|
||
Canvas.Handle := GetDC(0);
|
||
Canvas.Font.Name := 'Marlett';
|
||
Canvas.Font.Size := Size;
|
||
// Use the background for the Checkbox for the size, the Radio will be this
|
||
// size or a bit smaller
|
||
Result.Right := Canvas.TextWidth(Char($67));
|
||
Result.Bottom := Canvas.TextHeight(Char($67));
|
||
finally
|
||
if Assigned(Canvas) then
|
||
begin
|
||
ReleaseDC(0, Canvas.Handle);
|
||
Canvas.Handle := 0
|
||
end;
|
||
Canvas.Free
|
||
end;
|
||
end;
|
||
|
||
|
||
function HasMMX: Boolean;
|
||
|
||
// Helper method to determine whether the current processor supports MMX.
|
||
|
||
asm
|
||
PUSH EBX
|
||
XOR EAX, EAX // Result := False
|
||
PUSHFD // determine if the processor supports the CPUID command
|
||
POP EDX
|
||
MOV ECX, EDX
|
||
XOR EDX, $200000
|
||
PUSH EDX
|
||
POPFD
|
||
PUSHFD
|
||
POP EDX
|
||
XOR ECX, EDX
|
||
JZ @1 // no CPUID support so we can't even get to the feature information
|
||
PUSH EDX
|
||
POPFD
|
||
|
||
MOV EAX, 1
|
||
DW $A20F // CPUID, EAX contains now version info and EDX feature information
|
||
MOV EBX, EAX // free EAX to get the result value
|
||
XOR EAX, EAX // Result := False
|
||
CMP EBX, $50
|
||
JB @1 // if processor family is < 5 then it is not a Pentium class processor
|
||
TEST EDX, $800000
|
||
JZ @1 // if the MMX bit is not set then we don't have MMX
|
||
INC EAX // Result := True
|
||
@1:
|
||
POP EBX
|
||
end;
|
||
|
||
procedure AlphaBlendLineConstant(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);
|
||
// Blends a line of Count pixels from Source to Destination using a constant alpha value.
|
||
// The layout of a pixel must be BGRA where A is ignored (but is calculated as the other components).
|
||
// ConstantAlpha must be in the range 0..255 where 0 means totally transparent (destination pixel only)
|
||
// and 255 totally opaque (source pixel only).
|
||
// Bias is an additional value which gets added to every component and must be in the range -128..127
|
||
//
|
||
// EAX contains Source
|
||
// EDX contains Destination
|
||
// ECX contains Count
|
||
// ConstantAlpha and Bias are on the stack
|
||
asm
|
||
PUSH ESI // save used registers
|
||
PUSH EDI
|
||
|
||
MOV ESI, EAX // ESI becomes the actual source pointer
|
||
MOV EDI, EDX // EDI becomes the actual target pointer
|
||
|
||
// Load MM6 with the constant alpha value (replicate it for every component).
|
||
// Expand it to word size.
|
||
MOV EAX, [ConstantAlpha]
|
||
DB $0F, $6E, $F0 /// MOVD MM6, EAX
|
||
DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6
|
||
DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6
|
||
|
||
// Load MM5 with the bias value.
|
||
MOV EAX, [Bias]
|
||
DB $0F, $6E, $E8 /// MOVD MM5, EAX
|
||
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
|
||
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
|
||
|
||
// Load MM4 with 128 to allow for saturated biasing.
|
||
MOV EAX, 128
|
||
DB $0F, $6E, $E0 /// MOVD MM4, EAX
|
||
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
|
||
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
|
||
|
||
@1: // The pixel loop calculates an entire pixel in one run.
|
||
// Note: The pixel byte values are expanded into the higher bytes of a word due
|
||
// to the way unpacking works. We compensate for this with an extra shift.
|
||
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
|
||
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
|
||
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
|
||
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
|
||
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
|
||
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
|
||
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
|
||
|
||
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
|
||
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
|
||
DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha * (source - target)
|
||
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
|
||
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
|
||
|
||
// Bias is accounted for by conversion of range 0..255 to -128..127,
|
||
// doing a saturated add and convert back to 0..255.
|
||
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
|
||
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
|
||
DB $0F, $FD, $C4 /// PADDW MM0, MM4
|
||
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
|
||
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
|
||
@3:
|
||
ADD ESI, 4
|
||
ADD EDI, 4
|
||
DEC ECX
|
||
JNZ @1
|
||
POP EDI
|
||
POP ESI
|
||
end;
|
||
|
||
procedure AlphaBlendLinePerPixel(Source, Destination: Pointer; Count, Bias: Integer);
|
||
// Blends a line of Count pixels from Source to Destination using the alpha value of the source pixels.
|
||
// The layout of a pixel must be BGRA.
|
||
// Bias is an additional value which gets added to every component and must be in the range -128..127
|
||
//
|
||
// EAX contains Source
|
||
// EDX contains Destination
|
||
// ECX contains Count
|
||
// Bias is on the stack
|
||
asm
|
||
PUSH ESI // save used registers
|
||
PUSH EDI
|
||
|
||
MOV ESI, EAX // ESI becomes the actual source pointer
|
||
MOV EDI, EDX // EDI becomes the actual target pointer
|
||
|
||
// Load MM5 with the bias value.
|
||
MOV EAX, [Bias]
|
||
DB $0F, $6E, $E8 /// MOVD MM5, EAX
|
||
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
|
||
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
|
||
|
||
// Load MM4 with 128 to allow for saturated biasing.
|
||
MOV EAX, 128
|
||
DB $0F, $6E, $E0 /// MOVD MM4, EAX
|
||
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
|
||
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
|
||
|
||
@1: // The pixel loop calculates an entire pixel in one run.
|
||
// Note: The pixel byte values are expanded into the higher bytes of a word due
|
||
// to the way unpacking works. We compensate for this with an extra shift.
|
||
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
|
||
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
|
||
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
|
||
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
|
||
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
|
||
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
|
||
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
|
||
|
||
// Load MM6 with the source alpha value (replicate it for every component).
|
||
// Expand it to word size.
|
||
DB $0F, $6F, $F0 /// MOVQ MM6, MM0
|
||
DB $0F, $69, $F6 /// PUNPCKHWD MM6, MM6
|
||
DB $0F, $6A, $F6 /// PUNPCKHDQ MM6, MM6
|
||
|
||
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
|
||
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
|
||
DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha * (source - target)
|
||
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
|
||
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
|
||
|
||
// Bias is accounted for by conversion of range 0..255 to -128..127,
|
||
// doing a saturated add and convert back to 0..255.
|
||
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
|
||
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
|
||
DB $0F, $FD, $C4 /// PADDW MM0, MM4
|
||
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
|
||
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
|
||
@3:
|
||
ADD ESI, 4
|
||
ADD EDI, 4
|
||
DEC ECX
|
||
JNZ @1
|
||
POP EDI
|
||
POP ESI
|
||
end;
|
||
|
||
procedure AlphaBlendLineMaster(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);
|
||
// Blends a line of Count pixels from Source to Destination using the source pixel and a constant alpha value.
|
||
// The layout of a pixel must be BGRA.
|
||
// ConstantAlpha must be in the range 0..255.
|
||
// Bias is an additional value which gets added to every component and must be in the range -128..127
|
||
//
|
||
// EAX contains Source
|
||
// EDX contains Destination
|
||
// ECX contains Count
|
||
// ConstantAlpha and Bias are on the stack
|
||
asm
|
||
PUSH ESI // save used registers
|
||
PUSH EDI
|
||
|
||
MOV ESI, EAX // ESI becomes the actual source pointer
|
||
MOV EDI, EDX // EDI becomes the actual target pointer
|
||
|
||
// Load MM6 with the constant alpha value (replicate it for every component).
|
||
// Expand it to word size.
|
||
MOV EAX, [ConstantAlpha]
|
||
DB $0F, $6E, $F0 /// MOVD MM6, EAX
|
||
DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6
|
||
DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6
|
||
|
||
// Load MM5 with the bias value.
|
||
MOV EAX, [Bias]
|
||
DB $0F, $6E, $E8 /// MOVD MM5, EAX
|
||
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
|
||
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
|
||
|
||
// Load MM4 with 128 to allow for saturated biasing.
|
||
MOV EAX, 128
|
||
DB $0F, $6E, $E0 /// MOVD MM4, EAX
|
||
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
|
||
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
|
||
|
||
@1: // The pixel loop calculates an entire pixel in one run.
|
||
// Note: The pixel byte values are expanded into the higher bytes of a word due
|
||
// to the way unpacking works. We compensate for this with an extra shift.
|
||
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
|
||
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
|
||
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
|
||
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
|
||
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
|
||
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
|
||
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
|
||
|
||
// Load MM7 with the source alpha value (replicate it for every component).
|
||
// Expand it to word size.
|
||
DB $0F, $6F, $F8 /// MOVQ MM7, MM0
|
||
DB $0F, $69, $FF /// PUNPCKHWD MM7, MM7
|
||
DB $0F, $6A, $FF /// PUNPCKHDQ MM7, MM7
|
||
DB $0F, $D5, $FE /// PMULLW MM7, MM6, source alpha * master alpha
|
||
DB $0F, $71, $D7, $08 /// PSRLW MM7, 8, divide by 256
|
||
|
||
// calculation is: target = (alpha * master alpha * (source - target) + 256 * target) / 256
|
||
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
|
||
DB $0F, $D5, $C7 /// PMULLW MM0, MM7, alpha * (source - target)
|
||
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
|
||
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
|
||
|
||
// Bias is accounted for by conversion of range 0..255 to -128..127,
|
||
// doing a saturated add and convert back to 0..255.
|
||
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
|
||
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
|
||
DB $0F, $FD, $C4 /// PADDW MM0, MM4
|
||
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
|
||
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
|
||
@3:
|
||
ADD ESI, 4
|
||
ADD EDI, 4
|
||
DEC ECX
|
||
JNZ @1
|
||
POP EDI
|
||
POP ESI
|
||
end;
|
||
|
||
procedure AlphaBlendLineMasterAndColor(Destination: Pointer; Count: Integer; ConstantAlpha, Color: Integer);
|
||
// Blends a line of Count pixels in Destination against the given color using a constant alpha value.
|
||
// The layout of a pixel must be BGRA and Color must be rrggbb00 (as stored by a COLORREF).
|
||
// ConstantAlpha must be in the range 0..255.
|
||
//
|
||
// EAX contains Destination
|
||
// EDX contains Count
|
||
// ECX contains ConstantAlpha
|
||
// Color is passed on the stack
|
||
asm
|
||
// The used formula is: target = (alpha * color + (256 - alpha) * target) / 256.
|
||
// alpha * color (factor 1) and 256 - alpha (factor 2) are constant values which can be calculated in advance.
|
||
// The remaining calculation is therefore: target = (F1 + F2 * target) / 256
|
||
|
||
// Load MM3 with the constant alpha value (replicate it for every component).
|
||
// Expand it to word size. (Every calculation here works on word sized operands.)
|
||
DB $0F, $6E, $D9 /// MOVD MM3, ECX
|
||
DB $0F, $61, $DB /// PUNPCKLWD MM3, MM3
|
||
DB $0F, $62, $DB /// PUNPCKLDQ MM3, MM3
|
||
|
||
// Calculate factor 2.
|
||
MOV ECX, $100
|
||
DB $0F, $6E, $D1 /// MOVD MM2, ECX
|
||
DB $0F, $61, $D2 /// PUNPCKLWD MM2, MM2
|
||
DB $0F, $62, $D2 /// PUNPCKLDQ MM2, MM2
|
||
DB $0F, $F9, $D3 /// PSUBW MM2, MM3 // MM2 contains now: 255 - alpha = F2
|
||
|
||
// Now calculate factor 1. Alpha is still in MM3, but the r and b components of Color must be swapped.
|
||
MOV ECX, [Color]
|
||
BSWAP ECX
|
||
ROR ECX, 8
|
||
DB $0F, $6E, $C9 /// MOVD MM1, ECX // Load the color and convert to word sized values.
|
||
DB $0F, $EF, $E4 /// PXOR MM4, MM4
|
||
DB $0F, $60, $CC /// PUNPCKLBW MM1, MM4
|
||
DB $0F, $D5, $CB /// PMULLW MM1, MM3 // MM1 contains now: color * alpha = F1
|
||
|
||
@1: // The pixel loop calculates an entire pixel in one run.
|
||
DB $0F, $6E, $00 /// MOVD MM0, [EAX]
|
||
DB $0F, $60, $C4 /// PUNPCKLBW MM0, MM4
|
||
|
||
DB $0F, $D5, $C2 /// PMULLW MM0, MM2 // calculate F1 + F2 * target
|
||
DB $0F, $FD, $C1 /// PADDW MM0, MM1
|
||
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8 // divide by 256
|
||
|
||
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0 // convert words to bytes with saturation
|
||
DB $0F, $7E, $00 /// MOVD [EAX], MM0 // store the result
|
||
|
||
ADD EAX, 4
|
||
DEC EDX
|
||
JNZ @1
|
||
end;
|
||
|
||
procedure EMMS;
|
||
// Reset MMX state to use the FPU for other tasks again.
|
||
asm
|
||
DB $0F, $77 /// EMMS
|
||
end;
|
||
|
||
function GetBitmapBitsFromDeviceContext(DC: HDC; var Width, Height: Integer): Pointer;
|
||
// Helper function used to retrieve the bitmap selected into the given device context. If there is a bitmap then
|
||
// the function will return a pointer to its bits otherwise nil is returned.
|
||
// Additionally the dimensions of the bitmap are returned.
|
||
var
|
||
Bitmap: HBITMAP;
|
||
DIB: TDIBSection;
|
||
begin
|
||
Result := nil;
|
||
Width := 0;
|
||
Height := 0;
|
||
|
||
Bitmap := GetCurrentObject(DC, OBJ_BITMAP);
|
||
if Bitmap <> 0 then
|
||
begin
|
||
if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then
|
||
begin
|
||
Assert(DIB.dsBm.bmPlanes * DIB.dsBm.bmBitsPixel = 32, 'Alpha blending error: bitmap must use 32 bpp.');
|
||
Result := DIB.dsBm.bmBits;
|
||
Width := DIB.dsBmih.biWidth;
|
||
Height := DIB.dsBmih.biHeight;
|
||
end;
|
||
end;
|
||
Assert(Result <> nil, 'Alpha blending DC error: no bitmap available.');
|
||
end;
|
||
|
||
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
|
||
// Helper function to calculate the start address for the given row.
|
||
begin
|
||
if Height > 0 then // bottom-up DIB
|
||
Row := Height - Row - 1;
|
||
// Return DWORD aligned address of the requested scanline.
|
||
Integer(Result) := Integer(Bits) + Row * ((Width * 32 + 31) and not 31) div 8;
|
||
end;
|
||
|
||
procedure ConvertBitmapEx(Image32: TBitmap; var OutImage: TBitmap; const BackGndColor: TColor);
|
||
|
||
var
|
||
I, N: Integer;
|
||
LongColor: DWORD;
|
||
SourceRed, SourceGreen, SourceBlue, BkGndRed, BkGndGreen, BkGndBlue, RedTarget, GreenTarget, BlueTarget, Alpha: Byte;
|
||
Target, Mask: TBitmap;
|
||
LineDeltaImage32, PixelDeltaImage32, LineDeltaTarget, PixelDeltaTarget, LineDeltaMask, PixelDeltaMask: Integer;
|
||
PLineImage32, PLineTarget, PLineMask, PPixelImage32, PPixelTarget, PPixelMask: PByte;
|
||
begin
|
||
// Algorithm only works for bitmaps with a height > 1 pixel, should not be a limitation
|
||
// as it would then be a line!
|
||
if (Image32.PixelFormat = pf32Bit) and (Image32.Height > 1) then
|
||
begin
|
||
Target := TBitmap.Create;
|
||
Mask := TBitmap.Create;
|
||
try
|
||
Target.PixelFormat := pf32Bit;
|
||
Target.Width := Image32.Width;
|
||
Target.Height := Image32.Height;
|
||
Target.Assign(Image32);
|
||
|
||
Mask.PixelFormat := pf32Bit;
|
||
Mask.Width := Image32.Width;
|
||
Mask.Height := Image32.Height;
|
||
Mask.Canvas.Brush.Color := BackGndColor;
|
||
Mask.Canvas.FillRect(Mask.Canvas.ClipRect);
|
||
|
||
LineDeltaImage32 := DWORD( Image32.ScanLine[1]) - DWORD( Image32.ScanLine[0]);
|
||
LineDeltaTarget := DWORD( Target.ScanLine[1]) - DWORD( Target.ScanLine[0]);
|
||
LineDeltaMask := DWORD( Mask.ScanLine[1]) - DWORD( Mask.ScanLine[0]);
|
||
|
||
PixelDeltaImage32 := SizeOf(TRGBQuad);
|
||
PixelDeltaTarget := SizeOf(TRGBQuad);
|
||
PixelDeltaMask := SizeOf(TRGBQuad);
|
||
|
||
PLineImage32 := Image32.ScanLine[0];
|
||
PLineTarget := Target.ScanLine[0];
|
||
PLineMask := Mask.ScanLine[0];
|
||
|
||
for I := 0 to Image32.Height - 1 do
|
||
begin
|
||
PPixelImage32 := PLineImage32;
|
||
PPixelTarget := PLineTarget;
|
||
PPixelMask := PLineMask;
|
||
|
||
for N := 0 to Image32.Width - 1 do
|
||
begin
|
||
// Source GetColorValues ; Profiled = ~24-30% of time
|
||
LongColor := PDWORD( PPixelImage32)^;
|
||
SourceBlue := LongColor and $000000FF;
|
||
SourceGreen := (LongColor and $0000FF00) shr 8;
|
||
SourceRed := (LongColor and $00FF0000) shr 16;
|
||
Alpha := (LongColor and $FF000000) shr 24;
|
||
|
||
// Mask GetColorValues ; Profiled = ~24-30% of time
|
||
LongColor := PDWORD( PPixelMask)^;
|
||
BkGndBlue := LongColor and $000000FF;
|
||
BkGndGreen := (LongColor and $0000FF00) shr 8;
|
||
BkGndRed := (LongColor and $00FF0000) shr 16;
|
||
|
||
if Alpha < High(Byte) then
|
||
begin
|
||
// displayColor = sourceColor<6F>alpha / 255 + backgroundColor<6F>(255 <20> alpha) / 255
|
||
// Profiled = ~15-24% of time
|
||
RedTarget := SourceRed*Alpha shr 8 + BkGndRed*(255-Alpha) shr 8;
|
||
GreenTarget := SourceGreen*Alpha shr 8 + BkGndGreen*(255-Alpha) shr 8;
|
||
BlueTarget := SourceBlue*Alpha shr 8 + BkGndBlue*(255-Alpha) shr 8;
|
||
end else
|
||
begin
|
||
// skip non-blended pixels
|
||
RedTarget := SourceRed;
|
||
GreenTarget := SourceGreen;
|
||
BlueTarget := SourceBlue;
|
||
end;
|
||
|
||
// Create the RGB DWORD color ; Profiled = ~8%-9%% of time
|
||
// Mask out all but the alpha channel then build the backwards stored RGB preserving the alpha channel bits
|
||
PDWORD(PPixelTarget)^ := ((BlueTarget) or (GreenTarget shl 8)or (RedTarget shl 16));
|
||
|
||
Inc(PPixelImage32, PixelDeltaImage32);
|
||
Inc(PPixelTarget, PixelDeltaTarget);
|
||
Inc(PPixelMask, PixelDeltaMask);
|
||
end;
|
||
Inc(PLineImage32, LineDeltaImage32);
|
||
Inc(PLineTarget, LineDeltaTarget);
|
||
Inc(PLineMask, LineDeltaMask);
|
||
end;
|
||
OutImage.Assign(Target);
|
||
finally
|
||
FreeAndNil(Target);
|
||
FreeAndNil(Mask);
|
||
end;
|
||
end else
|
||
OutImage.Assign(Image32)
|
||
end;
|
||
|
||
procedure AlphaBlend(Source, Destination: HDC; R: TRect; Target: TPoint; Mode: TCommonBlendMode; ConstantAlpha, Bias: Integer);
|
||
|
||
// NOTE:::::::::::::
|
||
// AlphaBlend does not respect any clipping in the DC!!!!!!!
|
||
//
|
||
|
||
// Optimized alpha blend procedure using MMX instructions to perform as quick as possible.
|
||
// For this procedure to work properly it is important that both source and target bitmap use the 32 bit color format.
|
||
// R describes the source rectangle to work on.
|
||
// Target is the place (upper left corner) in the target bitmap where to blend to. Note that source width + X offset
|
||
// must be less or equal to the target width. Similar for the height.
|
||
// If Mode is bmConstantAlpha then the blend operation uses the given ConstantAlpha value for all pixels.
|
||
// If Mode is bmPerPixelAlpha then each pixel is blended using its individual alpha value (the alpha value of the source).
|
||
// If Mode is bmMasterAlpha then each pixel is blended using its individual alpha value multiplied by ConstantAlpha.
|
||
// If Mode is bmConstantAlphaAndColor then each destination pixel is blended using ConstantAlpha but also a constant
|
||
// color which will be obtained from Bias. In this case no offset value is added, otherwise Bias is used as offset.
|
||
// Blending of a color into target only (bmConstantAlphaAndColor) ignores Source (the DC) and Target (the position).
|
||
// CAUTION: This procedure does not check whether MMX instructions are actually available! Call it only if MMX is really
|
||
// usable.
|
||
|
||
var
|
||
Y: Integer;
|
||
SourceRun,
|
||
TargetRun: PByte;
|
||
|
||
SourceBits,
|
||
DestBits: Pointer;
|
||
SourceWidth,
|
||
SourceHeight,
|
||
DestWidth,
|
||
DestHeight: Integer;
|
||
|
||
begin
|
||
if not IsRectEmpty(R) then
|
||
begin
|
||
// Note: it is tempting to optimize the special cases for constant alpha 0 and 255 by just ignoring soure
|
||
// (alpha = 0) or simply do a blit (alpha = 255). But this does not take the bias into account.
|
||
case Mode of
|
||
cbmConstantAlpha:
|
||
begin
|
||
// Get a pointer to the bitmap bits for the source and target device contexts.
|
||
// Note: this supposes that both contexts do actually have bitmaps assigned!
|
||
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
|
||
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
|
||
if Assigned(SourceBits) and Assigned(DestBits) then
|
||
begin
|
||
for Y := 0 to R.Bottom - R.Top - 1 do
|
||
begin
|
||
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
|
||
Inc(SourceRun, 4 * R.Left);
|
||
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
|
||
Inc(TargetRun, 4 * Target.X);
|
||
AlphaBlendLineConstant(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
|
||
end;
|
||
end;
|
||
EMMS;
|
||
end;
|
||
cbmPerPixelAlpha:
|
||
begin
|
||
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
|
||
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
|
||
if Assigned(SourceBits) and Assigned(DestBits) then
|
||
begin
|
||
for Y := 0 to R.Bottom - R.Top - 1 do
|
||
begin
|
||
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
|
||
Inc(SourceRun, 4 * R.Left);
|
||
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
|
||
Inc(TargetRun, 4 * Target.X);
|
||
AlphaBlendLinePerPixel(SourceRun, TargetRun, R.Right - R.Left, Bias);
|
||
end;
|
||
end;
|
||
EMMS;
|
||
end;
|
||
cbmMasterAlpha:
|
||
begin
|
||
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
|
||
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
|
||
if Assigned(SourceBits) and Assigned(DestBits) then
|
||
begin
|
||
for Y := 0 to R.Bottom - R.Top - 1 do
|
||
begin
|
||
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
|
||
Inc(SourceRun, 4 * Target.X);
|
||
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
|
||
AlphaBlendLineMaster(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
|
||
end;
|
||
end;
|
||
EMMS;
|
||
end;
|
||
cbmConstantAlphaAndColor:
|
||
begin
|
||
// Source is ignore since there is a constant color value.
|
||
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
|
||
if Assigned(DestBits) then
|
||
begin
|
||
for Y := 0 to R.Bottom - R.Top - 1 do
|
||
begin
|
||
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + R.Top);
|
||
Inc(TargetRun, 4 * R.Left);
|
||
AlphaBlendLineMasterAndColor(TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
|
||
end;
|
||
end;
|
||
EMMS;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function DrawTextWEx(DC: HDC; Text: WideString; var lpRect: TRect;
|
||
Flags: TCommonDrawTextWFlags; MaxLineCount: Integer): Integer;
|
||
// Creates and extented version of DrawTextW that works in Win9x as well as
|
||
// NT. If MaxLineCount is -1 then the line count will depend on the Text. All
|
||
// lines that are extracted from the text are drawn or calcuated in the rectangle
|
||
//
|
||
// The result is the number of lines actually drawn, note if the CalcRect flags are
|
||
// used the result will be the number of lines that would be drawn
|
||
var
|
||
TextMetrics: TTextMetric;
|
||
Size: TSize;
|
||
TextPosX, TextPosY, i, NewLineTop: Integer;
|
||
TextOutFlags: Longword;
|
||
LineRect, OldlpRect: TRect;
|
||
Buffer: TCommonWideCharArray;
|
||
BufferIndex: PWideChar;
|
||
ShortText: WideString;
|
||
VOffset, SplitCount: Integer;
|
||
begin
|
||
OldlpRect := lpRect;
|
||
GetTextMetrics(DC, TextMetrics);
|
||
|
||
TextOutFlags := 0;
|
||
if dtRTLReading in Flags then
|
||
TextOutFlags := TextOutFlags or ETO_RTLREADING;
|
||
if not (dtNoClip in Flags) then
|
||
TextOutFlags := TextOutFlags or ETO_CLIPPED;
|
||
|
||
if dtSingleLine in Flags then
|
||
begin
|
||
Result := 1; // Easy one!
|
||
|
||
// Set up the LineRect in the Vertical Direction
|
||
// Default to the top
|
||
LineRect := Rect(lpRect.Left, lpRect.Top, lpRect.Right, lpRect.Top + TextMetrics.tmHeight);
|
||
if dtVCenter in Flags then
|
||
OffsetRect(LineRect, 0, (RectHeight(lpRect) - RectHeight(LineRect)) div 2)
|
||
else
|
||
if dtBottom in Flags then
|
||
OffsetRect(LineRect, 0, RectHeight(lpRect) - RectHeight(LineRect));
|
||
TextPosX := LineRect.Left;
|
||
TextPosY := LineRect.Top;
|
||
|
||
if dtEndEllipsis in Flags then
|
||
Text := ShortenTextW(DC, Text, RectWidth(LineRect));
|
||
|
||
GetTextExtentPoint32W(DC, PWideChar(Text), Length(Text), Size);
|
||
if Flags * [dtCenter, dtRight] <> [] then
|
||
begin
|
||
if dtCenter in Flags then
|
||
TextPosX := TextPosX + (RectWidth(LineRect) - Size.cx) div 2
|
||
else
|
||
TextPosX := LineRect.Right - Size.cx
|
||
end;
|
||
|
||
{ if dtCenter in Flags then
|
||
SetTextAlign(DC, TA_CENTER)
|
||
else
|
||
if dtLeft in Flags then
|
||
SetTextAlign(DC, TA_LEFT)
|
||
else
|
||
if dtRight in Flags then
|
||
SetTextAlign(DC, TA_RIGHT); }
|
||
|
||
// See if the caller wants to only calculate the rectangle for the text
|
||
if dtCalcRect in Flags then
|
||
begin
|
||
// Assume that the text will fit in the calulated line/rect
|
||
lpRect.Left := TextPosX;
|
||
lpRect.Top := TextPosY;
|
||
lpRect.Bottom := LineRect.Bottom;
|
||
lpRect.Right := lpRect.Left + Size.cx;
|
||
|
||
// If it does not then we have to do some adjusting
|
||
if Size.cx > RectWidth(OldlpRect) then
|
||
begin
|
||
if dtCalcRectAlign in Flags then
|
||
begin
|
||
lpRect.Left := OldlpRect.Left;
|
||
lpRect.Right := OldlpRect.Right;
|
||
end;
|
||
if dtCalcRectAdjR in Flags then
|
||
lpRect.Right := lpRect.Left + Size.cx;
|
||
end
|
||
end else
|
||
ExtTextOutW(DC, TextPosX, TextPosY, TextOutFlags, @LineRect, PWideChar(Text), Length(Text), nil);
|
||
|
||
end else
|
||
begin
|
||
// It is multi-line
|
||
SplitCount := SplitTextW(DC, Text, lpRect.Right-lpRect.Left, Buffer, MaxLineCount);
|
||
i := 0;
|
||
if Length(Buffer) > 0 then
|
||
begin
|
||
// We call ourselves recursivly one line at a time to draw the multi line text
|
||
Include(Flags, dtSingleLine);
|
||
BufferIndex := @Buffer[0];
|
||
|
||
// Calculate where the center of the text block is with respect to the
|
||
// rectangle
|
||
{ if dtVCenter in Flags then
|
||
begin
|
||
if (SplitCount > MaxLineCount) and (MaxLineCount > -1) then
|
||
VOffset := (RectHeight(OldlpRect) - (TextMetrics.tmHeight * MaxLineCount)) div 2
|
||
else
|
||
VOffset := (RectHeight(OldlpRect) - (TextMetrics.tmHeight * SplitCount)) div 2;
|
||
if VOffset < 0 then
|
||
VOffset := 0;
|
||
end else
|
||
if dtBottom in Flags then
|
||
begin
|
||
VOffset := (RectHeight(OldlpRect) - (TextMetrics.tmHeight * MaxLineCount))
|
||
end else
|
||
VOffset := 0; }
|
||
|
||
// Fix for multitext vertical alignment from Solerman Kaplon 11.9.04
|
||
if (dtVCenter in Flags) or (dtBottom in Flags) then
|
||
begin
|
||
if (SplitCount > MaxLineCount) and (MaxLineCount > -1) then
|
||
VOffset := (RectHeight(OldlpRect) - (TextMetrics.tmHeight * MaxLineCount))
|
||
else
|
||
VOffset := (RectHeight(OldlpRect) - (TextMetrics.tmHeight * SplitCount));
|
||
if VOffset < 0 then
|
||
VOffset := 0
|
||
else
|
||
if dtVCenter in Flags then
|
||
VOffset := VOffset shr 1;
|
||
end else
|
||
VOffset := 0;
|
||
while ((i < MaxLineCount) or (MaxLineCount < 0)) and (BufferIndex^ <> WideNull) do
|
||
begin
|
||
// Calculate where the top of a single line of text starts
|
||
NewLineTop := OldlpRect.Top + (i * TextMetrics.tmHeight) + VOffset;
|
||
LineRect := Rect(OldlpRect.Left, NewLineTop, OldlpRect.Right, NewLineTop + TextMetrics.tmHeight);
|
||
if (dtEndEllipsis in Flags) {and not(dtCalcRect in Flags)} then
|
||
begin
|
||
ShortText := ShortenTextW(DC, WideString(BufferIndex), RectWidth(OldlpRect));
|
||
DrawTextWEx(DC, ShortText, LineRect, Flags, MaxLineCount);
|
||
end else
|
||
DrawTextWEx(DC, WideString(BufferIndex), LineRect, Flags, MaxLineCount);
|
||
|
||
if dtCalcRect in Flags then
|
||
begin
|
||
if i = 0 then
|
||
lpRect := LineRect
|
||
else
|
||
UnionRect(lpRect, lpRect, LineRect);
|
||
end;
|
||
Inc(BufferIndex, lStrLenW(BufferIndex) + 1);
|
||
Inc(i)
|
||
end;
|
||
|
||
if (SplitCount = 0) and (dtCalcRect in Flags) then
|
||
begin
|
||
if dtCalcRectAdjR in Flags then
|
||
begin
|
||
lpRect.Right := lpRect.Left;
|
||
lpRect.Bottom := lpRect.Top + TextMetrics.tmHeight
|
||
end else
|
||
begin
|
||
lpRect.Bottom := lpRect.Top;
|
||
lpREct.Right := lpRect.Left + TextMetrics.tmAveCharWidth
|
||
end
|
||
end;
|
||
|
||
if SplitCount > MaxLineCount then
|
||
Result := MaxLineCount
|
||
else
|
||
Result := SplitCount
|
||
end else
|
||
Result := 0;
|
||
end
|
||
end;
|
||
|
||
// Helpers to create a callback function out of a object method
|
||
{ ----------------------------------------------------------------------------- }
|
||
{ This is a piece of magic by Jeroen Mineur. Allows a class method to be used }
|
||
{ as a callback. Create a stub using CreateStub with the instance of the object }
|
||
{ the callback should call as the first parameter and the method as the second }
|
||
{ parameter, ie @TForm1.MyCallback or declare a type of object for the callback }
|
||
{ method and then use a variable of that type and set the variable to the }
|
||
{ method and pass it: }
|
||
{ }
|
||
{ type }
|
||
{ TEnumWindowsFunc = function (AHandle: hWnd; Param: lParam): BOOL of object; stdcall; }
|
||
{ }
|
||
{ TForm1 = class(TForm) }
|
||
{ private }
|
||
{ function EnumWindowsProc(AHandle: hWnd; Param: lParam): BOOL; stdcall; }
|
||
{ end; }
|
||
{ }
|
||
{ var }
|
||
{ MyFunc: TEnumWindowsFunc; }
|
||
{ Stub: pointer; }
|
||
{ begin }
|
||
{ MyFunct := EnumWindowsProc; }
|
||
{ Stub := CreateStub(Self, MyFunct); }
|
||
{ .... }
|
||
{ or }
|
||
{ }
|
||
{ var }
|
||
{ Stub: pointer; }
|
||
{ begin }
|
||
{ MyFunct := EnumWindowsProc; }
|
||
{ Stub := CreateStub(Self, TForm1.EnumWindowsProc); }
|
||
{ .... }
|
||
{ Now Stub can be passed as the callback pointer to any windows API }
|
||
{ Don't forget to call Dispose Stub when not needed }
|
||
{ ----------------------------------------------------------------------------- }
|
||
const
|
||
AsmPopEDX = $5A;
|
||
AsmMovEAX = $B8;
|
||
AsmPushEAX = $50;
|
||
AsmPushEDX = $52;
|
||
AsmJmpShort = $E9;
|
||
|
||
type
|
||
TStub = packed record
|
||
PopEDX: Byte;
|
||
MovEAX: Byte;
|
||
SelfPointer: Pointer;
|
||
PushEAX: Byte;
|
||
PushEDX: Byte;
|
||
JmpShort: Byte;
|
||
Displacement: Integer;
|
||
end;
|
||
|
||
{ ----------------------------------------------------------------------------- }
|
||
function CreateStub(ObjectPtr: Pointer; MethodPtr: Pointer): Pointer;
|
||
var
|
||
Stub: ^TStub;
|
||
begin
|
||
// Allocate memory for the stub
|
||
// 1/10/04 Support for 64 bit, executable code must be in virtual space
|
||
Stub := VirtualAlloc(nil, SizeOf(TStub), MEM_COMMIT, PAGE_EXECUTE_READWRITE);
|
||
|
||
// Pop the return address off the stack
|
||
Stub^.PopEDX := AsmPopEDX;
|
||
|
||
// Push the object pointer on the stack
|
||
Stub^.MovEAX := AsmMovEAX;
|
||
Stub^.SelfPointer := ObjectPtr;
|
||
Stub^.PushEAX := AsmPushEAX;
|
||
|
||
// Push the return address back on the stack
|
||
Stub^.PushEDX := AsmPushEDX;
|
||
|
||
// Jump to the 'real' procedure, the method.
|
||
Stub^.JmpShort := AsmJmpShort;
|
||
Stub^.Displacement := (Integer(MethodPtr) - Integer(@(Stub^.JmpShort))) -
|
||
(SizeOf(Stub^.JmpShort) + SizeOf(Stub^.Displacement));
|
||
|
||
// Return a pointer to the stub
|
||
Result := Stub;
|
||
end;
|
||
{ ----------------------------------------------------------------------------- }
|
||
|
||
{ ----------------------------------------------------------------------------- }
|
||
procedure DisposeStub(Stub: Pointer);
|
||
begin
|
||
// 1/10/04 Support for 64 bit, executable code must be in virtual space
|
||
VirtualFree(Stub, SizeOf(TStub),MEM_DECOMMIT);
|
||
end;
|
||
{ ----------------------------------------------------------------------------- }
|
||
|
||
{$IFNDEF COMPILER_5_UP}
|
||
function Supports(const Instance: IUnknown; const IID: TGUID; out Intf): Boolean;
|
||
begin
|
||
Result := (Instance <> nil) and (Instance.QueryInterface(IID, Intf) = 0);
|
||
end;
|
||
|
||
function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; overload;
|
||
begin
|
||
Result := False;
|
||
Pointer( Intf) := nil;
|
||
if Assigned(Instance) then
|
||
Result := Instance.GetInterface(IID, Intf)
|
||
end;
|
||
|
||
procedure FreeAndNil(var Obj);
|
||
var
|
||
Temp: TObject;
|
||
begin
|
||
Temp := TObject(Obj);
|
||
Pointer(Obj) := nil;
|
||
Temp.Free;
|
||
end;
|
||
{$ENDIF}
|
||
|
||
{$IFNDEF COMPILER_6_UP}
|
||
function Supports(const Instance: IUnknown; const IID: TGUID): Boolean;
|
||
var
|
||
Temp: IUnknown;
|
||
begin
|
||
{$IFNDEF COMPILER_5_UP}
|
||
Result := Supports(Instance, IID, Temp);
|
||
{$ELSE}
|
||
Result := SysUtils.Supports(Instance, IID, Temp)
|
||
{$ENDIF}
|
||
end;
|
||
|
||
procedure ClearMenuItems(Menu: TMenu);
|
||
var
|
||
I: Integer;
|
||
begin
|
||
for I := Menu.Items.Count - 1 downto 0 do
|
||
Menu.Items[I].Free;
|
||
end;
|
||
{$ENDIF}
|
||
|
||
procedure CreateProcessMP(ExeFile, Parameters, InitalDir: WideString);
|
||
var
|
||
pi: TProcessInformation;
|
||
siW: TStartupInfoW;
|
||
siA: _STARTUPINFOA;
|
||
wA, wB, wC: PWideChar;
|
||
aA, aB, aC: PChar;
|
||
begin
|
||
FillChar(pi, SizeOf(pi), #0);
|
||
if Assigned(CreateProcessW_MP) then
|
||
begin
|
||
FillChar(siW, SizeOf(siW), #0);
|
||
wA := nil;
|
||
wB := nil;
|
||
wC := nil;
|
||
if ExeFile <> '' then
|
||
wA := PWideChar(ExeFile);
|
||
if Parameters <> '' then
|
||
wB := PWideChar(Parameters);
|
||
if InitalDir <> '' then
|
||
wC := PWideChar(InitalDir);
|
||
|
||
CreateProcessW_MP(
|
||
wA, // path to the executable file:
|
||
wB,
|
||
nil,
|
||
nil,
|
||
False,
|
||
NORMAL_PRIORITY_CLASS,
|
||
nil,
|
||
wC,
|
||
siW,
|
||
pi );
|
||
end else
|
||
begin
|
||
FillChar(siA, SizeOf(siA), #0);
|
||
aA := nil;
|
||
aB := nil;
|
||
aC := nil;
|
||
if ExeFile <> '' then
|
||
aA := PChar( string(ExeFile));
|
||
if Parameters <> '' then
|
||
aB := PChar( string(Parameters));
|
||
if InitalDir <> '' then
|
||
aC := PChar( string(InitalDir));
|
||
CreateProcessA(
|
||
aA,
|
||
aB, // path to the executable file:
|
||
nil,
|
||
nil,
|
||
False,
|
||
NORMAL_PRIORITY_CLASS,
|
||
nil,
|
||
aC,
|
||
siA,
|
||
pi );
|
||
end;
|
||
if pi.hProcess <> 0 then
|
||
CloseHandle(pi.hProcess);
|
||
if pi.hThread <> 0 then
|
||
CloseHandle(pi.hThread)
|
||
end;
|
||
|
||
|
||
function DiffRectHorz(Rect1, Rect2: TRect): TRect;
|
||
// Returns the "difference" rectangle of the passed rects in the Horz direction.
|
||
// Assumes that one corner is common between the two rects
|
||
begin
|
||
Rect1 := ProperRect(Rect1);
|
||
Rect2 := ProperRect(Rect2);
|
||
// Make sure we contain every thing horizontally
|
||
Result.Left := Min(Rect1.Left, Rect2.Left);
|
||
Result.Right := Max(Rect1.Right, Rect1.Right);
|
||
// Now find the difference rect height
|
||
if Rect1.Top = Rect2.Top then
|
||
begin
|
||
// The tops are equal so it must be the bottom that contains the difference
|
||
Result.Bottom := Max(Rect1.Bottom, Rect2.Bottom);
|
||
Result.Top := Min(Rect1.Bottom, Rect2.Bottom);
|
||
end else
|
||
begin
|
||
// The bottoms are equal so it must be the tops that contains the difference
|
||
Result.Bottom := Max(Rect1.Top, Rect2.Top);
|
||
Result.Top := Min(Rect1.Top, Rect2.Top);
|
||
end
|
||
end;
|
||
|
||
function DiffRectVert(Rect1, Rect2: TRect): TRect;
|
||
// Returns the "difference" rectangle of the passed rects in the Vert direction.
|
||
// Assumes that one corner is common between the two rects
|
||
begin
|
||
Rect1 := ProperRect(Rect1);
|
||
Rect2 := ProperRect(Rect2);
|
||
// Make sure we contain every thing vertically
|
||
Result.Top := Min(Rect1.Top, Rect2.Bottom);
|
||
Result.Bottom := Max(Rect1.Top, Rect1.Bottom);
|
||
// Now find the difference rect width
|
||
if Rect1.Left = Rect2.Left then
|
||
begin
|
||
// The tops are equal so it must be the bottom that contains the difference
|
||
Result.Right := Max(Rect1.Right, Rect2.Right);
|
||
Result.Left := Min(Rect1.Right, Rect2.Right);
|
||
end else
|
||
begin
|
||
// The bottoms are equal so it must be the tops that contains the difference
|
||
Result.Right := Max(Rect1.Left, Rect2.Left);
|
||
Result.Left := Min(Rect1.Left, Rect2.Left);
|
||
end
|
||
end;
|
||
|
||
function AbsRect(ARect: TRect): TRect;
|
||
// Makes all coodinates positive
|
||
begin
|
||
Result := ARect;
|
||
if Result.Left < 0 then
|
||
Result.Left := 0;
|
||
if Result.Top < 0 then
|
||
Result.Top := 0;
|
||
if Result.Right < 0 then
|
||
Result.Right := 0;
|
||
if Result.Bottom < 0 then
|
||
Result.Bottom := 0;
|
||
end;
|
||
|
||
function CenterRectInRect(OuterRect, InnerRect: TRect): TRect;
|
||
begin
|
||
if RectWidth(InnerRect) > RectWidth(OuterRect) then
|
||
begin
|
||
// If the inner rect is wider than the result is the outer rect x bounds
|
||
Result.Left := OuterRect.Left;
|
||
Result.Right := OuterRect.Right;
|
||
end else
|
||
begin
|
||
// If not then center the inner rectangle in the outer in the x direction
|
||
Result.Left := OuterRect.Left;
|
||
Result.Right := Result.Left + RectWidth(InnerRect);
|
||
OffsetRect(Result, (RectWidth(OuterRect) - RectWidth(InnerRect)) div 2, 0);
|
||
end;
|
||
if RectHeight(InnerRect) > RectHeight(OuterRect) then
|
||
begin
|
||
// If the inner rect is wider than the result is the outer rect y bounds
|
||
Result.Top := OuterRect.Top;
|
||
Result.Bottom := OuterRect.Bottom;
|
||
end else
|
||
begin
|
||
// If not then center the inner rectangle in the outer in the y direction
|
||
Result.Top := OuterRect.Top;
|
||
Result.Bottom := Result.Top + RectHeight(InnerRect);
|
||
OffsetRect(Result, 0, (RectHeight(OuterRect) - RectHeight(InnerRect)) div 2);
|
||
end;
|
||
end;
|
||
|
||
function CenterRectHorz(OuterRect, InnerRect: TRect): TRect;
|
||
begin
|
||
if RectWidth(InnerRect) > RectWidth(OuterRect) then
|
||
begin
|
||
// If the inner rect is wider than the result is the outer rect x bounds
|
||
Result.Left := OuterRect.Left;
|
||
Result.Right := OuterRect.Right;
|
||
end else
|
||
begin
|
||
// If not then center the inner rectangle in the outer in the x direction
|
||
Result.Left := OuterRect.Left;
|
||
Result.Right := Result.Left + RectWidth(InnerRect);
|
||
OffsetRect(Result, (RectWidth(OuterRect) - RectWidth(InnerRect)) div 2, 0);
|
||
end;
|
||
end;
|
||
|
||
function CenterRectVert(OuterRect, InnerRect: TRect): TRect;
|
||
begin
|
||
if RectHeight(InnerRect) > RectHeight(OuterRect) then
|
||
begin
|
||
// If the inner rect is wider than the result is the outer rect y bounds
|
||
Result.Top := OuterRect.Top;
|
||
Result.Bottom := OuterRect.Bottom;
|
||
end else
|
||
begin
|
||
// If not then center the inner rectangle in the outer in the y direction
|
||
Result.Top := OuterRect.Top;
|
||
Result.Bottom := Result.Top + RectHeight(InnerRect);
|
||
OffsetRect(Result, 0, (RectHeight(OuterRect) - RectHeight(InnerRect)) div 2);
|
||
end;
|
||
end;
|
||
|
||
function CommonSupports(const Instance: IUnknown; const IID: TGUID; out Intf): Boolean; overload;
|
||
begin
|
||
Result := (Instance <> nil) and (Instance.QueryInterface(IID, Intf) = S_OK);
|
||
end;
|
||
|
||
function CommonSupports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; overload;
|
||
var
|
||
LUnknown: IUnknown;
|
||
begin
|
||
Result := (Instance <> nil) and
|
||
(Instance.GetInterface(IID, Intf) or
|
||
(Instance.GetInterface(IUnknown, LUnknown) and Supports(LUnknown, IID, Intf)));
|
||
end;
|
||
|
||
function CommonSupports(const Instance: IUnknown; const IID: TGUID): Boolean; overload;
|
||
var
|
||
Temp: IUnknown;
|
||
begin
|
||
Result := Supports(Instance, IID, Temp);
|
||
end;
|
||
|
||
function CommonSupports(const Instance: TObject; const IID: TGUID): Boolean; overload;
|
||
var
|
||
Temp: IUnknown;
|
||
begin
|
||
Result := Supports(Instance, IID, Temp);
|
||
end;
|
||
|
||
procedure CopyToNullBufferA(S: WideString; Buffer: PChar; CharCount: Cardinal);
|
||
var
|
||
ANSI: string;
|
||
begin
|
||
ANSI := S;
|
||
FillChar(Buffer^, CharCount, #0);
|
||
if Length(ANSI) > 0 then
|
||
begin
|
||
if Cardinal(Length(ANSI)) + 1 > CharCount then
|
||
CharCount := CharCount - 1 // Leave room for the null
|
||
else
|
||
CharCount := Length(ANSI);
|
||
MoveMemory(Buffer, PChar(ANSI), CharCount);
|
||
end
|
||
end;
|
||
|
||
procedure CopyToNullBufferW(S: WideString; Buffer: PWideChar; CharCount: Cardinal);
|
||
begin
|
||
FillChar(Buffer^, CharCount * 2, #0);
|
||
if Length(S) > 0 then
|
||
begin
|
||
if Cardinal(Length(S)) + 2 > CharCount then
|
||
CharCount := CharCount - 2 // Leave room for the null
|
||
else
|
||
CharCount := Length(S);
|
||
MoveMemory(Buffer, PWideChar(S), CharCount * 2);
|
||
end
|
||
end;
|
||
|
||
procedure MinMax(var A, B: Integer);
|
||
// Makes sure that A < B
|
||
var
|
||
Temp: Integer;
|
||
begin
|
||
if A > B then
|
||
begin
|
||
Temp := A;
|
||
A := B;
|
||
B := Temp
|
||
end
|
||
end;
|
||
|
||
function IsRectProper(Rect: TRect): Boolean;
|
||
begin
|
||
Result := (Rect.Right >= Rect.Left) and (Rect.Bottom >= Rect.Top)
|
||
end;
|
||
|
||
function AddCommas(NumberString: WideString): WideString;
|
||
var
|
||
// i: integer;
|
||
BufferA: array[0..128] of Char;
|
||
BufferW: array[0..128] of WideChar;
|
||
begin
|
||
// Make the number format based on the local not the US 3 digit comma format
|
||
if Assigned(GetNumberFormatW_MP) then
|
||
begin
|
||
GetNumberFormatW_MP(LOCALE_USER_DEFAULT, 0, PWideChar(NumberString), nil, BufferW, SizeOf(BufferW));
|
||
Result := BufferW;
|
||
end
|
||
else begin
|
||
GetNumberFormatA(LOCALE_USER_DEFAULT, 0, PChar(string(NumberString)), nil, BufferA, SizeOf(BufferA));
|
||
Result := BufferA
|
||
end;
|
||
|
||
{ Trimming white space in Unicode is tough don't pass any }
|
||
{ i := Length(NumberString) mod 3;
|
||
if i = 0 then
|
||
i := 3;
|
||
while i < Length(NumberString) do
|
||
begin
|
||
InsertW(ThousandSeparator, NumberString, i);
|
||
Inc(i, 4);
|
||
end;
|
||
Result := NumberString }
|
||
end;
|
||
|
||
function CalcuateFolderSize(FolderPath: WideString; Recurse: Boolean): Int64;
|
||
|
||
// Recursivly gets the size of the folder and subfolders
|
||
var
|
||
S: string;
|
||
FreeSpaceAvailable, TotalSpace: Int64;
|
||
SectorsPerCluster,
|
||
BytesPerSector,
|
||
FreeClusters,
|
||
TotalClusters: DWORD;
|
||
begin
|
||
Result := 0;
|
||
if Recurse and WideIsDrive(FolderPath) then
|
||
begin
|
||
if IsUnicode and Assigned(GetDiskFreeSpaceExW_MP) then
|
||
begin
|
||
if GetDiskFreeSpaceExW_MP(PWideChar(FolderPath), FreeSpaceAvailable, TotalSpace, nil) then
|
||
Result := TotalSpace - FreeSpaceAvailable
|
||
end else
|
||
if not IsWin95_SR1 and Assigned(GetDiskFreeSpaceExA_MP) then
|
||
begin
|
||
S := FolderPath;
|
||
if GetDiskFreeSpaceExA_MP(PChar(S), FreeSpaceAvailable, TotalSpace, nil) then
|
||
Result := TotalSpace - FreeSpaceAvailable;
|
||
end else
|
||
begin
|
||
GetDiskFreeSpaceA(PChar( S), SectorsPerCluster, BytesPerSector, FreeClusters,
|
||
TotalClusters);
|
||
Result := SectorsPerCluster * BytesPerSector * TotalClusters
|
||
end;
|
||
end else
|
||
begin
|
||
SumFolderAbort := False;
|
||
SumFolder(FolderPath, Recurse, Result);
|
||
end
|
||
end;
|
||
|
||
function GetMyDocumentsVirtualFolder: PItemIDList;
|
||
|
||
const
|
||
MYCOMPUTER_GUID = WideString('::{450d8fba-ad25-11d0-98a8-0800361b1103}');
|
||
|
||
var
|
||
dwAttributes, pchEaten: ULONG;
|
||
Desktop: IShellFolder;
|
||
begin
|
||
Result := nil;
|
||
dwAttributes := 0;
|
||
SHGetDesktopFolder(Desktop);
|
||
pchEaten := Length(MYCOMPUTER_GUID);
|
||
if not Succeeded(Desktop.ParseDisplayName(0, nil,
|
||
PWideChar(MYCOMPUTER_GUID), pchEaten, Result, dwAttributes))
|
||
then
|
||
Result := nil
|
||
end;
|
||
|
||
procedure WideInsert(Source: WideString; var S: WideString; Index: Integer);
|
||
{ It appears there is a WideString Insert in the VCL already but since mine }
|
||
{ looks better and is simpler and I spent my time I will use mine <g> }
|
||
{ _WStrInsert in System through compiler magic. }
|
||
var
|
||
OriginalLen: integer;
|
||
begin
|
||
if (Index < Length(S) + 1) and (Index > - 1) then
|
||
begin
|
||
OriginalLen := Length(S);
|
||
SetLength(S, Length(Source) + Length(S));
|
||
{ We are correct up to Index }
|
||
{ Slide to end of new string leaving space for insert }
|
||
Move(S[Index + 1], S[Index + 1 + Length(Source)], (OriginalLen - Index) * 2);
|
||
Move(Source[1], S[Index + 1], Length(Source) * 2);
|
||
end
|
||
end;
|
||
|
||
function WideGetCurrentDir: WideString;
|
||
var
|
||
BufferW: array[0..MAX_PATH] of Widechar;
|
||
BufferA: array[0..MAX_PATH] of Char;
|
||
begin
|
||
if Assigned(GetCurrentDirectoryW_MP) then
|
||
begin
|
||
if GetCurrentDirectoryW_MP(MAX_PATH, BufferW) > 0 then
|
||
Result := BufferW;
|
||
end else
|
||
begin
|
||
if GetCurrentDirectoryA(MAX_PATH, BufferA) > 0 then
|
||
Result := BufferA;
|
||
end
|
||
end;
|
||
|
||
function WideGetTempDir: WideString;
|
||
var
|
||
BufferW: array[0..MAX_PATH] of Widechar;
|
||
BufferA: array[0..MAX_PATH] of Char;
|
||
begin
|
||
if Assigned(GetTempPathW_MP) then
|
||
begin
|
||
if GetTempPathW_MP(MAX_PATH, BufferW) > 0 then
|
||
Result := BufferW;
|
||
end else
|
||
begin
|
||
if GetTempPathA(MAX_PATH, BufferA) > 0 then
|
||
Result := BufferA;
|
||
end
|
||
end;
|
||
|
||
function WideIncludeTrailingBackslash(Path: WideString): WideString;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := TntSysUtils.WideIncludeTrailingBackslash(Path);
|
||
{$ELSE}
|
||
{$IFDEF COMPILER_6_UP}
|
||
{$WARN SYMBOL_PLATFORM OFF}
|
||
{$ENDIF}
|
||
Result := IncludeTrailingBackslash(Path);
|
||
{$IFDEF COMPILER_6_UP}
|
||
{$WARN SYMBOL_PLATFORM ON}
|
||
{$ENDIF}
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function WideIncrementalSearch(CompareStr, Mask: WideString): Integer;
|
||
begin
|
||
SetLength(CompareStr, Length(Mask));
|
||
|
||
if IsUnicode then
|
||
Result := lstrcmpiW(PWideChar(Mask), PWideChar(CompareStr))
|
||
else
|
||
Result := lstrcmpi(PChar(string(Mask)), PChar(string(CompareStr)));
|
||
end;
|
||
|
||
function WideIntToStr(Value: integer): WideString;
|
||
{ Need to find a way to do this in Unicode. }
|
||
begin
|
||
Result := IntToStr(Value);
|
||
end;
|
||
|
||
function WideIsDrive(Drive: WideString): Boolean;
|
||
begin
|
||
if Length(Drive) = 3 then
|
||
Result := (LowerCase(Drive[1]) >= 'a') and (LowerCase(Drive[1]) <= 'z') and (Drive[2] = ':') and (Drive[3] = '\')
|
||
else
|
||
if Length(Drive) = 2 then
|
||
Result := (LowerCase(Drive[1]) >= 'a') and (LowerCase(Drive[1]) <= 'z') and (Drive[2] = ':')
|
||
else
|
||
Result := False
|
||
end;
|
||
|
||
function WideIsFloppy(FileFolder: WideString): boolean;
|
||
begin
|
||
if Length(FileFolder) > 0 then
|
||
Result := WideIsDrive(FileFolder) and (Char(FileFolder[1]) in ['A', 'a', 'B', 'b'])
|
||
else
|
||
Result := False
|
||
end;
|
||
|
||
|
||
function IsAnyMouseButtonDown: Boolean;
|
||
begin
|
||
Result := not(((GetAsyncKeyState(VK_LBUTTON) and $8000) = 0) and
|
||
((GetAsyncKeyState(VK_RBUTTON) and $8000) = 0) and
|
||
((GetAsyncKeyState(VK_MBUTTON) and $8000) = 0))
|
||
end;
|
||
|
||
function IsFTPPath(Path: WideString): Boolean;
|
||
begin
|
||
if Length(Path) > 3 then
|
||
begin
|
||
Path := UpperCase(Path);
|
||
Result := (Path[1] = 'F') and (Path[2] = 'T') and (Path[3] = 'P')
|
||
end else
|
||
Result := False
|
||
end;
|
||
|
||
function WideNewFolderName(ParentFolder: WideString; SuggestedFolderName: WideString = ''): WideString;
|
||
var
|
||
i: integer;
|
||
TempFoldername: String;
|
||
begin
|
||
ParentFolder := WideStripTrailingBackslash(ParentFolder, True); // Strip even if a root folder
|
||
i := 1;
|
||
if SuggestedFolderName = '' then
|
||
Begin
|
||
Result := ParentFolder + '\' + STR_NEWFOLDER;
|
||
TempFoldername := STR_NEWFOLDER;
|
||
end
|
||
else
|
||
Begin
|
||
Result := ParentFolder + '\' + SuggestedFolderName;
|
||
Tempfoldername := SuggestedFolderName;
|
||
End;
|
||
while DirExistsW(PWideChar(Result)) and (i <= High(WORD)) do
|
||
begin
|
||
Result := ParentFolder + '\' + Tempfoldername + ' (' + IntToStr(i) + ')';
|
||
Inc(i);
|
||
end;
|
||
if i > High(WORD) then
|
||
Result := '';
|
||
end;
|
||
|
||
function WidePathMatchSpec(Path, Mask: WideString): Boolean;
|
||
begin
|
||
if Assigned(PathMatchSpecW_MP) then
|
||
Result := PathMatchSpecW_MP(PWideChar(Path), PWideChar( Mask))
|
||
else
|
||
if Assigned(PathMatchSpecA_MP) then
|
||
Result := PathMatchSpecA_MP(PChar( string(Path)), PChar( string(Mask)))
|
||
else
|
||
Result := False
|
||
end;
|
||
|
||
function WidePathMatchSpecExists: Boolean;
|
||
begin
|
||
Result := Assigned(PathMatchSpecW_MP) or Assigned(PathMatchSpecA_MP)
|
||
end;
|
||
|
||
function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean;
|
||
begin
|
||
Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = '\');
|
||
end;
|
||
|
||
function IsTextTrueType(DC: HDC): Boolean;
|
||
var
|
||
TextMetrics: TTextMetric;
|
||
begin
|
||
GetTextMetrics(DC, TextMetrics);
|
||
Result := TextMetrics.tmPitchAndFamily and TMPF_TRUETYPE <> 0
|
||
end;
|
||
|
||
function IsTextTrueType(Canvas: TCanvas): Boolean;
|
||
begin
|
||
Result := IsTextTrueType(Canvas.Handle);
|
||
end;
|
||
|
||
function IsUNCPath(const Path: WideString): Boolean;
|
||
begin
|
||
Result := ((Path[1] = '\') and (Path[2] = '\')) and (DirExistsW(PWideChar(Path)) or FileExistsW(Path))
|
||
end;
|
||
|
||
function StrRetToStr(StrRet: TStrRet; APIDL: PItemIDList): WideString;
|
||
{ Extracts the string from the StrRet structure. }
|
||
var
|
||
P: PChar;
|
||
// S: string;
|
||
begin
|
||
case StrRet.uType of
|
||
STRRET_CSTR:
|
||
begin
|
||
SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
|
||
// Result := S
|
||
end;
|
||
STRRET_OFFSET:
|
||
begin
|
||
if Assigned(APIDL) then
|
||
begin
|
||
{$R-}
|
||
P := PChar(@(APIDL).mkid.abID[StrRet.uOffset - SizeOf(APIDL.mkid.cb)]);
|
||
{$R+}
|
||
SetString(Result, P, StrLen(P));
|
||
// Result := S;
|
||
end else
|
||
Result := '';
|
||
end;
|
||
STRRET_WSTR:
|
||
begin
|
||
Result := StrRet.pOleStr;
|
||
if Assigned(StrRet.pOleStr) then
|
||
PIDLMgr.FreeOLEStr(StrRet.pOLEStr);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function SystemDirectory: WideString;
|
||
var
|
||
Len: integer;
|
||
S: string;
|
||
begin
|
||
Result := '';
|
||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||
Len := GetSystemDirectoryW_MP(PWideChar(Result), 0)
|
||
else
|
||
Len := GetSystemDirectoryA(PChar(S), 0);
|
||
if Len > 0 then
|
||
begin
|
||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||
begin
|
||
SetLength(Result, Len - 1);
|
||
GetSystemDirectoryW_MP(PWideChar(Result), Len);
|
||
end else
|
||
begin
|
||
SetLength(S, Len - 1);
|
||
GetSystemDirectoryA(PChar(S), Len);
|
||
Result := S
|
||
end
|
||
end
|
||
end;
|
||
|
||
function SysMenuFont: HFONT;
|
||
var
|
||
MetricsA: TNonClientMetricsA;
|
||
MetricsW: TNonClientMetricsW;
|
||
begin
|
||
if IsUnicode then
|
||
begin
|
||
FillChar(MetricsW, SizeOf(MetricsW), #0);
|
||
MetricsW.cbSize := SizeOf(MetricsW);
|
||
SystemParametersInfoW_MP(SPI_GETNONCLIENTMETRICS, Sizeof(MetricsW), @MetricsW, 0);
|
||
Result := CreateFontIndirectW_MP(MetricsW.lfMenuFont);
|
||
end else
|
||
begin
|
||
FillChar(MetricsA, SizeOf(MetricsA), #0);
|
||
MetricsA.cbSize := SizeOf(MetricsA);
|
||
SystemParametersInfoA(SPI_GETNONCLIENTMETRICS, Sizeof(MetricsA), @MetricsA, 0);
|
||
Result := CreateFontIndirectA(MetricsA.lfMenuFont);
|
||
end
|
||
end;
|
||
|
||
function SysMenuHeight: Integer;
|
||
var
|
||
MetricsA: TNonClientMetricsA;
|
||
MetricsW: TNonClientMetricsW;
|
||
begin
|
||
if IsUnicode then
|
||
begin
|
||
FillChar(MetricsW, SizeOf(MetricsW), #0);
|
||
MetricsW.cbSize := SizeOf(MetricsW);
|
||
SystemParametersInfoW_MP(SPI_GETNONCLIENTMETRICS, Sizeof(MetricsW), @MetricsW, 0);
|
||
Result := MetricsW.iMenuHeight
|
||
end else
|
||
begin
|
||
FillChar(MetricsA, SizeOf(MetricsA), #0);
|
||
MetricsA.cbSize := SizeOf(MetricsA);
|
||
SystemParametersInfoA(SPI_GETNONCLIENTMETRICS, Sizeof(MetricsA), @MetricsA, 0);
|
||
Result := MetricsA.iMenuHeight
|
||
end
|
||
end;
|
||
|
||
function TextExtentW(Text: WideString; Font: TFont): TSize;
|
||
var
|
||
Canvas: TCanvas;
|
||
begin
|
||
FillChar(Result, SizeOf(Result), #0);
|
||
if Text <> '' then
|
||
begin
|
||
Canvas := TCanvas.Create;
|
||
try
|
||
Canvas.Handle := GetDC(0);
|
||
Canvas.Lock;
|
||
Canvas.Font.Assign(Font);
|
||
Result := InternalTextExtentW(PWideChar(Text), Canvas.Handle);
|
||
finally
|
||
if Assigned(Canvas) and (Canvas.Handle <> 0) then
|
||
ReleaseDC(0, Canvas.Handle);
|
||
Canvas.Unlock;
|
||
Canvas.Free
|
||
end
|
||
end
|
||
end;
|
||
|
||
function TextExtentW(Text: WideString; Canvas: TCanvas): TSize;
|
||
begin
|
||
FillChar(Result, SizeOf(Result), #0);
|
||
if Assigned(Canvas) and (Text <> '') then
|
||
begin
|
||
Canvas.Lock;
|
||
Result := InternalTextExtentW(PWideChar(Text), Canvas.Handle);
|
||
Canvas.Unlock;
|
||
end;
|
||
end;
|
||
|
||
function TextExtentW(Text: PWideChar; Canvas: TCanvas): TSize;
|
||
begin
|
||
FillChar(Result, SizeOf(Result), #0);
|
||
if Assigned(Canvas) and (Assigned(Text)) then
|
||
begin
|
||
Canvas.Lock;
|
||
Result := InternalTextExtentW(Text, Canvas.Handle);
|
||
Canvas.Unlock;
|
||
end;
|
||
end;
|
||
|
||
function TextExtentW(Text: PWideChar; DC: hDC): TSize;
|
||
begin
|
||
FillChar(Result, SizeOf(Result), #0);
|
||
if (DC <> 0) and (Assigned(Text)) then
|
||
Result := InternalTextExtentW(Text, DC);
|
||
end;
|
||
|
||
type
|
||
TABCArray = array of TABC;
|
||
|
||
function TextTrueExtentsW(Text: WideString; DC: HDC): TSize;
|
||
var
|
||
ABC: TABC;
|
||
TextMetrics: TTextMetric;
|
||
S: string;
|
||
i: integer;
|
||
begin
|
||
// Get the Height at least
|
||
GetTextExtentPoint32W(DC, PWideChar(Text), Length(Text), Result);
|
||
|
||
GetTextMetrics(DC, TextMetrics);
|
||
if TextMetrics.tmPitchAndFamily and TMPF_TRUETYPE <> 0 then
|
||
begin
|
||
Result.cx := 0;
|
||
// Is TrueType
|
||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||
begin
|
||
for i := 1 to Length(Text) do
|
||
begin
|
||
GetCharABCWidthsW_MP(DC, Ord(Text[i]), Ord(Text[i]), ABC);
|
||
Result.cx := Result.cx + ABC.abcA + integer(ABC.abcB) + ABC.abcC;
|
||
end
|
||
end else
|
||
begin
|
||
S := Text;
|
||
for i := 1 to Length(S) do
|
||
begin
|
||
GetCharABCWidthsA(DC, Ord(S[i]), Ord(S[i]), ABC);
|
||
Result.cx := Result.cx + ABC.abcA + integer(ABC.abcB) + ABC.abcC;
|
||
end
|
||
end;
|
||
end
|
||
end;
|
||
|
||
function UniqueFileName(const AFilePath: WideString): WideString;
|
||
|
||
{ Creates a unique file name in based on other files in the passed path }
|
||
|
||
var
|
||
i: integer;
|
||
WP: PWideChar;
|
||
begin
|
||
Result := AFilePath;
|
||
i := 2;
|
||
while FileExistsW(Result) and (i < 20) do
|
||
begin
|
||
Result := AFilePath;
|
||
WP := WideStrRScan(PWideChar( Result), '.');
|
||
if Assigned(WP) then
|
||
WideInsert( ' (' + WideIntToStr(i) + ')', Result, PWideChar(WP) - PWideChar(Result))
|
||
else begin
|
||
Result := '';
|
||
Break;
|
||
end;
|
||
Inc(i)
|
||
end;
|
||
end;
|
||
|
||
function TNTConditionallyDefined: Boolean;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := True;
|
||
{$ELSE}
|
||
Result := False;
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function UnicodeStringLists: Boolean;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := True;
|
||
{$ELSE}
|
||
Result := False;
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function UniqueDirName(const ADirPath: WideString): WideString;
|
||
var
|
||
i: integer;
|
||
begin
|
||
Result := ADirPath;
|
||
i := 2;
|
||
while DirExistsW(PWideChar(Result)) and (i < 20) do
|
||
begin
|
||
Result := ADirPath;
|
||
WideInsert( ' (' + WideIntToStr(i) + ')', Result, Length(Result));
|
||
Inc(i)
|
||
end;
|
||
end;
|
||
|
||
function WideStripExt(AFile: WideString): WideString;
|
||
{ Strips the extenstion off a file name }
|
||
var
|
||
i: integer;
|
||
Done: Boolean;
|
||
begin
|
||
i := Length(AFile);
|
||
Done := False;
|
||
Result := AFile;
|
||
while (i > 0) and not Done do
|
||
begin
|
||
if AFile[i] = '.' then
|
||
begin
|
||
Done := True;
|
||
SetLength(Result, i - 1);
|
||
end;
|
||
Dec(i);
|
||
end;
|
||
end;
|
||
|
||
function WideStripRemoteComputer(const UNCPath: WideString): WideString;
|
||
// Strips the \\RemoteComputer\ part of an UNC path
|
||
var
|
||
Head: PWideChar;
|
||
begin
|
||
Result := '';
|
||
if IsUNCPath(UNCPath) then
|
||
begin
|
||
Result := '';
|
||
if IsUNCPath(UNCPath) then
|
||
begin
|
||
Result := UNCPath;
|
||
Head := @Result[1];
|
||
Head := Head + 2; // Skip past the '\\'
|
||
Head := WideStrScan(Head, WideChar('\'));
|
||
if Assigned(Head) then
|
||
begin
|
||
Head := Head + 1;
|
||
Move(Head[0], Result[1], (lstrlenW(Head) + 1) * 2);
|
||
end;
|
||
SetLength(Result, lstrlenW(PWideChar(Result)));
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function WideStripTrailingBackslash(const S: WideString; Force: Boolean = False): WideString;
|
||
begin
|
||
Result := S;
|
||
if Result <> '' then
|
||
begin
|
||
// Works with FilePaths and FTP Paths
|
||
if Result[ Length(Result)] in [WideChar('/'), WideChar('\')] then
|
||
if not WideIsDrive(Result) or Force then // Don't strip off if is a root drive
|
||
SetLength(Result, Length(Result) - 1);
|
||
end;
|
||
end;
|
||
|
||
function WideStripLeadingBackslash(const S: WideString): WideString;
|
||
begin
|
||
Result := S;
|
||
if Result <> '' then
|
||
begin
|
||
if (S[1] = '\') and (Length(S) > 1) then
|
||
Result := PWideChar( @S[2])
|
||
else
|
||
Result := ''
|
||
end;
|
||
end;
|
||
|
||
function WideStringReplace(const S, OldPattern, NewPattern: WideString; Flags: TReplaceFlags; WholeWord: Boolean = False): WideString;
|
||
begin
|
||
{$IFDEF TNTSUPPORT}
|
||
Result := Tnt_WideStringReplace(S, OldPattern, NewPattern, [rfReplaceAll, rfIgnoreCase], WholeWord);
|
||
{$ELSE}
|
||
StringReplace(S, OldPattern, NewPattern, [rfReplaceAll, rfIgnoreCase])
|
||
{$ENDIF};
|
||
end;
|
||
|
||
function WideShellExecute(hWnd: HWND; Operation, FileName, Parameters, Directory: WideString; ShowCmd: Integer = SW_NORMAL): HINST;
|
||
var
|
||
OperationA, FileNameA, ParametersA, DirectoryA: string;
|
||
PA, DA: PChar;
|
||
PW, DW: PWideChar;
|
||
begin
|
||
if Assigned(ShellExecuteW_MP) then
|
||
begin
|
||
PW := nil;
|
||
DW := nil;
|
||
if Parameters = '' then
|
||
PW := PWideChar(Parameters);
|
||
if Directory = '' then
|
||
DW := PWideChar(Directory);
|
||
Result := ShellExecuteW_MP(hWnd, PWideChar(Operation), PWideChar(FileName), PW, DW, SW_NORMAL)
|
||
end else
|
||
begin
|
||
OperationA := Operation;
|
||
FileNameA := FileName;
|
||
ParametersA := Parameters;
|
||
DirectoryA := Directory;
|
||
PA := nil;
|
||
DA := nil;
|
||
if ParametersA <> '' then
|
||
PA := PChar( ParametersA);
|
||
if DirectoryA <> '' then
|
||
DA := PChar( DirectoryA);
|
||
Result := ShellExecuteA(hWnd, PChar(OperationA), PChar(FileNameA), PA, DA, SW_NORMAL)
|
||
end
|
||
end;
|
||
|
||
procedure WideShowMessage(Window: HWND; ACaption, AMessage: WideString);
|
||
var
|
||
TextA, CaptionA: string;
|
||
begin
|
||
if IsUnicode then
|
||
MessageBoxW(Window, PWideChar( AMessage), PWideChar( ACaption), MB_ICONEXCLAMATION or MB_OK)
|
||
else begin
|
||
TextA := AMessage;
|
||
CaptionA := ACaption;
|
||
MessageBoxA(Window, PChar( TextA), PChar( CaptionA), MB_ICONEXCLAMATION or MB_OK)
|
||
end
|
||
end;
|
||
|
||
function WideLowerCase(const Str: WideString): WideString;
|
||
begin
|
||
Result := Str;
|
||
if IsUnicode then
|
||
CharLowerBuffW_MP(PWideChar(Result), Length(Result))
|
||
else
|
||
CharLowerBuffA(PChar(string(Result)), Length(Result))
|
||
end;
|
||
|
||
function WideMessageBox(Window: HWND; const ACaption, AMessage: WideString; uType: integer): integer;
|
||
var
|
||
TextA, CaptionA: string;
|
||
begin
|
||
if IsUnicode then
|
||
Result := MessageBoxW(Window, PWideChar( AMessage), PWideChar( ACaption), uType)
|
||
else begin
|
||
TextA := AMessage;
|
||
CaptionA := ACaption;
|
||
Result := MessageBoxA(Window, PChar( TextA), PChar( CaptionA), uType)
|
||
end
|
||
end;
|
||
|
||
function IncludeTrailingBackslashW(const S: WideString): WideString;
|
||
begin
|
||
Result := S;
|
||
if not WideIsPathDelimiter(Result, Length(Result)) then Result := Result + '\';
|
||
end;
|
||
|
||
function DiskInDrive(C: Char): Boolean;
|
||
var
|
||
OldErrorMode: Integer;
|
||
begin
|
||
C := UpCase(C);
|
||
if C in ['A'..'Z'] then
|
||
begin
|
||
OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
|
||
Result := DiskFree(Ord(C) - Ord('A') + 1) > -1;
|
||
SetErrorMode(OldErrorMode);
|
||
end else
|
||
Result := False
|
||
end;
|
||
|
||
function WideStrIComp(Str1, Str2: PWideChar): Integer;
|
||
// Insensitive case comparison
|
||
var
|
||
S1, S2: string;
|
||
begin
|
||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||
Result := lstrcmpiW_MP(Str1, Str2)
|
||
else begin
|
||
S1 := Str1;
|
||
S2 := Str2;
|
||
Result := lstrcmpi(PChar(S1), PChar(S2))
|
||
end
|
||
end;
|
||
|
||
function StrRScanW(Str: PWideChar; Chr: WideChar): PWideChar;
|
||
// returns a pointer to the last occurance of Chr in Str
|
||
asm
|
||
PUSH EDI
|
||
MOV EDI, Str
|
||
MOV ECX, 0FFFFFFFFH
|
||
XOR AX, AX
|
||
REPNE SCASW
|
||
NOT ECX
|
||
STD
|
||
SUB EDI, 2
|
||
MOV AX, Chr
|
||
REPNE SCASW
|
||
MOV EAX, 0
|
||
JNE @@1
|
||
MOV EAX, EDI
|
||
ADD EAX, 2
|
||
@@1:
|
||
CLD
|
||
POP EDI
|
||
end;
|
||
|
||
function WideStrComp(Str1, Str2: PWideChar): Integer;
|
||
// Sensitive case comparison
|
||
var
|
||
S1, S2: string;
|
||
begin
|
||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||
Result := lstrcmpW_MP(Str1, Str2)
|
||
else begin
|
||
S1 := Str1;
|
||
S2 := Str2;
|
||
Result := lstrcmp(PChar(S1), PChar(S2))
|
||
end
|
||
end;
|
||
|
||
function WideStrLower(Str: PWideChar): PWideChar;
|
||
// Returns the string in Str converted to lower case
|
||
var
|
||
S: string;
|
||
WS: WideString;
|
||
begin
|
||
Result := Str;
|
||
if IsUnicode then
|
||
CharLowerBuffW_MP(Str, lstrlenW(Str))
|
||
else begin
|
||
S := Str;
|
||
CharLowerBuffA(PChar(S), Length(S));
|
||
WS := S;
|
||
{ WS is a string index from 1, Result is PWideChar index from 0 }
|
||
Move(WS[1], Result[0], Length(WS));
|
||
end;
|
||
end;
|
||
|
||
procedure WideStrLCopy(Str1, Str2: PWideChar; Count: Integer);
|
||
// Count must include the terminating null
|
||
begin
|
||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||
lstrcpynW_MP(Str1, Str2, Count)
|
||
else
|
||
Move(Str2, Str1, Count * 2);
|
||
end;
|
||
|
||
function ShortenStringEx(DC: HDC; const S: WideString; Width: Integer; RTL: Boolean;
|
||
EllipsisPlacement: TShortenStringEllipsis): WideString;
|
||
// Shortens the passed string and inserts ellipsis "..." in the requested place.
|
||
// This is not a fast function but it is clear how it works. Also the RTL implmentation
|
||
// is still being understood.
|
||
var
|
||
Len: Integer;
|
||
EllipsisWidth: Integer;
|
||
TargetString: WideString;
|
||
Tail, Head, Middle: PWideChar;
|
||
L, ResultW: integer;
|
||
begin
|
||
Len := Length(S);
|
||
if (Len = 0) or (Width <= 0) then
|
||
Result := ''
|
||
else begin
|
||
// Determine width of triple point using the current DC settings
|
||
TargetString := '...';
|
||
EllipsisWidth := TextExtentW(PWideChar(TargetString), DC).cx;
|
||
|
||
if Width <= EllipsisWidth then
|
||
Result := ''
|
||
else begin
|
||
TargetString := S;
|
||
Head := PWideChar(TargetString);
|
||
Tail := Head;
|
||
Inc(Tail, lstrlenW(PWideChar(TargetString)));
|
||
case EllipsisPlacement of
|
||
sseEnd:
|
||
begin
|
||
L := EllipsisWidth + TextExtentW(PWideChar(TargetString), DC).cx;
|
||
while (L > Width) do
|
||
begin
|
||
Dec(Tail);
|
||
Tail^ := WideNull;
|
||
L := EllipsisWidth + TextExtentW(PWideChar(TargetString), DC).cx;
|
||
end;
|
||
Result := PWideChar(TargetString) + '...';
|
||
end;
|
||
sseFront:
|
||
begin
|
||
L := EllipsisWidth + TextExtentW(PWideChar(TargetString), DC).cx;
|
||
while (L > Width) do
|
||
begin
|
||
Inc(Head);
|
||
L := EllipsisWidth + TextExtentW(PWideChar(Head), DC).cx;
|
||
end;
|
||
Result := '...' + PWideChar(Head);
|
||
end;
|
||
sseMiddle:
|
||
begin
|
||
L := EllipsisWidth + TextExtentW(PWideChar(TargetString), DC).cx;
|
||
while (L > Width div 2 - EllipsisWidth div 2) do
|
||
begin
|
||
Dec(Tail);
|
||
Tail^ := WideNull;
|
||
L := TextExtentW(PWideChar(TargetString), DC).cx;
|
||
end;
|
||
Result := PWideChar(TargetString) + '...';
|
||
ResultW := TextExtentW(PWideChar(Result), DC).cx;
|
||
|
||
TargetString := S;
|
||
Head := PWideChar(TargetString);
|
||
Middle := Head;
|
||
Inc(Middle, lstrlenW(PWideChar(Result)) - 3); // - 3 for ellipsis letters
|
||
Tail := Head;
|
||
Inc(Tail, lstrlenW(PWideChar(TargetString)));
|
||
Head := Tail - 1;
|
||
|
||
L := ResultW + TextExtentW(Head, DC).cx;
|
||
while (L < Width) and (Head >= Middle) do
|
||
begin
|
||
Dec(Head);
|
||
L := ResultW + TextExtentW(PWideChar(Head), DC).cx;
|
||
end;
|
||
Inc(Head);
|
||
|
||
Result := Result + Head;
|
||
end;
|
||
sseFilePathMiddle:
|
||
begin
|
||
Head := Tail - 1;
|
||
L := EllipsisWidth + TextExtentW(Head, DC).cx;
|
||
while (Head^ <> '\') and (Head <> @TargetString[1]) and (L < Width) do
|
||
begin
|
||
Dec(Head);
|
||
L := EllipsisWidth + TextExtentW(Head, DC).cx;
|
||
end;
|
||
if Head^ <> '\' then
|
||
Inc(Head);
|
||
Result := '...' + Head;
|
||
|
||
ResultW := TextExtentW(PWideChar(Result), DC).cx;
|
||
|
||
Head^ := WideNull;
|
||
SetLength(TargetString, lstrlenW(PWideChar(TargetString)));
|
||
|
||
Head := PWideChar(TargetString);
|
||
Tail := Head;
|
||
Inc(Tail, lstrlenW(Head));
|
||
|
||
L := ResultW + TextExtentW(PWideChar(TargetString), DC).cx;
|
||
while (L > Width) and (Tail > @TargetString[1]) do
|
||
begin
|
||
Dec(Tail);
|
||
Tail^ := WideNull;
|
||
L := ResultW + TextExtentW(PWideChar(TargetString), DC).cx;
|
||
end;
|
||
|
||
Result := Head + Result;
|
||
end;
|
||
end;
|
||
|
||
// Windows 2000 automatically switches the order in the string. For every other system we have to take care.
|
||
{ if IsWin2000 or not RTL then
|
||
Result := Copy(S, 1, N - 1) + '...'
|
||
else
|
||
Result := '...' + Copy(S, 1, N - 1); }
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function WindowsDirectory: WideString;
|
||
var
|
||
Len: integer;
|
||
S: string;
|
||
begin
|
||
Result := '';
|
||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||
Len := GetWindowsDirectoryW_MP(PWideChar(Result), 0)
|
||
else
|
||
Len := GetWindowsDirectoryA(PChar(S), 0);
|
||
if Len > 0 then
|
||
begin
|
||
if IsUnicode then
|
||
begin
|
||
SetLength(Result, Len - 1);
|
||
GetWindowsDirectoryW_MP(PWideChar(Result), Len);
|
||
end else
|
||
begin
|
||
SetLength(S, Len - 1);
|
||
GetWindowsDirectoryA(PChar(S), Len);
|
||
Result := S
|
||
end
|
||
end
|
||
end;
|
||
|
||
function ModuleFileName(PathOnly: Boolean = True): Widestring;
|
||
var
|
||
BufferA: array[0..MAX_PATH] of Char;
|
||
BufferW: array[0..MAX_PATH] of WideChar;
|
||
begin
|
||
if IsUnicode then
|
||
begin
|
||
FillChar(BufferW, SizeOf(BufferW), #0);
|
||
if GetModuleFileNameW(0, BufferW, SizeOf(BufferW)) > 0 then
|
||
begin
|
||
if PathOnly then
|
||
Result := ExtractFileDirW(BufferW)
|
||
else
|
||
Result := BufferW;
|
||
end
|
||
end else
|
||
begin
|
||
FillChar(BufferA, SizeOf(BufferA), #0);
|
||
if GetModuleFileNameA(0 , BufferA, SizeOf(BufferA)) > 0 then
|
||
begin
|
||
if PathOnly then
|
||
Result := ExtractFileDirW(BufferA)
|
||
else
|
||
Result := BufferA
|
||
end
|
||
end
|
||
end;
|
||
|
||
function PIDLToPath(PIDL: PItemIDList): WideString;
|
||
var
|
||
PIDLMgr: TCommonPIDLManager;
|
||
LastID: PItemIDList;
|
||
LastCB: Word;
|
||
Desktop, Folder: IShellFolder;
|
||
StrRet: TStrRet;
|
||
begin
|
||
Result := '';
|
||
if Assigned(PIDL) then
|
||
begin
|
||
FillChar(StrRet, SizeOf(StrRet), #0);
|
||
PIDLMgr := TCommonPIDLManager.Create;
|
||
try
|
||
SHGetDesktopFolder(Desktop);
|
||
if PIDLMgr.IsDesktopFolder(PIDL) then
|
||
begin
|
||
end else
|
||
begin
|
||
PIDLMgr.StripLastID(PIDL, LastCB, LastID);
|
||
try
|
||
if Succeeded(Desktop.BindToObject(PIDL, nil, IShellFolder, pointer(Folder))) then
|
||
begin
|
||
LastID.mkid.cb := LastCB;
|
||
if Succeeded(Folder.GetDisplayNameOf(LastID, SHGDN_FORPARSING, StrRet)) then
|
||
Result := StrRetToStr(StrRet, LastID);
|
||
end
|
||
finally
|
||
LastID.mkid.cb := LastCB;
|
||
end
|
||
end
|
||
finally
|
||
PIDLMgr.Free
|
||
end
|
||
end
|
||
end;
|
||
|
||
function ShortFileName(const FileName: WideString): WideString;
|
||
var
|
||
S: string;
|
||
BufferA: array[0..MAX_PATH] of char;
|
||
BufferW: array[0..MAX_PATH] of WideChar;
|
||
begin
|
||
if IsUnicode then
|
||
begin
|
||
if GetShortPathNameW(PWideChar(FileName), BufferW, SizeOf(BufferW)) > 0 then
|
||
Result := BufferW
|
||
end else
|
||
begin
|
||
S := FileName;
|
||
if GetShortPathNameA(PChar(S), BufferA, SizeOf(BufferA)) > 0 then
|
||
Result := BufferA
|
||
end
|
||
end;
|
||
|
||
function ShortPath(const Path: WideString): WideString;
|
||
begin
|
||
Result := ShortFileName(Path)
|
||
end;
|
||
|
||
procedure LoadWideString(S: TStream; var Str: WideString);
|
||
var
|
||
Count: Integer;
|
||
begin
|
||
S.Read(Count, SizeOf(Integer));
|
||
SetLength(Str, Count);
|
||
S.Read(PWideChar(Str)^, Count * 2)
|
||
end;
|
||
|
||
procedure SaveWideString(S: TStream; Str: WideString);
|
||
var
|
||
Count: Integer;
|
||
begin
|
||
Count := Length(Str);
|
||
S.Write(Count, SizeOf(Integer));
|
||
S.Write(PWideChar(Str)^, Count * 2)
|
||
end;
|
||
|
||
|
||
function WideStrPos(Str, SubStr: PWideChar): PWideChar;
|
||
// returns a pointer to the first occurance of SubStr in Str
|
||
asm
|
||
PUSH EDI
|
||
PUSH ESI
|
||
PUSH EBX
|
||
OR EAX, EAX
|
||
JZ @@2
|
||
OR EDX, EDX
|
||
JZ @@2
|
||
MOV EBX, EAX
|
||
MOV EDI, EDX
|
||
XOR AX, AX
|
||
MOV ECX, 0FFFFFFFFH
|
||
REPNE SCASW
|
||
NOT ECX
|
||
DEC ECX
|
||
JZ @@2
|
||
MOV ESI, ECX
|
||
MOV EDI, EBX
|
||
MOV ECX, 0FFFFFFFFH
|
||
REPNE SCASW
|
||
NOT ECX
|
||
SUB ECX, ESI
|
||
JBE @@2
|
||
MOV EDI, EBX
|
||
LEA EBX, [ESI - 1]
|
||
@@1:
|
||
MOV ESI, EDX
|
||
LODSW
|
||
REPNE SCASW
|
||
JNE @@2
|
||
MOV EAX, ECX
|
||
PUSH EDI
|
||
MOV ECX, EBX
|
||
REPE CMPSW
|
||
POP EDI
|
||
MOV ECX, EAX
|
||
JNE @@1
|
||
LEA EAX, [EDI - 2]
|
||
JMP @@3
|
||
|
||
@@2:
|
||
XOR EAX, EAX
|
||
@@3:
|
||
POP EBX
|
||
POP ESI
|
||
POP EDI
|
||
end;
|
||
|
||
function ProperRect(Rect: TRect): TRect;
|
||
// Makes sure a rectangle's left is less than its right and its top is less than its bottom
|
||
var
|
||
Temp: integer;
|
||
begin
|
||
Result := Rect;
|
||
if Result.Right < Result.Left then
|
||
begin
|
||
Temp := Result.Right;
|
||
Result.Right := Rect.Left;
|
||
Result.Left := Temp;
|
||
end;
|
||
if Rect.Bottom < Rect.Top then
|
||
begin
|
||
Temp := Result.Top;
|
||
Result.Top := Rect.Bottom;
|
||
Result.Bottom := Temp;
|
||
end
|
||
end;
|
||
|
||
function DragDetectPlus(Handle: HWND; Pt: TPoint): Boolean;
|
||
// Replacement for DragDetect API which is buggy.
|
||
// Pt is in Client Coords of the Handle window
|
||
var
|
||
DragRect: TRect;
|
||
Msg: TMsg;
|
||
TestPt: TPoint;
|
||
HadCapture, Done: Boolean;
|
||
begin
|
||
Result := False;
|
||
Done := False;
|
||
HadCapture := GetCapture = Handle;
|
||
if (not ClientToScreen(Handle, Pt)) then
|
||
Exit;
|
||
DragRect.TopLeft := Pt;
|
||
DragRect.BottomRight := Pt;
|
||
InflateRect(DragRect, GetSystemMetrics(SM_CXDRAG), GetSystemMetrics(SM_CYDRAG));
|
||
SetCapture(Handle);
|
||
try
|
||
while (not Result) and (not Done) do
|
||
if (PeekMessage(Msg, Handle, 0,0, PM_REMOVE)) then
|
||
begin
|
||
case (Msg.message) of
|
||
WM_MOUSEMOVE:
|
||
begin
|
||
TestPt := Msg.Pt;
|
||
// Not sure why this works. The Message point "should" be in client
|
||
// coordinates but seem to be screen
|
||
// Windows.ClientToScreen(Msg.hWnd, TestPt);
|
||
Result := not(PtInRect(DragRect, TestPt));
|
||
end;
|
||
WM_RBUTTONUP,
|
||
WM_LBUTTONUP,
|
||
WM_CANCELMODE,
|
||
WM_LBUTTONDBLCLK,
|
||
WM_MBUTTONUP:
|
||
begin
|
||
// Let the window get these messages after we have ended our
|
||
// local message loop
|
||
PostMessage(Msg.hWnd, Msg.message, Msg.wParam, Msg.lParam);
|
||
Done := True;
|
||
end;
|
||
WM_QUIT:
|
||
begin
|
||
PostQuitMessage(Msg.wParam);
|
||
Done := True;
|
||
end
|
||
else
|
||
TranslateMessage(Msg);
|
||
DispatchMessage(Msg)
|
||
end
|
||
end else
|
||
Sleep(0);
|
||
finally
|
||
ReleaseCapture;
|
||
if HadCapture then
|
||
Mouse.Capture := Handle;
|
||
end;
|
||
end;
|
||
|
||
procedure FillWideChar(var Dest; count: Integer; Value: WideChar);
|
||
var
|
||
I: Integer;
|
||
P: PWideChar;
|
||
begin
|
||
P := PWideChar(@Dest);
|
||
for I := count-1 downto 0 do
|
||
P[I] := Value;
|
||
end;
|
||
|
||
procedure FreeMemAndNil(var P: Pointer);
|
||
{ Frees the memeory allocated with GetMem and nils the pointer }
|
||
var
|
||
Temp: Pointer;
|
||
begin
|
||
Temp := P;
|
||
P := nil;
|
||
FreeMem(Temp);
|
||
end;
|
||
|
||
function IsRectNull(ARect: TRect): Boolean;
|
||
begin
|
||
Result := EqualRect(ARect, Rect(0, 0, 0, 0))
|
||
end;
|
||
|
||
function IsUnicode: Boolean;
|
||
begin
|
||
Result := Win32Platform = VER_PLATFORM_WIN32_NT
|
||
end;
|
||
|
||
function IsWinNT: Boolean;
|
||
begin
|
||
Result := Win32Platform = VER_PLATFORM_WIN32_NT
|
||
end;
|
||
|
||
function IsWin2000: Boolean;
|
||
begin
|
||
Result := False;
|
||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||
Result := LoWord(Win32MajorVersion) >= 5
|
||
end;
|
||
|
||
function IsWin95_SR1: Boolean;
|
||
begin
|
||
Result := False;
|
||
if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
|
||
Result := ((Win32MajorVersion = 4) and
|
||
(Win32MinorVersion = 0) and
|
||
(LoWord(Win32BuildNumber) <= 1080))
|
||
end;
|
||
|
||
function IsWinME: Boolean;
|
||
begin
|
||
Result := False;
|
||
if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
|
||
Result := Win32BuildNumber >= $045A0BB8
|
||
end;
|
||
|
||
function IsWinNT4: Boolean;
|
||
begin
|
||
Result := False;
|
||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||
Result := Win32MajorVersion < 5
|
||
end;
|
||
|
||
function IsWinXP: Boolean;
|
||
begin
|
||
Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion = 5)
|
||
and (Win32MinorVersion > 0)
|
||
end;
|
||
|
||
function IsWinXPOrUp: Boolean;
|
||
begin
|
||
Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5)
|
||
and (Win32MinorVersion > 0)
|
||
end;
|
||
|
||
function IsWinVista: Boolean;
|
||
begin
|
||
Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion = 6)
|
||
and (Win32MinorVersion >= 0)
|
||
end;
|
||
|
||
function IsWinVistaOrUp: Boolean;
|
||
begin
|
||
Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 6)
|
||
and (Win32MinorVersion >= 0)
|
||
end;
|
||
|
||
function RectHeight(R: TRect): Integer;
|
||
begin
|
||
Result := R.Bottom - R.Top
|
||
end;
|
||
|
||
function RectToStr(R: TRect): string;
|
||
begin
|
||
Result := 'Left = ' + IntToStr(R.Left) +
|
||
' Top = ' + IntToStr(R.Top) +
|
||
' Right = ' + IntToStr(R.Right) +
|
||
' Bottom = ' + IntToStr(R.Bottom)
|
||
end;
|
||
|
||
function RectToSquare(R: TRect): TRect;
|
||
// Takes the passed rectangle and makes it square based on the longest dimension
|
||
begin
|
||
if RectWidth(R) > RectHeight(R) then
|
||
R.Right := R.Left + RectHeight(R)
|
||
else
|
||
if RectHeight(R) > RectWidth(R) then
|
||
begin
|
||
R.Bottom := R.Top + RectWidth(R);
|
||
end else
|
||
Result := R
|
||
end;
|
||
|
||
function RectWidth(R: TRect): Integer;
|
||
begin
|
||
Result := R.Right - R.Left
|
||
end;
|
||
|
||
function ContainsRect(OuterRect, InnerRect: TRect): Boolean;
|
||
//
|
||
// Returns true if the InnerRect is completely contained within the
|
||
// OuterRect
|
||
//
|
||
begin
|
||
Result := (InnerRect.Left >= OuterRect.Left) and
|
||
(InnerRect.Right <= OuterRect.Right) and
|
||
(InnerRect.Top >= OuterRect.Top) and
|
||
(InnerRect.Bottom <= OuterRect.Bottom)
|
||
end;
|
||
|
||
function KeyDataToShiftState(KeyData: Longint): TShiftState;
|
||
begin
|
||
Result := [];
|
||
if GetKeyState(VK_SHIFT) < 0 then
|
||
Include(Result, ssShift);
|
||
if GetKeyState(VK_CONTROL) < 0 then
|
||
Include(Result, ssCtrl);
|
||
if KeyData and $20000000 <> 0 then
|
||
Include(Result, ssAlt);
|
||
end;
|
||
|
||
function DropEffectToDropEffectState(Effect: Integer): TCommonDropEffect;
|
||
begin
|
||
Result := cdeNone;
|
||
if Effect and DROPEFFECT_COPY <> 0 then
|
||
Result := cdeCopy
|
||
else
|
||
if Effect and DROPEFFECT_MOVE <> 0 then
|
||
Result := cdeMove
|
||
else
|
||
if Effect and DROPEFFECT_LINK <> 0 then
|
||
Result := cdeLink
|
||
end;
|
||
|
||
function DropEffectStateToDropEffect(Effect: TCommonDropEffect): Integer;
|
||
begin
|
||
Result := 0;
|
||
if cdeCopy = Effect then
|
||
Result := Result or DROPEFFECT_COPY
|
||
else
|
||
if cdeMove = Effect then
|
||
Result := Result or DROPEFFECT_MOVE
|
||
else
|
||
if cdeLink = Effect then
|
||
Result := Result or DROPEFFECT_LINK
|
||
end;
|
||
|
||
function DropEffectToDropEffectStates(Effect: Integer): TCommonDropEffects;
|
||
begin
|
||
Result := [];
|
||
if (Effect = 0) or (Longword(Effect) = DROPEFFECT_SCROLL) then
|
||
Include(Result, cdeNone);
|
||
if Effect and DROPEFFECT_COPY <> 0 then
|
||
Include(Result, cdeCopy);
|
||
if Effect and DROPEFFECT_MOVE <> 0 then
|
||
Include(Result, cdeMove);
|
||
if Effect and DROPEFFECT_LINK <> 0 then
|
||
Include(Result, cdeLink);
|
||
if Effect and DROPEFFECT_SCROLL <> 0 then
|
||
Include(Result, cdeScroll)
|
||
end;
|
||
|
||
function DropEffectStatesToDropEffect(Effect: TCommonDropEffects): Integer;
|
||
begin
|
||
Result := 0;
|
||
if cdeCopy in Effect then
|
||
Result := Result or DROPEFFECT_COPY;
|
||
if cdeMove in Effect then
|
||
Result := Result or DROPEFFECT_MOVE;
|
||
if cdeLink in Effect then
|
||
Result := Result or DROPEFFECT_LINK;
|
||
if cdeScroll in Effect then
|
||
Result := Result or Integer(DROPEFFECT_SCROLL);
|
||
end;
|
||
|
||
function KeyToKeyStates(Keys: Word): TCommonKeyStates;
|
||
begin
|
||
Result := [];
|
||
if Keys and MK_CONTROL <> 0 then
|
||
Include(Result, cksControl);
|
||
if Keys and MK_LBUTTON <> 0 then
|
||
Include(Result, cksLButton);
|
||
if Keys and MK_MBUTTON <> 0 then
|
||
Include(Result, cksMButton);
|
||
if Keys and MK_RBUTTON <> 0 then
|
||
Include(Result, cksRButton);
|
||
if Keys and MK_SHIFT <> 0 then
|
||
Include(Result, cksShift);
|
||
if Keys and MK_ALT <> 0 then
|
||
Include(Result, cksAlt);
|
||
if Keys and MK_BUTTON <> 0 then
|
||
Include(Result, cksButton);
|
||
end;
|
||
|
||
function KeyStatesToMouseButton(Keys: Word): TCommonMouseButton;
|
||
begin
|
||
if Keys and MK_LBUTTON <> 0 then
|
||
Result := cmbLeft
|
||
else
|
||
if Keys and MK_MBUTTON <> 0 then
|
||
Result := cmbMiddle
|
||
else
|
||
if Keys and MK_RBUTTON <> 0 then
|
||
Result := cmbRight
|
||
else
|
||
Result := cmbNone
|
||
end;
|
||
|
||
function KeyStatesToKey(Keys: TCommonKeyStates): Longword;
|
||
begin
|
||
Result := 0;
|
||
if cksControl in Keys then
|
||
Result := Result or MK_CONTROL;
|
||
if cksLButton in Keys then
|
||
Result := Result or MK_LBUTTON;
|
||
if cksMButton in Keys then
|
||
Result := Result or MK_MBUTTON;
|
||
if cksRButton in Keys then
|
||
Result := Result or MK_RBUTTON;
|
||
if cksShift in Keys then
|
||
Result := Result or MK_SHIFT;
|
||
if cksAlt in Keys then
|
||
Result := Result or MK_ALT;
|
||
end;
|
||
|
||
function KeyStateToDropEffect(Keys: TCommonKeyStates): TCommonDropEffect;
|
||
begin
|
||
Result := cdeMove; // The default
|
||
if (cksControl in Keys) and not ((cksShift in Keys) or (cksAlt in Keys)) then
|
||
Result := cdeCopy
|
||
else
|
||
if ((cksAlt in Keys) and not ((cksShift in Keys) or (cksControl in Keys))) or
|
||
((cksShift in Keys) and (cksControl in Keys)) then
|
||
Result := cdeLink
|
||
end;
|
||
|
||
function KeyStateToMouseButton(KeyState: TCommonKeyStates): TCommonMouseButton;
|
||
begin
|
||
if KeyState * [cksLButton] <> [] then
|
||
Result := cmbLeft
|
||
else
|
||
if KeyState * [cksRButton] <> [] then
|
||
Result := cmbRight
|
||
else
|
||
if KeyState * [cksMButton] <> [] then
|
||
Result := cmbMiddle
|
||
else
|
||
Result := cmbNone
|
||
end;
|
||
|
||
function FileIconInit(FullInit: BOOL): BOOL; stdcall;
|
||
// Forces the system to load all Images into the ImageList. Normally with NT
|
||
// system icons are only loaded as needed.
|
||
type
|
||
TFileIconInit = function(FullInit: BOOL): BOOL; stdcall;
|
||
var
|
||
ShellDLL: HMODULE;
|
||
PFileIconInit: TFileIconInit;
|
||
begin
|
||
Result := False;
|
||
if (Win32Platform = VER_PLATFORM_WIN32_NT) then
|
||
begin
|
||
ShellDLL := CommonLoadLibrary(Shell32);
|
||
PFileIconInit := GetProcAddress(ShellDLL, PChar(660));
|
||
if (Assigned(PFileIconInit)) then
|
||
Result := PFileIconInit(FullInit);
|
||
end;
|
||
end;
|
||
|
||
function SHGetImageList(iImageList: Integer; const RefID: TGUID; out ppvOut): HRESULT; stdcall;
|
||
// Retrieves the system ImageList interface
|
||
var
|
||
ShellDLL: HMODULE;
|
||
ImageList: TSHGetImageList;
|
||
begin
|
||
Result := E_NOTIMPL;
|
||
if (Win32Platform = VER_PLATFORM_WIN32_NT) then
|
||
begin
|
||
// if GetFileVersion(comctl32) >= $00060000 then
|
||
begin
|
||
ShellDLL := CommonLoadLibrary(Shell32);
|
||
ImageList := GetProcAddress(ShellDLL, PChar(727));
|
||
if (Assigned(ImageList)) then
|
||
Result := ImageList(iImageList, RefID, ppvOut);
|
||
end
|
||
end;
|
||
end;
|
||
|
||
function Size(cx, cy: Integer): TSize;
|
||
begin
|
||
Result.cy := cy;
|
||
Result.cx := cx
|
||
end;
|
||
|
||
function ShortenTextW(DC: hDC; TextToShorten: WideString; MaxSize: Integer): WideString;
|
||
// Shortens the passed string in such a way that if it does not fit in the MaxSize
|
||
// (in Pixels) a "..." is inserted at the correct place where the new string fixs
|
||
// in MaxSize
|
||
var
|
||
Size: TSize;
|
||
EllipsisSize: TSize;
|
||
// TailA: String;
|
||
StrLen, Middle, Low, High{, LastHigh}: Cardinal;
|
||
// WChar: WideChar;
|
||
// Done: Boolean;
|
||
begin
|
||
if TextToShorten <> '' then
|
||
begin
|
||
GetTextExtentPoint32W(DC, PWideChar(TextToShorten), Length(TextToShorten), Size);
|
||
GetTextExtentPoint32W(DC, '...', 3, EllipsisSize);
|
||
StrLen := Length(TextToShorten);
|
||
if Size.cx > MaxSize then
|
||
begin
|
||
(* Middle := StrLen div 2;
|
||
Done := False;
|
||
Low := 0;
|
||
High := StrLen;
|
||
LastHigh := High;
|
||
// Do a psudo binary search
|
||
while not Done do
|
||
begin
|
||
GetTextExtentPoint32W(DC, @TextToShorten[1], Middle, Size);
|
||
Size.cx := Size.cx + EllipsisSize.cx;
|
||
|
||
if Size.cx > MaxSize then
|
||
begin
|
||
// Still to long
|
||
LastHigh := High;
|
||
High := Middle;
|
||
Middle := Low + (High - Low) div 2;
|
||
end else
|
||
begin
|
||
// Too short
|
||
High := LastHigh;
|
||
Low := Middle;
|
||
|
||
Middle := Low + (High - Low) div 2;
|
||
end;
|
||
Done := High - Low <= 2;
|
||
end; *)
|
||
|
||
// Milan's version
|
||
Low:=0;
|
||
High:=StrLen-1;
|
||
while (Low<High) do
|
||
begin
|
||
Middle:=(Low+High+1) shr 1;
|
||
// if IsUnicode then
|
||
GetTextExtentPoint32W(DC, @TextToShorten[1], Middle, Size);
|
||
// else begin
|
||
// TailA := TextToShorten[1];
|
||
// GetTextExtentPoint32(DC, @TailA[1], 1, Size);
|
||
// end;
|
||
Size.cx := Size.cx + EllipsisSize.cx;
|
||
if (Size.cx<=MaxSize) then
|
||
Low:=Middle
|
||
else
|
||
High:=Middle-1;
|
||
end;
|
||
|
||
SetLength(TextToShorten, Low);
|
||
if Low > 0 then
|
||
Result := TextToShorten + '...'
|
||
else
|
||
Result := '...'
|
||
end else
|
||
Result := TextToShorten
|
||
end else
|
||
Result := '';
|
||
end;
|
||
|
||
(*
|
||
function SplitTextW(DC: hDC; TextToSplit: WideString; MaxWidth: Integer;
|
||
var Buffer: TWideCharArray; MaxSplits: Integer): Integer;
|
||
// Takes the passed string and breaks it up so each piece fits within the MaxWidth
|
||
// The function detects any LF/CR pairs and treats them as one break if CR or LF
|
||
// is defined as a break character.
|
||
// The Buffer is a set of NULL terminated strings for each line, with the last
|
||
// one being terminated with a double NULL. Much like the SHFileOperation API
|
||
// This makes it ready to use to pass the strings to ExtTextOutW in a loop
|
||
// If the buffer is too small the Result will be false
|
||
// If MaxSplits = -1 then the function splits as many time as necessary
|
||
// The Return is the total number of lines the passed text was split into
|
||
var
|
||
Head, Tail, LastBreakChar, BufferHead: PWideChar;
|
||
Size: TSize;
|
||
LineWidth, SplitCount, Len: Integer;
|
||
TextMetrics: TTextMetric;
|
||
{ PeriodW1, PeriodW2, PeriodW3: Integer; }
|
||
begin
|
||
Result := 0;
|
||
if MaxWidth = 0 then
|
||
begin
|
||
SetLength(Buffer, 2);
|
||
Buffer[0] := WideNull;
|
||
Buffer[1] := WideNull;
|
||
end else
|
||
begin
|
||
GetTextMetrics(DC, TextMetrics);
|
||
|
||
// Can get into deep trouble if a single letter won't fit in the MaxWidth
|
||
if TextMetrics.tmMaxCharWidth > MaxWidth then
|
||
begin
|
||
Len := Length(TextToSplit);
|
||
SetLength(Buffer, Len + 2);
|
||
if Len > 0 then
|
||
begin
|
||
Head := @TextToSplit[1];
|
||
CopyMemory(Buffer, Head, Len*2);
|
||
Result := 1;
|
||
end;
|
||
Buffer[Len] := #0;
|
||
Buffer[Len + 1] := #0;
|
||
end else
|
||
begin
|
||
FillChar(Size, SizeOf(Size), #0);
|
||
// Arbitrary size that should be ok in most instances. This will be enough space
|
||
// for 127 lines
|
||
SetLength(Buffer, Length(TextToSplit) + 128);
|
||
BufferHead := @Buffer[0];
|
||
Head := PWideChar(TextToSplit);
|
||
Tail := Head;
|
||
SplitCount := 0;
|
||
while (Tail^ <> #0) and ((SplitCount < MaxSplits) or (MaxSplits = -1)) do
|
||
begin
|
||
LineWidth := 0;
|
||
LastBreakChar := nil;
|
||
while (Tail^ <> WideNull) and (LineWidth <= MaxWidth) and (Tail^ <> WideCR) and (Tail^ <> WideLF) do
|
||
begin
|
||
GetTextExtentPoint32W(DC, PWideChar(Tail), 1, Size);
|
||
Inc(LineWidth, Size.cx);
|
||
|
||
Inc(Tail);
|
||
|
||
if (LineWidth <= MaxWidth) and (Tail^ = WideSpace) then
|
||
LastBreakChar := Tail;
|
||
end;
|
||
|
||
if (LineWidth > MaxWidth) {and (Tail^ <> WideSpace)} then
|
||
begin
|
||
// Over ran the line unless it exactly fits
|
||
if Assigned(LastBreakChar) and (LineWidth > MaxWidth) then
|
||
begin
|
||
// We have word break to go back to
|
||
Tail := LastBreakChar;
|
||
Inc(SplitCount);
|
||
if SplitCount = MaxSplits then
|
||
begin
|
||
// If no more splits allows copy the entire rest of the string to the buffer
|
||
Len := lStrLenW(Head);
|
||
CopyMemory(BufferHead, Head, Len*2);
|
||
Inc(BufferHead, Len);
|
||
end else
|
||
begin
|
||
CopyMemory(BufferHead, Head, (Tail-Head)*2);
|
||
Inc(BufferHead, Tail-Head);
|
||
end;
|
||
BufferHead^ := WideNull;
|
||
Inc(BufferHead);
|
||
end else
|
||
begin
|
||
// Special case, the Tail is the end of the Text to split
|
||
if Tail^ <> WideNull then
|
||
Dec(Tail);
|
||
Inc(SplitCount);
|
||
if SplitCount = MaxSplits then
|
||
begin
|
||
// If no more splits allows copy the entire rest of the string to the buffer
|
||
Len := lStrLenW(Head);
|
||
CopyMemory(BufferHead, Head, Len*2);
|
||
Inc(BufferHead, Len);
|
||
end else
|
||
begin
|
||
CopyMemory(BufferHead, Head, (Tail-Head)*2);
|
||
Inc(BufferHead, Tail-Head);
|
||
end;
|
||
BufferHead^ := WideNull;
|
||
Inc(BufferHead);
|
||
end;
|
||
Inc(Result);
|
||
end else
|
||
begin
|
||
Inc(SplitCount);
|
||
if SplitCount = MaxSplits then
|
||
begin
|
||
// If no more splits allows copy the entire rest of the string to the buffer
|
||
Len := lStrLenW(Head);
|
||
CopyMemory(BufferHead, Head, Len*2);
|
||
Inc(BufferHead, Len);
|
||
end else
|
||
begin
|
||
CopyMemory(BufferHead, Head, (Tail-Head)*2);
|
||
Inc(BufferHead, Tail-Head);
|
||
end;
|
||
BufferHead^ := WideNull;
|
||
Inc(BufferHead);
|
||
Inc(Result)
|
||
end;
|
||
|
||
while (Tail^ <> #0) and ((Tail^ = WideCR) or (Tail^ = WideLF) or (Tail^ = WideSpace)) do
|
||
Inc(Tail);
|
||
Head := Tail
|
||
end
|
||
end
|
||
end
|
||
end;
|
||
*)
|
||
|
||
|
||
// Solerman's version
|
||
function SplitTextW(DC: hDC; TextToSplit: WideString; MaxWidth: Integer;
|
||
var Buffer: TCommonWideCharArray; MaxSplits: Integer): Integer;
|
||
// Takes the passed string and breaks it up so each piece fits within the MaxWidth
|
||
// The function detects any LF/CR pairs and treats them as one break if CR or LF
|
||
// is defined as a break character.
|
||
// The Buffer is a set of NULL terminated strings for each line, with the last
|
||
// one being terminated with a double NULL. Much like the SHFileOperation API
|
||
// This makes it ready to use to pass the strings to ExtTextOutW in a loop
|
||
// If the buffer is too small the Result will be false
|
||
// If MaxSplits = -1 then the function splits as many time as necessary
|
||
// The Return is the total number of lines the passed text was split into
|
||
var
|
||
Head, Tail, LastBreakChar, BufferHead: PWideChar;
|
||
// TailA: String;
|
||
Size: TSize;
|
||
LineWidth, SplitCount, Len: Integer;
|
||
TextMetrics: TTextMetric;
|
||
begin
|
||
Result := 0;
|
||
if MaxWidth = 0 then
|
||
begin
|
||
SetLength(Buffer, 2);
|
||
Buffer[0] := WideNull;
|
||
Buffer[1] := WideNull;
|
||
end else
|
||
begin
|
||
GetTextMetrics(DC, TextMetrics);
|
||
|
||
// Can get into deep trouble if a single letter won't fit in the MaxWidth
|
||
if TextMetrics.tmMaxCharWidth > MaxWidth then
|
||
begin
|
||
Len := Length(TextToSplit);
|
||
SetLength(Buffer, Len + 2);
|
||
if Len > 0 then
|
||
begin
|
||
Head := @TextToSplit[1];
|
||
CopyMemory(Buffer, Head, Len*2);
|
||
Result := 1;
|
||
end;
|
||
Buffer[Len] := #0;
|
||
Buffer[Len + 1] := #0;
|
||
end else
|
||
begin
|
||
FillChar(Size, SizeOf(Size), #0);
|
||
// Arbitrary size that should be ok in most instances. This will be enough space
|
||
// for 127 lines
|
||
SetLength(Buffer, Length(TextToSplit) + 128);
|
||
BufferHead := @Buffer[0];
|
||
Head := PWideChar(TextToSplit);
|
||
Tail := Head;
|
||
SplitCount := 0;
|
||
while (Tail^ <> #0) and ((SplitCount < MaxSplits) or (MaxSplits = -1)) do
|
||
begin
|
||
LineWidth := 0;
|
||
LastBreakChar := nil;
|
||
while (Tail^ <> WideNull) and (LineWidth <= MaxWidth) and (Tail^ <> WideCR) and (Tail^ <> WideLF) do
|
||
begin
|
||
// if IsUnicode then
|
||
GetTextExtentPoint32W(DC, PWideChar(Tail), 1, Size);
|
||
// else begin
|
||
// TailA := Tail^;
|
||
// GetTextExtentPoint32(DC, @TailA[1], 1, Size);
|
||
// end;
|
||
Inc(LineWidth, Size.cx);
|
||
|
||
Inc(Tail);
|
||
|
||
if (LineWidth <= MaxWidth) and (Tail^ = WideSpace) then
|
||
LastBreakChar := Tail;
|
||
end;
|
||
|
||
if (LineWidth > MaxWidth) then
|
||
begin
|
||
// We overran the MaxWidth if entering this block
|
||
|
||
// Over ran the line unless it exactly fits
|
||
if Assigned(LastBreakChar) and (LineWidth > MaxWidth) then
|
||
// We have word break to go back to
|
||
Tail := LastBreakChar
|
||
else
|
||
// Special case, the Tail is the end of the Text to split
|
||
if {(Tail^ <> WideNull) and} ((SplitCount + 1 < MaxSplits) or (MaxSplits < 0)) then
|
||
Dec(Tail);
|
||
end;
|
||
Inc(SplitCount);
|
||
// If we reach the MaxSplits make the last line be the rest of the text.
|
||
if (SplitCount > 0) and (SplitCount = MaxSplits) then
|
||
Inc(Tail, lstrlenW(Tail));
|
||
CopyMemory(BufferHead, Head, (Tail-Head)*2);
|
||
Inc(BufferHead, Tail-Head);
|
||
BufferHead^ := WideNull;
|
||
Inc(BufferHead);
|
||
Inc(Result);
|
||
|
||
while (Tail^ <> #0) and ((Tail^ = WideCR) or (Tail^ = WideLF) or (Tail^ = WideSpace)) do
|
||
Inc(Tail);
|
||
Head := Tail
|
||
end
|
||
end
|
||
end
|
||
end;
|
||
|
||
{$IFNDEF COMPILER_6_UP}
|
||
function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString;
|
||
begin
|
||
if not VarIsNull(V) then
|
||
Result := V
|
||
else
|
||
Result := ADefault;
|
||
end;
|
||
|
||
function VarToWideStr(const V: Variant): WideString;
|
||
begin
|
||
Result := VarToWideStrDef(V, NullAsStringValue);
|
||
end;
|
||
|
||
function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string;
|
||
const
|
||
cSimpleBoolStrs: array [boolean] of String = ('0', '-1');
|
||
begin
|
||
if UseBoolStrs then
|
||
begin
|
||
if B then
|
||
Result := 'True'
|
||
else
|
||
Result := 'False'
|
||
end
|
||
else
|
||
Result := cSimpleBoolStrs[B];
|
||
end;
|
||
|
||
function CompareTime(const A, B: TDateTime): TValueRelationship;
|
||
begin
|
||
if Abs(Frac(A) - Frac(B)) < (1 / MSecsPerDay) then
|
||
Result := 0
|
||
else if Frac(A) < Frac(B) then
|
||
Result := Low(TValueRelationship)
|
||
else
|
||
Result := High(TValueRelationship);
|
||
end;
|
||
|
||
function WideCompareText(S1, S2: WideString): Integer;
|
||
begin
|
||
Result := WideStrComp( PWideChar(S1), PWideChar(S2))
|
||
end;
|
||
|
||
function ExcludeTrailingBackslash(Path: WideString): WideString;
|
||
begin
|
||
Result := Path;
|
||
if Result <> '' then
|
||
begin
|
||
Result := Trim(Result);
|
||
if Length(Result) > 0 then
|
||
if Result[Length(Result)] = '\' then
|
||
SetLength(Result, Length(Result) - 1)
|
||
end
|
||
end;
|
||
|
||
function IncludeTrailingBackslash(Path: WideString): WideString;
|
||
begin
|
||
Result := Path;
|
||
if Path <> '' then
|
||
Result := ExcludeTrailingBackslash(Path) + '\'
|
||
end;
|
||
|
||
{$ENDIF}
|
||
|
||
function VariantToCaption(const V: Variant): WideString;
|
||
var
|
||
DateTime: TDateTime;
|
||
begin
|
||
case VarType(V) of
|
||
varString, varOleStr:
|
||
Result := VarToWideStr(V);
|
||
|
||
varInteger,{$IFDEF COMPILER_6_UP}varWord, varShortInt, varLongWord,{$ENDIF} varSmallint, varByte:
|
||
Result := IntToStr(V);
|
||
varDate:
|
||
begin
|
||
DateTime := V;
|
||
if Trunc(DateTime) = DateTime then // no time portion
|
||
Result := DateToStr(DateTime)
|
||
else
|
||
Result := DateTimeToStr(DateTime);
|
||
end;
|
||
varCurrency:
|
||
Result := CurrToStr(V);
|
||
varSingle, varDouble:
|
||
Result := FloatToStrF(V, ffFixed, 15, 2);
|
||
varBoolean:
|
||
Result := BoolToStr(V, True);
|
||
else
|
||
Result := VarToWideStrDef(V, '');
|
||
end;
|
||
end;
|
||
|
||
function StrCopyW(Dest, Source: PWideChar): PWideChar;
|
||
// copies Source to Dest and returns Dest
|
||
asm
|
||
PUSH EDI
|
||
PUSH ESI
|
||
MOV ESI, EAX
|
||
MOV EDI, EDX
|
||
MOV ECX, 0FFFFFFFFH
|
||
XOR AX, AX
|
||
REPNE SCASW
|
||
NOT ECX
|
||
MOV EDI, ESI
|
||
MOV ESI, EDX
|
||
MOV EDX, ECX
|
||
MOV EAX, EDI
|
||
SHR ECX, 1
|
||
REP MOVSD
|
||
MOV ECX, EDX
|
||
AND ECX, 1
|
||
REP MOVSW
|
||
POP ESI
|
||
POP EDI
|
||
end;
|
||
|
||
//----------------------------------------------------------------------------------------------------------------------
|
||
|
||
function BrightenColor(const RGB: TCommonRGB; Amount: Double): TCommonRGB;
|
||
var
|
||
HLS: TCommonHLS;
|
||
|
||
begin
|
||
HLS := RGBToHLS(RGB);
|
||
HLS.L := (1 + Amount) * HLS.L;
|
||
Result := HLSToRGB(HLS);
|
||
end;
|
||
|
||
function DarkenColor(const RGB: TCommonRGB; Amount: Double): TCommonRGB;
|
||
var
|
||
HLS: TCommonHLS;
|
||
|
||
begin
|
||
HLS := RGBToHLS(RGB);
|
||
// Darken means to decrease luminance.
|
||
HLS.L := (1 - Amount) * HLS.L;
|
||
Result := HLSToRGB(HLS);
|
||
end;
|
||
|
||
function RGBToHLS(const RGB: TCommonRGB): TCommonHLS;
|
||
|
||
// Converts from RGB to HLS.
|
||
// Input parameters and result values are all in the range 0..1.
|
||
// Note: Hue is normalized so 360<36> corresponds to 1.
|
||
|
||
var
|
||
Delta,
|
||
Max,
|
||
Min: Double;
|
||
|
||
begin
|
||
with RGB, Result do
|
||
begin
|
||
Max := MaxValue([R, G, B]);
|
||
Min := MinValue([R, G, B]);
|
||
|
||
L := (Max + Min) / 2;
|
||
|
||
if Max = Min then
|
||
begin
|
||
// Achromatic case.
|
||
S := 0;
|
||
H := 0; // Undefined
|
||
end
|
||
else
|
||
begin
|
||
Delta := Max - Min;
|
||
|
||
if L < 0.5 then
|
||
S := Delta / (Max + Min)
|
||
else
|
||
S := Delta / (2 - (Max + Min));
|
||
|
||
if R = Max then
|
||
H := (G - B) / Delta
|
||
else
|
||
if G = Max then
|
||
H := 2 + (B - R) / Delta
|
||
else
|
||
if B = Max then
|
||
H := 4 + (R - G) / Delta;
|
||
|
||
H := H / 6;
|
||
if H < 0 then
|
||
H := H + 1;
|
||
end
|
||
end;
|
||
end;
|
||
|
||
function HLSToRGB(const HLS: TCommonHLS): TCommonRGB;
|
||
|
||
// Converts from HLS (hue, luminance, saturation) to RGB.
|
||
// Input parameters and result values are all in the range 0..1.
|
||
// Note: Hue is normalized so 360<36> corresponds to 1.
|
||
|
||
//--------------- local function --------------------------------------------
|
||
|
||
function HueToRGB(m1, m2, Hue: Double): Double;
|
||
|
||
begin
|
||
if Hue > 1 then
|
||
Hue := Hue - 1
|
||
else
|
||
if Hue < 0 then
|
||
Hue := Hue + 1;
|
||
|
||
if 6 * Hue < 1 then
|
||
Result := m1 + (m2 - m1) * Hue * 6
|
||
else
|
||
if 2 * Hue < 1 then
|
||
Result := m2
|
||
else
|
||
if 3 * Hue < 2 then
|
||
Result := m1 + (m2 - m1) * (2 / 3 - Hue) * 6
|
||
else
|
||
Result := m1;
|
||
end;
|
||
|
||
//--------------- end local function ----------------------------------------
|
||
|
||
var
|
||
m1, m2: Double;
|
||
|
||
begin
|
||
with HLS, Result do
|
||
begin
|
||
if S = 0 then
|
||
begin
|
||
// Achromatic case (no hue).
|
||
R := L;
|
||
G := L;
|
||
B := L;
|
||
end
|
||
else
|
||
begin
|
||
if L <= 0.5 then
|
||
m2 := L * (S + 1)
|
||
else
|
||
m2 := L + S - L * S;
|
||
m1 := 2 * L - m2;
|
||
|
||
R := HueToRGB(m1, m2, H + 1 / 3);
|
||
G := HueToRGB(m1, m2, H);
|
||
B := HueToRGB(m1, m2, H - 1 / 3)
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function MakeTRBG(Color: TColor): TCommonRGB;
|
||
var
|
||
RGB: Longint;
|
||
begin
|
||
RGB := ColorToRGB(Color);
|
||
Result.B := GetBValue(RGB) / 255;
|
||
Result.G := GetGValue(RGB) / 255;
|
||
Result.R := GetRValue(RGB) / 255;
|
||
end;
|
||
|
||
function MakeTColor(RGB: TCommonRGB): TColor;
|
||
begin
|
||
Result := TColor(MakeColorRef(RGB));
|
||
end;
|
||
|
||
function MakeColorRef(RGB: TCommonRGB; Gamma: Double = 1): COLORREF;
|
||
// Converts a floating point RGB color to an 8 bit color reference as used by Windows.
|
||
// The function takes care not to produce out-of-gamut colors and allows to apply an optional gamma correction
|
||
// (inverse gamma).
|
||
begin
|
||
GammaCorrection(RGB, Gamma);
|
||
with RGB do
|
||
Result := Windows.RGB(Round(R * 255), Round(G * 255), Round(B * 255));
|
||
end;
|
||
|
||
procedure GammaCorrection(var RGB: TCommonRGB; Gamma: Double);
|
||
|
||
// Computes the gamma corrected RGB color and ensures the result is in-gamut.
|
||
|
||
begin
|
||
if Gamma <> 1 then
|
||
begin
|
||
Gamma := 1 / Gamma;
|
||
with RGB do
|
||
begin
|
||
if R > 0 then
|
||
R := Power(R, Gamma)
|
||
else
|
||
R := 0;
|
||
if G > 0 then
|
||
G := Power(G, Gamma)
|
||
else
|
||
G := 0;
|
||
if B > 0 then
|
||
B := Power(B, Gamma)
|
||
else
|
||
B := 0;
|
||
end;
|
||
end;
|
||
|
||
MakeSafeColor(RGB);
|
||
end;
|
||
|
||
function MakeSafeColor(var RGB: TCommonRGB): Boolean;
|
||
// Ensures the given RGB color is in-gamut, that is, no component is < 0 or > 1.
|
||
// Returns True if the color had to be adjusted to be in-gamut, otherwise False.
|
||
begin
|
||
Result := False;
|
||
|
||
if RGB.R < 0 then
|
||
begin
|
||
Result := True;
|
||
RGB.R := 0;
|
||
end;
|
||
if RGB.R > 1 then
|
||
begin
|
||
Result := True;
|
||
RGB.R := 1;
|
||
end;
|
||
|
||
if RGB.G < 0 then
|
||
begin
|
||
Result := True;
|
||
RGB.G := 0;
|
||
end;
|
||
if RGB.G > 1 then
|
||
begin
|
||
Result := True;
|
||
RGB.G := 1;
|
||
end;
|
||
|
||
if RGB.B < 0 then
|
||
begin
|
||
Result := True;
|
||
RGB.B := 0;
|
||
end;
|
||
if RGB.B > 1 then
|
||
begin
|
||
Result := True;
|
||
RGB.B := 1;
|
||
end;
|
||
end;
|
||
|
||
function UpsideDownDIB(Bits: TBitmap): Boolean;
|
||
var
|
||
OldRGB, TempRGB: LongInt;
|
||
P: PLongInt;
|
||
begin
|
||
Result := False;
|
||
Assert(Bits.PixelFormat = pf32Bit, 'UpsideDownDIB only works with 32 bit bitmaps');
|
||
if Bits.PixelFormat = pf32Bit then
|
||
begin
|
||
P := Bits.ScanLine[0];
|
||
OldRGB := P^;
|
||
Result := True;
|
||
// if Equal then we can can't be sure if upsidedown
|
||
if (P^ and $00FFFFFF) = (ColorToRGB(Bits.Canvas.Pixels[0, 0]) and $00FFFFFF) then
|
||
begin
|
||
// Flip the pixel bits
|
||
TempRGB := not OldRGB and $00FFFFFF;
|
||
Bits.Canvas.Pixels[0, 0] := TempRGB;
|
||
|
||
Result := (P^ and $00FFFFFF) <> (ColorToRGB(Bits.Canvas.Pixels[0, 0]) and $00FFFFFF);
|
||
P^ := OldRGB
|
||
end
|
||
end
|
||
end;
|
||
|
||
procedure ActivateTopLevelWindow(Child: HWND);
|
||
var
|
||
Parent: HWND;
|
||
Style: LongWord;
|
||
begin
|
||
Parent := GetParent(Child);
|
||
while Parent <> 0 do
|
||
begin
|
||
Style := GetWindowLong(Parent, GWL_STYLE);
|
||
if ((Style and WS_POPUP <> 0)) or (Style and WS_CHILD = 0) then
|
||
begin
|
||
BringWindowToTop(Parent);
|
||
Exit
|
||
end;
|
||
Parent := GetParent(Parent);
|
||
end
|
||
end;
|
||
|
||
initialization
|
||
PIDLMgr := TCommonPIDLManager.Create;
|
||
|
||
// We can be sure these are already loaded. This keeps us from having to
|
||
// reference count when VSTools is being used in an OCX
|
||
Shell32Handle := GetModuleHandle(Shell32);
|
||
Kernel32Handle := GetModuleHandle(Kernel32);
|
||
User32Handle := GetModuleHandle(User32);
|
||
GDI32Handle := GetModuleHandle(GDI32);
|
||
AdvAPI32Handle := GetModuleHandle(AdvAPI32);
|
||
ShlwapiHandle := CommonLoadLibrary(Shlwapi);
|
||
|
||
GetDiskFreeSpaceExA_MP := GetProcAddress(Kernel32Handle, 'GetDiskFreeSpaceA');
|
||
TrackMouseEvent_MP := GetProcAddress(User32Handle, 'TrackMouseEvent');
|
||
|
||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||
begin
|
||
GetDriveTypeW_MP := GetProcAddress(Kernel32Handle, 'GetDriveTypeW');
|
||
DrawTextW_MP := GetProcAddress(User32Handle, 'DrawTextW');
|
||
SHGetFileInfoW_MP := GetProcAddress(Shell32Handle, 'SHGetFileInfoW');
|
||
CreateFileW_MP := GetProcAddress(Kernel32Handle, 'CreateFileW');
|
||
SHGetDataFromIDListW_MP := GetProcAddress(Shell32Handle, 'SHGetDataFromIDListW');
|
||
FindFirstFileW_MP := GetProcAddress(Kernel32Handle, 'FindFirstFileW');
|
||
FindNextFileW_MP := GetProcAddress(Kernel32Handle, 'FindNextFileW');
|
||
lstrcmpiW_MP := GetProcAddress(Kernel32Handle, 'lstrcmpiW');
|
||
lstrcmpW_MP := GetProcAddress(Kernel32Handle, 'lstrcmpW');
|
||
lstrcpynW_MP := GetProcAddress(Kernel32Handle, 'lstrcpynW');
|
||
lstrcpyW_MP := GetProcAddress(Kernel32Handle, 'lstrcpyW');
|
||
CharLowerBuffW_MP := GetProcAddress(User32Handle, 'CharLowerBuffW');
|
||
CharUpperBuffW_MP := GetProcAddress(User32Handle, 'CharUpperBuffW');
|
||
CreateDirectoryW_MP := GetProcAddress(Kernel32Handle, 'CreateDirectoryW');
|
||
GetFullPathNameW_MP := GetProcAddress(Kernel32Handle, 'GetFullPathNameW');
|
||
ShellExecuteExW_MP := GetProcAddress(Shell32Handle, 'ShellExecuteExW');
|
||
ShellExecuteW_MP := GetProcAddress(Shell32Handle, 'ShellExecuteW');
|
||
FindFirstChangeNotificationW_MP := GetProcAddress(Kernel32Handle, 'FindFirstChangeNotificationW');
|
||
GetCharABCWidthsW_MP := GetProcAddress(GDI32Handle, 'GetCharABCWidthsW');
|
||
GetFileAttributesW_MP := GetProcAddress(Kernel32Handle, 'GetFileAttributesW');
|
||
GetSystemDirectoryW_MP := GetProcAddress(Kernel32Handle, 'GetSystemDirectoryW');
|
||
GetWindowsDirectoryW_MP := GetProcAddress(Kernel32Handle, 'GetWindowsDirectoryW');
|
||
GetDiskFreeSpaceExW_MP := GetProcAddress(Kernel32Handle, 'GetDiskFreeSpaceExW');
|
||
SetWindowTextW_MP := GetProcAddress(User32Handle, 'SetWindowTextW');
|
||
GetNumberFormatW_MP := GetProcAddress(Kernel32Handle, 'GetNumberFormatW');
|
||
RegOpenKeyW_MP := GetProcAddress(AdvAPI32Handle, 'RegOpenKeyW');
|
||
RegOpenKeyExW_MP := GetProcAddress(AdvAPI32Handle, 'RegOpenKeyExW');
|
||
RegQueryValueW_MP := GetProcAddress(AdvAPI32Handle, 'RegQueryValueW');
|
||
WritePrivateProfileStringW_MP := GetProcAddress(Kernel32Handle, 'WritePrivateProfileStringW');
|
||
GetPrivateProfileStringW_MP := GetProcAddress(Kernel32Handle, 'GetPrivateProfileStringW');
|
||
TryEnterCriticalSection_MP := GetProcAddress(Kernel32Handle, 'TryEnterCriticalSection');
|
||
InsertMenuItemW_MP := GetProcAddress(User32Handle, 'InsertMenuItemW');
|
||
SendMessageW_MP := GetProcAddress(User32Handle, 'SendMessageW');
|
||
SetFileAttributesW_MP := GetProcAddress(Kernel32Handle, 'SetFileAttributesW');
|
||
CreateFontIndirectW_MP := GetProcAddress(GDI32Handle, 'CreateFontIndirectW');
|
||
SystemParametersInfoW_MP := GetProcAddress(User32Handle, 'SystemParametersInfoW');
|
||
SHGetPathFromIDListW_MP := GetProcAddress(Shell32Handle, 'SHGetPathFromIDListW');
|
||
SHFileOperationW_MP := GetProcAddress(Shell32Handle, 'SHFileOperationW');
|
||
SHBrowseForFolderW_MP := GetProcAddress(Shell32Handle, 'SHBrowseForFolderW');
|
||
GetDiskFreeSpaceW_MP := GetProcAddress(Kernel32Handle, 'GetDiskFreeSpaceW');
|
||
GetCurrentDirectoryW_MP := GetProcAddress(Kernel32Handle, 'GetCurrentDirW');
|
||
GetTempPathW_MP := GetProcAddress(Kernel32Handle, 'GetTempPathW');
|
||
if ShlwapiHandle <> 0 then
|
||
begin
|
||
PathMatchSpecA_MP := GetProcAddress(ShlwapiHandle, 'PathMatchSpecA');
|
||
PathMatchSpecW_MP := GetProcAddress(ShlwapiHandle, 'PathMatchSpecW');
|
||
end;
|
||
CreateProcessW_MP := GetProcAddress(Kernel32Handle, 'CreateProcessW');
|
||
SHDoDragDrop_MP := GetProcAddress(Shell32Handle, 'SHDoDragDrop');
|
||
SHGetKnownFolderPath_MP := GetProcAddress(Shell32Handle, 'SHGetKnownFolderPath');
|
||
ExpandEnvironmentStringsW_MP := GetProcAddress(Kernel32Handle, 'ExpandEnvironmentStringsW');
|
||
|
||
// NTFS Volume (Junction) only functions
|
||
DeleteVolumeMountPoint_MP := GetProcAddress(Kernel32Handle, 'DeleteVolumeMountPointA');
|
||
GetVolumeNameForVolumeMountPoint_MP := GetProcAddress(Kernel32Handle, 'GetVolumeNameForVolumeMountPointA');
|
||
GetVolumePathName_MP := GetProcAddress(Kernel32Handle, 'GetVolumePathNameA');
|
||
SetVolumeMountPoint_MP := GetProcAddress(Kernel32Handle, 'SetVolumeMountPointA');
|
||
FindFirstVolume_MP := GetProcAddress(Kernel32Handle, 'FindFirstVolumeA');
|
||
FindNextVolume_MP := GetProcAddress(Kernel32Handle, 'FindNextVolumeA');
|
||
FindVolumeClose_MP := GetProcAddress(Kernel32Handle, 'FindVolumeClose');
|
||
FindFirstVolumeMountPoint_MP := GetProcAddress(Kernel32Handle, 'FindFirstVolumeMountPointA');
|
||
FindNextVolumeMountPoint_MP := GetProcAddress(Kernel32Handle, 'FindNextVolumeMountPointA');
|
||
FindVolumeMountPointClose_MP := GetProcAddress(Kernel32Handle, 'FindVolumeMountPointClose');
|
||
FindFirstFileExW_MP := GetProcAddress(Kernel32Handle, 'FindFirstFileExW');
|
||
end;
|
||
FindFirstFileExA_MP := GetProcAddress(Kernel32Handle, 'FindFirstFileExA');
|
||
|
||
// SHMultiFileProperties only supported on Win2k and WinXP
|
||
// http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/functions/shmultifileproperties.asp
|
||
SHMultiFileProperties_MP := GetProcAddress(Shell32Handle, PChar(716));
|
||
CDefFolderMenu_Create2_MP := GetProcAddress(Shell32Handle, PChar(701));
|
||
CDefFolderMenu_Create_MP := GetProcAddress(Shell32Handle, PChar(700));
|
||
|
||
|
||
|
||
// If this unit is to be weak packages this must be removed
|
||
finalization
|
||
FreeAndNil(PIDLMgr);
|
||
CommonUnloadAllLibraries;
|
||
|
||
end.
|
||
|