上一段做WindowsCE上的工作.翻译,包装了微软的RAPI和dccManSink等.
可以感知嵌入社设备的插拔.可以操作嵌入式设备上的注册表.文件,数据库等等.
发出来算是给Delphi社区做个贡献
下面贴出的是三个单元的代码.也可以在CSDN下载.里面包含例子.
http://download.csdn.net/source/1993722
{*******************************************************
RAPI接口
版权所有 (C) 2010 王锐
翻译自MSDN和RAPI.H
*******************************************************}
unit rapi;
interface
uses
Windows, Sysutils, shlobj;
const
FAF_ATTRIBUTES = $00000001;
FAF_CREATION_TIME = $00000002;
FAF_LASTACCESS_TIME = $00000004;
FAF_LASTWRITE_TIME = $00000008;
FAF_SIZE_HIGH = $00000010;
FAF_SIZE_LOW = $00000020;
FAF_OID = $00000040;
FAF_NAME = $00000080;
FAF_FLAG_COUNT = 8;
FAF_ATTRIB_CHILDREN = $00001000;
FAF_ATTRIB_NO_HIDDEN = $00002000;
FAF_FOLDERS_ONLY = $00004000;
FAF_NO_HIDDEN_SYS_ROMMODULES = $00008000;
FAD_OID = $1;
FAD_FLAGS = $2;
FAD_NAME = $4;
FAD_TYPE = $8;
FAD_NUM_RECORDS = $10;
FAD_NUM_SORT_ORDER = $20;
FAD_SIZE = $40;
FAD_LAST_MODIFIED = $80;
FAD_SORT_SPECS = $100;
FAD_FLAG_COUNT = $9;
CeDB_SORT_DESCENDING = $00000001;
CeDB_SORT_CASEINSENSITIVE = $00000002;
CeDB_SORT_UNKNOWNFIRST = $00000004;
CeDB_SORT_GENERICORDER = $00000008;
CeDB_MAXDBASENAMELEN = 32;
CeDB_MAXSORTORDER = 4;
CeDB_VALIDNAME = $0001;
CeDB_VALIDTYPE = $0002;
CeDB_VALIDSORTSPEC = $0004;
CeDB_VALIDMODTIME = $0008;
OBJTYPE_INVALID = 0;
OBJTYPE_FILE = 1;
OBJTYPE_DIRECTORY = 2;
OBJTYPE_DATABASE = 3;
OBJTYPE_RECORD = 4;
CeDB_AUTOINCREMENT = $00000001;
CeDB_SEEK_CeOID = $00000001;
CeDB_SEEK_BEGINNING = $00000002;
CeDB_SEEK_END = $00000004;
CeDB_SEEK_CURRENT = $00000008;
CeDB_SEEK_VALUESMALLER = $00000010;
CeDB_SEEK_VALUEFIRSTEQUAL = $00000020;
CeDB_SEEK_VALUEGREATER = $00000040;
CeDB_SEEK_VALUENEXTEQUAL = $00000080;
CeVT_I2 = 2;
CeVT_UI2 = 18;
CeVT_I4 = 3;
CeVT_UI4 = 19;
CeVT_FILETIME = 64;
CeVT_LPWSTR = 31;
CeVT_BLOB = 65;
CeDB_PROPNOTFOUND = $0100;
CeDB_PROPDELETE = $0200;
CeDB_MAXDATABLOCKSIZE = 4092;
CeDB_MAXPROPDATASIZE = (CeDB_MAXDATABLOCKSIZE * 16);
CeDB_MAXRECORDSIZE = (128 * 1024);
CeDB_ALLOWREALLOC = $00000001;
SYSMEM_CHANGED = 0;
SYSMEM_MUSTREBOOT = 1;
SYSMEM_REBOOTPENDING = 2;
SYSMEM_FAILED = 3;
AC_LINE_OFFLINE = $00;
AC_LINE_ONLINE = $01;
AC_LINE_BACKUP_POWER = $02;
AC_LINE_UNKNOWN = $FF;
BATTERY_FLAG_HIGH = $01;
BATTERY_FLAG_LOW = $02;
BATTERY_FLAG_CRITICAL = $04;
BATTERY_FLAG_CHARGING = $08;
BATTERY_FLAG_NO_BATTERY = $80;
BATTERY_FLAG_UNKNOWN = $FF;
BATTERY_PERCENTAGE_UNKNOWN = $FF;
BATTERY_LIFE_UNKNOWN = $FFFFFFFF;
type
TPROCESSOR_ARCHITECTURE =
(
PROCESSOR_ARCHITECTURE_INTEL,
PROCESSOR_ARCHITECTURE_MIPS,
PROCESSOR_ARCHITECTURE_ALPHA,
PROCESSOR_ARCHITECTURE_PPC,
PROCESSOR_ARCHITECTURE_SHX,
PROCESSOR_ARCHITECTURE_ARM,
PROCESSOR_ARCHITECTURE_IA64,
PROCESSOR_ARCHITECTURE_ALPHA64,
PROCESSOR_ARCHITECTURE_UNKNOWN = $FFFF
);
PCe_Find_Data = ^TCe_Find_Data;
TCe_Find_Data = record
dwFileAttributes: DWORD;
ftCreationTime: TFileTime;
ftLastAccessTime: TFileTime;
ftLastWriteTime: TFileTime;
nFileSizeHigh: DWORD;
nFileSizeLow: DWORD;
dwOID: DWORD;
cFileName: array [0 .. MAX_PATH - 1] of WideChar;
end;
TCe_Find_Data_array = array [0 .. MaxInt div sizeof(TCe_Find_Data) - 1]
of TCe_Find_Data;
PCe_Find_Data_array = ^TCe_Find_Data_array;
PStore_Information = ^TStore_Information;
TStore_Information = record
dwStoreSize: DWORD;
dwFreeSize: DWORD;
end;
CEGUID = record
Data1: DWORD;
Data2: DWORD;
Data3: DWORD;
Data4: DWORD;
end;
PCEGUID = ^CEGUID;
CePROPID = DWORD;
PCePROPID = ^CePROPID;
TCe_PropID_array = array [0 .. MaxInt div sizeof(CePROPID) - 1] of CePROPID;
PCe_PropID_array = ^TCe_PropID_array;
CeOID = DWORD;
PCeOID = ^CeOID;
TCeFileInfo = record
dwAttributes: DWORD;
oidParent: CeOID;
szFileName: array [0 .. MAX_PATH - 1] of WCHAR;
ftLastChanged: TFileTime;
dwLength: DWORD;
end;
TCeDirInfo = record
dwAttributes: DWORD;
oidParent: CeOID;
szDirName: array [0 .. MAX_PATH - 1] of WCHAR;
end;
TCeRecordInfo = record
oidParent: CeOID;
end;
TSortOrderSpec = record
propid: CePROPID;
dwFlags: DWORD;
end;
TCeDBaseInfo = record
dwFlags: DWORD;
szDbaseName: array [0 .. CeDB_MAXDBASENAMELEN - 1] of WCHAR;
dwDbaseType: DWORD;
wNumRecords: WORD;
wNumSortOrder: WORD;
dwSize: DWORD;
ftLastModified: TFileTime;
rgSortSpecs: array [0 .. CeDB_MAXSORTORDER - 1] of TSortOrderSpec;
end;
TCeDB_File_Data = record
OidDb: CeOID;
DbInfo: TCeDBaseInfo;
end;
PCeDB_File_Data = ^TCeDB_File_Data;
TCeDB_File_Data_Array = array [0 .. MaxInt div sizeof(TCeDB_File_Data) - 1]
of TCeDB_File_Data;
PCeDB_File_Data_Array = ^TCeDB_File_Data_Array;
TCeOIdInfo = record
wObjType: WORD;
wPad: WORD;
case Integer of
0:
(infFile: TCeFileInfo);
1:
(infDirectory: TCeDirInfo);
2:
(infDatabase: TCeDBaseInfo);
3:
(infRecord: TCeRecordInfo);
end;
PCeOIDInfo = ^TCeOIdInfo;
TCeOIContainerStruct = record
OID: CeOID;
OIDInfo: TCeOIdInfo;
end;
PCeOIContainerStruct = ^TCeOIContainerStruct;
TCeBlob = record
dwCount: DWORD;
lpb: DWORD;
end;
TCeValUnion = record
Case Integer OF
0:
(iVal: SHORT);
1:
(uiVal: WORD);
2:
(lVal: LONGINT);
3:
(ulVal: ULONG);
4:
(filetime: TFileTime);
5:
(lpwstr: lpwstr);
6:
(blob: TCeBlob);
7:
(boolVal: BOOL);
8:
(dblVal: double);
end;
TCePROPVAL = record
propid: CePROPID;
wLenData: WORD;
wFlags: WORD;
val: TCeValUnion;
end;
TCeOSVersionInfo = record
wOSVersionInfoSize: DWORD;
dwMajorVersion: DWORD;
dwMinorVersion: DWORD;
dwBuildNumber: DWORD;
dwPlatformId: DWORD;
szCSDVersion: array [0 .. 128 - 1] of WCHAR;
end;
PCeOSVersionInfo = ^TCeOSVersionInfo;
TSystem_Power_Status_Ex = record
ACLineStatus: BYTE;
BatteryFlag: BYTE;
BatteryLifePercent: BYTE;
Reserved1: BYTE;
BatteryLifeTime: DWORD;
BatteryFullLifeTime: DWORD;
Reserved2: BYTE;
BackupBatteryFlag: BYTE;
BackupBatteryLifePercent: BYTE;
Reserved3: BYTE;
BackupBatteryLifeTime: DWORD;
BackupBatteryFullLifeTime: DWORD;
end;
PSystem_Power_Status_Ex = ^TSystem_Power_Status_Ex;
TSystem_Power_Status_ExArray = array [0 .. MaxInt div sizeof
(TSystem_Power_Status_Ex) - 1] of TSystem_Power_Status_Ex;
PSystem_Power_Status_ExArray = ^TSystem_Power_Status_ExArray;
TRapiInit = record
cbSize: DWORD;
heRapiInit: THandle;
hrRapiInit: HResult;
end;
IRAPIStream = record
f1: DWORD;
f2: DWORD;
end;
pIRAPIStream = ^IRAPIStream;
ppIRAPIStream = ^pIRAPIStream;
PBYPTE = ^BYTE;
TCeRapiInit = function: LONGINT stdcall;
TCeRapiUninit = function: LONGINT stdcall;
TCeRapiInitEx = function(var RInit: TRapiInit): LONGINT stdcall;
TCeCreateDatabase = function(lpszName: lpwstr; dwDbaseType: DWORD;
wNumSortOrder: WORD; var rgSortSpecs: TSortOrderSpec): CeOID stdcall;
TCeDeleteDatabase = function(oidDBase: CeOID): BOOL stdcall;
TCeDeleteRecord = function(hDatabase: THandle; oidRecord: CeOID)
: BOOL stdcall;
TCeFindFirstDatabase = function(dwDbaseType: DWORD): THandle stdcall;
TCeFindNextDatabase = function(hEnum: THandle): CeOID stdcall;
TCeOidGetInfo = function(OID: CeOID; var poidInfo: TCeOIdInfo): BOOL stdcall;
TCeEnumDBVolumes = function(var PCEGUID: CEGUID; lpBuf: lpwstr;
dwNumChars: DWORD): BOOL stdcall;
TCeOpenDatabase = function(var poid: CeOID; lpszName: lpwstr;
propid: CePROPID; dwFlags: DWORD; hwndNotify: HWND): THandle stdcall;
TCeReadRecordProps = function(hDbase: THandle; dwFlags: DWORD;
var cPropID: WORD; rgPropID: Pointer; var Buffer: Pointer;
var cbBuffer: DWORD): CeOID stdcall;
TCeSeekDatabase = function(hDatabase: THandle; dwSeekType: DWORD;
dwValue: LONGINT; dwIndex: PDWORD): CeOID stdcall;
TCeSetDatabaseInfo = function(oidDBase: CeOID; var NewInfo: TCeDBaseInfo)
: BOOL stdcall;
TCeWriteRecordProps = function(hDbase: THandle; oidRecord: CeOID;
cPropID: WORD; var PropVal: TCePROPVAL): CeOID stdcall;
TCeFindFirstFile = function(lpFileName: LPCWSTR;
lpFindFileData: PCe_Find_Data): THandle stdcall;
TCeFindNextFile = function(hFindFile: THandle; lpFindFileData: PCe_Find_Data)
: BOOL stdcall;
TCeFindClose = function(hFindFile: THandle): BOOL stdcall;
TCeGetFileAttributes = function(lpFileName: LPCWSTR): DWORD stdcall;
TCeSetFileAttributes = function(FileName: LPCWSTR; dwFileAttributes: DWORD)
: BOOL stdcall;
TCeCreateFile = function(lpFileName: LPCWSTR; dwDesiredAccess: DWORD;
dwShareMode: DWORD; lpSecurityAttributes: PSecurityAttributes;
dwCreationDistribution: DWORD; dwFlagsAndAttributes: DWORD;
hTemplateFile: THandle): THandle stdcall;
TCeReadFile = function(hFile: THandle; lpBuffer: Pointer;
nNumberOfBytesToRead: DWORD; var NumberOfBytesRead: DWORD;
Overlapped: POVERLAPPED): BOOL stdcall;
TCeWriteFile = function(hFile: THandle; Buffer: Pointer;
NumberOfBytesToWrite: DWORD; var NumberOfBytesWritten: DWORD;
Overlapped: POVERLAPPED): BOOL stdcall;
TCeCloseHandle = function(hObject: THandle): BOOL stdcall;
TCeFindAllDatabases = function(dwDbaseType: DWORD; wFlags: WORD;
var cFindData: DWORD; var ppFindData: PCeDB_File_Data_Array): BOOL stdcall;
TCeGetLastError = function: DWORD stdcall;
TGetRapiError = function: LONGINT stdcall;
TCeSetFilePointer = function(hFile: THandle; DistanceToMove: LONGINT;
DistanceToMoveHigh: PULONG; dwMoveMethod: DWORD): DWORD stdcall;
TCeSetEndOfFile = function(hFile: THandle): BOOL stdcall;
TCeCreateDirectory = function(lpPathName: LPCWSTR;
lpSecurityAttributes: PSecurityAttributes): BOOL stdcall;
TCeRemoveDirectory = function(PathName: LPCWSTR): BOOL stdcall;
TCeCreateProcess = function(lpApplicationName: LPCWSTR;
lpCommandLine: LPCWSTR; lpProcessAttributes: PSecurityAttributes;
lpThreadAttributes: PSecurityAttributes; bInheritHandles: BOOL;
dwCreateFlags: DWORD; lpEnvironment: Pointer; lpCurrentDirectory: lpwstr;
lpStartupInfo: PSTARTUPINFO; lpProcessInformation: PProcessInformation)
: BOOL stdcall;
TCeMoveFile = function(lpExistingFileName: LPCWSTR; lpNewFileName: LPCWSTR)
: BOOL stdcall;
TCeCopyFile = function(lpExistingFileName: LPCWSTR; lpNewFileName: LPCWSTR;
bFailIfExists: BOOL): BOOL stdcall;
TCeDeleteFile = function(lpFileName: LPCWSTR): BOOL stdcall;
TCeGetFileSize = function(hFile: THandle; lpFileSizeHigh: PDWORD)
: DWORD stdcall;
TCeRegOpenKeyEx = function(hKey: hKey; SubKey: LPCWSTR; Reserved: DWORD;
samDesired: REGSAM; var Result: HKEY): LONGINT stdcall;
TCeRegEnumKeyEx = function(hKey: hKey; dwIndex: DWORD; KeyName: lpwstr;
chName: PDWORD; Reserved: PDWORD; szClass: lpwstr; cchClass: PDWORD;
ftLastWrite: PFILETIME): LONGINT stdcall;
TCeRegCreateKeyEx = function(hKey: hKey; lpSzSubKey: LPCWSTR;
dwReserved: DWORD; lpszClass: lpwstr; dwOption: DWORD; samDesired: REGSAM;
lpSecurityAttributes: PSecurityAttributes; var phkResult: HKEY;
lpdwDisposition: PDWORD): LONGINT stdcall;
TCeRegCloseKey = function(hKey: hKey): LONGINT stdcall;
TCeRegDeleteKey = function(hKey: hKey; lpSzSubKey: LPCWSTR): LONGINT stdcall;
TCeRegEnumValue = function(hKey: hKey; dwIndex: DWORD; lpszName: lpwstr;
lpcchName: PDWORD; lpReserved: PDWORD; lpszClass: PDWORD;
lpcchClass: PBYTE; lpftLastWrite: PDWORD): LONGINT stdcall;
TCeRegDeleteValue = function(hKey: hKey; lpszValueName: LPCWSTR)
: LONGINT stdcall;
TCeRegQueryInfoKey = function(hKey: hKey; ClassName: lpwstr;
cchClass: PDWORD; Reserved: PDWORD; cSubKeys: PDWORD;
cchMaxSubKeyLen: PDWORD; cchMaxClassLen: PDWORD; cValues: PDWORD;
cchMaxValueNameLen: PDWORD; cbMaxValueData: PDWORD;
cbSecurityDescriptor: PDWORD; LastWriteTime: PFILETIME): LONGINT stdcall;
TCeRegQueryValueEx = function(hKey: hKey; ValueName: LPCWSTR;
Reserved: PDWORD; pType: PDWORD; pData: PBYTE; cbData: PDWORD)
: LONGINT stdcall;
TCeRegSetValueEx = function(hKey: hKey; ValueName: LPCWSTR; Reserved: DWORD;
dwType: DWORD; pData: PBYTE; cbData: DWORD): LONGINT stdcall;
TCeGetStoreInformation = function(lpsi: PStore_Information): BOOL stdcall;
TCeGetSystemMetrics = function(nIndex: Integer): Integer stdcall;
TCeGetDesktopDeviceCaps = function(nIndedx: Integer): LONGINT stdcall;
TCeGetSystemInfo = procedure(lpSystemInfo: PSystemInfo)stdcall;
TCeSHCreateShortcut = function(ShortCut: lpwstr; Target: lpwstr)
: DWORD stdcall;
TCeSHGetShortcutTarget = function(ShortCut: lpwstr; Target: lpwstr;
cbMax: Integer): BOOL stdcall;
TCeCheckPassword = function(lpszPassword: lpwstr): BOOL stdcall;
TCeGetFileTime = function(hFile: THandle; lpCreationTime: PFILETIME;
lpLastAccessTime: PFILETIME; lpLastWriteTime: PFILETIME): BOOL stdcall;
TCeSetFileTime = function(hFile: THandle; CreationTime: PFILETIME;
LastAccessTime: PFILETIME; LastWriteTime: PFILETIME): BOOL stdcall;
TCeGetVersionEx = function(lpVersionInfo: PCeOSVersionInfo): BOOL stdcall;
TCeGetWindow = function(HWND: HWND; uCmd: UINT): HWND stdcall;
TCeGetWindowLong = function(HWND: HWND; nIndex: Integer): LONGINT stdcall;
TCeGetWindowText = function(HWND: HWND; lpString: lpwstr; nMaxCount: Integer)
: Integer stdcall;
TCeGetClassName = function(HWND: HWND; lpClassName: lpwstr;
nMaxCount: Integer): Integer stdcall;
TCeGlobalMemoryStatus = procedure(lpmst: PMemoryStatus)stdcall;
TCeGetSystemPowerStatusEx = function(pStatus: PSystem_Power_Status_Ex;
fUpdate: BOOL): BOOL stdcall;
TDesktopToDevice = function(DesktopLocation, TableList: String; Sync: BOOL;
Overwrite: Integer; DeviceLocation: String): LONGINT stdcall;
TCeRapiInvoke = function(pDllPath: LPCWSTR; pFunctionName: lpwstr;
cbInput: DWORD; pInput: Pointer; var pcbOutput: DWORD; var ppOutput: PBYTE;
mppIRAPIStream: ppIRAPIStream; dwReserved: DWORD): LONGINT stdcall;
TCeFindAllFiles = function(Path: PWideChar; Attr: DWORD; var Count: DWORD;
var FindData: PCe_Find_Data_array): BOOL stdcall;
TRapiFreeBuffer = procedure(p: Pointer)stdcall;
function CeRapiInit: LONGINT;
function CeRapiUninit: LONGINT;
function CeFindAllFiles(Path: PWideChar; Attr: DWORD; var Count: DWORD;
var FindData: PCe_Find_Data_array): BOOL;
procedure RapiFreeBuffer(p: Pointer);
function CeRapiInitEx(var RInit: TRapiInit): LONGINT;
function CeCreateDatabase(lpszName: lpwstr; dwDbaseType: DWORD;
wNumSortOrder: WORD; var rgSortSpecs: TSortOrderSpec): CeOID;
function CeDeleteDatabase(oidDBase: CeOID): BOOL;
function CeDeleteRecord(hDatabase: THandle; oidRecord: CeOID): BOOL;
function CeFindFirstDatabase(dwDbaseType: DWORD): THandle;
function CeFindNextDatabase(hEnum: THandle): CeOID;
function CeOidGetInfo(OID: CeOID; var poidInfo: TCeOIdInfo): BOOL;
function CeEnumDBVolumes(var PCEGUID: CEGUID; lpBuf: lpwstr; dwNumChars: DWORD)
: BOOL;
function CeOpenDatabase(var poid: CeOID; lpszName: lpwstr; propid: CePROPID;
dwFlags: DWORD; hwndNotify: HWND): THandle;
function CeReadRecordProps(hDbase: THandle; dwFlags: DWORD; var cPropID: WORD;
rgPropID: Pointer; var Buffer: Pointer; var cbBuffer: DWORD): CeOID;
function CeSeekDatabase(hDatabase: THandle; dwSeekType: DWORD;
dwValue: LONGINT; dwIndex: PDWORD): CeOID;
function CeSetDatabaseInfo(oidDBase: CeOID; var NewInfo: TCeDBaseInfo): BOOL;
function CeWriteRecordProps(hDbase: THandle; oidRecord: CeOID; cPropID: WORD;
var PropVal: TCePROPVAL): CeOID;
function CeFindFirstFile(lpFileName: LPCWSTR; lpFindFileData: PCe_Find_Data)
: THandle;
function CeFindNextFile(hFindFile: THandle; lpFindFileData: PCe_Find_Data)
: BOOL;
function CeFindClose(hFindFile: THandle): BOOL;
function CeGetFileAttributes(lpFileName: LPCWSTR): DWORD;
function CeSetFileAttributes(FileName: LPCWSTR; dwFileAttributes: DWORD): BOOL;
function CeCreateFile(lpFileName: LPCWSTR; dwDesiredAccess: DWORD;
dwShareMode: DWORD; lpSecurityAttributes: PSecurityAttributes;
dwCreationDistribution: DWORD; dwFlagsAndAttributes: DWORD;
hTemplateFile: THandle): THandle;
function CeReadFile(hFile: THandle; lpBuffer: Pointer;
nNumberOfBytesToRead: DWORD; var NumberOfBytesRead: DWORD;
Overlapped: POVERLAPPED): BOOL;
function CeWriteFile(hFile: THandle; Buffer: Pointer;
NumberOfBytesToWrite: DWORD; var NumberOfBytesWritten: DWORD;
Overlapped: POVERLAPPED): BOOL;
function CeCloseHandle(hObject: THandle): BOOL;
function CeFindAllDatabases(dwDbaseType: DWORD; wFlags: WORD;
var cFindData: DWORD; var ppFindData: PCeDB_File_Data_Array): BOOL;
function CeGetLastError: DWORD;
function GetRapiError: LONGINT;
function CeSetFilePointer(hFile: THandle; DistanceToMove: LONGINT;
DistanceToMoveHigh: PULONG; dwMoveMethod: DWORD): DWORD;
function CeSetEndOfFile(hFile: THandle): BOOL;
function CeCreateDirectory(lpPathName: LPCWSTR;
lpSecurityAttributes: PSecurityAttributes): BOOL;
function CeRemoveDirectory(PathName: LPCWSTR): BOOL;
function CeCreateProcess(lpApplicationName: LPCWSTR; lpCommandLine: LPCWSTR;
lpProcessAttributes: PSecurityAttributes;
lpThreadAttributes: PSecurityAttributes; bInheritHandles: BOOL;
dwCreateFlags: DWORD; lpEnvironment: Pointer; lpCurrentDirectory: lpwstr;
lpStartupInfo: PSTARTUPINFO; lpProcessInformation: PProcessInformation): BOOL;
function CeMoveFile(lpExistingFileName: LPCWSTR; lpNewFileName: LPCWSTR): BOOL;
function CeCopyFile(lpExistingFileName: LPCWSTR; lpNewFileName: LPCWSTR;
bFailIfExists: BOOL): BOOL;
function CeDeleteFile(lpFileName: LPCWSTR): BOOL;
function CeGetFileSize(hFile: THandle; lpFileSizeHigh: PDWORD): DWORD;
function CeRegOpenKeyEx(hKey: hKey; SubKey: LPCWSTR; Reserved: DWORD;
samDesired: REGSAM; var pResult: HKEY): LONGINT;
function CeRegEnumKeyEx(hKey: hKey; dwIndex: DWORD; KeyName: lpwstr;
chName: PDWORD; Reserved: PDWORD; szClass: lpwstr; cchClass: PDWORD;
ftLastWrite: PFILETIME): LONGINT;
function CeRegCreateKeyEx(hKey: hKey; lpSzSubKey: LPCWSTR; dwReserved: DWORD;
lpszClass: lpwstr; dwOption: DWORD; samDesired: REGSAM;
lpSecurityAttributes: PSecurityAttributes; var phkResult: HKEY;
lpdwDisposition: PDWORD): LONGINT;
function CeRegCloseKey(hKey: hKey): LONGINT;
function CeRegDeleteKey(hKey: hKey; lpSzSubKey: LPCWSTR): LONGINT;
function CeRegEnumValue(hKey: hKey; dwIndex: DWORD; lpszName: lpwstr;
lpcchName: PDWORD; lpReserved: PDWORD; lpszClass: PDWORD; lpcchClass: PBYTE;
lpftLastWrite: PDWORD): LONGINT;
function CeRegDeleteValue(hKey: hKey; lpszValueName: LPCWSTR): LONGINT;
function CeRegQueryInfoKey(hKey: hKey; ClassName: lpwstr; cchClass: PDWORD;
Reserved: PDWORD; cSubKeys: PDWORD; cchMaxSubKeyLen: PDWORD;
cchMaxClassLen: PDWORD; cValues: PDWORD; cchMaxValueNameLen: PDWORD;
cbMaxValueData: PDWORD; cbSecurityDescriptor: PDWORD;
LastWriteTime: PFILETIME): LONGINT;
function CeRegQueryValueEx(hKey: hKey; ValueName: LPCWSTR; Reserved: PDWORD;
pType: PDWORD; pData: PBYTE; cbData: PDWORD): LONGINT;
function CeRegSetValueEx(hKey: hKey; ValueName: LPCWSTR; Reserved: DWORD;
dwType: DWORD; pData: PBYTE; cbData: DWORD): LONGINT;
function CeGetStoreInformation(lpsi: PStore_Information): BOOL;
function CeGetSystemMetrics(nIndex: Integer): Integer;
function CeGetDesktopDeviceCaps(nIndedx: Integer): LONGINT;
procedure CeGetSystemInfo(lpSystemInfo: PSystemInfo);
function CeSHCreateShortcut(ShortCut: lpwstr; Target: lpwstr): DWORD;
function CeSHGetShortcutTarget(ShortCut: lpwstr; Target: lpwstr; cbMax: Integer)
: BOOL;
function CeCheckPassword(lpszPassword: lpwstr): BOOL;
function CeGetFileTime(hFile: THandle; lpCreationTime: PFILETIME;
lpLastAccessTime: PFILETIME; lpLastWriteTime: PFILETIME): BOOL;
function CeSetFileTime(hFile: THandle; CreationTime: PFILETIME;
LastAccessTime: PFILETIME; LastWriteTime: PFILETIME): BOOL;
function CeGetVersionEx(lpVersionInfo: PCeOSVersionInfo): BOOL;
function CeGetWindow(HWND: HWND; uCmd: UINT): HWND;
function CeGetWindowLong(HWND: HWND; nIndex: Integer): LONGINT;
function CeGetWindowText(HWND: HWND; lpString: lpwstr; nMaxCount: Integer)
: Integer;
function CeGetClassName(HWND: HWND; lpClassName: lpwstr; nMaxCount: Integer)
: Integer;
procedure CeGlobalMemoryStatus(lpmst: PMemoryStatus);
function CeGetSystemPowerStatusEx(pStatus: PSystem_Power_Status_Ex;
fUpdate: BOOL): BOOL;
function DesktopToDevice(DesktopLocation, TableList: String; Sync: BOOL;
Overwrite: Integer; DeviceLocation: String): LONGINT;
function CeRapiInvoke(pDllPath: LPCWSTR; pFunctionName: lpwstr; cbInput: DWORD;
pInput: Pointer; var pcbOutput: DWORD; var ppOutput: PBYTE;
mppIRAPIStream: ppIRAPIStream; dwReserved: DWORD): LONGINT;
//处理器类型的名称
function ProcessorArchitectureName(p: WORD): string;
procedure CREATE_INVALIDGUID(var pguid: CEGUID);
procedure CREATE_SYSTEMGUID(var pguid: CEGUID);
//判断RAPI是否加载成功,如果没被加载会尝试加载一下
function RapiLoaded: BOOL;
//尝试连接嵌入式设备,如果成功以后关闭的时候要调用CeRapiUninit();
function TryRapiConnect(dwTimeOut: DWORD): HRESULT;
implementation
function __HRESULT_FROM_WIN32(x: DWORD): HRESULT;
begin
if HRESULT(x) <= 0 then
Result := HRESULT(x)
else
Result := HRESULT((x and $0000FFFF) or (FACILITY_WIN32 shl 16) or $80000000);
end;
function HRESULT_FROM_WIN32(x: DWORD): HRESULT;
begin
Result := __HRESULT_FROM_WIN32(x);
end;
function TryRapiConnect(dwTimeOut: DWORD): HRESULT;
var
hr: HRESULT;
riCopy: TRAPIINIT;
fInitialized: Boolean;
dwRapiInit: DWORD;
begin
//hr := E_FAIL;
ZeroMemory(@riCopy, SizeOf(TRAPIINIT));
fInitialized := False;
riCopy.cbSize := SizeOf(riCopy);
hr := CeRapiInitEx(&riCopy);
if (SUCCEEDED(hr)) then
begin
fInitialized := true;
dwRapiInit := WaitForSingleObject(riCopy.heRapiInit, dwTimeOut);
if (WAIT_OBJECT_0 = dwRapiInit) then
begin
hr := riCopy.hrRapiInit;
end
else if (WAIT_TIMEOUT = dwRapiInit) then
begin
hr := HRESULT_FROM_WIN32(ERROR_TIMEOUT);
end
else
begin
hr := HRESULT_FROM_WIN32(GetLastError());
end
end;
if (fInitialized and FAILED(hr)) then
begin
CeRapiUninit();
end;
Result := hr;
end;
var
FCeRapiInit: TCeRapiInit;
FCeRapiUninit: TCeRapiUninit;
FCeFindAllFiles: TCeFindAllFiles;
FRapiFreeBuffer: TRapiFreeBuffer;
FCeRapiInitEx: TCeRapiInitEx;
FCeCreateDatabase: TCeCreateDatabase;
FCeDeleteDatabase: TCeDeleteDatabase;
FCeDeleteRecord: TCeDeleteRecord;
FCeFindFirstDatabase: TCeFindFirstDatabase;
FCeFindNextDatabase: TCeFindNextDatabase;
FCeOidGetInfo: TCeOidGetInfo;
FCeEnumDBVolumes: TCeEnumDBVolumes;
FCeOpenDatabase: TCeOpenDatabase;
FCeReadRecordProps: TCeReadRecordProps;
FCeSeekDatabase: TCeSeekDatabase;
FCeSetDatabaseInfo: TCeSetDatabaseInfo;
FCeWriteRecordProps: TCeWriteRecordProps;
FCeFindFirstFile: TCeFindFirstFile;
FCeFindNextFile: TCeFindNextFile;
FCeFindClose: TCeFindClose;
FCeGetFileAttributes: TCeGetFileAttributes;
FCeSetFileAttributes: TCeSetFileAttributes;
FCeCreateFile: TCeCreateFile;
FCeReadFile: TCeReadFile;
FCeWriteFile: TCeWriteFile;
FCeCloseHandle: TCeCloseHandle;
FCeFindAllDatabases: TCeFindAllDatabases;
FCeGetLastError: TCeGetLastError;
FGetRapiError: TGetRapiError;
FCeSetFilePointer: TCeSetFilePointer;
FCeSetEndOfFile: TCeSetEndOfFile;
FCeCreateDirectory: TCeCreateDirectory;
FCeRemoveDirectory: TCeRemoveDirectory;
FCeCreateProcess: TCeCreateProcess;
FCeMoveFile: TCeMoveFile;
FCeCopyFile: TCeCopyFile;
FCeDeleteFile: TCeDeleteFile;
FCeGetFileSize: TCeGetFileSize;
FCeRegOpenKeyEx: TCeRegOpenKeyEx;
FCeRegEnumKeyEx: TCeRegEnumKeyEx;
FCeRegCreateKeyEx: TCeRegCreateKeyEx;
FCeRegCloseKey: TCeRegCloseKey;
FCeRegDeleteKey: TCeRegDeleteKey;
FCeRegEnumValue: TCeRegEnumValue;
FCeRegDeleteValue: TCeRegDeleteValue;
FCeRegQueryInfoKey: TCeRegQueryInfoKey;
FCeRegQueryValueEx: TCeRegQueryValueEx;
FCeRegSetValueEx: TCeRegSetValueEx;
FCeGetStoreInformation: TCeGetStoreInformation;
FCeGetSystemMetrics: TCeGetSystemMetrics;
FCeGetDesktopDeviceCaps: TCeGetDesktopDeviceCaps;
FCeGetSystemInfo: TCeGetSystemInfo;
FCeSHCreateShortcut: TCeSHCreateShortcut;
FCeSHGetShortcutTarget: TCeSHGetShortcutTarget;
FCeCheckPassword: TCeCheckPassword;
FCeGetFileTime: TCeGetFileTime;
FCeSetFileTime: TCeSetFileTime;
FCeGetVersionEx: TCeGetVersionEx;
FCeGetWindow: TCeGetWindow;
FCeGetWindowLong: TCeGetWindowLong;
FCeGetWindowText: TCeGetWindowText;
FCeGetClassName: TCeGetClassName;
FCeGlobalMemoryStatus: TCeGlobalMemoryStatus;
FCeGetSystemPowerStatusEx: TCeGetSystemPowerStatusEx;
FDesktopToDevice: TDesktopToDevice;
FCeRapiInvoke: TCeRapiInvoke;
RapiModule, AdoCEModule: HMODULE;
function RapiLoaded: BOOL;
begin
if RapiModule <> 0 then
begin
Result := True;
Exit;
end;
{ Load RAPI }
RapiModule := LoadLibrary('RAPI.DLL');
if RapiModule <> 0 then
begin
Result := True;
@FCeRapiInit := GetProcAddress(RapiModule, 'CeRapiInit');
@FCeRapiInitEx := GetProcAddress(RapiModule, 'CeRapiInitEx');
@FCeRapiUninit := GetProcAddress(RapiModule, 'CeRapiUninit');
@FCeFindAllFiles := GetProcAddress(RapiModule, 'CeFindAllFiles');
@FRapiFreeBuffer := GetProcAddress(RapiModule, 'RapiFreeBuffer');
@FCeCreateDatabase := GetProcAddress(RapiModule, 'CeCreateDatabase');
@FCeDeleteDatabase := GetProcAddress(RapiModule, 'CeDeleteDatabase');
@FCeDeleteRecord := GetProcAddress(RapiModule, 'CeDeleteRecord');
@FCeFindFirstDatabase := GetProcAddress(RapiModule, 'CeFindFirstDatabase');
@FCeFindNextDatabase := GetProcAddress(RapiModule, 'CeFindNextDatabase');
@FCeOidGetInfo := GetProcAddress(RapiModule, 'CeOidGetInfo');
@FCeEnumDBVolumes := GetProcAddress(RapiModule, 'CeEnumDBVolumes');
@FCeOpenDatabase := GetProcAddress(RapiModule, 'CeOpenDatabase');
@FCeReadRecordProps := GetProcAddress(RapiModule, 'CeReadRecordProps');
@FCeSeekDatabase := GetProcAddress(RapiModule, 'CeSeekDatabase');
@FCeSetDatabaseInfo := GetProcAddress(RapiModule, 'CeSetDatabaseInfo');
@FCeWriteRecordProps := GetProcAddress(RapiModule, 'CeWriteRecordProps');
@FCeFindFirstFile := GetProcAddress(RapiModule, 'CeFindFirstFile');
@FCeFindNextFile := GetProcAddress(RapiModule, 'CeFindNextFile');
@FCeFindClose := GetProcAddress(RapiModule, 'CeFindClose');
@FCeGetFileAttributes := GetProcAddress(RapiModule, 'CeGetFileAttributes');
@FCeSetFileAttributes := GetProcAddress(RapiModule, 'CeSetFileAttributes');
@FCeCreateFile := GetProcAddress(RapiModule, 'CeCreateFile');
@FCeReadFile := GetProcAddress(RapiModule, 'CeReadFile');
@FCeWriteFile := GetProcAddress(RapiModule, 'CeWriteFile');
@FCeCloseHandle := GetProcAddress(RapiModule, 'CeCloseHandle');
@FCeFindAllDatabases := GetProcAddress(RapiModule, 'CeFindAllDatabases');
@FCeGetLastError := GetProcAddress(RapiModule, 'CeGetLastError');
@FGetRapiError := GetProcAddress(RapiModule, 'GetRapiError');
@FCeSetFilePointer := GetProcAddress(RapiModule, 'CeSetFilePointer');
@FCeSetEndOfFile := GetProcAddress(RapiModule, 'CeSetEndOfFile');
@FCeCreateDirectory := GetProcAddress(RapiModule, 'CeCreateDirectory');
@FCeRemoveDirectory := GetProcAddress(RapiModule, 'CeRemoveDirectory');
@FCeCreateProcess := GetProcAddress(RapiModule, 'CeCreateProcess');
@FCeMoveFile := GetProcAddress(RapiModule, 'CeMoveFile');
@FCeCopyFile := GetProcAddress(RapiModule, 'CeCopyFile');
@FCeDeleteFile := GetProcAddress(RapiModule, 'CeDeleteFile');
@FCeGetFileSize := GetProcAddress(RapiModule, 'CeGetFileSize');
@FCeRegOpenKeyEx := GetProcAddress(RapiModule, 'CeRegOpenKeyEx');
@FCeRegEnumKeyEx := GetProcAddress(RapiModule, 'CeRegEnumKeyEx');
@FCeRegCreateKeyEx := GetProcAddress(RapiModule, 'CeRegCreateKeyEx');
@FCeRegCloseKey := GetProcAddress(RapiModule, 'CeRegCloseKey');
@FCeRegDeleteKey := GetProcAddress(RapiModule, 'CeRegDeleteKey');
@FCeRegEnumValue := GetProcAddress(RapiModule, 'CeRegEnumValue');
@FCeRegDeleteValue := GetProcAddress(RapiModule, 'CeRegDeleteValue');
@FCeRegQueryInfoKey := GetProcAddress(RapiModule, 'CeRegQueryInfoKey');
@FCeRegQueryValueEx := GetProcAddress(RapiModule, 'CeRegQueryValueEx');
@FCeRegSetValueEx := GetProcAddress(RapiModule, 'CeRegSetValueEx');
@FCeGetStoreInformation := GetProcAddress(RapiModule,
'CeGetStoreInformation');
@FCeGetSystemMetrics := GetProcAddress(RapiModule, 'CeGetSystemMetrics');
@FCeGetDesktopDeviceCaps := GetProcAddress(RapiModule,
'CeGetDesktopDeviceCaps');
@FCeGetSystemInfo := GetProcAddress(RapiModule, 'CeGetSystemInfo');
@FCeSHCreateShortcut := GetProcAddress(RapiModule, 'CeSHCreateShortcut');
@FCeSHGetShortcutTarget := GetProcAddress(RapiModule,
'CeSHGetShortcutTarget');
@FCeCheckPassword := GetProcAddress(RapiModule, 'CeCheckPassword');
@FCeGetFileTime := GetProcAddress(RapiModule, 'CeGetFileTime');
@FCeSetFileTime := GetProcAddress(RapiModule, 'CeSetFileTime');
@FCeGetVersionEx := GetProcAddress(RapiModule, 'CeGetVersionEx');
@FCeGetWindow := GetProcAddress(RapiModule, 'CeGetWindow');
@FCeGetWindowLong := GetProcAddress(RapiModule, 'CeGetWindowLong');
@FCeGetWindowText := GetProcAddress(RapiModule, 'CeGetWindowText');
@FCeGetClassName := GetProcAddress(RapiModule, 'CeGetClassName');
@FCeGlobalMemoryStatus := GetProcAddress
(RapiModule, 'CeGlobalMemoryStatus');
@FCeGetSystemPowerStatusEx := GetProcAddress(RapiModule,
'CeGetSystemPowerStatusEx');
@FCeRapiInvoke := GetProcAddress(RapiModule, 'CeRapiInvoke');
end
else
Result := False;
end;
function AdoCELoaded: BOOL;
function GetProgramFilesDir():string;
begin
SetLength(Result, MAX_PATH);
SHGetSpecialFolderPath(0, PWideChar(Result), CSIDL_PROGRAM_FILES, False);
result:=strpas(PWideChar(Result));
end;
var
DLLName : string;
begin
if AdoCEModule <> 0 then
begin
Result := True;
Exit;
end;
//adofiltr.dll是在ActiveSync中支持的.Vista和WIN7只支持媒体中心.可能要从别处单独考这个DLL才行
DLLName := 'adofiltr.dll';
AdoCEModule := LoadLibrary(PWideChar(DLLName));
if AdoCEModule <= HINSTANCE_ERROR then
begin //再试一下
DLLName := GetProgramFilesDir() + '/Microsoft ActiveSync/adofiltr.dll';
AdoCEModule := LoadLibrary(PWideChar(DLLName));
end;
if AdoCEModule > HINSTANCE_ERROR then
begin
Result := True;
@FDesktopToDevice := GetProcAddress(AdoCEModule, 'DESKTOPTODEVICE');
end
else
Result := False;
end;
function CeFindAllFiles(Path: PWideChar; Attr: DWORD; var Count: DWORD;
var FindData: PCe_Find_Data_array): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeFindAllFiles <> nil then
Result := FCeFindAllFiles(Path, Attr, Count, FindData)
else
Result := False;
end;
procedure RapiFreeBuffer(p: Pointer);
begin
if not RapiLoaded then
begin
Exit;
end;
if @FRapiFreeBuffer <> nil then
FRapiFreeBuffer(p);
end;
function CeRapiInit: LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRapiInit <> nil then
Result := FCeRapiInit
else
Result := $FFFF;
end;
function CeRapiUninit: LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRapiUninit <> nil then
Result := FCeRapiUninit
else
Result := $FFFF;
end;
function CeRapiInitEx(var RInit: TRapiInit): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRapiInitEx <> nil then
Result := FCeRapiInitEx(RInit)
else
Result := $FFFF;
end;
function CeCreateDatabase(lpszName: lpwstr; dwDbaseType: DWORD;
wNumSortOrder: WORD; var rgSortSpecs: TSortOrderSpec): CeOID;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeCreateDatabase <> nil then
Result := FCeCreateDatabase(lpszName, dwDbaseType, wNumSortOrder,
rgSortSpecs)
else
Result := $FFFF;
end;
function CeDeleteDatabase(oidDBase: CeOID): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeDeleteDatabase <> nil then
Result := FCeDeleteDatabase(oidDBase)
else
Result := False;
end;
function CeDeleteRecord(hDatabase: THandle; oidRecord: CeOID): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeDeleteRecord <> nil then
Result := FCeDeleteRecord(hDatabase, oidRecord)
else
Result := False;
end;
function CeFindFirstDatabase(dwDbaseType: DWORD): THandle;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeFindFirstDatabase <> nil then
Result := FCeFindFirstDatabase(dwDbaseType)
else
Result := $FFFF;
end;
function CeFindNextDatabase(hEnum: THandle): CeOID;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeFindNextDatabase <> nil then
Result := FCeFindNextDatabase(hEnum)
else
Result := $FFFF;
end;
function CeOidGetInfo(OID: CeOID; var poidInfo: TCeOIdInfo): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeOidGetInfo <> nil then
Result := FCeOidGetInfo(OID, poidInfo)
else
Result := False;
end;
function CeEnumDBVolumes(var PCEGUID: CEGUID; lpBuf: lpwstr; dwNumChars: DWORD)
: BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeEnumDBVolumes <> nil then
Result := FCeEnumDBVolumes(PCEGUID, lpBuf, dwNumChars)
else
Result := False;
end;
function CeOpenDatabase(var poid: CeOID; lpszName: lpwstr; propid: CePROPID;
dwFlags: DWORD; hwndNotify: HWND): THandle;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeOpenDatabase <> nil then
Result := FCeOpenDatabase(poid, lpszName, propid, dwFlags, hwndNotify)
else
Result := $FFFF;
end;
function CeReadRecordProps(hDbase: THandle; dwFlags: DWORD; var cPropID: WORD;
rgPropID: Pointer; var Buffer: Pointer; var cbBuffer: DWORD): CeOID;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeReadRecordProps <> nil then
Result := FCeReadRecordProps(hDbase, dwFlags, cPropID, rgPropID, Buffer,
cbBuffer)
else
Result := $FFFF;
end;
function CeSeekDatabase(hDatabase: THandle; dwSeekType: DWORD;
dwValue: LONGINT; dwIndex: PDWORD): CeOID;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeSeekDatabase <> nil then
Result := FCeSeekDatabase(hDatabase, dwSeekType, dwValue, dwIndex)
else
Result := $FFFF;
end;
function CeSetDatabaseInfo(oidDBase: CeOID; var NewInfo: TCeDBaseInfo): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeSetDatabaseInfo <> nil then
Result := FCeSetDatabaseInfo(oidDBase, NewInfo)
else
Result := False;
end;
function CeWriteRecordProps(hDbase: THandle; oidRecord: CeOID; cPropID: WORD;
var PropVal: TCePROPVAL): CeOID;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeWriteRecordProps <> nil then
Result := FCeWriteRecordProps(hDbase, oidRecord, cPropID, PropVal)
else
Result := $FFFF;
end;
function CeFindFirstFile(lpFileName: LPCWSTR; lpFindFileData: PCe_Find_Data)
: THandle;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeFindFirstFile <> nil then
Result := FCeFindFirstFile(lpFileName, lpFindFileData)
else
Result := $FFFF;
end;
function CeFindNextFile(hFindFile: THandle; lpFindFileData: PCe_Find_Data)
: BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeFindNextFile <> nil then
Result := FCeFindNextFile(hFindFile, lpFindFileData)
else
Result := False;
end;
function CeFindClose(hFindFile: THandle): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeFindClose <> nil then
Result := FCeFindClose(hFindFile)
else
Result := False;
end;
function CeGetFileAttributes(lpFileName: LPCWSTR): DWORD;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeGetFileAttributes <> nil then
Result := FCeGetFileAttributes(lpFileName)
else
Result := $FFFF;
end;
function CeSetFileAttributes(FileName: LPCWSTR; dwFileAttributes: DWORD): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeSetFileAttributes <> nil then
Result := FCeSetFileAttributes(FileName, dwFileAttributes)
else
Result := False;
end;
function CeCreateFile(lpFileName: LPCWSTR; dwDesiredAccess: DWORD;
dwShareMode: DWORD; lpSecurityAttributes: PSecurityAttributes;
dwCreationDistribution: DWORD; dwFlagsAndAttributes: DWORD;
hTemplateFile: THandle): THandle;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeCreateFile <> nil then
Result := FCeCreateFile(lpFileName, dwDesiredAccess, dwShareMode,
lpSecurityAttributes, dwCreationDistribution, dwFlagsAndAttributes,
hTemplateFile)
else
Result := $FFFF;
end;
function CeReadFile(hFile: THandle; lpBuffer: Pointer;
nNumberOfBytesToRead: DWORD; var NumberOfBytesRead: DWORD;
Overlapped: POVERLAPPED): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeReadFile <> nil then
Result := FCeReadFile(hFile, lpBuffer, nNumberOfBytesToRead,
NumberOfBytesRead, Overlapped)
else
Result := False;
end;
function CeWriteFile(hFile: THandle; Buffer: Pointer;
NumberOfBytesToWrite: DWORD; var NumberOfBytesWritten: DWORD;
Overlapped: POVERLAPPED): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeWriteFile <> nil then
Result := FCeWriteFile(hFile, Buffer, NumberOfBytesToWrite,
NumberOfBytesWritten, Overlapped)
else
Result := False;
end;
function CeCloseHandle(hObject: THandle): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeCloseHandle <> nil then
Result := FCeCloseHandle(hObject)
else
Result := False;
end;
function CeFindAllDatabases(dwDbaseType: DWORD; wFlags: WORD;
var cFindData: DWORD; var ppFindData: PCeDB_File_Data_Array): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeFindAllDatabases <> nil then
Result := FCeFindAllDatabases(dwDbaseType, wFlags, cFindData, ppFindData)
else
Result := False;
end;
function CeGetLastError: DWORD;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeGetLastError <> nil then
Result := FCeGetLastError
else
Result := $FFFF;
end;
function GetRapiError: LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FGetRapiError <> nil then
Result := FGetRapiError
else
Result := $FFFF;
end;
function CeSetFilePointer(hFile: THandle; DistanceToMove: LONGINT;
DistanceToMoveHigh: PULONG; dwMoveMethod: DWORD): DWORD;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeSetFilePointer <> nil then
Result := FCeSetFilePointer(hFile, DistanceToMove, DistanceToMoveHigh,
dwMoveMethod)
else
Result := $FFFF;
end;
function CeSetEndOfFile(hFile: THandle): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeSetEndOfFile <> nil then
Result := FCeSetEndOfFile(hFile)
else
Result := False;
end;
function CeCreateDirectory(lpPathName: LPCWSTR;
lpSecurityAttributes: PSecurityAttributes): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeCreateDirectory <> nil then
Result := FCeCreateDirectory(lpPathName, lpSecurityAttributes)
else
Result := False;
end;
function CeRemoveDirectory(PathName: LPCWSTR): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeRemoveDirectory <> nil then
Result := FCeRemoveDirectory(PathName)
else
Result := False;
end;
function CeCreateProcess(lpApplicationName: LPCWSTR; lpCommandLine: LPCWSTR;
lpProcessAttributes: PSecurityAttributes;
lpThreadAttributes: PSecurityAttributes; bInheritHandles: BOOL;
dwCreateFlags: DWORD; lpEnvironment: Pointer; lpCurrentDirectory: lpwstr;
lpStartupInfo: PSTARTUPINFO; lpProcessInformation: PProcessInformation): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeCreateProcess <> nil then
Result := FCeCreateProcess(lpApplicationName, lpCommandLine,
lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreateFlags,
lpEnvironment, lpCurrentDirectory, lpStartupInfo, lpProcessInformation)
else
Result := False;
end;
function CeMoveFile(lpExistingFileName: LPCWSTR; lpNewFileName: LPCWSTR): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeMoveFile <> nil then
Result := FCeMoveFile(lpExistingFileName, lpNewFileName)
else
Result := False;
end;
function CeCopyFile(lpExistingFileName: LPCWSTR; lpNewFileName: LPCWSTR;
bFailIfExists: BOOL): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeCopyFile <> nil then
Result := FCeCopyFile(lpExistingFileName, lpNewFileName, bFailIfExists)
else
Result := False;
end;
function CeDeleteFile(lpFileName: LPCWSTR): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeDeleteFile <> nil then
Result := FCeDeleteFile(lpFileName)
else
Result := False;
end;
function CeGetFileSize(hFile: THandle; lpFileSizeHigh: PDWORD): DWORD;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeGetFileSize <> nil then
Result := FCeGetFileSize(hFile, lpFileSizeHigh)
else
Result := $FFFF;
end;
function CeRegOpenKeyEx(hKey: hKey; SubKey: LPCWSTR; Reserved: DWORD;
samDesired: REGSAM; var pResult: HKEY): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRegOpenKeyEx <> nil then
Result := FCeRegOpenKeyEx(hKey, SubKey, Reserved, samDesired, pResult)
else
Result := $FFFF;
end;
function CeRegEnumKeyEx(hKey: hKey; dwIndex: DWORD; KeyName: lpwstr;
chName: PDWORD; Reserved: PDWORD; szClass: lpwstr; cchClass: PDWORD;
ftLastWrite: PFILETIME): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRegEnumKeyEx <> nil then
Result := FCeRegEnumKeyEx(hKey, dwIndex, KeyName, chName, Reserved,
szClass, cchClass, ftLastWrite)
else
Result := $FFFF;
end;
function CeRegCreateKeyEx(hKey: hKey; lpSzSubKey: LPCWSTR; dwReserved: DWORD;
lpszClass: lpwstr; dwOption: DWORD; samDesired: REGSAM;
lpSecurityAttributes: PSecurityAttributes; var phkResult: HKEY;
lpdwDisposition: PDWORD): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRegCreateKeyEx <> nil then
Result := FCeRegCreateKeyEx(hKey, lpSzSubKey, dwReserved, lpszClass,
dwOption, samDesired, lpSecurityAttributes, phkResult, lpdwDisposition)
else
Result := $FFFF;
end;
function CeRegCloseKey(hKey: hKey): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRegCloseKey <> nil then
Result := FCeRegCloseKey(hKey)
else
Result := $FFFF;
end;
function CeRegDeleteKey(hKey: hKey; lpSzSubKey: LPCWSTR): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRegDeleteKey <> nil then
Result := FCeRegDeleteKey(hKey, lpSzSubKey)
else
Result := $FFFF;
end;
function CeRegEnumValue(hKey: hKey; dwIndex: DWORD; lpszName: lpwstr;
lpcchName: PDWORD; lpReserved: PDWORD; lpszClass: PDWORD; lpcchClass: PBYTE;
lpftLastWrite: PDWORD): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRegEnumValue <> nil then
Result := FCeRegEnumValue(hKey, dwIndex, lpszName, lpcchName, lpReserved,
lpszClass, lpcchClass, lpftLastWrite)
else
Result := $FFFF;
end;
function CeRegDeleteValue(hKey: hKey; lpszValueName: LPCWSTR): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRegDeleteValue <> nil then
Result := FCeRegDeleteValue(hKey, lpszValueName)
else
Result := $FFFF;
end;
function CeRegQueryInfoKey(hKey: hKey; ClassName: lpwstr; cchClass: PDWORD;
Reserved: PDWORD; cSubKeys: PDWORD; cchMaxSubKeyLen: PDWORD;
cchMaxClassLen: PDWORD; cValues: PDWORD; cchMaxValueNameLen: PDWORD;
cbMaxValueData: PDWORD; cbSecurityDescriptor: PDWORD;
LastWriteTime: PFILETIME): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRegQueryInfoKey <> nil then
Result := FCeRegQueryInfoKey(hKey, ClassName, cchClass, Reserved, cSubKeys,
cchMaxSubKeyLen, cchMaxClassLen, cValues, cchMaxValueNameLen,
cbMaxValueData, cbSecurityDescriptor, LastWriteTime)
else
Result := $FFFF;
end;
function CeRegQueryValueEx(hKey: hKey; ValueName: LPCWSTR; Reserved: PDWORD;
pType: PDWORD; pData: PBYTE; cbData: PDWORD): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRegQueryValueEx <> nil then
Result := FCeRegQueryValueEx(hKey, ValueName, Reserved, pType, pData,
cbData)
else
Result := $FFFF;
end;
function CeRegSetValueEx(hKey: hKey; ValueName: LPCWSTR; Reserved: DWORD;
dwType: DWORD; pData: PBYTE; cbData: DWORD): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeRegSetValueEx <> nil then
Result := FCeRegSetValueEx(hKey, ValueName, Reserved, dwType, pData, cbData)
else
Result := $FFFF;
end;
function CeGetStoreInformation(lpsi: PStore_Information): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeGetStoreInformation <> nil then
Result := FCeGetStoreInformation(lpsi)
else
Result := False;
end;
function CeGetSystemMetrics(nIndex: Integer): Integer;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeGetSystemMetrics <> nil then
Result := FCeGetSystemMetrics(nIndex)
else
Result := $FFFF;
end;
function CeGetDesktopDeviceCaps(nIndedx: Integer): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeGetDesktopDeviceCaps <> nil then
Result := FCeGetDesktopDeviceCaps(nIndedx)
else
Result := $FFFF;
end;
procedure CeGetSystemInfo(lpSystemInfo: PSystemInfo);
begin
if not RapiLoaded then
begin
Exit;
end;
if @FCeGetSystemInfo <> nil then
FCeGetSystemInfo(lpSystemInfo);
end;
function CeSHCreateShortcut(ShortCut: lpwstr; Target: lpwstr): DWORD;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeSHCreateShortcut <> nil then
Result := FCeSHCreateShortcut(ShortCut, Target)
else
Result := $FFFF;
end;
function CeSHGetShortcutTarget(ShortCut: lpwstr; Target: lpwstr; cbMax: Integer)
: BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeSHGetShortcutTarget <> nil then
Result := FCeSHGetShortcutTarget(ShortCut, Target, cbMax)
else
Result := False;
end;
function CeCheckPassword(lpszPassword: lpwstr): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeCheckPassword <> nil then
Result := FCeCheckPassword(lpszPassword)
else
Result := False;
end;
function CeGetFileTime(hFile: THandle; lpCreationTime: PFILETIME;
lpLastAccessTime: PFILETIME; lpLastWriteTime: PFILETIME): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeGetFileTime <> nil then
Result := FCeGetFileTime(hFile, lpCreationTime, lpLastAccessTime,
lpLastWriteTime)
else
Result := False;
end;
function CeSetFileTime(hFile: THandle; CreationTime: PFILETIME;
LastAccessTime: PFILETIME; LastWriteTime: PFILETIME): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeSetFileTime <> nil then
Result := FCeSetFileTime(hFile, CreationTime, LastAccessTime, LastWriteTime)
else
Result := False;
end;
function CeGetVersionEx(lpVersionInfo: PCeOSVersionInfo): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeGetVersionEx <> nil then
Result := FCeGetVersionEx(lpVersionInfo)
else
Result := False;
end;
function CeGetWindow(HWND: HWND; uCmd: UINT): HWND;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeGetWindow <> nil then
Result := FCeGetWindow(HWND, uCmd)
else
Result := $FFFF;
end;
function CeGetWindowLong(HWND: HWND; nIndex: Integer): LONGINT;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeGetWindowLong <> nil then
Result := FCeGetWindowLong(HWND, nIndex)
else
Result := $FFFF;
end;
function CeGetWindowText(HWND: HWND; lpString: lpwstr; nMaxCount: Integer)
: Integer;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeGetWindowText <> nil then
Result := FCeGetWindowText(HWND, lpString, nMaxCount)
else
Result := $FFFF;
end;
function CeGetClassName(HWND: HWND; lpClassName: lpwstr; nMaxCount: Integer)
: Integer;
begin
if not RapiLoaded then
begin
Result := $FFFF;
Exit;
end;
if @FCeGetClassName <> nil then
Result := FCeGetClassName(HWND, lpClassName, nMaxCount)
else
Result := $FFFF;
end;
procedure CeGlobalMemoryStatus(lpmst: PMemoryStatus);
begin
if not RapiLoaded then
begin
Exit;
end;
if @FCeGlobalMemoryStatus <> nil then
FCeGlobalMemoryStatus(lpmst);
end;
function CeGetSystemPowerStatusEx(pStatus: PSystem_Power_Status_Ex;
fUpdate: BOOL): BOOL;
begin
if not RapiLoaded then
begin
Result := False;
Exit;
end;
if @FCeGetSystemPowerStatusEx <> nil then
Result := FCeGetSystemPowerStatusEx(pStatus, fUpdate)
else
Result := False;
end;
function DesktopToDevice(DesktopLocation, TableList: String; Sync: BOOL;
Overwrite: Integer; DeviceLocation: String): LONGINT;
begin
if not AdoCELoaded then
begin
Result := $FFFF;
Exit;
end;
if @FDesktopToDevice <> nil then
Result := FDesktopToDevice(DesktopLocation, TableList, Sync, Overwrite,
DeviceLocation)
else
Result := $FFFF;
end;
function CeRapiInvoke(pDllPath: LPCWSTR; pFunctionName: lpwstr; cbInput: DWORD;
pInput: Pointer; var pcbOutput: DWORD; var ppOutput: PBYTE;
mppIRAPIStream: ppIRAPIStream; dwReserved: DWORD): LONGINT;
begin
if not AdoCELoaded then
begin
Result := $FFFF;
Exit;
end;
if @CeRapiInvoke <> nil then
Result := FCeRapiInvoke(pDllPath, pFunctionName, cbInput, pInput,
pcbOutput, ppOutput, mppIRAPIStream, dwReserved)
else
Result := $FFFF;
end;
procedure CREATE_INVALIDGUID(var pguid: CEGUID);
begin
FillMemory(@pguid, sizeof(CEGUID), Byte(-1));
end;
procedure CREATE_SYSTEMGUID(var pguid: CEGUID);
begin
ZeroMemory(@pguid, sizeof(CEGUID));
end;
function ProcessorArchitectureName(p: WORD): string;
begin
case TPROCESSOR_ARCHITECTURE(p) of
PROCESSOR_ARCHITECTURE_INTEL:
Result := 'INTEL';
PROCESSOR_ARCHITECTURE_MIPS:
Result := 'MIPS';
PROCESSOR_ARCHITECTURE_ALPHA:
Result := 'ALPHA';
PROCESSOR_ARCHITECTURE_PPC:
Result := 'PPC';
PROCESSOR_ARCHITECTURE_SHX:
Result := 'SHX';
PROCESSOR_ARCHITECTURE_ARM:
Result := 'ARM';
PROCESSOR_ARCHITECTURE_IA64:
Result := 'IA64';
PROCESSOR_ARCHITECTURE_ALPHA64:
Result := 'ALPHA64';
PROCESSOR_ARCHITECTURE_UNKNOWN:
Result := 'UNKNOWN';
else
Result := IntToStr(p);
end;
end;
end.
{*******************************************************
RAPI这套远程API函数进行Delphi化包装
版权所有 (C) 2010 王锐
提供了类似Delphi RTL函数的一些函数包装.提供了
TCERegistry和TCEFileStream等对象的包装.
*******************************************************}
unit rapirtl;
interface
uses
rapi, Classes, Registry, sysUtils, Windows;
//仿DelphiRTL函数对RAPI做的扩展
type
TCERegistry = class(TObject)
private
FCurrentKey: HKEY;
FRootKey: HKEY;
FCurrentPath: WideString;
FCloseRootKey: Boolean;
FAccess: LongWord;
FLastError: Longint;
procedure SetRootKey(Value: HKEY);
function GetLastErrorMsg: WideString;
protected
procedure ChangeKey(Value: HKey; const Path: WideString);
function CheckResult(RetVal: Longint): Boolean;
function GetBaseKey(Relative: Boolean): HKey;
function GetData(const Name: WideString; Buffer: Pointer;
BufSize: Integer; var RegData: TRegDataType): Integer;
function GetKey(const Key: WideString): HKEY;
function GetRootKeyName: WideString;
procedure PutData(const Name: WideString; Buffer: Pointer; BufSize: Integer; RegData: TRegDataType);
procedure SetCurrentKey(Value: HKEY);
public
constructor Create; overload;
constructor Create(AAccess: LongWord); overload;
destructor Destroy; override;
procedure CloseKey;
function CreateKey(const Key: WideString): Boolean;
function DeleteKey(const Key: WideString): Boolean;
function DeleteValue(const Name: WideString): Boolean;
function GetDataAsString(const ValueName: WideString; PrefixType: Boolean = false): WideString;
function GetDataInfo(const ValueName: WideString; var Value: TRegDataInfo): Boolean;
function GetDataSize(const ValueName: WideString): Integer;
function GetDataType(const ValueName: WideString): TRegDataType;
function GetKeyInfo(var Value: TRegKeyInfo): Boolean;
procedure GetKeyNames(Strings: TStrings);
procedure GetValueNames(Strings: TStrings);
function HasSubKeys: Boolean;
function KeyExists(const Key: WideString): Boolean;
procedure MoveKey(const OldName, NewName: WideString; Delete: Boolean);
function OpenKey(const Key: WideString; CanCreate: Boolean): Boolean;
function OpenKeyReadOnly(const Key: WideString): Boolean;
function ReadCurrency(const Name: WideString): Currency;
function ReadBinaryData(const Name: WideString; var Buffer; BufSize: Integer): Integer;
function ReadBool(const Name: WideString): Boolean;
function ReadDate(const Name: WideString): TDateTime;
function ReadDateTime(const Name: WideString): TDateTime;
function ReadFloat(const Name: WideString): Double;
function ReadInteger(const Name: WideString): Integer;
function ReadString(const Name: WideString): WideString;
function ReadTime(const Name: WideString): TDateTime;
procedure RenameValue(const OldName, NewName: WideString);
function ValueExists(const Name: WideString): Boolean;
procedure WriteCurrency(const Name: WideString; Value: Currency);
procedure WriteBinaryData(const Name: WideString; var Buffer; BufSize: Integer);
procedure WriteBool(const Name: WideString; Value: Boolean);
procedure WriteDate(const Name: WideString; Value: TDateTime);
procedure WriteDateTime(const Name: WideString; Value: TDateTime);
procedure WriteFloat(const Name: WideString; Value: Double);
procedure WriteInteger(const Name: WideString; Value: Integer);
procedure WriteString(const Name, Value: WideString);
procedure WriteExpandString(const Name, Value: WideString);
procedure WriteTime(const Name: WideString; Value: TDateTime);
property CurrentKey: HKEY read FCurrentKey;
property CurrentPath: WideString read FCurrentPath;
property LastError: Longint read FLastError;
property LastErrorMsg: WideString read GetLastErrorMsg;
property RootKey: HKEY read FRootKey write SetRootKey;
property RootKeyName: WideString read GetRootKeyName;
property Access: LongWord read FAccess write FAccess;
end;
TCEHandleStream = class(TStream)
protected
FHandle: THandle;
procedure SetSize(NewSize: Longint); override;
procedure SetSize(const NewSize: Int64); override;
public
constructor Create(AHandle: Integer);
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
property Handle: THandle read FHandle;
end;
TCEFileStream = class(TCEHandleStream)
strict private
FFileName: string;
public
constructor Create(const AFileName: string; Mode: Word); overload;
constructor Create(const AFileName: string; Mode: Word; Rights: Cardinal); overload;
destructor Destroy; override;
property FileName: string read FFileName;
end;
function CEFileExists(const FileName: WideString): Boolean;
function CEDirectoryExists(const Directory: WideString): Boolean;
function CEFileCreate(const FileName: WideString; Mode: LongWord; Rights: Integer): Integer; overload;
function CEFileCreate(const FileName: string): Integer; overload;
function CEFileOpen(const FileName: WideString; Mode: LongWord): Integer;
function CEFileWrite(Handle: Integer; const Buffer; Count: LongWord): Integer;
function CEFileRead(Handle: Integer; const Buffer; Count: LongWord): Integer;
procedure CEFileClose(Handle: Integer);
function CEFileSeek(Handle, Offset, Origin: Integer): Integer;
function BinaryToHexString(const BinaryData: array of Byte; const PrefixStr: WideString): WideString;
implementation
uses
RTLConsts;
procedure ReadError(const Name: WideString);
begin
raise ERegistryException.CreateResFmt(@SInvalidRegType, [Name]);
end;
function IsRelative(const Value: WideString): Boolean;
begin
Result := not ((Value <> '') and (Value[1] = '/'));
end;
function RegDataToDataType(Value: TRegDataType): Integer;
begin
case Value of
rdString: Result := REG_SZ;
rdExpandString: Result := REG_EXPAND_SZ;
rdInteger: Result := REG_DWORD;
rdBinary: Result := REG_BINARY;
else
Result := REG_NONE;
end;
end;
function DataTypeToRegData(Value: Integer): TRegDataType;
begin
if Value = REG_SZ then Result := rdString
else if Value = REG_EXPAND_SZ then Result := rdExpandString
else if Value = REG_DWORD then Result := rdInteger
else if Value = REG_BINARY then Result := rdBinary
else Result := rdUnknown;
end;
function BinaryToHexString(const BinaryData: array of Byte; const PrefixStr: WideString): WideString;
var
DataSize, I, Offset: Integer;
HexData: WideString;
PResult: PWideChar;
begin
OffSet := 0;
if PrefixStr <> '' then
begin
Result := PrefixStr;
Inc(Offset, Length(PrefixStr));
end;
DataSize := Length(BinaryData);
SetLength(Result, Offset + (DataSize*3) - 1); // less one for last ','
PResult := PWideChar(Result); // Use a char pointer to reduce WideString overhead
for I := 0 to DataSize - 1 do
begin
HexData := IntToHex(BinaryData[I], 2);
PResult[Offset] := HexData[1];
PResult[Offset+1] := HexData[2];
if I < DataSize - 1 then
PResult[Offset+2] := ',';
Inc(Offset, 3);
end;
end;
{ TCERegistry }
constructor TCERegistry.Create;
begin
RootKey := HKEY_CURRENT_USER;
FAccess := KEY_ALL_ACCESS;
end;
constructor TCERegistry.Create(AAccess: LongWord);
begin
Create;
FAccess := AAccess;
end;
destructor TCERegistry.Destroy;
begin
CloseKey;
inherited Destroy;
end;
function TCERegistry.CheckResult(RetVal: Integer): Boolean;
begin
FLastError := GetLastError;
if FLastError = 0 then
begin
GetTickCount;
end;
FLastError := RetVal;
Result := (RetVal = ERROR_SUCCESS);
end;
procedure TCERegistry.CloseKey;
begin
if CurrentKey <> 0 then
begin
CERegCloseKey(CurrentKey);
FCurrentKey := 0;
FCurrentPath := '';
end;
end;
procedure TCERegistry.SetRootKey(Value: HKEY);
begin
if RootKey <> Value then
begin
if FCloseRootKey then
begin
CERegCloseKey(RootKey);
FCloseRootKey := False;
end;
FRootKey := Value;
CloseKey;
end;
end;
procedure TCERegistry.ChangeKey(Value: HKey; const Path: WideString);
begin
CloseKey;
FCurrentKey := Value;
FCurrentPath := Path;
end;
function TCERegistry.GetBaseKey(Relative: Boolean): HKey;
begin
if (CurrentKey = 0) or not Relative then
Result := RootKey else
Result := CurrentKey;
end;
procedure TCERegistry.SetCurrentKey(Value: HKEY);
begin
FCurrentKey := Value;
end;
function TCERegistry.CreateKey(const Key: WideString): Boolean;
var
TempKey: HKey;
S: WideString;
Disposition: Integer;
Relative: Boolean;
begin
TempKey := 0;
S := Key;
Relative := IsRelative(S);
if not Relative then Delete(S, 1, 1);
Result := CheckResult(CERegCreateKeyEx(GetBaseKey(Relative), PWideChar(S), 0, nil,
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, nil, TempKey, @Disposition));
if Result then CERegCloseKey(TempKey)
else raise ERegistryException.CreateResFmt(@SRegCreateFailed, [Key]);
end;
function TCERegistry.OpenKey(const Key: WideString; Cancreate: boolean): Boolean;
var
TempKey: HKey;
S: WideString;
Disposition: Integer;
Relative: Boolean;
r : Integer;
begin
S := Key;
Relative := IsRelative(S);
if not Relative then Delete(S, 1, 1);
TempKey := 0;
if not CanCreate or (S = '') then
begin
Result := CheckResult(CERegOpenKeyEx(GetBaseKey(Relative), PWideChar(S), 0,
FAccess, TempKey));
end else
Result := CheckResult(CERegCreateKeyEx(GetBaseKey(Relative), PWideChar(S), 0, nil,
REG_OPTION_NON_VOLATILE, FAccess, nil, TempKey, @Disposition));
if Result then
begin
if (CurrentKey <> 0) and Relative then S := CurrentPath + '/' + S;
ChangeKey(TempKey, S);
end;
end;
function TCERegistry.OpenKeyReadOnly(const Key: WideString): Boolean;
var
TempKey: HKey;
S: WideString;
Relative: Boolean;
WOWFlags: Cardinal;
begin
S := Key;
Relative := IsRelative(S);
if not Relative then Delete(S, 1, 1);
TempKey := 0;
// Preserve KEY_WOW64_XXX flags for later use
WOWFlags := FAccess and KEY_WOW64_RES;
Result := CheckResult(CERegOpenKeyEx(GetBaseKey(Relative), PWideChar(S), 0,
KEY_READ or WOWFlags, TempKey));
if Result then
begin
FAccess := KEY_READ or WOWFlags;
if (CurrentKey <> 0) and Relative then S := CurrentPath + '/' + S;
ChangeKey(TempKey, S);
end
else
begin
Result := CheckResult(CERegOpenKeyEx(GetBaseKey(Relative), PWideChar(S), 0,
STANDARD_RIGHTS_READ or KEY_QUERY_VALUE or KEY_ENUMERATE_SUB_KEYS or WOWFlags,
TempKey));
if Result then
begin
FAccess := STANDARD_RIGHTS_READ or KEY_QUERY_VALUE or KEY_ENUMERATE_SUB_KEYS or WOWFlags;
if (CurrentKey <> 0) and Relative then S := CurrentPath + '/' + S;
ChangeKey(TempKey, S);
end
else
begin
Result := CheckResult(CERegOpenKeyEx(GetBaseKey(Relative), PWideChar(S), 0,
KEY_QUERY_VALUE or WOWFlags, TempKey));
if Result then
begin
FAccess := KEY_QUERY_VALUE or WOWFlags;
if (CurrentKey <> 0) and Relative then S := CurrentPath + '/' + S;
ChangeKey(TempKey, S);
end
end;
end;
end;
function TCERegistry.DeleteKey(const Key: WideString): Boolean;
var
Len: DWORD;
I: Integer;
Relative: Boolean;
S, KeyName: WideString;
OldKey, DeleteKey: HKEY;
Info: TRegKeyInfo;
begin
S := Key;
Relative := IsRelative(S);
if not Relative then Delete(S, 1, 1);
OldKey := CurrentKey;
DeleteKey := GetKey(Key);
if DeleteKey <> 0 then
try
SetCurrentKey(DeleteKey);
if GetKeyInfo(Info) then
begin
SetString(KeyName, nil, Info.MaxSubKeyLen + 1);
for I := Info.NumSubKeys - 1 downto 0 do
begin
Len := Info.MaxSubKeyLen + 1;
if CheckResult(CERegEnumKeyEx(DeleteKey, DWORD(I), PWideChar(KeyName), @Len, nil, nil, nil,
nil)) then
Self.DeleteKey(PWideChar(KeyName));
end;
end;
finally
SetCurrentKey(OldKey);
CERegCloseKey(DeleteKey);
end;
Result := CheckResult(CERegDeleteKey(GetBaseKey(Relative), PWideChar(S)));
end;
function TCERegistry.DeleteValue(const Name: WideString): Boolean;
begin
Result := CheckResult(CERegDeleteValue(CurrentKey, PWideChar(Name)));
end;
function TCERegistry.GetKeyInfo(var Value: TRegKeyInfo): Boolean;
begin
FillChar(Value, SizeOf(TRegKeyInfo), 0);
Result := CheckResult(CERegQueryInfoKey(CurrentKey, nil, nil, nil, @Value.NumSubKeys,
@Value.MaxSubKeyLen, nil, @Value.NumValues, @Value.MaxValueLen,
@Value.MaxDataLen, nil, @Value.FileTime));
if SysLocale.FarEast and (Win32Platform = VER_PLATFORM_WIN32_NT) then
with Value do
begin
Inc(MaxSubKeyLen, MaxSubKeyLen);
Inc(MaxValueLen, MaxValueLen);
end;
end;
procedure TCERegistry.GetKeyNames(Strings: TStrings);
var
Len: DWORD;
I: Integer;
Info: TRegKeyInfo;
S: WideString;
begin
Strings.Clear;
if GetKeyInfo(Info) then
begin
SetString(S, nil, Info.MaxSubKeyLen + 1);
for I := 0 to Info.NumSubKeys - 1 do
begin
Len := Info.MaxSubKeyLen + 1;
CERegEnumKeyEx(CurrentKey, I, PWideChar(S), @Len, nil, nil, nil, nil);
Strings.Add(PWideChar(S));
end;
end;
end;
function TCERegistry.GetLastErrorMsg: WideString;
begin
if FLastError <> ERROR_SUCCESS then
Result := SysErrorMessage(FLastError)
else
Result := '';
end;
function TCERegistry.GetRootKeyName: WideString;
const
KeyNames: array[HKEY_CLASSES_ROOT..HKEY_DYN_DATA] of WideString = (
'HKEY_CLASSES_ROOT', 'HKEY_CURRENT_USER', 'HKEY_LOCAL_MACHINE',
'HKEY_USERS', 'HKEY_PERFORMANCE_DATA', 'HKEY_CURRENT_CONFIG', 'HKEY_DYN_DATA');
begin
if (FRootKey >= HKEY_CLASSES_ROOT) and (FRootKey <= HKEY_DYN_DATA) then
Result := KeyNames[FRootKey]
else
Result := '';
end;
procedure TCERegistry.GetValueNames(Strings: TStrings);
var
Len: DWORD;
I: Integer;
Info: TRegKeyInfo;
S: WideString;
begin
Strings.Clear;
if GetKeyInfo(Info) then
begin
SetString(S, nil, Info.MaxValueLen + 1);
for I := 0 to Info.NumValues - 1 do
begin
Len := Info.MaxValueLen + 1;
CERegEnumValue(CurrentKey, I, PWideChar(S), @Len, nil, nil, nil, nil);
Strings.Add(PWideChar(S));
end;
end;
end;
function TCERegistry.GetDataInfo(const ValueName: WideString; var Value: TRegDataInfo): Boolean;
var
DataType: Integer;
begin
FillChar(Value, SizeOf(TRegDataInfo), 0);
Result := CheckResult(CERegQueryValueEx(CurrentKey, PWideChar(ValueName), nil, @DataType, nil,
@Value.DataSize));
Value.RegData := DataTypeToRegData(DataType);
end;
function TCERegistry.GetDataSize(const ValueName: WideString): Integer;
var
Info: TRegDataInfo;
begin
if GetDataInfo(ValueName, Info) then
Result := Info.DataSize else
Result := -1;
end;
function TCERegistry.GetDataType(const ValueName: WideString): TRegDataType;
var
Info: TRegDataInfo;
begin
if GetDataInfo(ValueName, Info) then
Result := Info.RegData else
Result := rdUnknown;
end;
procedure TCERegistry.WriteString(const Name, Value: WideString);
begin
PutData(Name, PWideChar(Value), (Length(Value)+1) * SizeOf(WideChar), rdString);
end;
procedure TCERegistry.WriteExpandString(const Name, Value: WideString);
begin
PutData(Name, PWideChar(Value), (Length(Value)+1) * SizeOf(WideChar), rdExpandString);
end;
function TCERegistry.ReadString(const Name: WideString): WideString;
var
Len: Integer;
RegData: TRegDataType;
begin
Len := GetDataSize(Name);
if Len > 0 then
begin
SetString(Result, nil, Len div SizeOf(WideChar));
GetData(Name, PWideChar(Result), Len, RegData);
if (RegData = rdString) or (RegData = rdExpandString) then
SetLength(Result, StrLen(PWideChar(Result)))
else ReadError(Name);
end
else Result := '';
end;
// Returns rdInteger and rdBinary as WideStrings
function TCERegistry.GetDataAsString(const ValueName: WideString;
PrefixType: Boolean = false): WideString;
const
SDWORD_PREFIX = 'dword:';
SHEX_PREFIX = 'hex:';
var
Info: TRegDataInfo;
BinaryBuffer: array of Byte;
begin
Result := '';
if GetDataInfo(ValueName, Info) and (Info.DataSize > 0) then
begin
case Info.RegData of
rdString, rdExpandString:
begin
SetString(Result, nil, Info.DataSize);
GetData(ValueName, PWideChar(Result), Info.DataSize, Info.RegData);
SetLength(Result, StrLen(PWideChar(Result)));
end;
rdInteger:
begin
if PrefixType then
Result := SDWORD_PREFIX+IntToHex(ReadInteger(ValueName), 8)
else
Result := IntToStr(ReadInteger(ValueName));
end;
rdBinary, rdUnknown:
begin
SetLength(BinaryBuffer, Info.DataSize);
ReadBinaryData(ValueName, Pointer(BinaryBuffer)^, Info.DataSize);
if PrefixType then
Result := BinaryToHexString(BinaryBuffer, SHEX_PREFIX)
else
Result := BinaryToHexString(BinaryBuffer, '');
end;
end;
end;
end;
procedure TCERegistry.WriteInteger(const Name: WideString; Value: Integer);
begin
PutData(Name, @Value, SizeOf(Integer), rdInteger);
end;
function TCERegistry.ReadInteger(const Name: WideString): Integer;
var
RegData: TRegDataType;
begin
GetData(Name, @Result, SizeOf(Integer), RegData);
if RegData <> rdInteger then ReadError(Name);
end;
procedure TCERegistry.WriteBool(const Name: WideString; Value: Boolean);
begin
WriteInteger(Name, Ord(Value));
end;
function TCERegistry.ReadBool(const Name: WideString): Boolean;
begin
Result := ReadInteger(Name) <> 0;
end;
procedure TCERegistry.WriteFloat(const Name: WideString; Value: Double);
begin
PutData(Name, @Value, SizeOf(Double), rdBinary);
end;
function TCERegistry.ReadFloat(const Name: WideString): Double;
var
Len: Integer;
RegData: TRegDataType;
begin
Len := GetData(Name, @Result, SizeOf(Double), RegData);
if (RegData <> rdBinary) or (Len <> SizeOf(Double)) then
ReadError(Name);
end;
procedure TCERegistry.WriteCurrency(const Name: WideString; Value: Currency);
begin
PutData(Name, @Value, SizeOf(Currency), rdBinary);
end;
function TCERegistry.ReadCurrency(const Name: WideString): Currency;
var
Len: Integer;
RegData: TRegDataType;
begin
Len := GetData(Name, @Result, SizeOf(Currency), RegData);
if (RegData <> rdBinary) or (Len <> SizeOf(Currency)) then
ReadError(Name);
end;
procedure TCERegistry.WriteDateTime(const Name: WideString; Value: TDateTime);
begin
PutData(Name, @Value, SizeOf(TDateTime), rdBinary);
end;
function TCERegistry.ReadDateTime(const Name: WideString): TDateTime;
var
Len: Integer;
RegData: TRegDataType;
begin
Len := GetData(Name, @Result, SizeOf(TDateTime), RegData);
if (RegData <> rdBinary) or (Len <> SizeOf(TDateTime)) then
ReadError(Name);
end;
procedure TCERegistry.WriteDate(const Name: WideString; Value: TDateTime);
begin
WriteDateTime(Name, Value);
end;
function TCERegistry.ReadDate(const Name: WideString): TDateTime;
begin
Result := ReadDateTime(Name);
end;
procedure TCERegistry.WriteTime(const Name: WideString; Value: TDateTime);
begin
WriteDateTime(Name, Value);
end;
function TCERegistry.ReadTime(const Name: WideString): TDateTime;
begin
Result := ReadDateTime(Name);
end;
procedure TCERegistry.WriteBinaryData(const Name: WideString; var Buffer; BufSize: Integer);
begin
PutData(Name, @Buffer, BufSize, rdBinary);
end;
function TCERegistry.ReadBinaryData(const Name: WideString; var Buffer; BufSize: Integer): Integer;
var
RegData: TRegDataType;
Info: TRegDataInfo;
begin
if GetDataInfo(Name, Info) then
begin
Result := Info.DataSize;
RegData := Info.RegData;
if ((RegData = rdBinary) or (RegData = rdUnknown)) and (Result <= BufSize) then
GetData(Name, @Buffer, Result, RegData)
else ReadError(Name);
end else
Result := 0;
end;
procedure TCERegistry.PutData(const Name: WideString; Buffer: Pointer;
BufSize: Integer; RegData: TRegDataType);
var
DataType: Integer;
begin
DataType := RegDataToDataType(RegData);
if not CheckResult(CERegSetValueEx(CurrentKey, PWideChar(Name), 0, DataType, Buffer,
BufSize)) then
raise ERegistryException.CreateResFmt(@SRegSetDataFailed, [Name]);
end;
function TCERegistry.GetData(const Name: WideString; Buffer: Pointer;
BufSize: Integer; var RegData: TRegDataType): Integer;
var
DataType: Integer;
begin
DataType := REG_NONE;
if not CheckResult(CERegQueryValueEx(CurrentKey, PWideChar(Name), nil, @DataType, PByte(Buffer),
@BufSize)) then
raise ERegistryException.CreateResFmt(@SRegGetDataFailed, [Name]);
Result := BufSize;
RegData := DataTypeToRegData(DataType);
end;
function TCERegistry.HasSubKeys: Boolean;
var
Info: TRegKeyInfo;
begin
Result := GetKeyInfo(Info) and (Info.NumSubKeys > 0);
end;
function TCERegistry.ValueExists(const Name: WideString): Boolean;
var
Info: TRegDataInfo;
begin
Result := GetDataInfo(Name, Info);
end;
function TCERegistry.GetKey(const Key: WideString): HKEY;
var
S: WideString;
Relative: Boolean;
begin
S := Key;
Relative := IsRelative(S);
if not Relative then Delete(S, 1, 1);
Result := 0;
CERegOpenKeyEx(GetBaseKey(Relative), PWideChar(S), 0, FAccess, Result);
end;
function TCERegistry.KeyExists(const Key: WideString): Boolean;
var
TempKey: HKEY;
OldAccess: Longword;
begin
OldAccess := FAccess;
try
FAccess := STANDARD_RIGHTS_READ or KEY_QUERY_VALUE or
KEY_ENUMERATE_SUB_KEYS or (OldAccess and KEY_WOW64_RES);
TempKey := GetKey(Key);
if TempKey <> 0 then CERegCloseKey(TempKey);
Result := TempKey <> 0;
finally
FAccess := OldAccess;
end;
end;
procedure TCERegistry.RenameValue(const OldName, NewName: WideString);
var
Len: Integer;
RegData: TRegDataType;
Buffer: PWideChar;
begin
if {ValueExists(OldName) and} not ValueExists(NewName) then
begin
Len := GetDataSize(OldName); // returns 0 if OldName doesn't exist
if Len > 0 then
begin
Buffer := AllocMem(Len);
try
Len := GetData(OldName, Buffer, Len, RegData);
DeleteValue(OldName);
PutData(NewName, Buffer, Len, RegData);
finally
FreeMem(Buffer);
end;
end;
end;
end;
procedure TCERegistry.MoveKey(const OldName, NewName: WideString; Delete: Boolean);
var
SrcKey, DestKey: HKEY;
procedure MoveValue(SrcKey, DestKey: HKEY; const Name: WideString);
var
Len: Integer;
OldKey, PrevKey: HKEY;
Buffer: PWideChar;
RegData: TRegDataType;
begin
OldKey := CurrentKey;
SetCurrentKey(SrcKey);
try
Len := GetDataSize(Name);
if Len > 0 then
begin
Buffer := AllocMem(Len);
try
Len := GetData(Name, Buffer, Len, RegData);
PrevKey := CurrentKey;
SetCurrentKey(DestKey);
try
PutData(Name, Buffer, Len, RegData);
finally
SetCurrentKey(PrevKey);
end;
finally
FreeMem(Buffer);
end;
end;
finally
SetCurrentKey(OldKey);
end;
end;
procedure CopyValues(SrcKey, DestKey: HKEY);
var
Len: DWORD;
I: Integer;
KeyInfo: TRegKeyInfo;
S: WideString;
OldKey: HKEY;
begin
OldKey := CurrentKey;
SetCurrentKey(SrcKey);
try
if GetKeyInfo(KeyInfo) then
begin
MoveValue(SrcKey, DestKey, '');
SetString(S, nil, KeyInfo.MaxValueLen + 1);
for I := 0 to KeyInfo.NumValues - 1 do
begin
Len := KeyInfo.MaxValueLen + 1;
if CheckResult(CERegEnumValue(SrcKey, I, PWideChar(S), @Len, nil, nil, nil, nil)) then
MoveValue(SrcKey, DestKey, PWideChar(S));
end;
end;
finally
SetCurrentKey(OldKey);
end;
end;
procedure CopyKeys(SrcKey, DestKey: HKEY);
var
Len: DWORD;
I: Integer;
Info: TRegKeyInfo;
S: WideString;
OldKey, PrevKey, NewSrc, NewDest: HKEY;
begin
OldKey := CurrentKey;
SetCurrentKey(SrcKey);
try
if GetKeyInfo(Info) then
begin
SetString(S, nil, Info.MaxSubKeyLen + 1);
for I := 0 to Info.NumSubKeys - 1 do
begin
Len := Info.MaxSubKeyLen + 1;
if CheckResult(CERegEnumKeyEx(SrcKey, I, PWideChar(S), @Len, nil, nil, nil, nil)) then
begin
NewSrc := GetKey(PWideChar(S));
if NewSrc <> 0 then
try
PrevKey := CurrentKey;
SetCurrentKey(DestKey);
try
CreateKey(PWideChar(S));
NewDest := GetKey(PWideChar(S));
try
CopyValues(NewSrc, NewDest);
CopyKeys(NewSrc, NewDest);
finally
CERegCloseKey(NewDest);
end;
finally
SetCurrentKey(PrevKey);
end;
finally
CERegCloseKey(NewSrc);
end;
end;
end;
end;
finally
SetCurrentKey(OldKey);
end;
end;
begin
if KeyExists(OldName) and not KeyExists(NewName) then
begin
SrcKey := GetKey(OldName);
if SrcKey <> 0 then
try
CreateKey(NewName);
DestKey := GetKey(NewName);
if DestKey <> 0 then
try
CopyValues(SrcKey, DestKey);
CopyKeys(SrcKey, DestKey);
if Delete then DeleteKey(OldName);
finally
CERegCloseKey(DestKey);
end;
finally
CERegCloseKey(SrcKey);
end;
end;
end;
function CEFileExists(const FileName: WideString): Boolean;
function ExistsLockedOrShared(const Filename: WideString): Boolean;
var
FindData: TCe_Find_Data;
LHandle: THandle;
begin
{ Either the file is locked/share_exclusive or we got an access denied }
LHandle := CEFindFirstFile(PWideChar(Filename), @FindData);
if LHandle <> INVALID_HANDLE_VALUE then
begin
CEFindClose(LHandle);
Result := FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0;
end
else
Result := False;
end;
var
Code: Integer;
LastError: Cardinal;
begin
Code := Integer(CeGetFileAttributes(PWideChar(FileName)));
if Code <> -1 then
Result := (FILE_ATTRIBUTE_DIRECTORY and Code = 0)
else
begin
LastError := CeGetLastError;
Result := (LastError <> ERROR_FILE_NOT_FOUND) and
(LastError <> ERROR_PATH_NOT_FOUND) and
(LastError <> ERROR_INVALID_NAME) and ExistsLockedOrShared(Filename);
end;
end;
function CEDirectoryExists(const Directory: WideString): Boolean;
var
Code: Cardinal;
begin
Code := CEGetFileAttributes(PWideChar(Directory));
Result := (Code <> INVALID_FILE_ATTRIBUTES) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;
function CEFileCreate(const FileName: WideString; Mode: LongWord; Rights: Integer): Integer;
const
ShareMode: array[0..4] of LongWord = (
0,
0,
FILE_SHARE_READ,
FILE_SHARE_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE);
begin
Result := -1;
if (Mode and $F0) <= fmShareDenyNone then
Result := Integer(CECreateFile(PWideChar(FileName), GENERIC_READ or GENERIC_WRITE,
ShareMode[(Mode and $F0) shr 4], nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0));
end;
function CEFileCreate(const FileName: string): Integer;
begin
Result := CEFileCreate(FileName, fmShareExclusive, 0);
end;
function CEFileOpen(const FileName: WideString; Mode: LongWord): Integer;
const
AccessMode: array[0..2] of LongWord = (
GENERIC_READ,
GENERIC_WRITE,
GENERIC_READ or GENERIC_WRITE);
ShareMode: array[0..4] of LongWord = (
0,
0,
FILE_SHARE_READ,
FILE_SHARE_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE);
begin
Result := -1;
if ((Mode and 3) <= fmOpenReadWrite) and
((Mode and $F0) <= fmShareDenyNone) then
Result := Integer(CECreateFile(PWideChar(FileName), AccessMode[Mode and 3],
ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0));
end;
function CEFileWrite(Handle: Integer; const Buffer; Count: LongWord): Integer;
begin
if not CEWriteFile(THandle(Handle), @Buffer, Count, LongWord(Result), nil) then
Result := -1;
end;
function CEFileRead(Handle: Integer; const Buffer; Count: LongWord): Integer;
begin
if not CEReadFile(THandle(Handle), @Buffer, Count, LongWord(Result), nil) then
Result := -1;
end;
procedure CEFileClose(Handle: Integer);
begin
CECloseHandle(THandle(Handle));
end;
function CEFileSeek(Handle, Offset, Origin: Integer): Integer;
begin
Result := CESetFilePointer(THandle(Handle), Offset, nil, Origin);
end;
{ TCEHandleStream }
constructor TCEHandleStream.Create(AHandle: Integer);
begin
inherited Create;
FHandle := AHandle;
end;
function TCEHandleStream.Read(var Buffer; Count: Integer): Longint;
begin
Result := CEFileRead(FHandle, Buffer, Count);
if Result = -1 then Result := 0;
end;
function TCEHandleStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
Result := CEFileSeek(FHandle, Offset, Ord(Origin));
end;
procedure TCEHandleStream.SetSize(NewSize: Integer);
begin
SetSize(Int64(NewSize));
end;
procedure TCEHandleStream.SetSize(const NewSize: Int64);
begin
Seek(NewSize, soBeginning);
Win32Check(CESetEndOfFile(FHandle));
end;
function TCEHandleStream.Write(const Buffer; Count: Integer): Longint;
begin
Result := CEFileWrite(FHandle, Buffer, Count);
if Result = -1 then Result := 0;
end;
{ TCEFileStream }
constructor TCEFileStream.Create(const AFileName: string; Mode: Word);
begin
Create(AFilename, Mode, 0);
end;
constructor TCEFileStream.Create(const AFileName: string; Mode: Word;
Rights: Cardinal);
var
LShareMode: Word;
begin
if (Mode and fmCreate = fmCreate) then
begin
LShareMode := Mode and $FF;
if LShareMode = $FF then
LShareMode := fmShareExclusive; // For compat in case $FFFF passed as Mode
inherited Create(CEFileCreate(AFileName, LShareMode, Rights));
if FHandle = INVALID_HANDLE_VALUE then
raise EFCreateError.CreateResFmt(@SFCreateErrorEx, [ExpandFileName(AFileName), SysErrorMessage(GetLastError)]);
end
else
begin
inherited Create(CEFileOpen(AFileName, Mode));
if FHandle = INVALID_HANDLE_VALUE then
raise EFOpenError.CreateResFmt(@SFOpenErrorEx, [ExpandFileName(AFileName), SysErrorMessage(GetLastError)]);
end;
FFileName := AFileName;
end;
destructor TCEFileStream.Destroy;
begin
if FHandle <> INVALID_HANDLE_VALUE then
CEFileClose(FHandle);
inherited Destroy;
end;
end.
{*******************************************************
dccManSink
版权所有 (C) 2010 王锐
可以感应WindowsCE,Windows Mobile设备的各种事件
*******************************************************}
unit dccManSink;
interface
uses
Windows, Classes, ActiveX, SysUtils, ComObj, Dialogs;
const
CLSID_DccMan: TGUID = '{499C0C20-A766-11cf-8011-00A0C90A8F78}';
IID_IDccMan: TGUID = '{A7B88841-A812-11cf-8011-00A0C90A8F78}';
IID_IDccManSink: TGUID = '{A7B88840-A812-11cf-8011-00A0C90A8F78}';
// 翻译自微软MSDN
type
IDccManSink = interface(IUnknown)
['{A7B88840-A812-11cf-8011-00A0C90A8F78}']
function OnLogIpAddr(dwIpAddr: DWORD): HResult; stdcall;
function OnLogTerminated: HResult; stdcall;
function OnLogActive: HResult; stdcall;
function OnLogInactive: HResult; stdcall;
function OnLogAnswered: HResult; stdcall;
function OnLogListen: HResult; stdcall;
function OnLogDisconnection: HResult; stdcall;
function OnLogError: HResult; stdcall;
end;
LPDCCMANSINK = IDccManSink;
IDccMan = interface(IUnknown)
['{A7B88841-A812-11cf-8011-00A0C90A8F78}']
function Advise(pDccSink: LPDCCMANSINK; var pdwContext: DWORD): HResult;
stdcall;
function Unadvise(dwContext: DWORD): HResult; stdcall;
function ShowCommSettings: HResult; stdcall;
function AutoconnectEnable: HResult; stdcall;
function AutoconnectDisable: HResult; stdcall;
function ConnectNow: HResult; stdcall;
function DisconnectNow: HResult; stdcall;
function SetIconDataTransferring: HResult; stdcall;
function SetIconNoDataTransferring: HResult; stdcall;
function SetIconError: HResult; stdcall;
end;
TLogType = (ltLogIpAddr, ltLogTerminated, ltLogActive, ltLogInactive,
ltLogAnswered, ltLogListen, ltLogDisconnection, ltLogError);
//如果触发OnLog的是IPAddr,那么可以读TDccMan的IPAddr属性获取IP地址
TOnLog = procedure(Sender: TObject; ALogType: TLogType) of Object;
TDccMan = class(TComponent, IDccManSink)
private
FContext: DWORD;
FActived: Boolean;
FInternalDccman: IDccMan;
FOnLog: TOnLog;
FIPAddr: DWORD;
procedure SetActived(const Value: Boolean);
procedure DoLog(ALogType: TLogType);
{ IDccManSink }
function OnLogIpAddr(dwIpAddr: DWORD): HResult; stdcall;
function OnLogTerminated: HResult; stdcall;
function OnLogActive: HResult; stdcall;
function OnLogInactive: HResult; stdcall;
function OnLogAnswered: HResult; stdcall;
function OnLogListen: HResult; stdcall;
function OnLogDisconnection: HResult; stdcall;
function OnLogError: HResult; stdcall;
//
published
property Actived: Boolean read FActived write SetActived;
property IPAddr: DWORD read FIPAddr;
property OnLog: TOnLog read FOnLog write FOnLog;
end;
implementation
{ TDccEventSink implementation }
function TDccMan.OnLogIpAddr(dwIpAddr: DWORD): HResult;
begin
FIPAddr := dwIpAddr;
DoLog(ltLogIpAddr);
Result := NO_ERROR;
end;
function TDccMan.OnLogTerminated: HResult;
begin
DoLog(ltLogTerminated);
Result := NO_ERROR;
end;
procedure TDccMan.DoLog(ALogType: TLogType);
begin
if Assigned(FOnLog) then
FOnLog(Self, ALogType);
end;
procedure TDccMan.SetActived(const Value: Boolean);
var
hr: HResult;
begin
if FActived <> Value then
begin
if Value then
begin
if FInternalDccman = nil then
begin
hr := CoCreateInstance(CLSID_DccMan, nil,
CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IID_IDccMan,
FInternalDccman);
if SUCCEEDED(hr) then
begin
hr := FInternalDccman.Advise(Self, FContext);
FActived := SUCCEEDED(hr);
end;
end;
end
else
begin
if (FInternalDccman <> nil) and SUCCEEDED
(FInternalDccman.Unadvise(FContext)) then
begin
FActived := False;
end;
end;
end;
end;
function TDccMan.OnLogActive: HResult;
begin
DoLog(ltLogActive);
Result := NO_ERROR;
end;
function TDccMan.OnLogInactive: HResult;
begin
DoLog(ltLogInactive);
Result := NO_ERROR;
end;
function TDccMan.OnLogAnswered: HResult;
begin
DoLog(ltLogAnswered);
Result := NO_ERROR;
end;
function TDccMan.OnLogListen: HResult;
begin
DoLog(ltLogListen);
Result := NO_ERROR;
end;
function TDccMan.OnLogDisconnection: HResult;
begin
DoLog(ltLogDisconnection);
Result := NO_ERROR;
end;
function TDccMan.OnLogError: HResult;
begin
DoLog(ltLogError);
Result := NO_ERROR;
end;
end.
扫一扫
169
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
