檢查是否為正確的Mac Address格式

function isMacAdrFormat(str: String): boolean;

begin

  Result := False;

  if Length(str) <> 17 then

    Exit;

  Result := ((str[1] in ['0'..'9', 'A'..'F']) and

             (str[2] in ['0'..'9', 'A'..'F']) and

             (str[3] = '-') and

             (str[4] in ['0'..'9', 'A'..'F']) and

             (str[5] in ['0'..'9', 'A'..'F']) and

             (str[6] = '-') and

             (str[7] in ['0'..'9', 'A'..'F']) and

             (str[8] in ['0'..'9', 'A'..'F']) and

             (str[9] = '-') and

             (str[10] in ['0'..'9', 'A'..'F']) and

             (str[11] in ['0'..'9', 'A'..'F']) and

             (str[12] = '-') and

             (str[13] in ['0'..'9', 'A'..'F']) and

             (str[14] in ['0'..'9', 'A'..'F']) and

             (str[15] = '-') and

             (str[16] in ['0'..'9', 'A'..'F']) and

             (str[17] in ['0'..'9', 'A'..'F']));

end;

判斷磁碟空間是否小於40M

procedure TForm1.Button1Click(Sender: TObject);
var
  btWorkDrive: Byte;
  DiskFreeSize: Int64;
begin
    //硬碟空間不夠，小於5m則跳出不存囉
    btWorkDrive := Ord(UpperCase('C:\test\')[1])-64; //g_sTempPath
    DiskFreeSize := DiskFree(btWorkDrive);
    if (DiskFreeSize<>-1) and ((DiskFreeSize div (1024*1024)){MB}<40) then
      Exit;
end;

判斷作業系統是否為Windows XP SP2+

//判斷作業系統是否為Windows XP SP2+
function IsXPSP2Above():boolean ;
var
  vi:   _OSVERSIONINFO;
begin
  Result:=False;
  FillChar(vi, SizeOf(vi), 0);
  vi.dwOSVersionInfoSize := SizeOf(vi);
  Windows.GetVersionEx(vi);

  // 作業系統
  if      (vi.dwMajorVersion=5) and (vi.dwMinorVersion = 1) and (Pos('Service Pack 2', AnsiString(vi.szCSDVersion)) > 0) then Result:=True  //Windows XP SP2
  else if (vi.dwMajorVersion=5) and (vi.dwMinorVersion = 1) and (Pos('Service Pack 3', AnsiString(vi.szCSDVersion)) > 0) then Result:=True  //Windows XP SP3
  else if (vi.dwMajorVersion=5) and (vi.dwMinorVersion = 2) then Result:=True  //Microsoft Windows Server 2003, Windows XP 64
  //(vi.dwMajorVersion=5) and (vi.dwMinorVersion = 0) Microsoft Windows 2000
  else if (vi.dwMajorVersion>5) then Result:=True;    //Vista+
end;

判斷是否有安裝Access趨動

uses Registry;

function IsInstallAccessDatabaseEngine: boolean;
var
  reg:          TRegistry;
begin
  Result := False;
  reg:=TRegistry.Create;
  try
    reg.RootKey:=HKEY_LOCAL_MACHINE;
    if (Reg.OpenKeyReadOnly('SOFTWARE\Classes\Microsoft.ACE.OLEDB.12.0')) or
      (Reg.OpenKeyReadOnly('SOFTWARE\Wow6432Node\Classes\Microsoft.ACE.OLEDB.12.0')) then
      Result := True;
  finally
    reg.CloseKey;
    reg.Free;
  end;
end;

取得固定硬碟的序號

procedure TForm1.Button1Click(Sender: TObject);
var
  VolumeSerialNumber : DWORD;
  MaximumComponentLength : DWORD;
  FileSystemFlags : DWORD;
  TheSerialNumber : String;
  DR: Char;
  RootPath: PChar;
begin
  for DR := 'C' To 'Z' Do
  begin
    RootPath := PChar(DR + ':\');
    if (GetDriveType(RootPath) = DRIVE_FIXED) Then
    begin
      if GetVolumeInformation(RootPath,nil,0,@VolumeSerialNumber,
         MaximumComponentLength,FileSystemFlags,nil,0) then
      begin
        TheSerialNumber := IntToHex(HiWord(VolumeSerialNumber), 4) +
                            IntToHex(LoWord(VolumeSerialNumber), 4);
      end;
      memo1.Clear;
      memo1.Lines.Add( Format('固定磁碟序號：%s',[TheSerialNumber]) );
    end;
  end;
end;

刪除目錄下所有檔案

procedure DelTree(sPath: string);
var
  hFind: THandle;
  filename: string;
  fd: WIN32_FIND_DATA;
  bDelete: BOOL;
  i: Integer;

begin
  if sPath='' then
    exit;
  filename:=sPath+'\*.*';
  hFind:=Windows.FindFirstFile(PChar(filename), fd);
  if(hFind <> INVALID_HANDLE_VALUE) then
  begin
    while Windows.FindNextFile(hFind, fd) do
    begin
      filename:=fd.cFileName;
      if((filename = '.') or (filename = '..')) then
        Continue;
      if(fd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) > 0 then
      begin
        //子目錄
        DelTree(sPath+'\'+filename);
      end
      else
      begin
        //Full filename.
        filename:=sPath+'\'+filename;
        if(not SetFileAttributes(PChar(filename),
            FILE_ATTRIBUTE_NORMAL)) then
        begin
          //SaveLog('Set '+filename+' file attribute to normal error !');
        end;
        i:=0;
        bDelete:=DeleteFile(PChar(filename));
        while((i<5) and (not bDelete)) do
        begin
          Sleep(1000);
          bDelete:=DeleteFile(PChar(filename));
          Inc(i);
        end;
        if(not bDelete) then
        begin
          //SaveLog('Delete file '+filename+' error !');
        end;
      end;
    end;
    Windows.FindClose(hFind);
  end;
  if(not SetFileAttributes(PChar(sPath),
            FILE_ATTRIBUTE_NORMAL)) then
  begin
    //SaveLog('Set '+sPath+' directory attribute to normal error !');
  end;
  //SaveLog('Remove directory '+sPath);
  if(not RemoveDirectory(PChar(sPath))) then
  begin
    //SaveLog('Remove directory '+sPath+' error !');
  end;
  //SaveLog('CcyDelTree '+sPath+' completely.');
end;

取得PROGRAM FILES目錄位置

procedure TForm1.Button1Click(Sender: TObject);
begin
  With TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    if OpenKey('Software\Microsoft\Windows\CurrentVersion', False) then
      Caption := ReadString('ProgramFilesDir');
  finally
    Free;
  end;
end;

判斷作業系統

function GetOSVer: integer ;
var
  vi:   _OSVERSIONINFO;
begin
  Result:=osUnknow;
  FillChar(vi, SizeOf(vi), 0);
  vi.dwOSVersionInfoSize := SizeOf(vi);
  Windows.GetVersionEx(vi);

  if (Win32Platform=1) then begin
    if (Win32MinorVersion=0) then begin
      Result:=osWin95;
    end else begin
      Result:=osWin98;
    end;
  end else if (Win32Platform=2) then begin
    if (Win32MajorVersion=4) then begin
      Result:=osWinNT
    end else if (Win32MajorVersion=5) then begin
      if (Win32MinorVersion=0) then begin
        Result:=osWin2K;
      end else if (Win32MinorVersion=1) begin
        Result:=osWinXP;
      end else begin
        Result:=osVista;
      end;
    end;
  end;
end;
參考網址：
http://www.ge.net.tw/?q=node/919

讓程式不能重覆開啟

//專案檔最前面加上，1.檢查Mutex，若XMonitor已存在，則離開。
if ProgramAlreadyExists() then exit;

function ProgramAlreadyExists():boolean;
var
  hRunningForm: Thandle;
begin
  //g_hMutex:=CreateMutex(nil, False, 'X-Console');
  g_hMutex:=CreateEvent(nil, False, TRUE, 'X-Monitor');
  if (g_hMutex=0) OR (GetLastError()=ERROR_ALREADY_EXISTS) then //已存在
  begin
    hRunningForm := FindWindow(_XMONITOR_CLASS_NAME,nil);
    if hRunningForm<>0 then
    begin
      SetForegroundWindow(hRunningForm);
//      PostMessage(hRunningForm,WM_SYSCOMMAND,SC_MAXIMIZE,0);
    end;

    Result:=true;
  end
  else
    Result:=false;
end;

取得最上層的視窗名稱及程序名稱

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, psAPI, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    Label2: TLabel;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
function   GetProcessPath(PID   :   Integer):   String;   
var
  hProcess:   THandle;
  hMod         :   hModule;
  cbNeeded:   DWORD;
  szProcessName:   array[0..1024]   of   Char;
begin
  hProcess := OpenProcess(PROCESS_QUERY_INFORMATION   OR   PROCESS_VM_READ,
                                                  FALSE,   PID   );
  szProcessName := 'unknown';
  if (hProcess<>0) then
  begin
    if (EnumProcessModules(hProcess,@hMod,sizeof(hMod),cbNeeded)) then
    begin
      GetModuleFileNameEx(hProcess,hMod,szProcessName,sizeof(szProcessName));
      Result := StrPas(szProcessName);
    end;
  end;
  CloseHandle(hProcess);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  wnd : THandle;
  szText: array[0..254] of char;
  ThreadId:   DWORD;
  FileName:string;
begin
  wnd:= GetForegroundWindow;
  if wnd <> 0 then
  begin
    if GetWindowText(wnd, @szText, 255)>0 then
      Label1.caption := szText;

    GetWindowThreadProcessId(wnd, ThreadId);
    FileName:=GetProcessPath(ThreadId);
    Label2.caption :=FileName;
  end;
end;


procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Button1.Click;
end;

end.

取得磁碟剩餘空間

var
  g_sTempDriver : integer;
  DiskFreeSize : int64;
begin
  g_sTempDriver := Ord(UpperCase(g_sTempPath)[1])-64; //UpperCase(g_sTempPath)[1]某個槽
  DiskFreeSize := DiskFree(g_sTempDriver);

  //DiskFreeSize div 1024 = bytes

取得APP PATH

procedure TForm1.FormCreate(Sender: TObject);
begin
  caption := extractfilepath(ParamStr(0));
end;

CoreBoot系統改讀其路徑

uses Registry;

Function GetCoreBootValue : string;
var
  reg:TRegistry;
  skey : string;
begin
  Result := '';
  reg:=TRegistry.create;
  try
    reg.RootKey:=HKEY_LOCAL_MACHINE;
    skey:='SYSTEM\CurrentControlSet\Services\Coreboot';
    if reg.OpenKeyReadOnly(skey) then
    begin
      if(reg.ValueExists('CorebootEnable')) then
      begin
        if (reg.ReadInteger('CorebootEnable')=1) and (reg.ValueExists('CorebootDrive')) then
          Result:=Trim(reg.ReadString('CorebootDrive'));
      end;
      reg.closekey;
    end;
  finally
    reg.free;
  end;
end;

判斷工作管理員內的某個處理程序是否還存在

uses
    Tlhelp32;

function FindProc(ProcName: string): Boolean;   
var
    OK: Bool;
    hPL: THandle;
    ProcessStruct: TProcessEntry32;
begin
    Result := False;
    hPL := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
    ProcessStruct.dwSize := SizeOf(TProcessEntry32);
    OK := Process32First(hPL, ProcessStruct);
    while OK do
    begin
    if UpperCase(ProcessStruct.szExeFile) = UpperCase(ProcName) then
    begin
      Result := True;   
    end;
    OK := Process32Next(hPL, ProcessStruct);
    end;   
    CloseHandle(hPL);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if FindProc('bds.exe') then
  begin

  end;

end;



///////////////////new////////////
//加入process的數量判斷,若大於2,一定是重復執行囉~
function FindProc(ProcName: string): integer;
var
    OK: Bool;
    hPL: THandle;
    ProcessStruct: TProcessEntry32;
    i:integer;
begin
  i:=0;
  hPL := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
  ProcessStruct.dwSize := SizeOf(TProcessEntry32);
  OK := Process32First(hPL, ProcessStruct);
  while OK do
  begin
    if UpperCase(ProcessStruct.szExeFile) = UpperCase(ProcName) then
    begin
      i := i+1;
    end;
    OK := Process32Next(hPL, ProcessStruct);
  end;
  Result := i;
  CloseHandle(hPL);
end;

取得Windows的SessionID

windows xp的SessionID從0開始
windows vista的SessionID從1開始.0是給特殊權限如SYSTEM

function GetSessionId:DWord;
type _P2S=function (PId:DWORD; var SId:DWORD):BOOL; stdcall;
var P2S: _P2S;
    Hd :HMODULE;
    SId:DWord;
begin
  Result:=0;
  Hd:=LoadLibrary('Kernel32.dll');
  if Hd<>0 then begin
    @P2S:=GetProcAddress(Hd,'ProcessIdToSessionId');
    if Assigned(P2S) and P2S(GetCurrentProcessId,SId) then Result:=SId;
    FreeLibrary(Hd);
  end;
end;

寫網卡MAC到exe檔裡，並在程式開始時做判斷

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    Edit5: TEdit;
    Edit6: TEdit;
    Button1: TButton;
    Label1: TLabel;
    SaveDialog1: TSaveDialog;
    Button2: TButton;
    Edit7: TEdit;
    Button3: TButton;
    Label2: TLabel;
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
  DWordA  =array [0..7] of DWord;
  DWordP  =^DWordA;
  DWordB  =array [0..7] of Byte;
var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button2Click(Sender: TObject);
begin
  if SaveDialog1.Execute then
    Edit7.Text := SaveDialog1.FileName ;
end;

function UpdateExe(N:string; ChkL:DWord; ChkH:DWord):boolean;    // Write CRC to file
var
  Hd,i:integer;
  D,R:DWordB;    // $1E
begin
  Result:=False;
  DWordP(@D[0])[0]:=ChkL; //20處開始由低位元塞CRC資料 若為DWordP(@D[3])[0] 則是從21處開始塞
  DWordP(@D[4])[0]:=ChkH;

  if FileExists(N) then
  begin
    Hd:=FileOpen(N,fmOpenReadWrite); //開啟N
    FileSeek(Hd,$20,0);
    FileWrite(Hd,D[0],8); //從20開始寫入8個byte值
    FileSeek(Hd,$20,0);
    FileRead(Hd,R[0],8);
    //檢查
    Result:=TRUE;
    for i:=0 to SizeOf(D)-1 do
      if D[i]<>R[i] then
      begin
        Result:=False;
      end;
    FileClose(Hd);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  m1 : DWord;
  m2 : DWord;
begin
  m1 := (strtoint('$'+Edit1.Text) + strtoint('$'+Edit2.Text+'00') + strtoint('$'+Edit3.Text+'0000') + strtoint('$'+Edit4.Text+'000000')) xor $AE5C2DDA;
  m2 := (strtoint('$'+Edit5.Text) + strtoint('$'+Edit6.Text+'00')) xor $0000C1A3;
  UpdateExe(Edit7.Text, m1, m2);

end;

function ReadFileHeader(N:string;var Chk:DWordB):boolean;    // Write CRC to file
var
  Hd : integer;
  R : DWordB;    // $1E
begin
  Result:=False;
  if FileExists(N) then
  begin
    Hd:=FileOpen(N,fmOpenRead); //開啟N
    FileSeek(Hd,$20,0);
    FileRead(Hd,R[0],8);
    CHk := R;
    Result:=True;
    FileClose(Hd);
  end;
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] xor $DA, 2) + '-' +
         IntToHex(GUID1.D4[3] xor $2D, 2) + '-' +
         IntToHex(GUID1.D4[4] xor $5C, 2) + '-' +
         IntToHex(GUID1.D4[5] xor $AE, 2) + '-' +
         IntToHex(GUID1.D4[6] xor $A3, 2) + '-' +
         IntToHex(GUID1.D4[7] xor $C1, 2);
      end; 
    end; 
    FreeLibrary(Lib); 
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  R1: DWordB;    // $1E
begin
  ReadFileHeader(Edit7.Text, R1);
  Label1.Caption:=IntToHex(R1[0],2)+'-'+IntToHex(R1[1],2)+'-'+IntToHex(R1[2],2)+'-'+IntToHex(R1[3],2)+'-'+IntToHex(R1[4],2)+'-'+IntToHex(R1[5],2);
  Label2.Caption:=MacAddress;

  if not SameText(Label1.Caption, Label2.Caption) then
    application.Terminate ;
end;
end.