使用sharememory方式在各程式之間傳送參數

//宣告部分，寫入及讀取端程式都要有
const
  _SMWithXMonitorPolicy             =   'XFortMonitorPolicy';

type
  TCmdDataWithMonitorPolicy  =   record    //  policy
    btData1:                    Byte;    //壓縮率
    btData2:                    Byte;    //縮放率
    btData3:                    Byte;    //
    boolData1:                  Boolean;   //是否抓完整圖   ?
    boolData2:                  Boolean;
    boolData3:                  Boolean;
    dwData1:                    DWORD;   //錄影間隔時間(秒)   ?
    dwData2:                    DWORD;   //影像長度(pixel) ?
    dwData3:                    DWORD;   //影像寬度(pixel)  ？
    dwData4:                    DWORD;
    dwData5:                    DWORD;
    dwData6:                    DWORD;
    intData1:                   Integer; //sessionid
    intData2:                   Integer; //usrid
    intData3:                   Integer; //port
    intData4:                   Integer; 
    intData5:                   Integer;
    int64Data1:                 Int64;
    int64Data2:                 Int64;
    dtDateTimeData1:            TDateTime; // Double(8 bytes)
    dtDateTimeData2:            TDateTime;
    ptData1:                    Pointer;
    ptData2:                    Pointer;
    strData1:                   array [0..511] of Char; //IP
    strData2:                   array [0..511] of Char; //擷取端電腦名稱
    strData3:                   array [0..511] of Char;
    strData4:                   array [0..511] of Char;
    strData5:                   array [0..511] of Char;
  end;
  PCmdDataWithMonitorPolicy  =   ^TCmdDataWithMonitorPolicy;


public
    g_hShareMemPolicy       :Thandle;
    g_pShareMemPolicy       :Pointer;

//一端的create須先建立起sharememory
create
  g_hShareMemPolicy := CreateFileMapping(
    $FFFFFFFF,                    // Shared memory File，Handle 傳入 $FFFFFFFF
    nil,                          // 不設定安全屬性
    PAGE_READWRITE,               // 存取模式設定為可讀寫以便行程交換資料
    0,                            // 使用 paging file 時一般將之設為零
    SizeOf(TCmdDataWithMonitorPolicy), // 共享記憶體的大小 2048bytes
    _SMWithXMonitorPolicy);             // 其他的行程將以此名稱參考到選擇共享記憶體

  //MapViewOfFile函數返回一個指向共用記憶體塊的在該程式記憶體空間中有效的指標
  g_pShareMemPolicy :=MapViewOfFile(
    g_hShareMemPolicy ,                  // File-mapping object 的 Handle 值
    FILE_MAP_ALL_ACCESS,          //設為 FILE_MAP_ALL_ACCESS 開放存取
    0,
    0,
    //0);                         // 映射回來的 byte 數
    SizeOf(TCmdDataWithMonitorPolicy));

//將資料寫入sharememory中
procedure TFormMain.Button1Click(Sender: TObject);
begin
  PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.btData1 := 100;  //壓縮率
  PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.btData2 := 90;   //縮放率


  PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.intData1 := 5;   //sessionid
  PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.intData2 := 33;   //usrid
  PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.intData3 := 24137;   //port

  //IP
  FillChar(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.strData1,SizeOf(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.strData1),0);
  StrCopy(PCmdDataWithMonitorPolicy(g_pShareMemPolicy).strData1, PCHAR('10.1.0.3'));

  //擷取端電腦名稱
  FillChar(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.strData2,SizeOf(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.strData2),0);
  StrCopy(PCmdDataWithMonitorPolicy(g_pShareMemPolicy).strData2, PCHAR('Yivon'));
end;

//讀取sharememory資料
procedure TForm1.Button2Click(Sender: TObject);
var
  piRes :^Integer;
  sTmpFileName : string;
begin
  g_hShareMemPolicy := OpenFileMapping(
    FILE_MAP_ALL_ACCESS,            // Shared memory File，Handle 傳入 $FFFFFFFF
    true,
    _SMWithXMonitorPolicy);             // 其他的行程將以此名稱參考到選擇共享記憶體
  if g_hShareMemPolicy <> 0 then     //判斷這一塊SHAREMEMORY有無配置
  begin
    g_pShareMemPolicy:=MapViewOfFile(
      g_hShareMemPolicy,                  // File-mapping object 的 Handle 值
      FILE_MAP_ALL_ACCESS,          //設為 FILE_MAP_ALL_ACCESS 開放存取
      0,
      0,
    //0);                         // 映射回來的 byte 數
      SizeOf(TCmdDataWithMonitorPolicy));

    Memo1.Lines.add('壓縮率：'+inttostr(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.btData1));
    Memo1.Lines.add('縮放率：'+inttostr(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.btData2));
    Memo1.Lines.add('SessionID：'+inttostr(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.intData1));
    Memo1.Lines.add('usrid：'+inttostr(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.intData2));
    Memo1.Lines.add('Port：'+inttostr(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.intData3));
    Memo1.Lines.add('IP：'+String(PCmdDataWithMonitorPolicy(g_pShareMemPolicy).strData1));
    Memo1.Lines.add('CapComputerName：'+String(PCmdDataWithMonitorPolicy(g_pShareMemPolicy).strData2));
  end;
end;

初始化ADOConnection函數

procedure TRecUIControl.InitADOConnectionBeginTrans(ADOConnBatchTrans: TADOConnection);
begin
  // 設定ADOConnBatchTrans物件所需參數
  with ADOConnBatchTrans do
  begin
    CommandTimeout   := 300;
    //ConnectOptions   := coAsyncConnect;        // The connection is formed asynchronously
    CursorLocation   := clUseServer;           // Connection is client-side
    LoginPrompt      := False;                 // Don't show the login dialog when connecting to a database
    Provider         := 'SQLOLEDB.1';          //
    ConnectionString := frmMain.ADOConnection1.ConnectionString;  // 取主程式的ConnectionString
  end;
end;

big problem

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

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;

開啟chm某個關聯的位置網頁

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function HtmlHelpA (hwndcaller:Longint; lpHelpFile:string; wCommand:Longint;dwData:string): HWND;stdcall; external 'hhctrl.ocx'
procedure ShowChmHelp(sTopic:string);
var
  i : integer;
begin
  i:=HtmlHelpA(Application.Handle,Pchar('c:\windows.chm'), 0, sTopic);
  if i=0 then
  begin
    showmessage(' help.chm幫助文件損壞！');
    exit;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  tmp : integer;
begin
  tmp := 10100;
  case tmp of
    10100: ShowChmHelp('Win32GDI/15.htm');
    10101: ShowChmHelp('edtInput.htm');

    else  ShowChmHelp('default.htm');
  end;
end;

end.

StrToDate可能會發生not a valid date

這是因為控制台->地區選項->日期分隔字元或型式有改變。
這是你須用程式去設定其地區選項設定

//設定日期格式為 yyyy/MM/dd
SetLocaleInfo(LOCALE_SYSTEM_DEFAULT, LOCALE_SSHORTDATE, 'yyyy/MM/dd') ;

//設定日曆格式為1 型式
SetLocaleInfo(LOCALE_SYSTEM_DEFAULT, LOCALE_ICALENDARTYPE, '1') ;

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

判斷磁碟機是否有效

可判斷磁碟機，如A槽或光碟槽是否有效

function ValidDrive( driveletter: Char ): Boolean;
var
  mask: String[6];
  sRec: TSearchRec;
  oldMode: Cardinal;
  retcode: Integer;
begin
   oldMode :=SetErrorMode( SEM_FAILCRITICALERRORS );
   mask:= '?:\*.*';
   mask[1] := driveletter;
   {$I-}  { don't raise exceptions if we fail }
   retcode := FindFirst( mask, faAnyfile, SRec );
   if retcode = 0 then
     FindClose( SRec );
   {$I+}
   Result := Abs(retcode) in
     [ERROR_SUCCESS,ERROR_FILE_NOT_FOUND,ERROR_NO_MORE_FILES];
   SetErrorMode( oldMode );
end; { ValidDrive }