A: Here is an app that I found on compuserve. I ran it and it worked! It represents a LOT of impressive work on the part of the author and I applaud his efforts.
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:pPROC32LIST=nil; { array of PROC32ENTRY
structures. }
CALLOCGROW=10;
{ number of entries to grow rgProc32Entry by}
rgProc32handle:thandle=0;
{ Handle auf globalen Speicherbereich für 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:pointer;n,c:longint):longint;
FreeLibrary32W:function(handle:longint):bool;
GetProcAddress32W:function(module:longint;funcname:pchar):pointer;
LoadLibraryEx32W:function(libname:pchar;a,b:longint):longint;
lpvGetLastError:function:pchar;
lpvGetCapture:pointer;
lpvGetHandle32:pointer;
procedure Call32(iProc:longint);
function Declare32(lpstrName,lpstrLib,lpstrArg:pchar):longint;
function GetVDMPointer32W(name:pchar;Length:word):longint;
{Get 32-bit pointer from 16-bit pointer and length}
procedure XlatHwnd(var phwnd:longint);
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.
//
Note: Revised 05/01/96 by John Newlin
WOW _does_ support a function for translating
a
16-bit handle into a 32-bit handle as you
can
see below. The original technique that
utilizes
SetCapture has been commented out.
// May cause 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;
if @lpvGetHandle32=nil then begin
hinstUser:=LoadLibraryEx32W('wow32',0,0);
if hInstUser<>0 then begin
lpvGetHandle32:=GetProcAddress32W(hinstUser,'WOWHandle32');
FreeLibrary32W(hInstUser);
end;
if lpvGetHandle32 = nil then exit;
end;
pHwnd := CallProc32W(lpvGetHandle32,hwnd16,0);
(*
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 called. 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:pPROC32ENTRY;
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.
// It allocates and fills in a PROC32ENTRY structure
// so that we can call the 32 bit function.
//-----------------------------------------------------}
function Declare32(lpstrName,lpstrLib,lpstrArg:pchar):longint;
var
hinst:longint;
{ 32-bit DLL instance handle }
lpfunc:pointer;
{ 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:pchar;
nparams:longint;
end;
olderror:boolean;
{ Was there an error before?}
begin
{/ First time called, get the addresses of the Generic Thunk
// functions. Raise 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:pchar;Length:word):longint;
var lpGetVDMPointer32W:function(name:pchar;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;
lpvGetHandle32:=nil;
exitsave:=exitproc;
exitproc:=@cleanuplibs;
{$W+,S+}
end.
{***************************}
unit Icontray;
(*
Sample project that uses thunking and the WOW interface to
utilize the Windows 95 system tray. This package includes
the following units:
CALL32NT.PAS
LONGNAME.PAS
W32FILOP.PAS
In addition to the Windows 95 system tray capability, the
units above provide complete Windows 95 long file and
directory name support.
Compile and run and then click on the InsertBtn to add the
application icon (any icon is okay) to the Win 95 system
tray. The program will minimize and the icon will appear
on the tray. Left-click on the icon to restore the app.
Right-click on the icon to display the pop-up menu.
It works!
Have fun!
John Newlin
CIS 71535,665
*)
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
Controls, Forms, Dialogs, LongName, W32FilOp, StdCtrls,
Buttons, Menus;
type
TTestForm = class(TForm)
CloseBtn: TBitBtn;
InsertBtn: TButton;
TrayPop: TPopupMenu;
ItemA1: TMenuItem;
ItemB1: TMenuItem;
Label1: TLabel;
procedure CloseBtnClick(Sender: TObject);
procedure InsertBtnClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose:
Boolean);
procedure ItemA1Click(Sender: TObject);
procedure ItemB1Click(Sender: TObject);
private
DoRemove : boolean;
NRec : TNotifyIconData;
LongHandle : longint;
procedure TrayNotify(var Msg:TMessage); Message
WM_User;
public
{ Public declarations }
end;
var
TestForm: TTestForm;
implementation
{$R *.DFM}
Const
ProgId : longint = 44; {or whatever you like because it's a
unique identifer}
procedure TTestForm.TrayNotify(var Msg:TMessage);
var
p : TPoint;
begin
{lParam specifies the mouse message generated by the system
and wParam specifies the unique identifer}
case Msg.lParam of
wm_MouseMove : if Visible then
begin
GetCursorPos(P);
Label1.Caption := 'Mouse
x/y = '+inttostr(p.x)+'/'+
inttostr(p.y);
end;
wm_LButtonDown :
begin
Application.restore; {in
case minimized}
Show;
end;
wm_RButtonDown :
begin
GetCursorPos(P);
TrayPop.PopUp(p.x,p.y-100);
end;
end;
end;
procedure TTestForm.CloseBtnClick(Sender: TObject);
begin
Close;
end;
procedure TTestForm.InsertBtnClick(Sender: TObject);
begin
FillChar(NRec,SizeOf(NRec),0);
LongHandle := Handle32(Handle); {convert to 32-bit handle}
With NRec do
begin
cbSize := Sizeof(NRec);
wnd := LongHandle;
uid := ProgId;
uflags := nif_icon or nif_message
or nif_tip;
ucallbackmessage := WM_USER;
hIcon := Application.Icon.Handle;
StrCopy(szTip,'Test hint here');
end;
if W32Shell_NotifyIcon(Nim_Add,@NRec,id_W32Shell_NotifyIcon)
then
begin
DoRemove := true;
Hide;
InsertBtn.Enabled := false;
end else ShowMessage('Ooops! The call failed!');
end;
procedure TTestForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if DoRemove then
W32Shell_NotifyIcon(Nim_Delete,@NRec,id_W32Shell_NotifyIcon);
end;
procedure TTestForm.ItemA1Click(Sender: TObject);
begin
ShowMessage('Selected item A');
end;
procedure TTestForm.ItemB1Click(Sender: TObject);
begin
ShowMessage('Selected item B');
end;
end.
{*********** icontray.dfm ****************}
object TestForm: TTestForm
Left = 225
Top = 115
Width = 363
Height = 185
Caption = 'Put Icon on System Tray'
Font.Color = clWindowText
Font.Height = -12
Font.Name = 'Arial'
Font.Style = []
PixelsPerInch = 96
Position = poScreenCenter
OnCloseQuery = FormCloseQuery
TextHeight = 15
object Label1: TLabel
Left = 119
Top = 71
Width = 117
Height = 16
Caption = 'Mouse position here'
Font.Color = clBlack
Font.Height = -13
Font.Name = 'Arial'
Font.Style = []
ParentFont = False
end
object CloseBtn: TBitBtn
Left = 245
Top = 122
Width = 84
Height = 28
TabOrder = 0
OnClick = CloseBtnClick
Kind = bkClose
end
object InsertBtn: TButton
Left = 29
Top = 122
Width = 84
Height = 28
Caption = 'Insert Icon'
TabOrder = 1
OnClick = InsertBtnClick
end
object TrayPop: TPopupMenu
Left = 383
Top = 27
object ItemA1: TMenuItem
Caption = 'Item A'
OnClick = ItemA1Click
end
object ItemB1: TMenuItem
Caption = 'Item B'
OnClick = ItemB1Click
end
end
end
{********************************}
unit longname;
{Functions to use long filenames
All functions start with "W32" to distinguish them from 16 bit
functions
To call a function, use it like a normal function, with one exception:
the last parameter must be the id value for that function.
Example:
longhandle:=W32FindFirstFile('c:\*.*',finddata,id_W32FindFirstFile);
VERY IMPORTANT: All these functions work fine on Windows 95, but
NOT all work on
Windows NT:
- W32SetCurrentDirectory returns true, but does NOT actually
change the current directory
all other functions seem to work fine, but test your application
on NT before saying that
it runs fine!
}
interface
uses WinTypes,call32nt;
const
ABM_NEW
= $00000000;
ABM_REMOVE = $00000001;
ABM_QUERYPOS = $00000002;
ABM_SETPOS = $00000003;
ABM_GETSTATE = $00000004;
ABM_GETTASKBARPOS = $00000005;
ABM_ACTIVATE = $00000006;
ABM_GETAUTOHIDEBAR = $00000007;
ABM_SETAUTOHIDEBAR = $00000008;
VER_WIN32s = 0;
VER_WIN32 = 1;
VER_WIN32NT = 2;
NIM_ADD = $00000000;
NIM_MODIFY = $00000001;
NIM_DELETE = $00000002;
NIF_MESSAGE = $00000001;
NIF_ICON = $00000002;
NIF_TIP = $00000004;
INVALID_HANDLE_VALUE = -1;
FILE_BEGIN = 0;
FILE_CURRENT = 1;
FILE_END = 2;
FILE_FLAG_WRITE_THROUGH = $80000000;
FILE_FLAG_OVERLAPPED = $40000000;
FILE_FLAG_NO_BUFFERING = $20000000;
FILE_FLAG_RANDOM_ACCESS = $10000000;
FILE_FLAG_SEQUENTIAL_SCAN = $8000000;
FILE_FLAG_DELETE_ON_CLOSE = $4000000;
FILE_FLAG_BACKUP_SEMANTICS = $2000000;
FILE_FLAG_POSIX_SEMANTICS = $1000000;
CREATE_NEW = 1;
CREATE_ALWAYS = 2;
OPEN_EXISTING = 3;
OPEN_ALWAYS = 4;
TRUNCATE_EXISTING = 5;
_DELETE
= $00010000; { Renamed from DELETE }
READ_CONTROL
= $00020000;
WRITE_DAC
= $00040000;
WRITE_OWNER
= $00080000;
{ SYNCHRONIZE
= $00100000; defined above }
{ STANDARD_RIGHTS_REQUIRED = $000F0000; defined above }
STANDARD_RIGHTS_READ = READ_CONTROL;
STANDARD_RIGHTS_WRITE = READ_CONTROL;
STANDARD_RIGHTS_EXECUTE = READ_CONTROL;
STANDARD_RIGHTS_ALL = $001F0000;
SPECIFIC_RIGHTS_ALL = $0000FFFF;
ACCESS_SYSTEM_SECURITY = $01000000;
MAXIMUM_ALLOWED
= $02000000;
GENERIC_READ
= $80000000;
GENERIC_WRITE
= $40000000;
GENERIC_EXECUTE
= $20000000;
GENERIC_ALL
= $10000000;
FILE_SHARE_READ
= $00000001;
FILE_SHARE_WRITE
= $00000002;
FILE_ATTRIBUTE_READONLY
= $00000001;
FILE_ATTRIBUTE_HIDDEN
= $00000002;
FILE_ATTRIBUTE_SYSTEM
= $00000004;
FILE_ATTRIBUTE_DIRECTORY = $00000010;
FILE_ATTRIBUTE_ARCHIVE
= $00000020;
FILE_ATTRIBUTE_NORMAL
= $00000080;
FILE_ATTRIBUTE_TEMPORARY = $00000100;
FILE_ATTRIBUTE_ATOMICWRITE = $00000200;
FILE_ATTRIBUTE_XACTIONWRITE = $00000400;
FILE_NOTIFY_CHANGE_FILE_NAME = $00000001;
FILE_NOTIFY_CHANGE_DIR_NAME = $00000002;
FILE_NOTIFY_CHANGE_ATTRIBUTES = $00000004;
FILE_NOTIFY_CHANGE_SIZE
= $00000008;
FILE_NOTIFY_CHANGE_LAST_WRITE = $00000010;
FILE_NOTIFY_CHANGE_SECURITY = $00000100;
FILE_CASE_SENSITIVE_SEARCH = 1;
FILE_CASE_PRESERVED_NAMES = 2;
FILE_UNICODE_ON_DISK = 4;
FILE_PERSISTENT_ACLS = 8;
FILE_FILE_COMPRESSION = $10;
FILE_VOLUME_IS_COMPRESSED = $8000;
MOVEFILE_REPLACE_EXISTING = 1;
MOVEFILE_COPY_ALLOWED = 2;
MOVEFILE_DELAY_UNTIL_REBOOT = 4;
FOF_MULTIDESTFILES
= $0001;
FOF_CONFIRMMOUSE
= $0002;
FOF_SILENT
= $0004; { don't create progress/report }
FOF_RENAMEONCOLLISION = $0008;
FOF_NOCONFIRMATION
= $0010; { Don't prompt the user. }
FOF_WANTMAPPINGHANDLE = $0020;
{ Fill in SHFILEOPSTRUCT.hNameMappings
Must be freed using SHFreeNameMappings }
FOF_ALLOWUNDO
= $0040;
FOF_FILESONLY
= $0080; { on *.*, do only files }
FOF_SIMPLEPROGRESS
= $0100; { means don't show names of files }
FOF_NOCONFIRMMKDIR
= $0200; { don't confirm making any needed dirs }
FO_MOVE
= $0001;
FO_COPY
= $0002;
FO_DELETE =
$0003;
FO_RENAME =
$0004;
STARTF_USESHOWWINDOW = 1;
STARTF_USESIZE = 2;
STARTF_USEPOSITION = 4;
STARTF_USECOUNTCHARS = 8;
STARTF_USEFILLATTRIBUTE = $10;
STARTF_RUNFULLSCREEN = $20; { ignored for non-x86 platforms
}
STARTF_FORCEONFEEDBACK = $40;
STARTF_FORCEOFFFEEDBACK = $80;
STARTF_USESTDHANDLES = $100;
STARTF_USEHOTKEY = $200;
type
longfile=longint;
{WIN32_FIND_DATA structure:}
type
PNotifyIconData = ^TNotifyIconData;
TNotifyIconData = record
cbSize: Longint;
Wnd: longint;
uID: longint;
uFlags: longint;
uCallbackMessage: longint;
hIcon: longint;
szTip: array [0..63] of Char;
end;
PAppBarData = ^TAppBarData;
TAppBarData = record
cbSize: longint;
hWnd: longint;
uCallbackMessage: longint;
uEdge:longint;
rc: TRect;
lParam: longint; { message specific }
end;
WIN32_FIND_DATA=record
FileAttr:longint;
ftCreationTime,
ftLastAccessTime,
ftLastWriteTime:array[0..1] of longint;
nFileSizeHigh,
nFileSizeLow,
dwReserved0,
dwReserved1:longint;
cFileName:array[0..259] of char;
cAlternateFileName:array[0..13] of char;
end;
pWIN32_FIND_DATA=^WIN32_FIND_DATA;
PMemoryStatus = ^TMemoryStatus;
TMemoryStatus = record
Length: longint;
MemoryLoad: longint;
TotalPhys: longint;
AvailPhys: longint;
TotalPageFile: longint;
AvailPageFile: longint;
TotalVirtual: longint;
AvailVirtual: longint;
end;
type
tFILETIME=record
dwLowDateTime,
dwHighDateTime:longint;
end;
pFILETIME=^tFILETIME;
tSYSTEMTIME=record
Year,
Month,
DayOfWeek,
Day,
Hour,
Min,
Sec,
Milliseconds:word;
end;
tStartupInfo=record
cb:longint;
lpReserved,
lpDesktop,
lpTitle:pchar;
dwX,
dwY,
dwXSize,
dwYSize,
dwXCountChars,
dwYCountChars,
dwFillAttribute,
dwFlags:longint;
wShowWindow,
cbReserved2:word;
lpReserved2:^byte;
hStdInput,
hStdOutput,
hStdError:longint;
end;
TSECURITY_ATTRIBUTES = Record
nLength : longint;
lpSecDescriptor : pointer;
bInheritHandle:longbool;
End;
PROCESS_INFORMATION=record
hProcess,
hThread,
dwProcessId,
dwThreadId:longint;
end;
TFileOps = record
Wnd: Longint;
wFunc: Word;
pFrom: PChar;
pTo: PChar;
Flags: Word;
OpsAborted: longBOOL;
hNameMappings: Pointer;
ProgressTitle: PChar; { only used if FOF_SIMPLEPROGRESS
}
end;
TOSVerType = record
dwOSVersionInfoSize: longint;
dwMajorVersion: longint;
dwMinorVersion: longint;
dwBuildNumber: longint;
dwPlatformId: longint;
szCSDVersion: array[0..127] of Char; { Maintenance
string for PSS usage }
end;
var
W32WowHandle32:function(dwHandle,dwType,id:longint):longint;
W32SHAppBarMessage:function(dwMessage: longint; pData:
PAppBarData;id:longint): longBool;
W32Shell_NotifyIcon:function(dwMessage: longint; lpData: PNotifyIconData;id:longint):
longBOOL;
W32GlobalMemoryStatus:function(var lpBuffer: TMemoryStatus;
id:longint) : longbool;
W32SetVolumeLabel:function(lpszRoot,lpszLabel:Pchar;id:longint):longbool;
W32GetVersionEx:function(var osver : TOSVertype;id:longint):longbool;
W32CopyFile:function(lpszSrc,lpszDest:Pchar; Action:LongBool;id:longint)
: longbool;
W32SetEndOfFile:function(hFile:longint;id:longint):longbool;
W32GetFileSize:function(hFile:longint; lpFileSizeHigh: Pointer;id:longint):longint;
W32FindFirstFile:function(lpszSearchFile:pchar;var lpffd:WIN32_FIND_DATA;id:longint):longint;
W32FindNextFile:function(hFindFile:longint;var lpffd:WIN32_FIND_DATA;id:longint):longbool;
W32FindClose:function(hFindFile:longint;id:longint):Longbool;
W32FileTimeToDosTime:function(var lpft:tFILETIME;var H, L: Word; id:longint):Longbool;
W32DosTimeToFileTime:function(DosDate,DosTime:longint; var lpft:tFILETIME;id:longint):LongBool;
W32FileTimeToSystemTime:function(var lpft:tFILETIME;var lpst:tsystemtime;id:longint):longbool;
W32FileTimeToLocalFileTime:function(var lpft,lpftlocal:tFILETIME;id:longint):longbool;
W32SystemTimeToFileTime:function(var lpst:tsystemtime;var lpft:tFILETIME;id:longint):longbool;
W32LocalFileTimeToFileTime:function(var lpftlocal,lpft:tFILETIME;id:longint):longbool;
W32GetCurrentDirectory:function(cchCurDir:longint;lpszCurDir:pchar;id:longint):longint;
W32SetCurrentDirectory:function(lpszCurDir:pchar;id:longint):longbool;
W32CreateFile:function(lpszName:pchar;fdwAccess,fdwShareMode:longint;lpsa:pointer;
fdwCreate,fdwAttrsAndFlags,hTemplateFile,id:longint):longint;
W32MoveFile:function(lpszExisting,lpszNew:pchar;id:longint):longbool;
W32MoveFileEx:function(lpExistingFileName, lpNewFileName: PChar;
dwFlags: longint;id:longint): longbool;
W32GetLastError:function(id:longint):longint;
W32CreateDirectory:function(path:pchar;security:pointer;id:longint):longbool;
W32RemoveDirectory:function(path:pchar;id:longint):longbool;
W32SetFileAttributes:function(path:pchar;attr,id:longint):longbool;
W32GetFileAttributes:function(path:pchar;id:longint):longint;
W32Deletefile:function(path:pchar;id:longint):longbool;
W32SetFilePointer:function(hFile,lDistanceToMove:longint;lpDistanceToMoveHigh:pointer;
dwMoveMethod,id:longint):longint;
W32SetFileTime:function(hFile:longint;lpftCreation,lpftLastAccess,lpftLastWrite:pfiletime;
id:longint):longbool;
W32GetFileTime:function(hFile:longint; Var lpftCreation,lpftLastAccess,lpftLastWrite:tfiletime;
id:longint):longbool;
W32CloseHandle:function(hfile,id:longint):longbool;
W32ReadFile:function(hFile:longint;var lpBuffer;nNumberOfBytesToRead:longint;
var lpNumberOfBytesRead:longint;lpOverlapped:pointer;id:longint):longbool;
W32WriteFile:function(hFile:longint;var lpBuffer;nNumberOfBytesToWrite:longint;
var lpNumberOfBytesWritten:longint;lpOverlapped:pointer;id:longint):longbool;
W32FlushFileBuffers:function(hfile,id:longint):longbool;
W32ShellExecute:function(hwnd:longint;lpszOp,lpszFile,lpszParams,lpszDir:pchar;wShowCmd,id:longint):longint;
W32GetExitCodeProcess:function(hProcess: longint; var lpExitCode:
longint; id:longint): LongBOOL;
W32WaitForSingleObject:function(hObject,dwTimeout,id:longint):longint;
W32GetVolumeInfo:function(lpRootPathName: PChar;
lpVolumeNameBuffer: PChar;
nVolumeNameSize: longint;
var lpVolumeSerialNumber,
lpMaximumComponentLength,
lpFileSystemFlags: longint;
lpFileSystemNameBuffer: PChar;
nFileSystemNameSize: longint;
id:longint): longbool;
W32CreateProcess:function(lpszImageName,
lpszCommandLine:pchar;
lpsaProcess,lpsaThread:pointer;
fInheritHandles:longbool;
fdwCreate:longint;
lpvEnvironment:pointer;
lpszCurDir:pchar;
var lpsiStartInfo:tstartupinfo;
var lppiProcInfo:PROCESS_INFORMATION;
id:longint):longbool;
var
id_W32WowHandle32,
id_W32SHAppBarMessage,
id_W32Shell_NotifyIcon,
id_W32GlobalMemoryStatus,
id_W32GetVolumeInfo,
id_W32SetVolumeLabel,
id_W32GetExitCodeProcess,
id_W32GetVersionEx,
id_W32CopyFile,
id_W32SetEndOfFile,
id_W32GetFileSize,
id_W32DosTimeToFileTime,
id_W32FileTimeToDosTime,
id_W32FileOps,
id_W32FindFirstFile,
id_W32FindNextFile,
id_W32FindClose,
id_W32FileTimeToSystemTime,
id_W32FileTimeToLocalFileTime,
id_W32SystemTimeToFileTime,
id_W32LocalFileTimeToFileTime,
id_W32GetCurrentDirectory,
id_W32SetCurrentDirectory,
id_W32CreateFile,
id_W32MoveFile,
id_W32MoveFileEx,
id_W32GetLastError,
id_W32CreateDirectory,
id_W32RemoveDirectory,
id_W32SetFileAttributes,
id_W32GetFileAttributes,
id_W32Deletefile,
id_W32SetFilePointer,
id_W32setFileTime,
id_W32GetFileTime,
id_W32CloseHandle,
id_W32ReadFile,
id_W32WriteFile,
id_W32FlushFileBuffers,
id_W32ShellExecute,
id_W32WaitForSingleObject,
id_W32CreateProcess:longint;
implementation
Initialization
@W32WowHandle32:=@Call32;
@W32SHAppBarMessage:=@Call32;
@W32Shell_NotifyIcon:=@Call32;
@W32GlobalMemoryStatus:=@Call32;
@W32GetVolumeInfo:=@Call32;
@W32SetVolumeLabel:=@Call32;
@W32GetExitCodeProcess:=@Call32;
@W32GetVersionEx:=@Call32;
@W32CopyFile:=@Call32;
@W32SetEndOfFile:=@Call32;
@W32GetFileSize:=@Call32;
@W32DosTimeToFileTime:=@Call32;
@W32FileTimeToDosTime:=@Call32;
@W32FindFirstFile:=@Call32;
@W32FindNextFile:=@Call32;
@W32FindClose:=@Call32;
@W32FileTimeToSystemTime:=@Call32;
@W32FileTimeToLocalFileTime:=@Call32;
@W32SystemTimeToFileTime:=@Call32;
@W32LocalFileTimeToFileTime:=@Call32;
@W32GetCurrentDirectory:=@Call32;
@W32SetCurrentDirectory:=@Call32;
@W32CreateFile:=@Call32;
@W32MoveFile:=@Call32;
@W32MoveFileEx:=@CAll32;
@W32GetLastError:=@Call32;
@W32CreateDirectory:=@Call32;
@W32RemoveDirectory:=@Call32;
@W32SetFileAttributes:=@Call32;
@W32GetFileAttributes:=@Call32;
@W32Deletefile:=@Call32;
@W32SetFilePointer:=@Call32;
@W32setFileTime:=@Call32;
@W32GetFileTime:=@Call32;
@W32CloseHandle:=@Call32;
@W32ReadFile:=@Call32;
@W32WriteFile:=@Call32;
@W32FlushFileBuffers:=@Call32;
@W32ShellExecute:=@Call32;
@W32WaitForSingleObject:=@Call32;
@W32CreateProcess:=@Call32;
id_W32WowHandle32:=Declare32('WOWHandle32','wow32','ii');
id_W32SHAppBarMessage:=Declare32('SHAppBarMessage','shell32','ip');
id_W32Shell_NotifyIcon:=Declare32('Shell_NotifyIconA','shell32','ip');
id_W32GlobalMemoryStatus:=Declare32('GlobalMemoryStatus','kernel32','p');
id_W32GetVolumeInfo:=Declare32('GetVolumeInformation','kernel32','ppippppi');
id_W32SetVolumeLabel:=Declare32('SetVolumeLabel','kernel32','pp');
id_W32GetExitCodeProcess:=Declare32('GetExitCodeProcess','kernel32','ip');
id_W32GetVersionEx:=Declare32('GetVersionExA','kernel32','p');
id_W32CopyFile:=Declare32('CopyFile','kernel32','ppi');
id_W32SetEndOfFile:=Declare32('SetEndOfFile','kernel32','i');
id_W32GetFileSize:=Declare32('GetFileSize','kernel32','ip');
id_W32DosTimeToFileTime:=Declare32('DosDateTimeToFileTime','kernel32','iip');
id_W32FileTimeToDosTime:=Declare32('FileTimeToDosDateTime','kernel32','ppp');
id_W32FindFirstFile:=Declare32('FindFirstFile', 'kernel32',
'pp');
id_W32FindNextFile:=Declare32('FindNextFile', 'kernel32', 'ip');
id_W32FindClose:=Declare32('FindClose', 'kernel32', 'i');
id_W32FileTimeToSystemTime:=Declare32('FileTimeToSystemTime',
'kernel32', 'pp');
id_W32FileTimeToLocalFileTime:=Declare32('FileTimeToLocalFileTime',
'kernel32', 'pp');
id_W32SystemTimeToFileTime:=Declare32('SystemTimeToFileTime','kernel32','pp');
id_W32LocalFileTimeToFileTime:=Declare32('LocalFileTimeToFileTime','kernel32','pp');
id_W32GetCurrentDirectory:=Declare32('GetCurrentDirectory','kernel32','ip');
id_W32SetCurrentDirectory:=Declare32('SetCurrentDirectory','kernel32','p');
id_W32CreateFile:=Declare32('CreateFile','kernel32','piipiii');
id_W32MoveFile:=Declare32('MoveFile','kernel32','pp');
id_W32MoveFileEx:=Declare32('MoveFile','kernel32','ppi');
id_W32GetLastError:=Declare32('GetLastError','kernel32','');
id_W32CreateDirectory:=Declare32('CreateDirectory','kernel32','pp');
id_W32RemoveDirectory:=Declare32('RemoveDirectory','kernel32','p');
id_W32SetFileAttributes:=Declare32('SetFileAttributes','kernel32','pi');
id_W32GetFileAttributes:=Declare32('GetFileAttributes','kernel32','p');
id_W32Deletefile:=Declare32('DeleteFile','kernel32','p');
id_W32SetFilePointer:=Declare32('SetFilePointer','kernel32','iipi');
id_W32setFileTime:=Declare32('SetFileTime','kernel32','ippp');
id_W32GetFileTime:=Declare32('GetFileTime','kernel32','ippp');
id_W32CloseHandle:=Declare32('CloseHandle','kernel32','i');
id_W32ReadFile:=Declare32('ReadFile','kernel32','ipipp');
id_W32WriteFile:=Declare32('WriteFile','kernel32','ipipp');
id_W32FlushFileBuffers:=Declare32('FlushFileBuffers','kernel32','i');
id_W32ShellExecute:=Declare32('ShellExecute','shell32','wppppi');
id_W32WaitForSingleObject:=Declare32('WaitForSingleObject','kernel32','ii');
id_W32CreateProcess:=Declare32('CreateProcess','kernel32','ppppiipppp');
end.
{************ Traytest.dpr ********************}
program Traytest;
uses
Forms,
Icontray in 'ICONTRAY.PAS' {TestForm};
{$R *.RES}
begin
Application.CreateForm(TTestForm, TestForm);
Application.Run;
end.
{********************************}
unit W32filop;
(*
Provides 16-bit Delphi 1.0 access to the Windows 95/NT 32-bit
API.
Update 05/01/96 by John Newlin, CIS 71535,665. This source
code, like the supporting units LONGNAME.PAS aynd CALL32NT.PAS
is
released to the public domain. The author of this unit
makes no
guarantees, expressed or implied, and cautions you to use at
your
own risk.
This unit puts wrappers on the routines in LONGNAME.PAS and
CALL32NT.PAS {written by Christian Ghisler, CIS: 100332,1175}.
These routines have been tested successfully on floppy and hard
drives on a Micron P-100 running Windows95. It is suggested
that
you test them carefully before incorporating them into your
code.
Note that you can add just about any WIN32 API function to this
library by follwing the rules set forth in the file USAGE.TXT.
ENJOY!
Updated 05/01/96.
Bug fixes and new routines.
*)
interface
uses
WinTypes, WinProcs, SysUtils, Dialogs, LongName,Call32NT;
type
ActionType32 = (read32,write32);
function GetVolLabel(Const Drive : string) : string;
function SetVolLabel(Const Drive,Vlabel:string) : boolean;
function GetVersionW32(var OsVer:TOSVerType):longbool;
function FileSize32(fHandle:longint) : longint;
function CopyFile32(Const Source,Dest : string; NoOverwrite : boolean)
: LongBool;
function MoveFile32(Const OldName,NewName : string) : LongBool;
function BackupFile32(Var FullPath,NewName : string) : LongBool;
function DeleteFile32(Const FileName : string) : LongBool;
function FindFirst32(Const Path : string; Var Srec :WIN32_FIND_DATA)
: longint;
function FindNext32(FindHandle : longint; Var Srec :WIN32_FIND_DATA)
: longBool;
function FindClose32(FindHandle:longint) : LongBool;
function MkDir32(Const DirName : string) : LongBool;
function RmDir32(Const DirName : string) : Longbool;
function GetFileDateTime32(Var Rec:WIN32_FIND_DATA; Which:byte):TDateTime;
function DosShortName32(const FileName : string) : string;
function ResetFile32(Const FileName : string) : longint;
function ReWriteFile32(Const FileName : string) : longint;
function OpenFile32(Const FileName : string; Action : longint) : longint;
function CloseFile32(Handle:longint) : LongBool;
function BlockRead32(Handle:longint; Var Buffer; Count:longint; Var
BytesRead : longint) : LongBool;
function BlockWrite32(Handle:longint; Var Buffer; Count:longint; Var
BytesRead : longint) : LongBool;
function SeekFile32(Handle,Position : longint) : Longint;
function FilePos32(Handle : longint) : longint;
function SetEndOfFile32(Handle:longint) : longBool;
function SetFileTime32(Handle:longint; H,L : word) : LongBool;
function GetFileTime32(Handle:longint; Var H,L : word) : longBool;
function GetFileAttr32(FileName : string) : Word;
function MemStatus32(Var Rec:TMemoryStatus) : longBool;
function Handle32(handle:word):longint;
implementation
type
PCharBuffer = array[0..254] of char;
function Handle32(handle:word):longint;
begin
result := W32Wowhandle32(longint(handle),0,id_W32Wowhandle32);
end;
function MemStatus32(var Rec:TMemoryStatus) : longbool;
begin
fillchar(Rec,Sizeof(Rec),#0);
Rec.Length := SizeOf(Rec);
Result := W32GlobalMemoryStatus(rec,id_w32GlobalMemoryStatus);
end;
function GetVersionW32(var OSVer:TOSVerType) : longbool;
begin
FillChar(OsVer,SizeOf(OsVer),0);
OsVer.dwOSVersionInfoSize := SizeOf(TOsVerType);
Result := W32GetVersionEx(OsVer,id_W32GetVersionEx);
end;
function SetFileTime32(Handle:longint; H,L : word) : longBool;
var
Ft : tFileTime;
begin
Result := W32DosTimeToFileTime(H,L,Ft,id_W32DosTimeToFileTime);
if result = false then exit;
Result := W32SetFileTime(handle,@Ft,@Ft,@Ft,id_W32SetFileTime);
end;
function GetFileTime32(Handle:longint; Var H,L : word) : longBool;
var
Fc,Fa,Fw : tFileTime;
begin
result := W32GetFileTime(Handle,Fc,Fa,Fw,id_W32GetFileTime);
if not result then exit;
W32FileTimeToDosTime(Fw,h,l,id_W32FileTimeToDosTime);
end;
function SetVolLabel(Const Drive,Vlabel:string) : boolean;
var
Root,Lab : PCharBuffer;
begin
StrPCopy(Root,Drive[1]+':\');
StrPCopy(Lab,Vlabel);
Result := W32SetVolumeLabel(Root,Lab,id_W32SetVolumeLabel);
end;
function GetVolLabel(Const Drive : string) : string;
var
root,Vname,FileSysSize : PCharBuffer;
SerNum,MaxNameLen,Flags : longint;
begin
StrPCopy(Root,Drive[1]+':\');
Vname[0] := #0;
FileSysSize[0] := #0;
if W32GetVolumeInfo(Root,Vname,11,SerNum,MaxNameLen,Flags,
FileSysSize,40,id_W32GetVolumeInfo) then
Result := StrPas(Vname) else
Result := '';
end;
function GetFileAttr32(FileName:string) : word;
var
n : longint;
Fname : PCharBuffer;
begin
StrPCopy(Fname,FileName);
n := W32GetFileAttributes(FName,id_W32GetFileAttributes);
result := Word(n);
end;
function SetEndOfFile32(Handle:longint) : longBool;
begin
Result := W32SetEndOfFile(handle,id_W32SetEndOfFile);
end;
function ResetFile32(Const FileName : string) : longint;
var
Fname : PCharBuffer;
begin
StrPCopy(Fname,FileName);
Result := W32CreateFile(Fname,GENERIC_READ,FILE_SHARE_READ,nil,
OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0,
id_W32CreateFile);
end;
function FileSize32(fHandle:longint) : longint;
begin
result := W32GetFileSize(fhandle,nil,id_W32GetFileSize);
end;
function ReWriteFile32(Const FileName : string) : longint;
var
Fname : PCharBuffer;
begin
StrPCopy(Fname,FileName);
Result := W32CreateFile(FName,GENERIC_WRITE,0,nil,
OPEN_ALWAYS,FILE_ATTRIBUTE_NORMAL,0,
id_W32CreateFile);
end;
function OpenFile32(Const FileName : string; Action : longint) : longint;
var
Fname : PCharBuffer;
begin
StrPCopy(Fname,FileName);
Result := W32CreateFile(Fname,GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE,
Nil,
Action,FILE_ATTRIBUTE_NORMAL,
0,
id_W32CreateFile);
end;
function SeekFile32(Handle,Position : longint) : Longint;
begin
Result := W32SetFilePointer(Handle,Position,nil,FILE_BEGIN,id_W32SetFilePointer);
end;
function FilePos32(Handle : longint) : longint;
begin
Result := W32SetFilePointer(Handle,0,nil,FILE_CURRENT,id_W32SetFilePointer);
end;
function CloseFile32(Handle:longint) : LongBool;
begin
Result := W32CloseHandle(Handle,id_W32CloseHandle);
end;
function BlockRead32(Handle:longint; Var Buffer; Count:Longint;
Var BytesRead : longint) : LongBool;
begin
Result := W32ReadFile(Handle,Buffer,Count,BytesRead,nil,id_W32ReadFile);
end;
function BlockWrite32(Handle:longint; Var Buffer; Count:longint; Var
BytesRead : longint) : LongBool;
begin
Result := W32WriteFile(Handle,Buffer,Count,BytesRead,nil,id_W32WriteFile);
end;
function CopyFile32(Const Source,Dest : string; NoOverwrite : boolean)
: LongBool;
var
src,des : PCharBuffer;
begin
StrPCopy(Src,Source);
StrPCopy(Des,Dest);
Result := W32CopyFile(Src,Des,NoOverwrite,id_W32CopyFile);
end;
(*
EXIT;
Result := true;
Try
GetMem(CopyBuffer,BuffSize);
except result := false;
End;
if not result then exit;
if Overwrite then CreateCriteria := CREATE_ALWAYS else
CreateCriteria := CREATE_NEW;
Result := false;
StrPCopy(Src,Source);
StrPCopy(Des,Dest);
SrcH := W32CreateFile(Src,GENERIC_READ,FILE_SHARE_READ,nil,
OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0,
id_W32CreateFile);
if SrcH = -1 then
begin
Result := false;
FreeMem(CopyBuffer,BuffSize);
exit;
end;
DesH := W32CreateFile(Des,GENERIC_WRITE,0,nil,
CreateCriteria,FILE_ATTRIBUTE_NORMAL,0,
id_W32CreateFile);
if DesH = -1 then
begin
W32CloseHandle(SrcH,id_W32CloseHandle);
result := false;
FreeMem(CopyBuffer,BuffSize);
exit;
end;
Repeat
Ok := W32ReadFile(SrcH,CopyBuffer^,BuffSize,BytesRead,nil,id_W32ReadFile);
if Ok then Ok := W32WRiteFile(DesH,CopyBuffer^,BytesRead,Written,nil,id_W32WriteFile);
Until (BytesRead = 0) or not Ok;
Result := ok;
FreeMem(CopyBuffer,BuffSize);
W32CloseHandle(DesH,id_W32CloseHandle);
W32CloseHandle(SrcH,id_W32CloseHandle);
end;
*)
function MoveFile32(Const OldName,NewName : string) : LongBool;
var
OldFile,NewFile : PCharBuffer;
flags : longint;
begin
flags := MOVEFILE_REPLACE_EXISTING or
MOVEFILE_COPY_ALLOWED;
StrPCopy(OldFile,OldName);
StrPCopy(NewFile,NewName);
Result := W32MoveFileEx(OldFile,NewFile,MOVEFILE_REPLACE_EXISTING,id_W32MoveFileEx);
end;
function BackupFile32(var FullPath,NewName : string) : LongBool;
var
NewPath : string;
Orig,NewFile : PCharBuffer;
begin
result := false;
NewPath := ExtractFilePath(FullPath)+ ExtractFileName(NewName);
if LowerCase(FullPath) = LowerCase(NewPath) then exit;
StrPCopy(Orig,FullPath);
StrPCopy(NewFile,NewPath);
Result := CopyFile32(FullPath,NewPath,true);
end;
function DeleteFile32(Const FileName : string) : LongBool;
var
FName : PCharBuffer;
begin
StrPCopy(Fname,FileName);
Result := W32DeleteFile(Fname,id_W32DeleteFile);
end;
function FindFirst32(Const Path : string; Var Srec :WIN32_FIND_DATA)
: longint;
var
Lpath : PCharBuffer;
begin
StrPCopy(Lpath,Path);
Result := W32FindFirstFile(Lpath,Srec,id_W32FindFirstFile);
end;
function FindNext32(FindHandle : longint; Var Srec :WIN32_FIND_DATA)
: longBool;
begin
Result := W32FindNextFile(FindHandle,Srec,id_W32FindNextFile);
end;
function FindClose32(FindHandle:longint) : LongBool;
begin
Result := W32FindClose(FindHandle,id_W32FindClose);
end;
function MkDir32(Const DirName : string) : LongBool;
var
NewDir : PCharBuffer;
begin
StrPCopy(NewDir,DirName);
Result := W32CreateDirectory(NewDir,nil,id_W32CreateDirectory);
end;
function RmDir32(Const DirName : string) : Longbool;
Var
OldDir : PCharBuffer;
begin
StrPCopy(OldDir,DirName);
Result := W32RemoveDirectory(OldDir,id_W32RemoveDirectory);
end;
function SetCurrDir32(Var Dir : string) : LongBool;
var
CurrDir : PCharBuffer;
begin
StrPCopy(CurrDir,Dir);
Result := W32SetCurrentDirectory(CurrDir,id_W32SetCurrentDirectory);
end;
function GetCurrDir32 : string;
var
CurrDir : PCharBuffer;
begin
W32GetCurrentDirectory(sizeOf(CurrDir),CurrDir,id_W32GetCurrentDirectory);
Result := StrPas(CurrDir);
end;
function GetFileDateTime32(Var Rec:WIN32_FIND_DATA; Which:byte):TDateTime;
var
Dtime,Ddate : word;
Dt,x : longint;
TimeRec : tFileTime;
begin
x := rec.ftlastwritetime[0];
Result := StrtoDate('01/01/80');
with Rec do case Which of
1 :
begin
TimeRec.dwLowDateTime := ftCreationTime[0];
TimeRec.dwHighDateTime := ftCreationTime[1];
end;
2 :
begin
TimeRec.dwLowDateTime := ftLastAccessTime[0];
TimeRec.dwHighDateTime := ftLastAccessTime[1];
end;
3 :
begin
TimeRec.dwLowDateTime := ftLastWriteTime[0];
TimeRec.dwHighDateTime := ftLastWriteTime[1];
end;
Else exit;
End; {of case}
if W32FileTimeToDosTime(TimeRec,Ddate,DTime,id_W32FileTimeToDosTime)
then
begin
Dt := Ddate;
dt := (dt shl 16) + Dtime;
Try
Result := FileDateToDateTime(dt);
except
End;
W32DosTimeToFileTime(Ddate,Dtime,TimeRec,id_W32DosTimeToFileTime);
end;
end;
function DosShortName32(const FileName : string) : string;
var
Srec : WIN32_FIND_DATA;
FHandle,Result32 : longint;
ShortName : string[13];
begin
Result := '';
Result32 := FindFirst32(FileName,Srec);
if Result32 = -1 then exit;
FindClose32(Result32);
if SRec.cAlternateFileName[0] <> #0 then
ShortName := StrPas(Srec.cAlternateFileName) else
ShortName := StrPas(Srec.cFileName);
Result := ShortName;
end;
END.
(*
dwDesiredAccess
Specifies the type of access to the file or other object. An application
can obtain read access, write access, read-write access, or device
query access. You can use the following flag constants to build a value
for this parameter. Both GENERIC_READ and GENERIC_WRITE must be set
to
obtain read-write access:
Value Meaning
0
Allows an application to query device attributes without
actually accessing the device.
GENERIC_READ Specifies read access to the file. Data
can be read from
the file and the file pointer can be moved.
GENERIC_WRITE Specifies write access to the file. Data
can be written to
the file and the file pointer can be moved.
dwShareMode
Specifies how this file can be shared. This parameter must be some combination of the following values:
Value
Meaning
0
Prevents the file from being shared.
FILE_SHARE_READ Other
open operations can be performed on the file for
read access. If the CreateFile function is opening the client
end of a mailslot, this flag is specified.
FILE_SHARE_WRITE Other open
operations can be performed on the file for write access.
lpSecurityAttributes
Points to a SECURITY_ATTRIBUTES structure that specifies the security
attributes for the file. The file system must support this parameter
for it to have an effect.
dwCreationDistribution
Specifies which action to take on files that exist, and which action
to
take when files do not exist. This parameter must be one of the following
values:
Value
Meaning
CREATE_NEW
Creates a new file. The function fails if the
specified file already exists.
CREATE_ALWAYS
Creates a new file. The function overwrites the file
if it exists.
OPEN_EXISTING
Opens the file. The function fails if the file does
not exist.
OPEN_ALWAYS
Opens the file, if it exists. If the file does not
exist, the function creates the file as if
dwCreationDistribution were CREATE_NEW.
TRUNCATE_EXISTING Opens the file.
Once opened, the file is truncated
so that its size is zero bytes. The calling process
must open the file with at least GENERIC_WRITE access. The function fails
if the file does not exist.
dwFlagsAndAttributes
Specifies the file attributes and flags for the file.
Any combination of the following attributes is acceptable, except all
other file attributes override FILE_ATTRIBUTE_NORMAL.
Attribute
Meaning
FILE_ATTRIBUTE_ARCHIVE The file is an archive file. Applications
use this
attribute to mark files for backup or removal.
FILE_ATTRIBUTE_COMPRESSED The file or directory is compressed. For
a
file, this means that all of the data in the file is
compressed. For a directory, this means that
compression is the default for newly created files
and subdirectories.
FILE_ATTRIBUTE_NORMAL The file has no other attributes
set. This attribute
is valid only if used alone.
FILE_ATTRIBUTE_HIDDEN The file is hidden. It is not to
be included in an
ordinary directory listing.
FILE_ATTRIBUTE_READONLY The file is read only. Applications can read
the file
but cannot write to it or delete it.
FILE_ATTRIBUTE_SYSTEM The file is part of or is used exclusively
by the
operating system.
Any combination of the following flags is acceptable.
Flag
Meaning
FILE_FLAG_WRITE_THROUGH Instructs the operating system to write through
any
intermediate cache and go directly to the file. The
operating system can still cache write operations,
but cannot lazily flush them.
FILE_FLAG_OVERLAPPED Instructs the operating system
to initialize the file,
so ReadFile, WriteFile, ConnectNamedPipe, and
TransactNamedPipe operations that take a significant
amount of time to process return ERROR_IO_PENDING.
When the operation is finished, an event is set to
the signaled state. When you specify
FILE_FLAG_OVERLAPPED, the ReadFile and WriteFile
functions must specify an OVERLAPPED structure. That
is, when FILE_FLAG_OVERLAPPED is specified, an
application must perform overlapped reading and
writing. When FILE_FLAG_OVERLAPPED is specified, the
operating system does not maintain the file pointer.
The file position must be passed as part of the
lpOverlapped parameter (pointing to an OVERLAPPED
structure) to the ReadFile and WriteFile functions.
This flag also enables more than one operation to be
performed simultaneously with the handle (a
simultaneous read and write operation, for example).
FILE_FLAG_NO_BUFFERING Instructs the operating system to open
the file with
no intermediate buffering or caching. This can provide
performance gains in some situations. An application
must meet certain requirements when working with files
opened with FILE_FLAG_NO_BUFFERING. File access must
begin at offsets within the file that are integer
multiples of the volume's sector size. File access
must be for numbers of bytes that are integer
multiples of the volume's sector size. For example,
if the sector size is 512 bytes, an application can
request reads and writes of 512, 1024, or 2048 bytes,
but not of 335, 981, or 7171 bytes. · Buffer
addresses for read and write operations must be
aligned on addresses in memory that are integer
multiples of the volume's sector size. An application
can determine a volume's sector size by calling the
GetDiskFreeSpace function.
FILE_FLAG_RANDOM_ACCESS Indicates that the file is accessed randomly.
Windows
uses this flag to optimize file caching.
FILE_FLAG_SEQUENTIAL_SCAN Indicates that the file is to be accessed
sequentially from beginning to end. Windows uses this
flag to optimize file caching. If an application
moves the file pointer for random access, optimum
caching may not occur; however, correct operation is
still guaranteed. Specifying this flag can increase
performance for applications that read large files
using sequential access. Performance gains can be even
more noticeable for applications that read large files
mostly sequentially, but occasionally skip over small
ranges of bytes.
FILE_FLAG_DELETE_ON_CLOSE Indicates that the operating system
is to delete
the file immediately after all of its handles have
been closed.If you use this flag when you call
CreateFile, then open the file again, and then close
the handle for which you specified
FILE_FLAG_DELETE_ON_CLOSE, the file will not be
deleted until after you have closed the second and
any other handle to the file.
FILE_FLAG_BACKUP_SEMANTICS Windows NT only: Indicates that the
file is being
opened or created for a backup or restore operation.
The operating system ensures that the calling process
overrides file security checks, provided it has the
necessary permission to do so. The relevant
permissions are SE_BACKUP_NAME and SE_RESTORE_NAME. A
Windows NT application can also set this flag to
obtain a handle to a directory. A directory handle
can be passed to some Win32 functions in place of a
file handle.
FILE_FLAG_POSIX_SEMANTICS Indicates that the file is to be accessed
according
to POSIX rules. This includes allowing multiple
files
with names, differing only in case, for file systems
that support such naming. Use care when using this
option because files created with this flag may not
be accessible by applications written for MS-DOS,
Windows 3.x, or Windows NT.
*)
function WinExecAndWait32(FileName:String; Visibility : integer):integer;
{ returns -1 if the Exec failed, otherwise returns the process'
exit
code when the process terminates }
var
zAppName:array[0..512] of char;
zCurDir:array[0..255] of char;
WorkDir:String;
StartupInfo:TStartupInfo;
ProcessInfo:Process_information;
begin
StrPCopy(zAppName,FileName);
GetDir(0,WorkDir);
StrPCopy(zCurDir,WorkDir);
FillChar(StartupInfo,Sizeof(StartupInfo),#0);
StartupInfo.cb := Sizeof(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not w32CreateProcess(nil,
zAppName,
{ pointer to command line string }
nil,
{ pointer to process security attributes }
nil,
{ pointer to thread security attributes }
false,
{ handle inheritance flag }
CREATE_NEW_CONSOLE or
{ creation flags }
NORMAL_PRIORITY_CLASS,
nil,
{ pointer to new environment block }
nil,
{ pointer to current directory name }
StartupInfo,
{ pointer to STARTUPINFO }
ProcessInfo) then Result := -1 { pointer to
PROCESS_INF }
else
begin
W32WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
W32GetExitCodeProcess(ProcessInfo.hProcess,Result);
end;
end;