delphi常用関数
9991 ワード
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TFileItem = class(TCollectionItem)
public
FileName: WideString;
FileSize: Int64;
IsDirectory: Boolean;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
//------ CPU uses WinSock
function GetCPUID: string;
procedure SetCPU(Handle: THandle; CPUNO: Integer);
var
ProcessAffinity: Cardinal;
_SystemAffinity: Cardinal;
begin
GetProcessAffinityMask(handle, ProcessAffinity, _SystemAffinity);
ProcessAffinity := CPUNO;
SetProcessAffinityMask(handle, ProcessAffinity);
end;
const
CPUINFO = '%.8x-%.8x-%.8x-%.8x';
var
iEax: Integer;
iEbx: Integer;
iEcx: Integer;
iEdx: Integer;
begin
SetCPU(GetCurrentProcess, 1);
asm
push ebx
push ecx
push edx
mov eax, 1
DW $A20F//cpuid
mov iEax, eax
mov iEbx, ebx
mov iEcx, ecx
mov iEdx, edx
pop edx
pop ecx
pop ebx
end;
Result := Format(CPUINFO, [iEax, iEbx, iEcx, iEdx]);
end;
//
function MacAddress: string;
var
Lib: Cardinal;
Func : function(GUID: PGUID): Longint; stdcall;
GUID1, GUID2: TGUID;
begin
Result := '';
Lib := LoadLibrary('rpcrt4.dll');
if Lib <> 0 then
begin
if Win32Platform <>VER_PLATFORM_WIN32_NT then
@Func := GetProcAddress(Lib, 'UuidCreate')
else @Func := GetProcAddress(Lib, 'UuidCreateSequential');
if Assigned(Func) then
begin
if (Func(@GUID1) = 0) and
(Func(@GUID2) = 0) and
(GUID1.D4[2] = GUID2.D4[2]) and
(GUID1.D4[3] = GUID2.D4[3]) and
(GUID1.D4[4] = GUID2.D4[4]) and
(GUID1.D4[5] = GUID2.D4[5]) and
(GUID1.D4[6] = GUID2.D4[6]) and
(GUID1.D4[7] = GUID2.D4[7]) then
begin
Result :=
IntToHex(GUID1.D4[2], 2) + '-' +
IntToHex(GUID1.D4[3], 2) + '-' +
IntToHex(GUID1.D4[4], 2) + '-' +
IntToHex(GUID1.D4[5], 2) + '-' +
IntToHex(GUID1.D4[6], 2) + '-' +
IntToHex(GUID1.D4[7], 2);
end;
end;
FreeLibrary(Lib);
end;
end;
// :
function GetIdeSerialNumber: Pansichar; // ；
const IDENTIFY_BUFFER_SIZE = 512;
type
TIDERegs = packed record
bFeaturesReg: BYTE;
bSectorCountReg: BYTE;
bSectorNumberReg: BYTE;
bCylLowReg: BYTE;
bCylHighReg: BYTE;
bDriveHeadReg: BYTE;
bCommandReg: BYTE;
bReserved: BYTE;
end;
TSendCmdInParams = packed record
cBufferSize: DWORD;
irDriveRegs: TIDERegs;
bDriveNumber: BYTE;
bReserved: array[0..2] of Byte;
dwReserved: array[0..3] of DWORD;
bBuffer: array[0..0] of Byte;
end;
TIdSector = packed record
wGenConfig: Word;
wNumCyls: Word;
wReserved: Word;
wNumHeads: Word;
wBytesPerTrack: Word;
wBytesPerSector: Word;
wSectorsPerTrack: Word;
wVendorUnique: array[0..2] of Word;
sSerialNumber: array[0..19] of CHAR;
wBufferType: Word;
wBufferSize: Word;
wECCSize: Word;
sFirmwareRev: array[0..7] of Char;
sModelNumber: array[0..39] of Char;
wMoreVendorUnique: Word;
wDoubleWordIO: Word;
wCapabilities: Word;
wReserved1: Word;
wPIOTiming: Word;
wDMATiming: Word;
wBS: Word;
wNumCurrentCyls: Word;
wNumCurrentHeads: Word;
wNumCurrentSectorsPerTrack: Word;
ulCurrentSectorCapacity: DWORD;
wMultSectorStuff: Word;
ulTotalAddressableSectors: DWORD;
wSingleWordDMA: Word;
wMultiWordDMA: Word;
bReserved: array[0..127] of BYTE;
end;
PIdSector = ^TIdSector;
TDriverStatus = packed record
bDriverError: Byte;
bIDEStatus: Byte;
bReserved: array[0..1] of Byte;
dwReserved: array[0..1] of DWORD;
end;
TSendCmdOutParams = packed record
cBufferSize: DWORD;
DriverStatus: TDriverStatus;
bBuffer: array[0..0] of BYTE;
end;
var
hDevice: Thandle;
cbBytesReturned: DWORD;
SCIP: TSendCmdInParams;
aIdOutCmd: array[0..(SizeOf(TSendCmdOutParams) + IDENTIFY_BUFFER_SIZE-1)-1] of Byte;
IdOutCmd: TSendCmdOutParams absolute aIdOutCmd;
procedure ChangeByteOrder(var Data; Size: Integer);//
var
ptr: Pchar;
i: Integer;
c: Char;
begin
ptr := @Data;
for I := 0 to (Size shr 1) - 1 do begin
c := ptr^;
ptr^ := (ptr + 1)^;
(ptr + 1)^ := c;
Inc(ptr, 2);
end;
end;
begin //
Result := '';
if SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT then
begin // Windows NT, Windows 2000
hDevice := CreateFile('\\.\PhysicalDrive0', GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
end
else // Version Windows 95 OSR2, Windows 98
hDevice := CreateFile('\\.\SMARTVSD', 0, 0, nil, CREATE_NEW, 0, 0);
if hDevice = INVALID_HANDLE_VALUE then Exit;
try
FillChar(SCIP, SizeOf(TSendCmdInParams) - 1, #0);
FillChar(aIdOutCmd, SizeOf(aIdOutCmd), #0);
cbBytesReturned := 0;
with SCIP do
begin
cBufferSize := IDENTIFY_BUFFER_SIZE;
with irDriveRegs do
begin
bSectorCountReg := 1;
bSectorNumberReg := 1;
bDriveHeadReg := $A0;
bCommandReg := $EC;
end;
end;
if not DeviceIoControl(hDevice, $0007C088, @SCIP, SizeOf(TSendCmdInParams) - 1,@aIdOutCmd, SizeOf(aIdOutCmd), cbBytesReturned, nil) then Exit;
finally
CloseHandle(hDevice);
end;
with PIdSector(@IdOutCmd.bBuffer)^ do
begin
ChangeByteOrder(sSerialNumber, SizeOf(sSerialNumber));
(Pchar(@sSerialNumber) + SizeOf(sSerialNumber))^:= #0;
Result := PAnsichar(@sSerialNumber);
end;
end;
//
procedure FindAllFiles(APath: WideString; AFiles: TCollection;
var AFileSize: Int64);
var
strSearchPath: WideString;
strSafePath: WideString;
FindData: WIN32_FIND_DATAW;
hFind: THandle;
objItem: TFileItem;
begin
strSafePath := Trim(APath);
if strSafePath[Length(strSafePath)] <> '\' then strSafePath := strSafePath + '\';
strSearchPath := strSafePath + '*.*';
hFind := FindFirstFileW(PWideChar(strSearchPath), FindData);
if (INVALID_HANDLE_VALUE = hFind) then Exit;
while True do
begin
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY then
begin
if(FindData.cFileName[0] <> '.') then
begin
objItem := TFileItem(AFiles.Add());
objItem.FileName := strSafePath + FindData.cFileName;
objItem.FileSize := 0;
objItem.IsDirectory := True;
FindAllFiles(strSafePath + FindData.cFileName, AFiles, AFileSize);
end;
end
else
begin
objItem := TFileItem(AFiles.Add());
objItem.FileName := strSafePath + FindData.cFileName;
objItem.FileSize := FindData.nFileSizeLow or FindData.nFileSizeHigh shl SizeOf(FindData.nFileSizeHigh);
objItem.IsDirectory := False;
AFileSize := AFileSize + objItem.FileSize;
end;
if (not FindNextFileW(hFind, FindData)) then Break;
end;
Windows.FindClose(hFind);
end;
//
function ForceToRemoveDir(ADir: string): Boolean;
var
pDir: PChar;
SR: TSearchRec;
FR: Integer;
begin
Result := False;
pDir := PChar(ADir);
if not DirectoryExists(pDir) then Exit;
try
if Copy(pDir, Length(pDir), 1) <> '\' then
pDir := PChar(pDir + '\');
FR := FindFirst(pDir + '*.*', FaAnyfile, SR);
while FR = 0 do
begin
if ((SR.Attr and FaDirectory) = FaDirectory) and
(SR.Name <> '.') and (SR.Name <> '..') then
begin
if not ForceToRemoveDir(StrPas(pDir) + SR.Name) then Break;
end;
if ((SR.Attr and FaDirectory <> FaDirectory) and
(SR.Attr and FaVolumeID <> FaVolumeID)) then
begin
SysUtils.FileSetAttr(pDir + SR.Name,
SysUtils.FileGetAttr(pDir + SR.Name) and (not
SysUtils.faReadOnly)); //
if not DeleteFile(PChar(pDir + SR.Name)) then
Break;
end;
FR := FindNext(SR);
end;
SysUtils.FindClose(SR);
RemoveDirectory(pDir);
Result := True;
except
end;
end;
// windows
function GetWindowsVersion: string;
var
AWin32Version: Extended;
os: string;
begin
os := 'Windows ';
AWin32Version := StrtoFloat(format('%d.%d' ,[Win32MajorVersion, Win32MinorVersion]));
if Win32Platform = VER_PLATFORM_WIN32s then
Result := os + '32'
else if Win32Platform=VER_PLATFORM_WIN32_WINDOWS then
begin
if AWin32Version=4.0 then
Result := os + '95'
else if AWin32Version=4.1 then
Result := os + '98'
else if AWin32Version=4.9 then
Result := os + 'Me'
else
Result := os + '9x'
end
else if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
if AWin32Version=3.51 then
Result := os + 'NT 3.51'
else if AWin32Version=4.0 then
Result := os + 'NT 4.0'
else if AWin32Version=5.0 then
Result := os + '2000'
else if AWin32Version=5.1 then
Result := os + 'XP'
else if AWin32Version=5.2 then
Result := os + '2003'
else if AWin32Version=6.0 then
Result := os + 'Vista'
else if AWin32Version=6.1 then
Result := os + '7'
else
Result := os ;
end
else
Result := os + '??';
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i:integer;
begin
showmessage(MacAddress());
showmessage(GetCPUID());
showmessage(GetIdeSerialNumber());
showmessage(GetWindowsVersion());
end;
procedure TForm1.Button2Click(Sender: TObject);
var
aFiles: TCollection;
aFileSize: Int64;
begin
//FindAllFiles('C:\\apache-tomcat-6.0.32',aFiles,aFileSize);
//showmessage(inttostr(aFileSize));
ForceToRemoveDir('C:\apache-tomcat-6.0.32');
showmessage(' ！');
end;
end.