寫網卡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.

設定快捷鍵的方法

方法一：
用TActionList來管理

方法二：
安裝ElPack4元件
開到ELPack Tools，選擇ElSysHotKey元件
在其屬性ShortCut就可以修改快捷鍵
Enabled設為true
並在事件OnPress設定為欲執行的事件即可(如Button1.click;)

用訊號燈的方式，限制thread同時執行的數目

MainForm

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FSemaphor: THandle;
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
uses Unit2;
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
  FSemaphor := CreateSemaphore( nil, 3, 3, nil );
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
  CloseHandle( FSemaphor );
end;
procedure TForm1.Button1Click(Sender: TObject);
var
  aIndex: Integer;
  aExchange: TExchange;
begin
  for aIndex := 1 to 20 do
  begin
    if ( WaitForSingleObject( FSemaphor, INFINITE ) = WAIT_OBJECT_0 ) then
    begin
      aExchange := TExchange.Create( True, FSemaphor );
      aExchange.FreeOnTerminate := True;
      aExchange.Resume;
    end;
  end;
end;
end.

Thread

type
  TExchange = class(TThread)
  private
    { Private declarations }
    FSemaphor: THandle;
  protected
    procedure Execute; override;
  public
    constructor Create(CreateSuspended:Boolean; ASemaphor: THandle); reintroduce;
  end;
implementation
{ TExchange }
constructor TExchange.Create(CreateSuspended: Boolean; ASemaphor: THandle);
begin
  inherited Create( CreateSuspended );
  FSemaphor := ASemaphor;
end;
procedure TExchange.Execute;
begin
  while not Self.Terminated do
  begin
    Sleep( 10000 );
    Break;
  end;
  ReleaseSemaphore( FSemaphor, 1, nil );
end;

將組合字串還原存進TStringList陣列的方法

procedure GetSetData(CombinedStr:String;var sl:TStringList);
var
  s : String;
  p,l      : integer;
begin
  sl.Clear;
  l:=Length(CombinedStr);
  if l=0 then exit;
  p:=1;
  while p > 0 do
  begin
    p:=Pos(',,,',CombinedStr);
    if p > 0 then
    begin
      s:=Copy(CombinedStr,1,p-1);
      sl.Add(s);
      CombinedStr:=Copy(CombinedStr,p+3,Length(CombinedStr));
    end;
  end;
  if Length(CombinedStr) > 0 then
  begin
    sl.Add(CombinedStr);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  mysl : TStringList;
begin
  mysl := TStringList.Create;
  try
    GetSetData('oo,,,ertff,,,wett' ,mysl);
    caption := mysl[0]+'__'+mysl[1]+'__'+mysl[2];
  finally
    mysl.Free;
  end;
end;

如何讓Button上的文字顯示二行以上

首先將Button1屬性WordWrap設為true
方法1：
在Object Inspector去點兩下修改Button的Caption，
記得使用Ctrl+Enter來換行喔!!

方法2：
接下來按ALT+F12去編輯dfm的檔案
去搜尋到Button1的caption去編輯
如：
'AAA'+#13#10+'BBB'

UpperCase轉中文字時會出現錯誤的問題

可用UpperCaseEx來取代UpperCase函數

function UpperCaseEx(const S: string): string;
var
  Ch: Char;
  L: Integer;
  Source, Dest: PChar;
  nH: Integer;
begin
  L := Length(S);
  SetLength(Result, L);
  Source := Pointer(S);
  Dest := Pointer(Result);
  nH := 0;
  while L <> 0 do
  begin
    Ch := Source^;
    if nH = 0 then
      if Ord(ch) >= 128 then
        nH := 2;
    if nH > 0 then
      Dec(nH)
    else
      if (Ch >= 'a') and (Ch <= 'z') then Dec(Ch, 32);
    Dest^ := Ch;
    Inc(Source);
    Inc(Dest);
    Dec(L);
  end;
end;

多國語言讀入字串後要注意的事

Label屬性設定
AutoSize=False
Height=20
Layout=tlcenter
ParentFont=false
TransParent=true
Button屬性設定
ParentFont=true

  // caption及Label要設定為螢幕字型及語言，Button不同，會依照form來決定字型
  self.Font.Name          := Screen.MenuFont.Name;
  self.Font.Charset       := Screen.MenuFont.Charset;
  Caption := _sArray[_L_ExportCaption];

  Label1.Font.Name    :=Screen.MenuFont.Name;
  Label1.Font.Charset :=Screen.MenuFont.Charset;
  Label1.Caption := _sArray[_L_ExportPleaseSel];

截取當前的視窗(不是全螢幕)

procedure TForm1.Button1Click(Sender: TObject);
var
  HWND:THandle;
  dc:HDC ;
  rect:TRect ;
  dest:TBitmap;
  jpg :TJpegImage;
  w, h : integer;
begin
  HWND:=handle;
  GetWindowRect(HWND,rect);
  dc:=GetWindowDC(HWND);
  dest := TBitmap.Create;
  jpg :=  TJpegImage.create;
  w := rect.Right-rect.Left;
  h := rect.Bottom-rect.Top;
  dest.Width := w;
  dest.height := h;
  try
    BitBlt(dest.canvas.handle,0,0,w,h,dc,0,0,SRCCOPY );
    jpg.Assign(dest);
    jpg.CompressionQuality:=100;
    jpg.JPEGNeeded;
    jpg.Compress;
    jpg.SaveToFile('c:\1.jpg');
  finally
    ReleaseDC(HWND,dc);
    jpg.free;
    dest.Free;
  end;
end;

開始寫Delphi程式要注意的事

Project -> options > Compiler -> Code generation -> 取消勾選Optimization
Tool -> Environment Options -> Delphi Direct -> 取消勾選Automatically poll network

Form 屬性scaled設成false 屬性設字型大小建議用Height

主視窗隱藏

Application.ShowMainForm := False;

隱藏主視窗窗體

Application.ShowMainForm := False;

UTC跟LocalTime

var
  g_dtTimeZoneInfo:TIME_ZONE_INFORMATION ;
function GetTimeZoneInfo():boolean ;//取得utc時間
begin
  Result := (TIME_ZONE_ID_INVALID<>GetTimeZoneInformation(g_dtTimeZoneInfo) ) ;
end ;
function LocalTimeToUTC(const dtLocalTime: TDateTime) : TDateTime ;
begin
  Result := IncMinute(dtLocalTime, g_dtTimeZoneInfo.Bias ) ;
end ;

function UTCToLocalTime(const dtUTC: TDateTime) : TDateTime ;
begin
  Result := IncMinute(dtUTC, -g_dtTimeZoneInfo.Bias ) ;
end ;

function UTCNow(): TDateTime;
var
  st: SYSTEMTIME;

begin
  GetSystemTime(st);
  Result:=SystemTimeToDateTime(st);
end;
//---------------------------------------------------------------------------

function UTCDate(): TDateTime;
var
  st: SYSTEMTIME;

begin
  GetSystemTime(st);
  Result:=EncodeDate(st.wYear, st.wMonth, st.wDay);
end;