Delphi控件源码

开发平台：
Delphi

Mmthunk.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: +0351-8012255                   =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 20.01.1998 - 18:00:00 $                                      =}
{========================================================================}
unit MMThunk;
{$R-,S-,Q-,D+,L-}
interface
uses
    Windows;
const
    ShowNTWarning: Boolean = True;
type
  THandle16 = Word;
{ Windows 95 undocumented routines. These won't be found in Windows NT }
var
   QT_Thunk: procedure; 
//procedure QT_Thunk;
function  LoadLibrary16(LibFileName: PChar): THandle; stdcall;
procedure FreeLibrary16(LibModule: THandle); stdcall;
function  GetProcAddress16(Module: THandle; ProcName: PChar): Pointer; stdcall;
function  GlobalAlloc16(Flags: Integer; Bytes: Longint): THandle16; stdcall;
function  GlobalFree16(Mem: THandle16): THandle16; stdcall;
function  GlobalLock16(Mem: THandle16): Pointer; stdcall;
function  GlobalUnLock16(Mem: THandle16): WordBool; stdcall;
{ Windows NT/95 documented but undeclared routines                       }
{ 16:16 -> 0:32 Pointer translation.                                     }
{                                                                        }
{ WOWGetVDMPointer will convert the passed in 16-bit address             }
{ to the equivalent 32-bit flat pointer.  If fProtectedMode              }
{ is TRUE, the function treats the upper 16 bits as a selector           }
{ in the local descriptor table.  If fProtectedMode is FALSE,            }
{ the upper 16 bits are treated as a real-mode segment value.            }
{ In either case the lower 16 bits are treated as the offset.            }
{                                                                        }
{ The return value is NULL if the selector is invalid.                   }
{                                                                        }
{ NOTE:  Limit checking is not performed in the retail build             }
{ of Windows NT.  It is performed in the checked (debug) build           }
{ of WOW32.DLL, which will cause NULL to be returned when the            }
{ limit is exceeded by the supplied offset.                              }
function WOWGetVDMPointer(vp, dwBytes: DWord;
                          fProtectedMode: Bool): Pointer; stdcall;
{ The following two functions are here for compatibility with            }
{ Windows 95.  On Win95, the global heap can be rearranged,              }
{ invalidating flat pointers returned by WOWGetVDMPointer, while         }
{ a thunk is executing.  On Windows NT, the 16-bit VDM is completely     }
{ halted while a thunk executes, so the only way the heap will           }
{ be rearranged is if a callback is made to Win16 code.                  }
{                                                                        }
{ The Win95 versions of these functions call GlobalFix to                }
{ lock down a segment's flat address, and GlobalUnfix to                 }
{ release the segment.                                                   }
{                                                                        }
{ The Windows NT implementations of these functions do *not*             }
{ call GlobalFix/GlobalUnfix on the segment, because there               }
{ will not be any heap motion unless a callback occurs.                  }
{ If your thunk does callback to the 16-bit side, be sure                }
{ to discard flat pointers and call WOWGetVDMPointer again               }
{ to be sure the flat address is correct.                                }
function WOWGetVDMPointerFix(vp, dwBytes: DWord;
                             fProtectedMode: Bool): Pointer; stdcall;
procedure WOWGetVDMPointerUnfix(vp: DWord); stdcall;
{ compound memory routines                                               }
function GlobalAllocPtr16(Flags: Word; Bytes: Longint): Pointer;
function GlobalAllocPointer16(Flags: Word; Bytes: Longint;
         var FlatPointer: Pointer; var Source; DataSize: Longint): Pointer;
function GlobalFreePtr16(P: Pointer): THandle16;
{ utility routines                                                       }
function Ptr16To32(P: Pointer): Pointer;
function Ptr16To32Fix(P: Pointer): Pointer;
procedure Ptr16To32Unfix(P: Pointer);
function GetAddress16(Module: HModule; ProcName: String): TFarProc;
function LoadLib16(LibFileName: String): THandle;
function GDI16Handle: THandle;
function Kernel16Handle: THandle;
function User16Handle: THandle;
implementation
uses
    SysUtils, Classes, Dialogs;
type
    EInvalidArgument = class(EMathError);
    EInvalidProc = class(Exception);
    EThunkError = class(Exception);
const
    kernel32 = 'kernel32.dll';
    wow32 = 'wow32.dll';
{ These routines are exported with no names, hence the use of index }
{ Microsoft has changed the index for QT_THUNK !!! }
//procedure QT_Thunk;              external kernel32 index 561; //559;
//procedure QT_Thunk; external kernel32 name 'QT_Thunk';
function  LoadLibrary16;         external kernel32 index 35;
procedure FreeLibrary16;         external kernel32 index 36;
function  GetProcAddress16;      external kernel32 index 37;
function  GlobalAlloc16;         external kernel32 index 24;
function  GlobalFree16;          external kernel32 index 31;
function  GlobalLock16;          external kernel32 index 25;
function  GlobalUnLock16;        external kernel32 index 26;
{ These routines are exported with names, hence the normal use of name   }
function  WOWGetVDMPointer;      external wow32 name 'WOWGetVDMPointer';
function  WOWGetVDMPointerFix;   external wow32 name 'WOWGetVDMPointerFix';
procedure WOWGetVDMPointerUnfix; external wow32 name 'WOWGetVDMPointerUnfix';
{------------------------------------------------------------------------}
function GlobalAllocPtr16(Flags: Word; Bytes: Longint): Pointer;
begin
  Result := nil;
  //Ensure memory is fixed, meaning there is no need to lock it
  Flags := Flags or gmem_Fixed;
  LongRec(Result).Hi := GlobalAlloc16(Flags, Bytes);
end;
//16-bit pointer returned. FlatPointer is 32-bit pointer
//Buffer is allocated and then DataSize bytes from Source
//are copied in
function GlobalAllocPointer16(Flags: Word; Bytes: Longint;
         var FlatPointer: Pointer; var Source; DataSize: Longint): Pointer;
begin
  //Allocate memory in an address range
  //that _can_ be accessed by 16-bit apps
  Result := GlobalAllocPtr16(Flags, Bytes);
  //Get 32-bit pointer to this memory
  FlatPointer := Ptr16To32(Result);
  //Copy source data into the new bimodal buffer
  Move(Source, FlatPointer^, DataSize);
end;
function GlobalFreePtr16(P: Pointer): THandle16;
begin
  Result := GlobalFree16(LongRec(P).Hi);
end;
//Turn 16-bit pointer (selector and offset)
//into 32-bit pointer (offset)
function Ptr16To32(P: Pointer): Pointer;
begin
  Result := WOWGetVDMPointer(DWord(P), 0, True);
end;
function Ptr16To32Fix(P: Pointer): Pointer;
begin
  Result := WOWGetVDMPointerFix(DWord(P), 0, True);
end;
procedure Ptr16To32Unfix(P: Pointer);
begin
  WOWGetVDMPointerUnfix(DWord(P));
end;
function GetAddress16(Module: HModule; ProcName: String): TFarProc;
begin
  Result := GetProcAddress16(Module, PChar(ProcName));
  if not Assigned(Result) then
    raise EInvalidProc.Create('GetProcAddress16 failed');
end;
function LoadLib16(LibFileName: String): THandle;
begin
  Result := LoadLibrary16(PChar(LibFileName));
  if Result < HInstance_Error then
    raise EFOpenError.Create('LoadLibrary16 failed!');
end;
function GDI16Handle: THandle;
begin
  //Get GDI handle by loading it.
  Result := LoadLib16('GDI.EXE');
  //Free this particular load - GDI will stay in memory
  FreeLibrary16(Result);
end;
function Kernel16Handle: THandle;
begin
  //Get Kernel handle by loading it.
  Result := LoadLib16('KRNL386.EXE');
  //Free this particular load - Kernel will stay in memory
  FreeLibrary16(Result);
end;
function User16Handle: THandle;
begin
  //Get User handle by loading it.
  Result := LoadLib16('USER.EXE');
  //Free this particular load - User will stay in memory
  FreeLibrary16(Result);
end;
var
   hKernel: THANDLE;
initialization
//  if Win32Platform <> Ver_Platform_Win32_Windows then
//    raise EThunkError.Create('Flat thunks only supported under Windows 95');
  QT_THUNK := nil;
  if Win32Platform = Ver_Platform_Win32_Windows then
  begin
     hKernel := GetModuleHandle('KERNEL32.DLL');
     if (hKernel <> 0) then
     begin
        QT_THUNK := GetProcAddress(hKernel,'QT_Thunk');
     end;
  end;
end.

						