ehlibvcl.pas

最新的 DBGRIDEH4.0

{*******************************************************}
{                                                       }
{                       EhLib v4.2                      }
{            Specific routines for VCL.Win32            }
{                      Build 4.0.20                     }
{                                                       }
{      Copyright (c) 2004 by Dmitry V. Bolshakov        }
{                                                       }
{*******************************************************}

{$I EhLib.Inc}

unit EhLibVCL;

interface

{$WARNINGS OFF}

uses
  Windows, Forms, SysUtils, Classes, DB, TypInfo, Controls, Graphics,
{$IFDEF EH_LIB_6}
  RTLConsts, Variants,
{$ELSE}
  Consts,
{$ENDIF}
  Messages;

type
  TCMParentFontChanged = TMessage;
  IntPtr = Pointer;
  TBytes = array of Byte;
    
procedure FillDWord(var Dest; Count, Value: Integer);
function StackAlloc(Size: Integer): Pointer;
procedure StackFree(P: Pointer);

function DataSetCompareBookmarks(DataSet: TDataSet; Bookmark1, Bookmark2: TBookmarkStr): Integer;
function DataSetBookmarkValid(DataSet: TDataSet; Bookmark: TBookmarkStr): Boolean;

function GetMasterDataSet(FDataSet: TDataSet; APropInfo: PPropInfo): TDataSet;

function DrawTextEh(hDC: HDC; Text: String; nCount: Integer;
  var lpRect: TRect; uFormat: UINT): Integer;
function WindowsDrawTextEx(DC: HDC; lpchText: String; cchText: Integer;
  var p4: TRect;  dwDTFormat: UINT; DTParams: TDrawTextParams): Integer; overload;
function WindowsDrawTextEx(DC: HDC; lpchText: String; cchText: Integer;
  var p4: TRect;  dwDTFormat: UINT): Integer; overload;

{function DrawTextEh(hDC: HDC; Text: WideString; nCount: Integer;
  var lpRect: TRect; uFormat: UINT): Integer; overload;
function WindowsDrawTextEx(DC: HDC; lpchText: WideString; cchText: Integer;
  var p4: TRect;  dwDTFormat: UINT; DTParams: TDrawTextParams): Integer; overload;
function WindowsDrawTextEx(DC: HDC; lpchText: WideString; cchText: Integer;
  var p4: TRect;  dwDTFormat: UINT): Integer; overload;
}  

function WindowsExtTextOut(DC: HDC; X, Y: Integer; Options: Longint;
  var Rect: TRect; Str: String; Count: Longint{; Dx: PInteger}): BOOL;

function WindowsGetOutlineTextMetrics(DC: HDC; p2: UINT; var OTMetricStructs: TOutlineTextMetric): UINT;

//function SendStructlParamMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; var lParam): LRESULT;
function SendStructMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; var lParam): LRESULT;
function SendTextMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: string): LRESULT;
function SendGetTextMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; var lParam: string; BufferSize: Integer): LRESULT;

function SystemParametersInfoEh(uiAction, uiParam: UINT; var pvParam; fWinIni: UINT): BOOL;
function WindowsInvalidateRect(hWnd: HWND; var Rect: TRect; bErase: BOOL): BOOL;
function WindowsValidateRect(hWnd: HWND; var Rect: TRect): BOOL;
function WindowsScrollWindowEx(hWnd: HWND; dx, dy: Integer;
  var prcScroll,  prcClip: TRect;
  hrgnUpdate: HRGN; {prcUpdate: TRect; }flags: UINT): BOOL;
function WindowsScrollWindow(hWnd: HWND; dx, dy: Integer; var prcScroll, prcClip: TRect): BOOL;
function FindWindowEh(lpClassName, lpWindowName: String): HWND;

function WindowsLPtoDP(DC: HDC; var ARect: TRect): BOOL;
function WindowsCreatePolygonRgn(Points: array of TPoint; Count, FillMode: Integer): HRGN;

// WindowsSetStdCursor

function IsObjectAndIntegerRefSame(AObject: TObject; IntRef: Integer): Boolean;
function IntPtrToObject(AIntPtr: Integer): TObject;
function ObjectToIntPtr(AObject: TObject): Integer;
function IntPtrToString(AIntPtr: Integer): String;

procedure VarToMessage(var VarMessage; var Message: TMessage);
function MessageToTMessage(var Message): TMessage;
function MessageToTWMMouse(var Message): TWMMouse;
function MessageToTWMKey(var Message): TWMKey;
function UnwrapMessageEh(var Message): TMessage;

function SmallPointToInteger(SmallPoint: TSmallPoint): Integer;
function LongintToSmallPoint(Value: Longint): TSmallPoint;

procedure MessageSendGetSel(hWnd: HWND; var SelStart, SelEnd: Integer);

function NlsUpperCase(const S: String): String;
function NlsLowerCase(const S: String): String;
function NlsCompareStr(const S1, S2: String): Integer;
function NlsCompareText(const S1, S2: String): Integer;

function WideStringCompare(ws1, ws2: WideString; CharCount: Integer = 0; CaseInsensitive: Boolean = False): Integer;
function AnsiStringCompare(s1, s2: String; CharCount: Integer = 0; CaseInsensitive: Boolean = False): Integer;

procedure BitmapLoadFromResourceName(Bmp: TBitmap; Instance: THandle; const ResName: String);
function LoadBitmapEh(hInstance: HINST; lpBitmapID: Integer): HBITMAP;

//procedure Clipboard_SetBuffer(AClipboard: TClipboard; Format: Word; Buffer: TBytes; Size: Integer);

type
  TPropListArray = array of PPropInfo;

function GetPropListAsArray(ATypeInfo: PTypeInfo; TypeKinds: TTypeKinds): TPropListArray;

function HexToBinEh(Text: Pointer; var Buffer: TBytes; Count: Integer): Integer;
procedure BinToHexEh(Buffer: TBytes; var Text: String; Count: Integer);

procedure StreamWriteBytes(Stream: TStream; Buffer: TBytes);
procedure StreamReadBytes(Stream: TStream; var Buffer: TBytes; Count: Integer);

function BytesOf(S: String): TBytes;

function PropInfo_getPropType(APropInfo: PPropInfo): PTypeInfo;
function PropInfo_getName(APropInfo: PPropInfo): String;
function PropType_getKind(APropType: PTypeInfo): TTypeKind;

procedure VarArrayRedimEh(var A : Variant; HighBound: Integer);

{$IFNDEF EH_LIB_5}

function GetObjectProp(Instance: TObject; PropInfo: PPropInfo): TObject;
function GetObjectPropClass(Instance: TObject; PropInfo: PPropInfo): TClass;
procedure SetObjectProp(Instance: TObject; PropInfo: PPropInfo; Value: TObject);

{$ENDIF}

function GetUltimateOwner(APersistent: TPersistent): TPersistent;

function LongMulDiv(Mult1, Mult2, Div1: Longint): Longint; stdcall;
function EmptyRect: TRect;

function VariantToRefObject(Value: Variant): TObject;
function RefObjectToVariant(Value: TObject): Variant;
procedure DataVarCastAsObject(var Dest: Variant; const Source: Variant);

type

{ TFilerAccess }

  TFilerAccess = class(TInterfacedObject) // Same as TFilerAccess in D8.
  private
    FPersistent: TPersistent;
  public
    constructor Create(APersistent: TPersistent);
    procedure DefineProperties(AFiler: TFiler);
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent);
    function GetChildOwner: TComponent;
    function GetChildParent: TComponent;
    procedure SetAncestor(Value: Boolean);
    procedure SetChildOrder(Child: TComponent; Order: Integer);
    procedure Updated;
    procedure Updating;
  end;

{ TMemoryStreamEh }

  TMemoryStreamEh = class(TMemoryStream)
  private
    FHalfMemoryDelta: Integer;
  protected
    function Realloc(var NewCapacity: Longint): Pointer; override;
  public
    constructor Create;
    property HalfMemoryDelta: Integer read FHalfMemoryDelta write FHalfMemoryDelta;
  end;

{$IFNDEF EH_LIB_6}

type
  IInterface = IUnknown;

  IInterfaceComponentReference = interface
    ['{E28B1858-EC86-4559-8FCD-6B4F824151ED}']
    function GetComponent: TComponent;
  end;

  TDragObjectEx = class(TDragObject)
  public
    procedure BeforeDestruction; override;
  end;

const
  sLineBreak = {$IFDEF LINUX} #10 {$ELSE} #13#10 {$ENDIF};

function VarToWideStr(const V: Variant): WideString;
  
{$ENDIF}

function ExplicitLongwordToLongInt(v: Longword): LongInt;
function WStrCopy(Dest: PWideChar; const Source: PWideChar): PWideChar;

implementation

function LongMulDiv(Mult1, Mult2, Div1: Longint): Longint; stdcall;
{$IFDEF LINUX}
  external 'libwine.borland.so' name 'MulDiv';
{$ELSE}
  external 'kernel32.dll' name 'MulDiv';
{$ENDIF}

function WideStringCompare(ws1, ws2: WideString; CharCount: Integer = 0; CaseInsensitive: Boolean = False): Integer;
var
  dwCmpFlags: LongWord;
  cchCount: Integer;
begin
  if CaseInsensitive
    then dwCmpFlags := NORM_IGNORECASE
    else dwCmpFlags := 0;

  if CharCount = 0
    then cchCount := -1
    else cchCount := CharCount;

  Result := CompareStringW(LOCALE_USER_DEFAULT, dwCmpFlags, PWideChar(ws1),
      cchCount, PWideChar(ws2), cchCount) - 2;
end;

function AnsiStringCompare(s1, s2: String; CharCount: Integer = 0; CaseInsensitive: Boolean = False): Integer;
var
  dwCmpFlags: LongWord;
  cchCount: Integer;
begin
  if CaseInsensitive
    then dwCmpFlags := NORM_IGNORECASE
    else dwCmpFlags := 0;

  if CharCount = 0
    then cchCount := -1
    else cchCount := CharCount;

  Result := CompareString(LOCALE_USER_DEFAULT, dwCmpFlags, PChar(s1),
      cchCount, PChar(s2), cchCount) - 2;
end;

function IsObjectAndIntegerRefSame(AObject: TObject; IntRef: Integer): Boolean;
begin
  Result := (Integer(AObject) = IntRef);
end;

function IntPtrToObject(AIntPtr: Integer): TObject;
begin
  Result := TObject(AIntPtr);
end;

function ObjectToIntPtr(AObject: TObject): Integer;
begin
  Result := Integer(AObject);
end;

function IntPtrToString(AIntPtr: Integer): String;
begin
  Result := String(PChar(AIntPtr));
end;

procedure FillDWord(var Dest; Count, Value: Integer); register;
asm
  XCHG  EDX, ECX
  PUSH  EDI
  MOV   EDI, EAX
  MOV   EAX, EDX
  REP   STOSD
  POP   EDI
end;

{ StackAlloc allocates a 'small' block of memory from the stack by
  decrementing SP.  This provides the allocation speed of a local variable,
  but the runtime size flexibility of heap allocated memory.  }
function StackAlloc(Size: Integer): Pointer; register;
asm
  POP   ECX          { return address }
  MOV   EDX, ESP
  ADD   EAX, 3
  AND   EAX, not 3   // round up to keep ESP dword aligned
  CMP   EAX, 4092
  JLE   @@2
@@1:
  SUB   ESP, 4092
  PUSH  EAX          { make sure we touch guard page, to grow stack }
  SUB   EAX, 4096
  JNS   @@1
  ADD   EAX, 4096
@@2:
  SUB   ESP, EAX
  MOV   EAX, ESP     { function result = low memory address of block }
  PUSH  EDX          { save original SP, for cleanup }
  MOV   EDX, ESP
  SUB   EDX, 4
  PUSH  EDX          { save current SP, for sanity check  (sp = [sp]) }
  PUSH  ECX          { return to caller }
end;

{ StackFree pops the memory allocated by StackAlloc off the stack.
- Calling StackFree is optional - SP will be restored when the calling routine
  exits, but it's a good idea to free the stack allocated memory ASAP anyway.
- StackFree must be called in the same stack context as StackAlloc - not in
  a subroutine or finally block.
- Multiple StackFree calls must occur in reverse order of their corresponding
  StackAlloc calls.
- Built-in sanity checks guarantee that an improper call to StackFree will not
  corrupt the stack. Worst case is that the stack block is not released until
  the calling routine exits. }
procedure StackFree(P: Pointer); register;
asm
  POP   ECX                     { return address }
  MOV   EDX, DWORD PTR [ESP]
  SUB   EAX, 8
  CMP   EDX, ESP                { sanity check #1 (SP = [SP]) }
  JNE   @@1
  CMP   EDX, EAX                { sanity check #2 (P = this stack block) }
  JNE   @@1
  MOV   ESP, DWORD PTR [ESP+4]  { restore previous SP  }
@@1:
  PUSH  ECX                     { return to caller }
end;

function DataSetCompareBookmarks(DataSet: TDataSet; Bookmark1, Bookmark2: TBookmarkStr): Integer;
begin
  Result := DataSet.CompareBookmarks(TBookmark(Bookmark1), TBookmark(Bookmark2));
end;

function DataSetBookmarkValid(DataSet: TDataSet; Bookmark: TBookmarkStr): Boolean;
begin
  Result := DataSet.BookmarkValid(TBookmark(Bookmark));
end;

function GetMasterDataSet(FDataSet: TDataSet; APropInfo: PPropInfo): TDataSet;
var PropValue: TDataSource;
begin
  Result := nil;
  PropValue := nil;
  if (APropInfo <> nil) then
  begin
    if APropInfo^.PropType^.Kind = tkClass then
    try
      PropValue := (TObject(GetOrdProp(FDataSet, APropInfo)) as TDataSource);
    except // if PropInfo is not TDataSource or not inherited of
    end;
  end;
  if (PropValue <> nil)
    then Result := PropValue.DataSet;
end;

function DrawTextEh(hDC: HDC; Text: String; nCount: Integer;
  var lpRect: TRect; uFormat: UINT): Integer;
begin
  Result := DrawText(hDC, PChar(Text), nCount, lpRect, uFormat);
end;

function WindowsDrawTextEx(DC: HDC; lpchText: String; cchText: Integer;
  var p4: TRect;  dwDTFormat: UINT; DTParams: TDrawTextParams): Integer;
begin
  Result := DrawTextEx(DC, PChar(lpchText), cchText, p4, dwDTFormat, @DTParams);
end;

function WindowsDrawTextEx(DC: HDC; lpchText: String; cchText: Integer;
  var p4: TRect;  dwDTFormat: UINT): Integer; overload;
begin
  Result := DrawTextEx(DC, PChar(lpchText), cchText, p4, dwDTFormat, nil);
end;

{
function DrawTextEh(hDC: HDC; Text: WideString; nCount: Integer;
  var lpRect: TRect; uFormat: UINT): Integer; overload;
begin
  Result := DrawTextW(hDC, PWideChar(Text), nCount, lpRect, uFormat);
end;

function WindowsDrawTextEx(DC: HDC; lpchText: WideString; cchText: Integer;
  var p4: TRect;  dwDTFormat: UINT; DTParams: TDrawTextParams): Integer; overload;
begin
  Result := DrawTextExW(DC, PWideChar(lpchText), cchText, p4, dwDTFormat, @DTParams);
end;

function WindowsDrawTextEx(DC: HDC; lpchText: WideString; cchText: Integer;
  var p4: TRect;  dwDTFormat: UINT): Integer; overload;
begin
  Result := DrawTextExW(DC, PWideChar(lpchText), cchText, p4, dwDTFormat, nil);
end;
}

function WindowsExtTextOut(DC: HDC; X, Y: Integer; Options: Longint;
  var Rect: TRect; Str: String; Count: Longint{; Dx: PInteger}): BOOL;
begin
  Result := ExtTextOut(DC, X, Y, Options,
    @Rect, PChar(Str), Count, nil);
end;

function WindowsGetOutlineTextMetrics(DC: HDC; p2: UINT; var OTMetricStructs: TOutlineTextMetric): UINT;
begin
  Result := GetOutlineTextMetrics(DC, p2, @OTMetricStructs);
end;

{function SendStructlParamMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; var lParam): LRESULT;
begin
  Result := SendMessage(hWnd, Msg, wParam, Integer(@lParam));
end;}

function SendStructMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; var lParam): LRESULT;
begin
  Result := SendMessage(hWnd, Msg, wParam, Integer(@lParam));
end;