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° 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×alpha / 255 + backgroundColor×(255 – 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° 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° 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.