I
import
Unregistered / Unconfirmed
GUEST, unregistred user!
Q: How do I use a 32 bit DLL with 16 bit Delphi?
A: Here is something that I got from compuserve that looks good:
CALL32nt.pas: Library for Delphi/TPW/BPW to call 32 bit functions in Windows NT or Windows 95
Adapted to Pascal by Christian Ghisler from CALL32.DLL, a DLL for Visual Basic written and placed in the Public Domain by Peter Golde
This unit is placed in the public domain. Please feel free to redistribute as you wish. No guarantees are made as to its suitability or usefulness, and no support can be provided.
To call a function in a 32-bit DLL, follow these steps:
1. Declare the function you wish to call. Declare it in the ordinary fashion, with the following exceptions:
> Declare it as a function variable > Add an additional argument at the end, of type Longint:
For example, if you are calling the function: (C code)
GetWindowText(HWND hwnd, LPSTR lpsz, int cch)
declare it as follows (remember that ints and all handles are 32 bits, so use a Longint):
var GetWindowText:function(hwnd:Longint;lpsz
Char;cch:longint;id:Longint):Longint;
2. Each function needs an identifier to distinguish the function from other called functions. Declare this identifier in a var block.
For the above example:
var id_GetWindowText:longint;
3. In the initialization section of your application, set the address of the called function to the address of Call32:
@GetWindowtext:=@Call32;
4. Also in the initialization section of your application, declare the actual library and name of the function you
want to call with the Declare32 function. Pass it the name of the function (CASE SENSITIVE!!!), the library name, and a string describing the argument types.
Each letter in the string declares the type of one argument, and should be either "i" for a 32-bit integer or handle
type, "p" for any pointer type, or "w" for an HWND parameter to which you want to pass a 16-bit HWND and have it be automatically converted to a 32-bit HWND. Save the return value of Declare32 in a global variable to pass as the last parameter to the function you declared earlier. So, in continuing the example, you would call:
id_GetWindowText:=Declare32('GetWindowText','user32','wpi');
(As a side note, this more properly would be declared as 'GetWindowTextA', since this is the real exported name. However, Declare32 will automatically add an 'A' to the end of a function name if necessary.)
To call the function, you would call:
cbCopy:=GetWindowText(hwnd, sz, cb, id_GetWindowText);
It is important to use the correct data types when calling DLL functions. There are two important points to pay
attention to when using CALL32NT.PAS.
First, only 32-bit integers can be passed to a DLL procedure. Since virtually all 32-bit functions take int, UINT, LONG, DWORD, or HANDLE parameters, which are all 32 bits, this is not a major restriction. However, you must remember to always declare function arguments as Longint, not Integer.
Second, 16-bit handles and 32-bit handles are not interchangeable. For example, a 16-bit bitmap handle that you get from calling a 16-bit DLL or from the Delphi/TPW environment cannot be passed to a 32-bit function expecting a bitmap handle. Similarly, a 32-bit handle obtained from a 32-bit function cannot be passed to a 16- bit DLL. The only exception is window handles (HWND). If you declare a function parameter with the "w" letter in the argument description string passed to Declare32, the corresponding parameter will be automatically converted from a 16-bit HWND to a 32-bit HWND when the call is made. You must still declare the argument as a LONG. This is convenient, for example, when passing the value returned by the "handle" property of a form/control to a 32-bit DLL function. Only windows created by your application can be translated.
The following is a summary of data types:
C data type Type specified in Declare Character for Declare32
int, UINT Longint i
LONG, DWORD Longint i
HANDLE Longint i
WORD, short not supported
HWND Longint w (i for no 16->32 translation)
LPSTR PChar p
LPLONG, LPDWORD,
LPUINT, int FAR * VAR x:Longint p
LPWORD VAR x:Word p
Note on Declare32 function names: Declare32 will automatically try three different names for the function name you pass in. First, it uses the exact name you pass in. If it doesn't find that function name, it converts the name to the stdcall decorated name convention by adding an underscore at the beginning and adding "@nn" at the end, where "nn" is the number of bytes of arguments. If it doesn't find that name, it adds an "A" to the end of the original name to try the Win32(R) ANSI function calling convention.
If there occurs an error in Declare32, the returned id will be less than 0. Also, the variable Call32NTError will be set, so you only have to check one variable to check that all went well. You can use this variable to distinguish between Windows 3.1 and Windows NT/95: if Call32NTError is false, you can use the declared 32-bit functions, otherwise you must use 16-bit replacement functions. This allows you to write programs which work in both 16 and 32 bit environments.
If you have to pass a record containing a pointer, you must use the function GetVDMPointer32W to create a 0:32 pointer from your 16:16 pointer.
CALL32NT requires the Microsoft Windows NT operating system or Windows 95 Preview or later to perform its task. The program will also run in Win 3.1, but of course the functions will not work.
Unit Call32nt;
{Delphi/TPW/BPW Unit to call 32-bit functions from 16 bit programs}
{Written in Turbo Pascal for Windows 1.5 /Delphi}
{By Christian Ghisler, CIS: 100332,1175 }
{Released to the public domain on June 14,1995 }
{$W-}
{No Windows Stack frame!}
{$R-}
{No range checking!}
{
Translation by Christian Ghisler, from:
//----------------------------------------------------------
// CALL32.C
//
// This creates a DLL for 16-bit Visual Basic programs to
// call 32-bit DLLs on Windows NT 3.1. It uses the
// Generic Thunks feature of the WOW subsystem on Windows
// NT to load and call 32 bit DLLs. This file should
// be compile into a 16-bit DLL.
//
// Writted by Peter Golde.
//----------------------------------------------------------
}
interface
uses wintypes,
winprocs,
{$ifdef ver80}sysutils {$else} strings {$endif};
const Call32NTError:boolean=false;
type tPROC32ENTRY=record
hinst:longint; { 32-bit instance handle of library }
lpfunc:tfarproc; { 32-bit function address of function }
dwAddrXlat, { bit mask of params: 1 indicates arg is address }
dwHwndXlat, { bit mask of params: 1 indicates arg is 16-bit hwnd }
nParams:longint; { number of parameters }
end;
pPROC32ENTRY=^tPROC32ENTRY;
tPROC32LIST=array[0..0] of tPROC32ENTRY;
pPROC32LIST=^tPROC32LIST;
{ rgProc32Entry points to an array of PROC32ENTRY functions, which
is grown as needed. The value returned by Declare32 is an
index into this array.}
const
cRegistered:integer=0; { number of registered functions. }
cAlloc:integer=0; { number of alloced PROC32ENTRY structures. }
rgPROC32ENTRYPROC32LIST=nil; { array of PROC32ENTRY structures. }
CALLOCGROW=10; { number of entries to grow rgProc32Entry by}
rgProc32handle:thandle=0; { Handle auf globalen Speicherbereich f黵 rgProc32Entry }
{ These are the addresses of the Generic Thunk functions in
the WOW KERNEL.}
fGotProcs:bool=FALSE; { Did we successfully get the addresses? }
var
Callproc32W:function (addressointer;n,c:longint):longint;
FreeLibrary32W:function(handle:longint):bool;
GetProcAddress32W:function(module:longint;funcnamechar)ointer;
LoadLibraryEx32W:function(libnamechar;a,b:longint):longint;
lpvGetLastError:functionchar;
lpvGetCaptureointer;
procedure Call32(iProc:longint);
function Declare32(lpstrName,lpstrLib,lpstrArgchar):longint;
function GetVDMPointer32W(namechar;Length:word):longint; {Get 32-bit pointer from 16-bit pointer and length}
implementation
{/-----------------------------------------------------
// XlatHwnd
// Translates a 16-bit HWND into a 32-bit HWND.
// The HWND must be one in our 16-bit process.
// NULL is translated to NULL and doesn't cause
// and error.
//
// Unfortunately, WOW does not export a function
// for doing this, so our procedure is as follows:
// We do 16-bit SetCapture call to the window
// to set the capture, and then a 32-bit GetCapture
// call to get the 32-bit equivalent handle. The
// capture is then restored to what it was beforehand.
//
// May cause VB runtime error, and hence never return.
//-----------------------------------------------------}
procedure XlatHwnd(var phwnd:longint);
var hwnd16,
hwndCapturePrev:word;
hwnd32,
hinstUser:longint;
begin
hwnd16:=LOWORD(phwnd); { 16-bit hwnd }
{ Check for valid 16-bit handle. }
if (phwnd<>word(hwnd16)) then exit;
if (hwnd16<>0) and not IsWindow(hwnd16) then exit;
{ Get Address of 32-bit GetCapture }
if (@lpvGetCapture=nil) then begin
hinstUser:=LoadLibraryEx32W('user32', 0, 0);
if (hinstUser<>0) then begin
lpvGetCapture:=GetProcAddress32W(hinstUser, 'GetCapture');
FreeLibrary32W(hinstUser);
end;
if (@lpvGetCapture=nil) then exit;
end;
{/ Set capture to window, get capture to get 32-bit handle.
// Be sure to restore capture afterward.
// NULL isn't translated }
if (hwnd16<>0) then begin
hwndCapturePrev:=SetCapture(hwnd16);
hwnd32:=CallProc32W(lpvGetCapture,0,0);
if (hwndCapturePrev<>0) then
SetCapture(hwndCapturePrev)
else
ReleaseCapture;
if (hwnd32=0) then exit;
end;
phwnd:=hwnd32;
end;
{/-----------------------------------------------------
// MungeArgs
// Modify the args array so it can be passed to
// to CallProc32W. This uses the PROC32ENTRY structure
// to set up the arg list correctly on the stack
// so CallProc32W can be call. HWND translation is
// performed. The frame is changed as follows:
// In: Out:
// unused number of params
// dwArgs-> unused address xlat mask
// PROC32ENTRY index 32-bit function address.
// argument argument, possible HWND xlated
// argument argument, possible HWND xlated
// ... ...
//-----------------------------------------------------}
type plongint=^longint;
pfarproc=^tfarproc;
procedure MungeArgs(dwArgs:longint);
var pentryPROC32ENTRY;
iArg:integer;
dwHwndXlat:longint;
begin
pentry:=@rgProc32Entry^[plongint(dwArgs+4)^];
iArg:=2;
plongint(dwArgs-4)^:=pentry^.nParams;
plongint(dwArgs)^:=pentry^.dwAddrXlat;
pfarproc(dwArgs+4)^:=pentry^.lpfunc;
dwHwndXlat:=pentry^.dwHwndXlat;
while (dwHwndXlat<>0) do begin
if (dwHwndXlat and 1)<>0 then
XlatHwnd(plongint(dwArgs+4*iArg)^);
inc(iArg);
dwHwndXlat:=dwHwndXlat shr 1;
end;
end;
{/-----------------------------------------------------
// Call32
// This function is called by applications directly.
// Arguments to the function are also on the stack
// (iProc is the PROC32ENTRY index). We correctly
// set up the stack frame, then JUMP to CallProc32W,
// which eventually returns to the user.
//-----------------------------------------------------}
var dest:tfarproc; {Destination for jump back!}
var addit:word; {value to add to sp to restore stack pointer}
var _sp,_bp:word;
procedure Call32(iProc:longint);
begin
if iProc<0 then begin {Procedure is invalid -> stop execution!}
if messagebox(0,'Error calling 32 bit function, continue?','Call32',
mb_yesno or mb_iconquestion)=idno then halt(1);
addit:=(-iProc) shl 2; {4 more for id!}
asm
mov sp,bp
pop bp
pop di
mov word(dest),di
pop di
mov word(dest+2),di
add sp,addit
xor ax,ax {return 0}
xor dx,dx
jmp dest
end;
end;
asm { here comes the thunking call! }
pop bp { restore BP }
mov bx, sp { bx = sp on entry }
sub sp, 8 { 2 additional words }
mov ax, ss:[bx] { ax = return address offst }
mov dx, ss:[bx+2] { dx = return address segment }
mov ss:[bx-8], ax
mov ss:[bx-6], dx
push ds { Save our DS }
push ss
push bx { Push pointer to args }
call MungeArgs { Munge the args }
pop es { es is our DS }
jmp CallProc32W { Jump to the call thunker }
end;
end;
{/-----------------------------------------------------
// Declare32
// This function is called directly from VB.
// It allocates and fills in a PROC32ENTRY structure
// so that we can call the 32 bit function.
//-----------------------------------------------------}
function Declare32(lpstrName,lpstrLib,lpstrArgchar):longint;
var
hinst:longint; { 32-bit DLL instance handle }
lpfuncointer; { 32-bit function pointer }
dwAddrXlat, { address xlat mask }
dwHwndXlat, { hwnd xlat mask }
nParams:longint; { number of params }
szBuffer:array[0..127] of char; { scratch buffer }
hinstKernel:word; { Instance handle of WOW KERNEL.DLL }
hinstKernel32:longint; { Instance handle of Win32 KERNEL32.DLL }
rg:record
lpstrNamechar;
nparams:longint;
end;
olderror:boolean; { Was there an error before?}
begin
{/ First time called, get the addresses of the Generic Thunk
// functions. Raise VB runtime error if can't (probably because
// we're not running on NT). }
olderror:=Call32NTError;
Call32NTError:=true;
Declare32:=-1-lstrlen(lpstrArg);
if not fGotProcs then begin
hinstKernel:=LoadLibrary('KERNEL');
if (hinstKernel < 32) then exit;
@CallProc32W:=GetProcAddress(hinstKernel, 'CALLPROC32W');
@FreeLibrary32W:=GetProcAddress(hinstKernel, 'FREELIBRARY32W');
@LoadLibraryEx32W:=GetProcAddress(hinstKernel, 'LOADLIBRARYEX32W');
@GetProcAddress32W:=GetProcAddress(hinstKernel, 'GETPROCADDRESS32W');
FreeLibrary(hinstKernel);
if (@LoadLibraryEx32W<>nil) and (@GetProcAddress32W<>nil) and (@FreeLibrary32W<>nil) then begin
hinstKernel32:=LoadLibraryEx32W('kernel32', 0, 0);
@lpvGetLastError:=GetProcAddress32W(hinstKernel32, 'GetLastError');
FreeLibrary32W(hinstKernel);
end;
if (@CallProc32W=nil) or (@FreeLibrary32W=nil) or (@LoadLibraryEx32W=nil) or
(@GetProcAddress32W=nil) or (@lpvGetLastError=nil) then begin
exit;
end;
fGotProcs:=TRUE;
end;
{ If needed, allocate a PROC32ENTRY structure }
if (cRegistered = cAlloc) then begin
if (rgProc32Entry<>nil) then begin
globalunlock(rgProc32handle);
rgProc32handle:=GlobalReAlloc(rgProc32handle,
(cAlloc + CALLOCGROW) * sizeof(tPROC32ENTRY), GMEM_MOVEABLE);
rgProc32Entry:=Globallock(rgProc32handle);
end else begin
rgProc32handle:=GlobalAlloc(GMEM_MOVEABLE, CALLOCGROW * sizeof(tPROC32ENTRY));
rgProc32Entry:=Globallock(rgProc32handle);
end;
if (rgProc32Entry=nil) then exit;
inc(cAlloc,CALLOCGROW);
end;
{/ Process the arg list descriptor string to
// get the hwnd and addr translation masks, and the
// number of args. }
dwAddrXlat:=0;
dwHwndXlat:=0;
nParams:=lstrlen(lpstrArg);
if (nParams > 32) then exit; {Too many parameters}
while (lpstrArg[0]<>#0) do begin
dwAddrXlat:=dwAddrXlat shl 1;
dwHwndXlat:=dwHwndXlat shl 1;
case lpstrArg[0] of
'p':dwAddrXlat:=dwAddrXlat or 1;
'i':
'w':dwHwndXlat:=dwHwndXlat or 1;
else
exit;
end;
inc(lpstrArg);
end;
{/ Load the 32-bit library. }
hinst:=LoadLibraryEx32W(lpstrLib, 0, 0);
if (hinst=0) then begin
exit;
end;
{/ Get the 32-bit function address. Try the following three
// variations of the name (example: NAME):
// NAME
// _NAME@nn (stdcall naming convention: nn is bytes of args)
// NAMEA (Win32 ANSI function naming convention) }
lpfunc:=GetProcAddress32W(hinst, lpstrName);
if (lpfunc=nil) and (lstrlen(lpstrName) < 122) then begin
{ Change to stdcall naming convention. }
rg.lpstrName:=lpstrName;
rg.nparams:=nParams * 4;
wvsprintf(szBuffer, '_%s@%d', rg);
lpfunc:=GetProcAddress32W(hinst, szBuffer);
end;
if (lpfunc=nil) and (lstrlen(lpstrName) < 126) then begin
{ Add suffix "A" for ansi }
strcopy(szBuffer, lpstrName);
strcat(szBuffer, 'A');
lpfunc:=GetProcAddress32W(hinst, szBuffer);
end;
if (lpfunc=nil) then begin
FreeLibrary32W(hinst);
exit;
end;
{/ Fill in PROC32ENTRY struct and return index. }
rgProc32Entry^[cRegistered].hinst:=hinst;
rgProc32Entry^[cRegistered].lpfunc:=lpfunc;
rgProc32Entry^[cRegistered].dwAddrXlat:=dwAddrXlat;
rgProc32Entry^[cRegistered].dwHwndXlat:=dwHwndXlat;
rgProc32Entry^[cRegistered].nParams:=nParams;
Declare32:=cRegistered;
inc(cRegistered);
Call32NTError:=olderror; {If there was no error, set Call32NTErrorOccurred to false}
end;
function GetVDMPointer32W(namechar;Length:word):longint;
var lpGetVDMPointer32W:function(namechar;UINT:word):longint;
begin
@lpGetVDMPointer32W:=getProcAddress(GetModuleHandle('kernel'),'GetVDMPointer32W');
if @lpGetVDMPointer32W<>nil then
GetVDMPointer32W:=lpGetVDMPointer32W(name,Length)
else
GetVDMPointer32W:=0;
end;
{/-----------------------------------------------------
// WEP
// Called when DLL is unloaded. We free all the
// 32-bit DLLs we were using and clear the
// PROC32ENTRY list.
//-----------------------------------------------------}
var exitsave:tfarproc;
procedure cleanuplibs; far;
begin
Exitproc:=Exitsave;
dec(cRegistered);
while (cRegistered >= 0) do begin
FreeLibrary32W(rgProc32Entry^[cRegistered].hinst);
dec(cregistered);
end;
if (rgProc32Entry<>nil) then begin
globalunlock(rgProc32handle);
GlobalFree(rgProc32handle);
end;
rgProc32Entry:=NIL;
rgProc32handle:=0;
cRegistered:=0;
cAlloc:=0;
end;
begin
@Callproc32W:=nil;
@FreeLibrary32W:=nil;
@GetProcAddress32W:=nil;
@LoadLibraryEx32W:=nil;
@lpvGetLastError:=nil;
lpvGetCapture:=nil;
exitsave:=exitproc;
exitproc:=@cleanuplibs;
end.
A: Here is something that I got from compuserve that looks good:
CALL32nt.pas: Library for Delphi/TPW/BPW to call 32 bit functions in Windows NT or Windows 95
Adapted to Pascal by Christian Ghisler from CALL32.DLL, a DLL for Visual Basic written and placed in the Public Domain by Peter Golde
This unit is placed in the public domain. Please feel free to redistribute as you wish. No guarantees are made as to its suitability or usefulness, and no support can be provided.
To call a function in a 32-bit DLL, follow these steps:
1. Declare the function you wish to call. Declare it in the ordinary fashion, with the following exceptions:
> Declare it as a function variable > Add an additional argument at the end, of type Longint:
For example, if you are calling the function: (C code)
GetWindowText(HWND hwnd, LPSTR lpsz, int cch)
declare it as follows (remember that ints and all handles are 32 bits, so use a Longint):
var GetWindowText:function(hwnd:Longint;lpsz
Char;cch:longint;id:Longint):Longint;2. Each function needs an identifier to distinguish the function from other called functions. Declare this identifier in a var block.
For the above example:
var id_GetWindowText:longint;
3. In the initialization section of your application, set the address of the called function to the address of Call32:
@GetWindowtext:=@Call32;
4. Also in the initialization section of your application, declare the actual library and name of the function you
want to call with the Declare32 function. Pass it the name of the function (CASE SENSITIVE!!!), the library name, and a string describing the argument types.
Each letter in the string declares the type of one argument, and should be either "i" for a 32-bit integer or handle
type, "p" for any pointer type, or "w" for an HWND parameter to which you want to pass a 16-bit HWND and have it be automatically converted to a 32-bit HWND. Save the return value of Declare32 in a global variable to pass as the last parameter to the function you declared earlier. So, in continuing the example, you would call:
id_GetWindowText:=Declare32('GetWindowText','user32','wpi');
(As a side note, this more properly would be declared as 'GetWindowTextA', since this is the real exported name. However, Declare32 will automatically add an 'A' to the end of a function name if necessary.)
To call the function, you would call:
cbCopy:=GetWindowText(hwnd, sz, cb, id_GetWindowText);
It is important to use the correct data types when calling DLL functions. There are two important points to pay
attention to when using CALL32NT.PAS.
First, only 32-bit integers can be passed to a DLL procedure. Since virtually all 32-bit functions take int, UINT, LONG, DWORD, or HANDLE parameters, which are all 32 bits, this is not a major restriction. However, you must remember to always declare function arguments as Longint, not Integer.
Second, 16-bit handles and 32-bit handles are not interchangeable. For example, a 16-bit bitmap handle that you get from calling a 16-bit DLL or from the Delphi/TPW environment cannot be passed to a 32-bit function expecting a bitmap handle. Similarly, a 32-bit handle obtained from a 32-bit function cannot be passed to a 16- bit DLL. The only exception is window handles (HWND). If you declare a function parameter with the "w" letter in the argument description string passed to Declare32, the corresponding parameter will be automatically converted from a 16-bit HWND to a 32-bit HWND when the call is made. You must still declare the argument as a LONG. This is convenient, for example, when passing the value returned by the "handle" property of a form/control to a 32-bit DLL function. Only windows created by your application can be translated.
The following is a summary of data types:
C data type Type specified in Declare Character for Declare32
int, UINT Longint i
LONG, DWORD Longint i
HANDLE Longint i
WORD, short not supported
HWND Longint w (i for no 16->32 translation)
LPSTR PChar p
LPLONG, LPDWORD,
LPUINT, int FAR * VAR x:Longint p
LPWORD VAR x:Word p
Note on Declare32 function names: Declare32 will automatically try three different names for the function name you pass in. First, it uses the exact name you pass in. If it doesn't find that function name, it converts the name to the stdcall decorated name convention by adding an underscore at the beginning and adding "@nn" at the end, where "nn" is the number of bytes of arguments. If it doesn't find that name, it adds an "A" to the end of the original name to try the Win32(R) ANSI function calling convention.
If there occurs an error in Declare32, the returned id will be less than 0. Also, the variable Call32NTError will be set, so you only have to check one variable to check that all went well. You can use this variable to distinguish between Windows 3.1 and Windows NT/95: if Call32NTError is false, you can use the declared 32-bit functions, otherwise you must use 16-bit replacement functions. This allows you to write programs which work in both 16 and 32 bit environments.
If you have to pass a record containing a pointer, you must use the function GetVDMPointer32W to create a 0:32 pointer from your 16:16 pointer.
CALL32NT requires the Microsoft Windows NT operating system or Windows 95 Preview or later to perform its task. The program will also run in Win 3.1, but of course the functions will not work.
Unit Call32nt;
{Delphi/TPW/BPW Unit to call 32-bit functions from 16 bit programs}
{Written in Turbo Pascal for Windows 1.5 /Delphi}
{By Christian Ghisler, CIS: 100332,1175 }
{Released to the public domain on June 14,1995 }
{$W-}
{No Windows Stack frame!}
{$R-}
{No range checking!}
{
Translation by Christian Ghisler, from:
//----------------------------------------------------------
// CALL32.C
//
// This creates a DLL for 16-bit Visual Basic programs to
// call 32-bit DLLs on Windows NT 3.1. It uses the
// Generic Thunks feature of the WOW subsystem on Windows
// NT to load and call 32 bit DLLs. This file should
// be compile into a 16-bit DLL.
//
// Writted by Peter Golde.
//----------------------------------------------------------
}
interface
uses wintypes,
winprocs,
{$ifdef ver80}sysutils {$else} strings {$endif};
const Call32NTError:boolean=false;
type tPROC32ENTRY=record
hinst:longint; { 32-bit instance handle of library }
lpfunc:tfarproc; { 32-bit function address of function }
dwAddrXlat, { bit mask of params: 1 indicates arg is address }
dwHwndXlat, { bit mask of params: 1 indicates arg is 16-bit hwnd }
nParams:longint; { number of parameters }
end;
pPROC32ENTRY=^tPROC32ENTRY;
tPROC32LIST=array[0..0] of tPROC32ENTRY;
pPROC32LIST=^tPROC32LIST;
{ rgProc32Entry points to an array of PROC32ENTRY functions, which
is grown as needed. The value returned by Declare32 is an
index into this array.}
const
cRegistered:integer=0; { number of registered functions. }
cAlloc:integer=0; { number of alloced PROC32ENTRY structures. }
rgPROC32ENTRY
PROC32LIST=nil; { array of PROC32ENTRY structures. }CALLOCGROW=10; { number of entries to grow rgProc32Entry by}
rgProc32handle:thandle=0; { Handle auf globalen Speicherbereich f黵 rgProc32Entry }
{ These are the addresses of the Generic Thunk functions in
the WOW KERNEL.}
fGotProcs:bool=FALSE; { Did we successfully get the addresses? }
var
Callproc32W:function (address
ointer;n,c:longint):longint;FreeLibrary32W:function(handle:longint):bool;
GetProcAddress32W:function(module:longint;funcname
char)ointer;LoadLibraryEx32W:function(libname
char;a,b:longint):longint;lpvGetLastError:function
char;lpvGetCapture
ointer;procedure Call32(iProc:longint);
function Declare32(lpstrName,lpstrLib,lpstrArg
char):longint;function GetVDMPointer32W(name
char;Length:word):longint; {Get 32-bit pointer from 16-bit pointer and length}implementation
{/-----------------------------------------------------
// XlatHwnd
// Translates a 16-bit HWND into a 32-bit HWND.
// The HWND must be one in our 16-bit process.
// NULL is translated to NULL and doesn't cause
// and error.
//
// Unfortunately, WOW does not export a function
// for doing this, so our procedure is as follows:
// We do 16-bit SetCapture call to the window
// to set the capture, and then a 32-bit GetCapture
// call to get the 32-bit equivalent handle. The
// capture is then restored to what it was beforehand.
//
// May cause VB runtime error, and hence never return.
//-----------------------------------------------------}
procedure XlatHwnd(var phwnd:longint);
var hwnd16,
hwndCapturePrev:word;
hwnd32,
hinstUser:longint;
begin
hwnd16:=LOWORD(phwnd); { 16-bit hwnd }
{ Check for valid 16-bit handle. }
if (phwnd<>word(hwnd16)) then exit;
if (hwnd16<>0) and not IsWindow(hwnd16) then exit;
{ Get Address of 32-bit GetCapture }
if (@lpvGetCapture=nil) then begin
hinstUser:=LoadLibraryEx32W('user32', 0, 0);
if (hinstUser<>0) then begin
lpvGetCapture:=GetProcAddress32W(hinstUser, 'GetCapture');
FreeLibrary32W(hinstUser);
end;
if (@lpvGetCapture=nil) then exit;
end;
{/ Set capture to window, get capture to get 32-bit handle.
// Be sure to restore capture afterward.
// NULL isn't translated }
if (hwnd16<>0) then begin
hwndCapturePrev:=SetCapture(hwnd16);
hwnd32:=CallProc32W(lpvGetCapture,0,0);
if (hwndCapturePrev<>0) then
SetCapture(hwndCapturePrev)
else
ReleaseCapture;
if (hwnd32=0) then exit;
end;
phwnd:=hwnd32;
end;
{/-----------------------------------------------------
// MungeArgs
// Modify the args array so it can be passed to
// to CallProc32W. This uses the PROC32ENTRY structure
// to set up the arg list correctly on the stack
// so CallProc32W can be call. HWND translation is
// performed. The frame is changed as follows:
// In: Out:
// unused number of params
// dwArgs-> unused address xlat mask
// PROC32ENTRY index 32-bit function address.
// argument argument, possible HWND xlated
// argument argument, possible HWND xlated
// ... ...
//-----------------------------------------------------}
type plongint=^longint;
pfarproc=^tfarproc;
procedure MungeArgs(dwArgs:longint);
var pentry
PROC32ENTRY;iArg:integer;
dwHwndXlat:longint;
begin
pentry:=@rgProc32Entry^[plongint(dwArgs+4)^];
iArg:=2;
plongint(dwArgs-4)^:=pentry^.nParams;
plongint(dwArgs)^:=pentry^.dwAddrXlat;
pfarproc(dwArgs+4)^:=pentry^.lpfunc;
dwHwndXlat:=pentry^.dwHwndXlat;
while (dwHwndXlat<>0) do begin
if (dwHwndXlat and 1)<>0 then
XlatHwnd(plongint(dwArgs+4*iArg)^);
inc(iArg);
dwHwndXlat:=dwHwndXlat shr 1;
end;
end;
{/-----------------------------------------------------
// Call32
// This function is called by applications directly.
// Arguments to the function are also on the stack
// (iProc is the PROC32ENTRY index). We correctly
// set up the stack frame, then JUMP to CallProc32W,
// which eventually returns to the user.
//-----------------------------------------------------}
var dest:tfarproc; {Destination for jump back!}
var addit:word; {value to add to sp to restore stack pointer}
var _sp,_bp:word;
procedure Call32(iProc:longint);
begin
if iProc<0 then begin {Procedure is invalid -> stop execution!}
if messagebox(0,'Error calling 32 bit function, continue?','Call32',
mb_yesno or mb_iconquestion)=idno then halt(1);
addit:=(-iProc) shl 2; {4 more for id!}
asm
mov sp,bp
pop bp
pop di
mov word(dest),di
pop di
mov word(dest+2),di
add sp,addit
xor ax,ax {return 0}
xor dx,dx
jmp dest
end;
end;
asm { here comes the thunking call! }
pop bp { restore BP }
mov bx, sp { bx = sp on entry }
sub sp, 8 { 2 additional words }
mov ax, ss:[bx] { ax = return address offst }
mov dx, ss:[bx+2] { dx = return address segment }
mov ss:[bx-8], ax
mov ss:[bx-6], dx
push ds { Save our DS }
push ss
push bx { Push pointer to args }
call MungeArgs { Munge the args }
pop es { es is our DS }
jmp CallProc32W { Jump to the call thunker }
end;
end;
{/-----------------------------------------------------
// Declare32
// This function is called directly from VB.
// It allocates and fills in a PROC32ENTRY structure
// so that we can call the 32 bit function.
//-----------------------------------------------------}
function Declare32(lpstrName,lpstrLib,lpstrArg
char):longint;var
hinst:longint; { 32-bit DLL instance handle }
lpfunc
ointer; { 32-bit function pointer }dwAddrXlat, { address xlat mask }
dwHwndXlat, { hwnd xlat mask }
nParams:longint; { number of params }
szBuffer:array[0..127] of char; { scratch buffer }
hinstKernel:word; { Instance handle of WOW KERNEL.DLL }
hinstKernel32:longint; { Instance handle of Win32 KERNEL32.DLL }
rg:record
lpstrName
char;nparams:longint;
end;
olderror:boolean; { Was there an error before?}
begin
{/ First time called, get the addresses of the Generic Thunk
// functions. Raise VB runtime error if can't (probably because
// we're not running on NT). }
olderror:=Call32NTError;
Call32NTError:=true;
Declare32:=-1-lstrlen(lpstrArg);
if not fGotProcs then begin
hinstKernel:=LoadLibrary('KERNEL');
if (hinstKernel < 32) then exit;
@CallProc32W:=GetProcAddress(hinstKernel, 'CALLPROC32W');
@FreeLibrary32W:=GetProcAddress(hinstKernel, 'FREELIBRARY32W');
@LoadLibraryEx32W:=GetProcAddress(hinstKernel, 'LOADLIBRARYEX32W');
@GetProcAddress32W:=GetProcAddress(hinstKernel, 'GETPROCADDRESS32W');
FreeLibrary(hinstKernel);
if (@LoadLibraryEx32W<>nil) and (@GetProcAddress32W<>nil) and (@FreeLibrary32W<>nil) then begin
hinstKernel32:=LoadLibraryEx32W('kernel32', 0, 0);
@lpvGetLastError:=GetProcAddress32W(hinstKernel32, 'GetLastError');
FreeLibrary32W(hinstKernel);
end;
if (@CallProc32W=nil) or (@FreeLibrary32W=nil) or (@LoadLibraryEx32W=nil) or
(@GetProcAddress32W=nil) or (@lpvGetLastError=nil) then begin
exit;
end;
fGotProcs:=TRUE;
end;
{ If needed, allocate a PROC32ENTRY structure }
if (cRegistered = cAlloc) then begin
if (rgProc32Entry<>nil) then begin
globalunlock(rgProc32handle);
rgProc32handle:=GlobalReAlloc(rgProc32handle,
(cAlloc + CALLOCGROW) * sizeof(tPROC32ENTRY), GMEM_MOVEABLE);
rgProc32Entry:=Globallock(rgProc32handle);
end else begin
rgProc32handle:=GlobalAlloc(GMEM_MOVEABLE, CALLOCGROW * sizeof(tPROC32ENTRY));
rgProc32Entry:=Globallock(rgProc32handle);
end;
if (rgProc32Entry=nil) then exit;
inc(cAlloc,CALLOCGROW);
end;
{/ Process the arg list descriptor string to
// get the hwnd and addr translation masks, and the
// number of args. }
dwAddrXlat:=0;
dwHwndXlat:=0;
nParams:=lstrlen(lpstrArg);
if (nParams > 32) then exit; {Too many parameters}
while (lpstrArg[0]<>#0) do begin
dwAddrXlat:=dwAddrXlat shl 1;
dwHwndXlat:=dwHwndXlat shl 1;
case lpstrArg[0] of
'p':dwAddrXlat:=dwAddrXlat or 1;
'i':
'w':dwHwndXlat:=dwHwndXlat or 1;
else
exit;
end;
inc(lpstrArg);
end;
{/ Load the 32-bit library. }
hinst:=LoadLibraryEx32W(lpstrLib, 0, 0);
if (hinst=0) then begin
exit;
end;
{/ Get the 32-bit function address. Try the following three
// variations of the name (example: NAME):
// NAME
// _NAME@nn (stdcall naming convention: nn is bytes of args)
// NAMEA (Win32 ANSI function naming convention) }
lpfunc:=GetProcAddress32W(hinst, lpstrName);
if (lpfunc=nil) and (lstrlen(lpstrName) < 122) then begin
{ Change to stdcall naming convention. }
rg.lpstrName:=lpstrName;
rg.nparams:=nParams * 4;
wvsprintf(szBuffer, '_%s@%d', rg);
lpfunc:=GetProcAddress32W(hinst, szBuffer);
end;
if (lpfunc=nil) and (lstrlen(lpstrName) < 126) then begin
{ Add suffix "A" for ansi }
strcopy(szBuffer, lpstrName);
strcat(szBuffer, 'A');
lpfunc:=GetProcAddress32W(hinst, szBuffer);
end;
if (lpfunc=nil) then begin
FreeLibrary32W(hinst);
exit;
end;
{/ Fill in PROC32ENTRY struct and return index. }
rgProc32Entry^[cRegistered].hinst:=hinst;
rgProc32Entry^[cRegistered].lpfunc:=lpfunc;
rgProc32Entry^[cRegistered].dwAddrXlat:=dwAddrXlat;
rgProc32Entry^[cRegistered].dwHwndXlat:=dwHwndXlat;
rgProc32Entry^[cRegistered].nParams:=nParams;
Declare32:=cRegistered;
inc(cRegistered);
Call32NTError:=olderror; {If there was no error, set Call32NTErrorOccurred to false}
end;
function GetVDMPointer32W(name
char;Length:word):longint;var lpGetVDMPointer32W:function(name
char;UINT:word):longint;begin
@lpGetVDMPointer32W:=getProcAddress(GetModuleHandle('kernel'),'GetVDMPointer32W');
if @lpGetVDMPointer32W<>nil then
GetVDMPointer32W:=lpGetVDMPointer32W(name,Length)
else
GetVDMPointer32W:=0;
end;
{/-----------------------------------------------------
// WEP
// Called when DLL is unloaded. We free all the
// 32-bit DLLs we were using and clear the
// PROC32ENTRY list.
//-----------------------------------------------------}
var exitsave:tfarproc;
procedure cleanuplibs; far;
begin
Exitproc:=Exitsave;
dec(cRegistered);
while (cRegistered >= 0) do begin
FreeLibrary32W(rgProc32Entry^[cRegistered].hinst);
dec(cregistered);
end;
if (rgProc32Entry<>nil) then begin
globalunlock(rgProc32handle);
GlobalFree(rgProc32handle);
end;
rgProc32Entry:=NIL;
rgProc32handle:=0;
cRegistered:=0;
cAlloc:=0;
end;
begin
@Callproc32W:=nil;
@FreeLibrary32W:=nil;
@GetProcAddress32W:=nil;
@LoadLibraryEx32W:=nil;
@lpvGetLastError:=nil;
lpvGetCapture:=nil;
exitsave:=exitproc;
exitproc:=@cleanuplibs;
end.