程式學: 10月 2007

星期一, 10月 29, 2007

複製程序(procedure)或函式(function)的程式碼後，在private能自動產生的方法

在程序名或函式名上(不用圈選)按右鍵，選擇complete class at cursor即可。

例外處理

Object Pascal定義了許多例外類別，在Delphi中，類別幾乎都以T開頭，但例外類別卻大部分是E開頭，例如：EDateTimeError, EConvertError,EDivByZero,ERangeError等，所有例外皆繼承自Exception 類別。

要在Delphi中在設計階段能使用 Exception的功能，須先設定下列步驟：

主選單 ==> Tools ==> Debugging Options...
==> Language Exceptions標籤頁中的 Stop on Delphi Exceptions 的勾勾取消即可。

try ... except ... 的範例：


try
  保護的指令
except
  有例外發生時，要如何處理
end;

為何要 try ... except ... ，其目的在於"保護的指令"該區段若有任何的錯誤，不希望造成系統的停止運作，而是將運作的流程直接跳到 except區段，由該區段來執行錯誤排除的工作。

範例一


procedure TForm1.Button1Click(Sender: TObject);
var
  d: Tdatetime;
  i,j: integer;
begin
  try
    d:= strtodatetime(edit1.Text);
    i:= strtoint(edit2.text);
    j:= strtoint(edit3.text);
    i:= i div j;
    edit2.Text:= inttostr(i);
  except
    on EDivByZero do showmessage('除以零的錯誤');
     //可以自訂錯誤訊息
    on Econverterror do showmessage('型態轉換錯誤');
    on e:Exception do   //超過一行的指令需用begin...end; //任何變數名稱都可以，不一定要e，在此為臨時的變數名稱。 Exception為所有例外處理的老祖宗
      showmessage('系統訊息： ' + e.Message);
  end;
end;

自製的 raise Exception型態，程式設計者可以自訂錯誤訊息，並將例外的情形集中處理


interface
type
   EMyException=class(Exception); //自訂的錯誤型態

begin
  try
    i:= strtoint(edit1.Text);
    j:= strtoint(edit2.Text);
    if i < 10 then
      raise EMyException.Create('edit1 值小於 10')
    else if i > 100 then
      raise EMyException.Create('edit1 值大於 100');
    edit2.Text:= inttostr(i div j);
  except
    on e:EMyException do showmessage(e.Message);
           //自訂的exception會自動移除，不須自己寫指令清除 e.destroy
    on ee:Exception do showmessage('系統錯誤訊息:' + ee.Message);
  end;
end;

Try ... Finally ... end;
目的為了保護系統的資源以便在完成工作後釋放原先所取得的資源，在Delphi中以下的資源通常需要下指令去取得，也需要下指令去釋放 Files，Memory，Windows resources (VCL only)，Objects等。

格式如下


{ 取得資源的指令}
try
  { 利用該資源的相關指令}
finally
  { 最後須釋放相關資源}
end;

範例：
以下範例取得之記憶體的資源將無法正常的釋放，造成你在寫成程式，記憶體愈來愈少。


procedure TForm1.Button1Click(Sender: TComponent);
var
  APointer: Pointer;
  AnInteger, ADividend: Integer;
begin
  ADividend := 0;
  GetMem(APointer, 1024); // 要求 1K 的記憶體容量
  AnInteger := 10 div ADividend; //若在此發生錯誤，則下列的釋放資源的工作將無法做到
  FreeMem(APointer, 1024);
end;
}
//修改成下列方式，其意義就是不管 div的指令有無錯誤，皆須執行 finally內之指令，即釋放記憶體freemem。

procedure TForm1.Button1Click(Sender: TComponent);
var
  APointer: Pointer;
  AnInteger, ADividend: Integer;
begin
  ADividend := 0;
  GetMem(APointer, 1024); { allocate 1K of memory }
  try
    AnInteger := 10 div ADividend; { this generates an error }
  finally
    FreeMem(APointer, 1024); { execution resumes here, despite the error }
  end;
end;

except 與 finally 合併使用
語法如下：


try
  try
    statement1;
    statement2;
    ...
  except
    on E:except do ...//進行例外處理
  end;
finally
  statement_n;  //釋放系統資源
end;

範例：


procedure TForm1.Button1Click(Sender: TObject);
var
  i,j: integer;
begin
  try
    try
      i:=strtoint(edit1.text);
      j:=strtoint(edit2.text);
      i:= i div j;
      edit1.text:= inttostr(i);
    except
      on E:Exception do
        showmessage(E.message);
    end;
  finally
    showmessage('finally 這一段一定會做(釋放系統資源)');
  end;
end;

Global exception handeling(一般不建議，因為太多的exception，會更亂)
如果希望將所有的 Exception 統一在副程式中處理，可以利用 Application.onException的屬性，將應用程式中所有的例外狀況，交由同一段指令來處理。

使用步驟如下：


//1. 宣告處理Exception的程序名稱，例如MyExceptionHandler
{ Public declarations }
procedure MyExceptionHandler(Sender : TObject; E : Exception );

//2. 定義 Exception Handler於 implementation區，例如：
procedure TForm1.MyExceptionHandler(Sender : TObject; E : Exception );
var
  wRetVal : Word;
begin
  wRetVal := MessageDlg('錯誤訊息: ' + E.Message, mtError, mbAbortRetryIgnore,0);
  case wRetVal of
    mrAbort:
    begin
      { handle "Abort" here... }
    end;
    mrRetry:
    begin
      { handle "Retry" here... }
    end;
    mrIgnore:
    begin
      { handle "Ignore" here... }
    end;
    else
    begin
      { handle "other" action here...}
    end;
  end;
end;

//3. 指定應用程式的Exception將集中至 MyExceptionHandler管理
procedure TForm1.FormCreate(Sender: TObject);
begin
  { begin new code }
  Application.OnException:=MyExceptionHandler;
  { end new code }
end;

巢狀式(分層次)的例外處理


try //第一層的保護區塊起點
  statement...;

  try //第二層的保護區塊起點
    statement...;
  except //第二層的例外處理程式
    statement...;
  end;
    ...
except //第一層的例外處理
  on e:Exception do ...
end;

物件 : 多型(三)

『多型性』基本上就是一種樣式多種呈現的方式，或者說同一件事情有兩種以上的解釋。

例如在C++中 I = J + K 其中的 "+" 可能會因 J 及 K 的形態不同而有許多種不同的意義。
例如生物的覓食 Eat() 具有多種不同的定義。
例如每個人對賺錢 make_money() 皆有不同的方法。
Polymorphism可以做到軟體元件的Plug and Play 。

現代的OOP compiler(如C++，Java，object pascal) 皆支援 virtual function以完成 polymorphism 的機制。

polymorphism 的方式可以用 overloading 或 overriding 來解釋。

所謂 overloading上一章已經提過，主要就是同一個副程式的名稱，呼叫是依據輸入引數的型態或輸入引數的數量來決定，執行哪一個副程式。

而 overriding則是與繼承性有關，任何父類別中的副程式，若宣告為 virtual或 dynamic則可以被子類別的副程式所覆蓋 (指用override的指令)。如果父類別的副程式不想實現真正的程式碼，則須在加上宣告 abstract。

overriding只對 virtual 或 dynamic的副程式有效，所以任何要做 overriding皆須在宣告的後面加上 virtual 或 dynamic，不加的話是屬於 static 的副程式(一般 function 或 procedure 預設為 static)，無法 overriding。

其中 virtual method可以有較快的執行速度，而 dynamic method可以有較小的程式碼，一般來說 virtual method將較為有效率。

polymorphism 更重要的是父類別的功能可以由子類別來取代，如此在執行階段，將會非常有彈性地，我們由下列程式範例來說明。

5個class類別TFigure、TCircle、TPolygon、TSquare及TTriangle。
TCircle及TPolygon繼承Tfigure。TSquare及TTriangle繼承TPolygon。


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;
type
   TFigure = class
   public
    procedure draw;virtual;abstract; //若要做overridding則用virtual;否則用abstract
       // 宣告 abstract所以不須實作TFigure.draw之程式碼
       // virtual亦可使用 dynamic，一般來說virtual要較大的記憶體空間，但效率較好，dynamic則較小的記憶體空間，但效率較差
end;
type
   TCircle = class(TFigure)
   public
    procedure draw;override;

end;
type
   TPolygon = class(TFigure)
   public
    procedure draw;override;
    procedure static_draw;
end;
type
   TSquare = class(TPolygon)
   public
    procedure draw;override;
end;
type
   TTriangle = class(TPolygon)
   public
    procedure draw;override;
    procedure static_draw;

end;
var
   Form1: TForm1;
implementation
{$R *.dfm}
procedure TCircle.draw;
begin
   showmessage('TCircle');
end;
procedure TPolygon.draw;
begin
   showmessage('TPolygon');
end;
procedure TSquare.draw;
begin
   showmessage('TSquare');
end;
procedure TTriangle.draw;
begin
   showmessage('TTriangle');
end;


procedure TPolygon.static_draw;

begin
   showmessage('static function -- polygon draw');

end;
procedure TTriangle.static_draw;

begin
   showmessage('static function -- triangle draw');

end;
procedure TForm1.Button1Click(Sender: TObject);
   var F: array[0..3] of TFigure;
   i: integer;
   p1: Tpolygon;

begin
   F[0]:=TCircle.Create;
   F[1]:=TPolygon.Create;
   F[2]:=TSquare.Create;
   F[3]:=TTriangle.Create;
   for i:=0 to 3 do
     F[i].draw;      // 所謂的一種樣式多種表現形式
   for i:=0 to 3 do  // 釋放物件之記憶體，或可用 F[i].destroy;
     F[i].Free;      // 但 Free會先判斷是否有有被建立物件
  
//測試static function 與 virtual function 或 dynamic function之差異
   p1:= TTriangle.create;
   
   p1.static_draw; // 雖然p1由TTriangle所建立，仍靜態連結到Tpolygon
   Ttriangle(p1).static_draw;  //須強制轉態方能執行Ttriangle中的static_draw函數
   p1.draw;  // 這個會執行Ttriangle的draw，由此可了解virtual(dynamic)與static之差異

             // 多型的功能須藉由virtual或dynamic function方能達到
   p1.free;
end;
end.


type
  TFirstComponent = class(TCustomControl)
    procedure Move; { static method}
    //procedure Move; abstract; {不想定義實做寫}
    procedure Flash; virtual; { virtual method}
    procedure Beep; dynamic;  {dynamic virtual method}
  end;

  TSecondComponet = class(TFirstComponent)
    procedure Move; //可重新定義，但不用寫overrides
    procedure Flash; override;  {overrides inherited method}
    procedure Beep; override;  {overrides inherited method}
  end;

物件 : 繼承性(二)

1. unit1有Tc1及Tc2類別，Tc2類別是繼承Tc1，因屬同一個unit底下，所以所有的屬性(public、private及protected)皆可以被呼叫。

2. unit2若單純uses unit1的話，Tc1類別的public，Tc2類別的public，及Tc類別所繼承父的public。

3. unit2有Tc3類別，其為繼承Tc2，則只能呼叫public及protected，但是不能呼叫private。在此須注意uses要放在interface裡，不能放在implementation裡。

uint1.pas


unit Unit1;
interface
uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
type
   TForm1 = class(TForm)
   procedure FormCreate(Sender: TObject);
   private
   { Private declarations }
   public
   { Public declarations }
end;
type
   Tc1 = class
   public
     public_c1: string;
   private
     private_c1: string;
   protected
     protected_c1: string;
end;
type
   Tc2 = class(Tc1)
   public
     public_c2: string;
   private
     private_c2: string;
   protected
     protected_c2: string;
end;
var
   Form1: TForm1;
   c2: Tc2;
   c1: Tc1;
implementation
uses Unit2;
{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
   c2 := Tc2.Create;
   c2.public_c2:='a';
   c2.private_c2:='b';
   c2.protected_c2:='c';
   c2.public_c1:='d';  //都可以存取，主要是繼承Tc1
   c2.private_c1:='e';
   c2.protected_c1:='f';
   c1 := Tc1.Create;
   c1.public_c1:='aa';
   c1.private_c1:='bb';
   c1.protected_c1:='cc';
 // 各位要觀察的是 c2或c1物件按下.的時候可以下拉哪些 function
end;

end.

uint2.pas


unit Unit2;
interface
uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls, unit1;

//因為要繼承 Tc2，所以引用的 unit1 單元須寫在 class type的宣告之前，所以須
//寫在 interface 區
type
   TForm2 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
end;
type
   Tc3= class(Tc2)  //因為在interface 就需要Tc2，所以unit1要寫在interface上面喔
   public
     public_c3: string;
   private
     private_c3: string;
   protected
     protected_c3: string;
end;
var
   Form2: TForm2;
implementation
//uses Unit1;   //不能寫implemetation後面
{$R *.dfm}
procedure TForm2.Button1Click(Sender: TObject);
begin
 // 只有 public 區的資料可以被讀取
   c1.public_c1:='a';
   c2.public_c1 :='b';
   c2.public_c2 := 'c';
end;
procedure TForm2.Button2Click(Sender: TObject);
 var c3: Tc3;
begin
   c3:= Tc3.Create;
   c3.public_c3 := 'a';
   c3.private_c3:= 'a';
   c3.protected_c3:= 'a';

   c3.public_c2:= 'a';
   c3.protected_c2:= 'a';

   c3.public_c1 := 'a';
   c3.protected_c1:= 'a';
// 有沒有發現Tc2及Tc1內的private變數無法經由繼承的方式來讀取，
// 但是protected 的資料卻可存取
// 記得如果是Tc2與Tc3在同一個 unit，則 private 變數仍可存取

end;
end.

有繼承的類別，若有與父類別相同的程序(屬性)則將會覆蓋掉父類別的程序(屬性)


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;
type
   Tc1 = class
   public
     public_c1: string;
     procedure public_p1;
   private
     private_c1: string;
   protected
     protected_c1: string;
end;
type
   Tc2 = class(Tc1)
   public
     public_c2: string;
     procedure public_p1;
     procedure public_p2;
   private
     private_c2: string;
   protected
     protected_c2: string;
end;
var
   Form1: TForm1;
   c2: Tc2;
   c1: Tc1;
implementation
uses Unit2;
{$R *.dfm}
procedure Tc1.public_p1;
begin
  showmessage('Tc1.p1');
end;

procedure Tc2.public_p1;
begin
  showmessage('Tc2.p1');
end;

procedure Tc2.public_p2;
begin
  showmessage('Tc2.p2');
end;

procedure TForm1.Button1Click(Sender: TObject);
var c1:Tc1;
    c2:Tc2;
begin
  c1:=Tc1.create;
  c2:=Tc2.Create;
  c1.public_p1; //Tc1.p1
  c2.public_p1; //Tc2.p1   有相同的子類別會覆蓋掉父類別的程序(屬性)
  c2.public_p2; //Tc2.p2
end;

end.

物件 : 設計與封裝性(一)


type  TMyClass = class(被繼承的類別) //若class後面不寫，則是繼承TObject(class的老祖宗)
   Button1: TButton;   // 不寫，置放VCL 物件，此為published 區
   Edit1: TEdit;
   procedure Button1Click(Sender: TObject);
   private
     ... { private declarations here}
   protected
     ... { protected declarations here }
   public
     ... { public declarations here }
   published
     ... { published declarations here }
end;

public --- 不管同一單元或不同單元皆可存取，只要有引用皆可存取。
private --- 僅限於同一單元的可以存取，此點與 C++不同，在 C++ 中 private 的存取須同一個 class。
protected --- 僅限於繼承父類別的子子孫孫，方可以存取，不限制是否在同一個單元。
published --- 除了具有 Run-time Type Information (RTTI)的功能外，與 public 的功能完全相同。
RTTI 為了增加整個程式的生產力的東西，就像是設計階段已把元件屬性改掉，但執行階段想把剛設定的屬性值，靠RTTI幫你載入剛設定屬性的檔案。


unit Unit1;

interface

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

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

type
   Tmyclass = class (Tobject)  // 或 Tmyclass = class 自動繼承了Tobject
   private
     a: integer;
     b: string;
   public
     c: integer;
     procedure showData();
     property pa: integer write a; //權限管理 pa虛擬變數可以寫入a
     property pb: string read b; //權限管理 pb虛擬變數可以讀取b
     property pc: string read b write b; //權限管理 pc虛擬變數可以讀取b寫入b
  end;
var
  Form1: TForm1;
  myObj: Tmyclass; //定義在此，別的unit也可以讀得到，但若建立在implementation別的unit就讀不到囉
implementation

{$R *.dfm}
procedure Tmyclass.showData();
begin
  showmessage(b);   
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  myObj := Tmyclass.create; //非視覺化的物件，記得要自己把它建立物件實體
  myObj.pa := 12;                  // OK
  //myObj.pb := 'ab';                // 不行，因為 readonly
  showmessage( myObj.pb );         // OK因為可讀
  myObj.pc:='12';                    // OK，因可讀可寫
  showmessage(myObj.pc); // OK

  //myObj.a:=12;   　　//private變數，在相同的unit下可讀取，

  //myObj.b:='abc';　　//不同的unit下不可讀取,可透過public 區的property變數pc來讀取

end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  myObj.Free; //若物件有被建立則移除掉，若沒有，則不做動作，用此方式比較好
  myObj.Destroy; //暴力移除掉物件，可能會有問題
end;
end.

第一步：設計類別 ( 例子中沒有視覺化物件 )
類別內的成員有三種：(1) Field (2) Method (Function或 Procedure) (3) Property
Field: 就是定義在 class 內的變數
Method: 定義在 class 內的 procedure 或 function
Property: 針對現有 Field 增加存取的屬性

第二步：建立物件,依據類別所建立的實體

成員的存取
類別內 private 區的資料在同一個 unit 內的函數皆可存取，但在不同的 unit 內則不能存取。
(就像 implementation區內的資料)
類別內 pubilc 區的資料在同一個或不同的 unit 內的函數，只要有uses該單元皆可存取。
(像 interface 區內的資料)
記得物件本身的存取仍受到位於 interface 區或 implemenation 區的規範。

建構子 constructor 及解構子 destructor //像是unit的initialization
建構子宣告方式 constructor create; //像是unit的finalization
解構子宣告方式 destructor destroy;
以下為完整的範例，先建立一個Form使用兩個Buttons


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;
type Tc=class
   public
   a: integer;
   constructor create;
   destructor destroy;
   private
end;
var
   Form1: TForm1;
   obj: Tc; 
   s: string;
implementation
{$R *.dfm}
constructor Tc.create; //當物件被create就會執行
begin
   s:='object created';
end; 
destructor Tc.destroy;
begin
   s:='object destroyed';
end; 
procedure TForm1.Button1Click(Sender: TObject);
begin
   obj:= Tc.create;
   showmessage(s);end;
procedure TForm1.Button2Click(Sender: TObject);
begin
   obj.destroy;
   showmessage(s);
end;

end.

變數存取空間

1. 副程式內的變數，僅對函數內的存取有效，即可視空間為整個副程式。
如：


procedure p1; //procedure及function皆為副程式
var i:interger;//i僅對函數內的存取有效
begin
 ...
end;

2. unit 內的變數 (不管在 interface 或 implementation區) ，其可視空間為整個 unit，如果變數或副程式定義於interface 區，則其他 unit 亦可存取(但須用uses去引用)，若定義於 implementation 區則可視空間僅在該 unit 內。
如：


unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;
type
  TForm1 = class(TForm)
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
  j:integer; //屬於interface，其他 unit 亦可存取(但須用uses去引用)
implementation
{$R *.dfm}
var i:integer; //屬於implementation，其他unit不可存取。並記得在此的變數要定義在最前(副程式前)，如此副程式才能讀到此變數
end.

3. 同一個變數名稱不能在 interface 區宣告，但又在 implementation 區宣告。

4. 同一個副程式名稱，如果要其他程式單元可以引用，則須在 interface 有所宣告，否則只須在 implemention區宣告並定義實體的副程式內容。
如：


unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;
type
  TForm1 = class(TForm)
  private
    { Private declarations }
  public
    { Public declarations }
  end;
procedure p1; //宣告
var
  Form1: TForm1;
implementation
{$R *.dfm}
procedure p1; //在implemetation定義的副程式要給別的unit使用，則要宣告在interface裡
begin
 ...
end;
end.

5. 變數的引用，以距離最近為存取原則，若相同的變數，函數內有定義，則存取函數內之值，若無，存取 class內所定義之值，若 class內無此變數，則存取該 unit 內之變數，若該 unit 內無此變數，則可存取所引用的其他單元之變數值，如果引用的許多的單元中，皆有定義此變數，則以先引用的單元為主。
如：


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    i : integer; //第二優先讀取Form(class)
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  i : integer; //第三優先讀取interface(因與implementation宣告的變數不能相同)
implementation

{$R *.dfm}
var i : integer; //第三優先讀取unit(因與imterface宣告的變數不能相同)

procedure TForm1.Button1Click(Sender: TObject);
var i : integer; //第一優先讀取副程式
begin
  ...
end;

6. 定義於 class 內的變數及副程式，除了受到位於 interface 區或 implemenatation 區的影響外，仍須受到 class 封裝特性 public，private，protected，published 的規範。
public --- 不管同一單元或不同單元皆可存取，只要有引用皆可存取。
private --- 僅限於同一單元的可以存取，此點與 C++不同，在 C++ 中 private 的存取須同一個 class。
protected --- 僅限於繼承父類別的子子孫孫，方可以存取，不限制是否在同一個單元。
published --- 除了具有 Runtime Type Information (RTTI)的功能外，與 public 的功能完全相同。
如：


type
  TForm1 = class(TForm)
  private
    i : integer;
    { Private declarations }
  public
    j : integer;  //別的unit，有use到就可以讀到
    { Public declarations }
  end;

星期五, 10月 26, 2007

集合

集合型態的宣告

type Tmyset = set of 基本型態;

其中基本型態，指的是序數型態(ordinal)，且個數不得大於256 (0 到 255)。

範例：


type
  T1=1..10;
  T2= (Red, Yellow, Green);
  T3='A'..'F';
  Tset1 = set of T1;
  Tset2 = set of T2;
  Tset3 = set of T3;

var
  a: Tset1;
  b: Tset2;
  c: Tset3;

或簡化為


var 
  a: set of 1..10;
  b: set of (Red, Yellow, Green);
  c: set of 'A'..'F';

下列範例超過256將有錯誤產生


var
  d: set of integer;
  e: set of real;
  f: set of string;
  g: set of char;

集合的設定


a:= [1,2,3];
b:=[Red, Green];
c:[A,D];

集合的運算

+, - , * , <=, >= , = , <>, in

數獨

新增一個TButton並點兩下加入事件
在Form的OnCreate, OnPaint點兩下加入事件
接著就加入程式碼囉~


unit Unit1;

interface

uses
  Windows, Graphics, Forms, Classes, Controls, StdCtrls, Dialogs, Grids;
  
type
  TByteSet = set of Byte;
  TBytes = array of Byte;

  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    Done: Boolean;
    ResultTable: array[0..8, 0..8] of Byte;    //最後產出之結果
  public
    function SetToBytes(ASet: TByteSet; Range: Integer): TBytes;
    function ColSet(Index: Integer): TByteSet;
    function RowSet(Index: Integer): TByteSet;
  end;

var
  Form1: TForm1;

implementation

uses SysUtils;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Randomize;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Sudos: TBytes;
  I, K, L, C, R: Byte;
  S: array[0..2] of TByteSet;
  AreaSet: array[0..8] of TByteSet;//作為比對
begin
  Sudos := nil;
  repeat
    Done := True;
    for I := 0 to 8 do AreaSet[I] := [];   //九個區域
    FillChar(ResultTable, SizeOf(ResultTable), $FF);
    for I := 0 to 80 do   //81個號碼
    begin
      C := I mod 9;    //C=除以9取黍數  Cols
      R := I div 9;    //R=除以9        Rows
      K := (R div 3) * 3 + (C div 3);  //K=列除3*3+行除3
      S[0] := [0..8] - ColSet(C);     //Column Available SudoSet
      S[1] := [0..8] - RowSet(R);     //Row Available SudoSet
      S[2] := [0..8] - AreaSet[K];   //Area Available SudoSet
      S[0] := S[0] * S[1] * S[2];     //Intersection: The Available SudoSet
      if S[0] = [] then   //空集合時就不做了
        Done := False
      else
      begin
        Sudos := SetToBytes(S[0], 9);     //Random Selection
        L := Sudos[Random(Length(Sudos))];
        AreaSet[K] := AreaSet[K] + [L]; 
        ResultTable[C, R] := L;
      end;
    end;
  until Done;

  Repaint;//繪出數讀表

end;

function TForm1.SetToBytes(ASet: TByteSet; Range: Integer): TBytes;
var
  I, J: Byte;
begin
  SetLength(Result, Range);
  J := 0;
  for I := 0 to Range-1 do
  begin
    if I in ASet then
    begin
      Result[J] := I;
      ASet := ASet - [I];
      Inc(J);
    end;
    if ASet = [] then Break;
  end;
  SetLength(Result, J);
end;

function TForm1.ColSet(Index: Integer): TByteSet;
var
  i: Integer;
begin
  Result := [];
  for i := 0 to 8 do
    if ResultTable[Index, i] <> $FF then
      Result := Result + [ResultTable[Index, i]];
end;

function TForm1.RowSet(Index: Integer): TByteSet;
var
  i: Integer;
begin
  Result := [];
  for i := 0 to 8 do
    if ResultTable[i, Index] <> $FF then
      Result := Result + [ResultTable[i, Index]];
end;

procedure TForm1.FormPaint(Sender: TObject);
const
  CW = 40;
  RH = 40;

  procedure SetPen(Color: TColor; Width: Integer; Style: TPenStyle; Mode: TPenMode);
  begin
    Canvas.Pen.Color := Color;
    Canvas.Pen.Width := Width;
    Canvas.Pen.Style := Style;
    Canvas.Pen.Mode := Mode;
  end;

  procedure SetBrush(Color: TColor; Style: TBrushStyle);
  begin
    Canvas.Brush.Color := Color;
    Canvas.Brush.Style := Style;
  end;

  procedure SetFont(Name: string; Height: Integer; Color: TColor; Style: TFontStyles);
  begin
    Canvas.Font.Name := Name;
    Canvas.Font.Height := Height;
    Canvas.Font.Color := Color;
    Canvas.Font.Style := Style;
  end;

  procedure Clear;
  var
    rt: TRect;
  begin
    SetPen(clGray, 1, psSolid, pmCopy); //設定邊寬
    SetBrush(clSilver, bsSolid); //設定背景
    rt := Rect(0, 0, CW*9-8, RH*9-8); //設定常數   //352 //352
    OffsetRect(rt, 10, 10);
    Canvas.Rectangle(rt); //畫被景圖
  end;

  procedure DrawColsRows;
  var
    i: Integer;
    rt: TRect;
  begin
    SetPen(clSilver, 1, psSolid, pmCopy); //銀色，固，1
    SetBrush(clGray, bsSolid); //灰，固
    rt := Rect(0, 0, CW, RH*9-8); //0,0,40,352

    OffsetRect(rt, 10, 10); //位於圖的初使位置
    for i := 0 to 7 do
    begin
      Canvas.FrameRect(rt);
      OffsetRect(rt, CW-1, 0); //偏移位置少一，才不會兩行寬
    end;

    rt := Rect(0, 0, CW*9-8, RH); //0,0,352,40
    OffsetRect(rt, 10, 10); //位於圖的初使位置
    for I := 0 to 8 do
    begin
      Canvas.FrameRect(rt);
      OffsetRect(rt, 0, RH-1);
    end;
  end;

  procedure DrawColsRows2;
  var
    i: Integer;
    rt: TRect;
  begin
    SetPen(clSilver, 1, psSolid, pmCopy);
    SetBrush(clRed, bsSolid);
    rt := Rect(0, 0, CW*9-8, RH*3-2);  //0, 0, 352, 118
    OffsetRect(rt, 10, 10);
    for i := 0 to 2 do
    begin
      Canvas.FrameRect(rt);     //畫直的矩形
      OffsetRect(rt, 0, (RH-1)*3);
    end;

    rt := Rect(0, 0, CW*3-2, RH*9-8);
    OffsetRect(rt, 10, 10);
    for i := 0 to 2 do
    begin
      Canvas.FrameRect(rt);     //畫橫的矩形
      OffsetRect(rt, (CW-1)*3, 0);
    end;
  end;

  procedure DrawContents;
  var
    i, j: Integer;
    rt: TRect;
    S: string;
  begin
    SetBrush(clGray, bsSolid);
    SetFont('ARIAL',36,clWhite,[fsBold]); //設定字型
    for i := 0 to 8 do
      for j := 0 to 8 do
      begin
        rt := Rect((CW-1)*i, (RH-1)*j, (CW-1)*(i+1), (RH-1)*(j+1)); //39*i, 39*j, 39*(i+1), 39*(j+1)
        OffsetRect(rt, 10, 10);
        InflateRect(rt, -2, -2);
        Inc(rt.Right);
        Inc(rt.Bottom);
        S := IntToStr(ResultTable[i, j]+1); //結果表加1，然後存到S字串
        Canvas.TextRect(Rt, Rt.Left+10, Rt.Top+2, S);
      end;
  end;

begin
  Clear;
  DrawColsRows;
  DrawColsRows2;

  if Done then  //如果做完就畫內容囉
    DrawContents;
end;

end.

好玩的MSN遊戲機器人設計

先是截此視窗的圖，然後做辨視，接著依演算法去點選。
截圖
只截取此視窗，並不可亂移動，參數一開始即確定
辨視
依圖形顏色，位置，形狀去判斷，不能判斷再重抓圖一次
演算法
先橫的由下而上，再直的由左而右
至少三點，所以要一個來記錄前兩點，
若前兩點為相同則記錄flag，
flag=y然後再第三點就去找相對位置，y就break，n就記錄(記錄此點值，並判斷與前一點是否相同，設定flag)後跳到下一點
flag=n目前點去找前二點的相對位置(依序找，相同的點才進入判斷相對位置，否則跳到下一點)看有沒有同樣的，y就break，用程式去點擊相對位置(兩個)，n就記錄(記錄此點值，並判斷與前一點是否相同，設定flag)後跳到下一點

星期三, 10月 24, 2007

cxSplitter 物件使用

假如版面上到下分別為cxGrid cxSplitter ElTree
cxGrid屬性Align = alTop
cxSplitter屬性AlignSplitter = salTop
ElTree屬性Align = alClient

cxSplitter
屬性Control = cxGrid1
屬性HotZone = MediaPlayer9

如此cxSplitter點下去，cxGrid就會不見，ElTree則往上擴展開來。

星期一, 10月 22, 2007

地圖上直接顯示股價資訊(網頁上)

累似STOCKQ，但是是顯示在全世界的地圖上，有顯示的國家用不同顏色。
所要用到的技術：
php讀取網頁http://twpug.net/modules/xfsnippet/detail.php?type=snippet&snippet_id=10
php自動更新，但只更新文字，不更新圖片。
全世界地圖製作。
原物料小圖示製作(股市不用，用地圖)。

基本上只顯示股市及原物料
將一步可再使用MSCI指數，可以較大範圍來看(如：MSCI台灣:1235)

視窗繪圖基本概念

處理畫面經常使用到Canvas物件，此物件定義於Graphics單元裡，其屬性有
Brush，其同時屬於TCanvas及TForm物件裡，在TShape物件中，Brush是用來決定填充的背景顏色或樣式，而當Brush用於Controls時，只能用於繪製背景，且此時Brush是唯讀且Run-time的屬性。

　　GDI是Graphics Device Interface 的縮寫，是作業系統在螢幕以及印表機上繪製圖形的次性統，同時也提供給應用程式透過GDI函式庫與資料結構，處理顯示與列印等相關工作，不同於之前練習的簡單空白視窗，讓我們將利用GDI處理一些有趣的東西 !!

　　基本上，視窗作業系統是採取將硬體與應用程式隔離開的策略，應用程式被禁止直接存取硬體的資源，所有跟硬體相關的工作都是由作業系統代為完成，也包括繪圖與文字顯示(文字是由許多點繪製而成)的部分，往往理所當然的簡單工作，在手工打造的過程下卻往往呈現繁複而細緻的樣貌，而GDI正是視窗應用程式用於圖形處理的主要構件，要駕馭龐雜又功能強大的GDI，往往也是對程式設計工作的一大考驗。

　　由於作業系統不允許應用程式直接存取硬體資源(顯示卡、印表機..等裝置)，但視窗應用程式又極需仰賴複雜的圖形，用來顯示與使用者互動的訊息，因此作業系統必須提供繪圖介面供應用程式使用，否則視窗將無法完成繪製圖形以及顯示文字的工作，這也就意味著在視覺的呈現上將會犧牲對使用者的吸引力。

　　由於GDI刻意對應用程式隱藏硬體裝置的細節，這也就表示，應用程式的繪圖與顯示文字的需求就必須交由GDI代為與硬體裝置溝通，這種做法可以避免視窗應用程式過度依賴特定裝置的能力，儘管GDI可以代理與裝置溝通的工作，基於使用上的目的， GDI主要是用於處理靜態的圖形輸出，因此僅具有簡單的動畫顯示能力，如果需要產生大量的動畫效果如GAME這類的應用程式，你應該更進一步的尋求DirectX或是 OpenGL這類的函式庫來解決問題。

　　不管微軟在GDI的函式庫是如何處理與硬體裝置溝通的細節，你可以簡單的將GDI視為虛擬的繪圖裝置(印表的過程也可以視為是繪圖，只是他的輸出是在印表紙上),透過GDI所提供的函式庫完成工作，這種做法，至少可以滿足二個主要的問題-簡化工作與統一管理。
簡化工作
　　在現今的PC上，裝置是由許多的廠商各自所生產的，如果應用程式都需要直接控制硬體，就必須針對各個不同廠牌以及型號單獨撰寫程式碼，而這幾乎是不可能的任務，更糟糕的情況是，以目前硬體進步的速度，可能很多軟體還沒測試出廠，就被淘汰了，對程式設計師而言這將是一場噩夢，因此由作業系統提供一個虛擬裝置的介面，實際控制的部分就由裝置的驅動程式與作業系統溝通，應用程式不需要關心實際硬體的細節，所有低階控制的部分都交由介面負責，這樣相較之下就顯得比較簡化而合理。

統一管理
　　由於視窗作業環境在同一時間往往有許多應用程式執行，而這些應用程式的視窗也必須同時輸出在螢幕上(多工作業下的正常狀況)，如果每個應用程式都想要掌握硬體的控制權，這時問題就大了，A視窗的作業可能在最大化之後遮蓋整個桌面，而擋住B視窗的資料，或是B視窗的工作會輸出在A視窗之上，這先看似理所當然的工作其實牽涉到許多麻煩的狀況，在不同視窗間的輸出區域可能會增加也可能會減少，甚至使用者移動視窗後，顯示區域也會互相重疊，甚至被破壞，因此必須有一個隨時將顯示區域恢復正常的機制，否則使用者將無法獲得正確的輸出甚至為讓視窗應用程式無法運作，由於GDI是由作業系統提供，在運用GDI函式的同時，也要求應用程式必須相對提出視窗相關資料，因此可以由作業系統判斷何者該更新或是該如何更新。

何謂全域式運算(ROP:raster operation)？當視窗系統用色筆來畫線時，它實際是在色筆的像素與顯示器表面的像素之間執行位元的布林運算。
何謂二元全域式運算(ROP2:binary raster operation)？因為畫線只牽涉兩種像素的圖案，所以布林運算亦稱為如此。

GDI圖形裝置介面 - 視窗系統內的圖形由此來操作的，控制圖形輸出設備的顯示，並在這些驅動檔案中去呼叫常式，如GDI建立可知道顯示器螢幕的.Drv將處理什麼；不處理時則自己將計算畫圖，如畫橢圓。目前都只有普通功能，若要更好的功能，則要借助DirectX及OpenGL。
圖形輸出設備區分為 1.全域式設備(raster)，如顯示器介面卡，印表機及2.向量式設備(vector)，如繪圖機。
當要在圖形輸出設備上要畫東西，你就要先取得設備環境代碼，即DC，其如當畫文字時，有文字背景、色彩及字元間隔，而GDI函數的參數只須起始點、文字、文字長度。當釋放DC時即不再有效。
取得特別一個視窗的設備環境1. hdc = BeginPaint (hwnd, &ps); //ps變數是PAINTSTRUCT型態的結構，此結構含有一個叫rcPaint的RECT(矩形)結構，該結構定義一塊能圍住視窗本文工作區無效區域的矩形，利用此傳回的環境代碼，你只能在此區域內畫圖。EndPaint(hwnd, &ps);2. hdc = GetDC(hwnd); //傳回本文工作區的視窗代碼3. hdc = GetWindowDc(hwnd); //而非只是本文工作區，此功能少用。假如你想用，必零去誘捕WM_NCPAINT(非本文北作區著畫)訊息以防止視窗系統在非本文工作區上著畫。ReleaseDC(hwnd, hdc); //釋放DC
取得整個顯示器的設備環境hdc = CreateDC(lpszDriver, lpszDevice, lpszOutput, lpData);// 如hdc = CreateDC('DISPLAY', null, null, null); // 取得一個允許我們在視窗本文工作區之外著畫的設備環境代碼;// 如hdcPrinter = CreateDC('IBMGRX', 'IBM Graphics', 'LPT1:', null); //取得印表機設備環境的代碼Delete(DC);
若只是想取得有關設備環境的資訊，並非想著畫可用hdcInfo = CreateIC(lpszDriver, lpszDevice, lpszOutput, lpData);DeleteDC(hdcInfo);// 如取得記憶體設備環境來操控某些點陣圖hdcMem = CreateCompatibleDC(hdc);DeleteDC(hdcMem);
中介檔案(metafiles)，其為寫成二進位形式之GDI呼叫的一些集合，你可用取得中介檔案設備環境來建立中介檔案：hdcMeta = CreateMetaFile(lpszFilename);hmf = CloseMetaFile(hdcMeta);在中介檔案設備環境有效期間，任何你以hdcMeta呼叫的GDI函數都變成中介檔案的一部分。當你呼叫CloseMetafile時，設備環境代碼即為無效。而函數傳回此中介檔案的代碼(hmf)。
取得設備環境資訊如顯示器大小和其色彩的相容性，可呼叫：nValue = GetDeviceCaps(hdc, nIndex);nIndex參數是定義在Windows.H中28個識別字的其中一個。例如， nIndex為HORZRES能使GetDeviceCaps傳回以像素為單位的設備寬度；而VERTRES參數傳回以像素為單位的設備高度。假如hdc是螢幕設備環境的代碼時，你所得到的資訊與從GetSystemMetrics取得的是一樣。假如hdc是印表機的設備環境代碼，則GetDeviceCaps取得以像素為單位的印表機顯示區域之高度和寬度。你可用GetDeviceCaps取得設備處理各類圖形的能力。這點對影像顯示器不重要，但如果是對印表機就很重要。例如，多數的繪圖機無法畫出點陣圖影像-這點就是由GetDeviceCaps告訴你的。
因為GDI問題在於彩色的點陣圖無法以不同的色彩組織來被儲存，和使用在圖形輸出設備上，固有個新的點陣圖被定義為獨立於設備的點陣圖稱之為DIB，因為其本身的色彩對照表便可指出像素位元如何對應到RGB色彩。

圖形區塊轉移函數有
PatBlt、BitBlt、MaskBlt、PlgBlt、TransparentBlt和StretchBlt等

PatBlt(hdc, xDest, yDest, xWidth, yHeight, dwROP);會用目前選進設備環境中的畫筆

名稱 ROP碼(16進制) 新像素點算法(P來源像素, D目的像素)
BLACKNESS 000042 全部為0
0500A9 ~(P D)
0A0329 ~P & D
0F0001 ~P
500325 ~P & -D
DSTINVERT 550009 ~D
PATINVERT 5A0049 P ^ D
5F00E9 ~(P & D)
A000C9 P & D
A50065 ~(P ^ D)
AA0029 D
AF0229 ~P D
PATCOPY F00021 P
F50225 P ~D
FA0089 P D
WHITENESS FF0062 全部為1

範例如：
procedure TForm1.Button1Click(Sender: TObject);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
Bitmap.LoadFromFile('test.Bmp');
Form1.Canvas.Brush.Bitmap := Bitmap;
Form1.Canvas.FillRect(Rect(0,0,100,100));
finally
Form1.Canvas.Brush.Bitmap := nil;
Bitmap.Free;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
Bitmap.LoadFromFile('test.Bmp');
Form1.Canvas.Brush.Bitmap := Bitmap;
PatBlt(Form1.Canvas.Handle, 0, 0, 100, 100, PATCOPY); //用PATCOPY就等於FillRect
finally
Form1.Canvas.Brush.Bitmap := nil;
Bitmap.Free;
end;
end;

用BitBlt來轉換位元
BitBlt(hdcDest, xDest, yDest, xWidth, yHeight, hdcSrc, xSrc, ySrc, swROP);
名稱 ROP碼(16進制) 新像素點算法(P來源像素, D目的像素)
BLACKNESS 000042 全部為0
NOTSRCERASE 1100A6 ~(S D)
NOTSRCCOPY 330008 ~S
SRCERASE 440328 S & ~D
DSTINVERT 550009 ~D
PATINVERT 5A0049 P ^ D
SRCINVERT 660046 S ^ D
SRCAND 8800C6 S & D
MERGEPAINT BB0226 ~S D
MERGECOPY C000CA P & S
SRCCOPY CC0020 S
SRCPAINT EE0086 S D
PATCOPY F00021 P
PATPAINT FB0A09 P ~S D
WHITENESS FF0062 全部為1

用StretchBlt來擴張Bitmaps
StretchBlt(hdcDest, xDest, yDest, xDestWidth, yDestHeight, hdcSrc, xSrc, ySrc, xSrcWidth, ySrcHeight, dwROP);
當xSrcWidth和xDestWidth值之正負號不相同時，則StretchBlt會建立一個鏡子影像。

當壓縮點陣圖時，StretchBlt必須把數行或數列的像素結合成一行或一列。它根據設備環境中的延伸模式屬性可有三種方法來完成。你還可用SetStretchBltMode函數更改延伸模式：
SetStretchBltMode(hdc, nMode);
nMode之值可為下列之任一個：
BLACKONWHITE(預設值)：假如有兩個或更多個像素零被結合成一個像素時，StretchBlt對這些像素執行邏輯AND運算。結果的像素只有在所有原始像素都是白色時才會是白色，這實際意指黑色像素比白色像素更有優勢。
WHITEONBLACK：假如有兩個或更多個像素零被結合成一個像素時，StretchBlt對這些像素執行邏輯OR運算。結果的像素只有在所有原始像素都是黑色時才會是黑色，這實際意指白色像素比黑色像素更有優勢。
COLORONCOLOR：StretchBlt僅把行或列像素除走而不做任何的邏輯運算。對彩色點陣圖而言，因為其他兩種模式會使色彩遭到扭曲，所以通常這是最好的方法。

星期五, 10月 19, 2007

大數運算

先去http://www.submanifold.be/網站下載FGInt.zip回來用就可以囉~


uses FGInt;

procedure TForm1.Button1Click(Sender: TObject);
var
    a,b,c:TFGInt;
    s:string;
begin
    FGInt.Base10StringToFGInt('987654321',a); //a = 987654321
    FGInt.Base10StringToFGInt('123456789',b); //b = 123456789

    FGInt.FGIntAdd(a,b,c); // c = a + b
    FGint.FGIntToBase10String(c,s);
    showmessage(s);

    FGInt.FGIntSub(a,b,c); // c = a - b
    FGint.FGIntToBase10String(c,s);
    showmessage(s);

    FGInt.FGIntMul(a,b,c); // c = a * b
    FGint.FGIntToBase10String(c,s);
    showmessage(s);

    FGInt.FGIntDiv(a,b,c); // c = a / b
    FGint.FGIntToBase10String(c,s);
    showmessage(s);
end;

星期四, 10月 18, 2007

矩陣操作

新增9個TButton、3個TMemo、1個TLabel


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Memo2: TMemo;
    Button6: TButton;
    Button7: TButton;
    Memo3: TMemo;
    Label1: TLabel;
    Button9: TButton;
    Button8: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button9Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button8Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  n : array[1..100] of integer;
  a : array [1..4, 1..4] of integer;
  m : array[1..100] of integer;
  b : array [1..4, 1..4] of integer;
implementation

{$R *.dfm}
procedure swap(var a,b:integer);
var
  t : integer;
begin
  t := a;
  a := b;
  b := t;
end;

// 讀入陣列A
procedure TForm1.Button1Click(Sender: TObject);
var
  i : integer;
  F : textfile;
begin
  Memo1.clear;
  i := 0;
  AssignFile(F,'number.txt');
  reset(F);
  while not(EOF(F)) do begin
    i := i+1;
    readln(F,n[i]);
    Memo1.lines.add(inttostr(n[i]));
  end;
  closeFile(F);
end;

// 排序
procedure TForm1.Button2Click(Sender: TObject);
var
  i, j : integer;
begin
  Memo1.clear;
  for i:=1 to 15 do begin
    for j:=i+1 to 16 do
      if n[i]>n[j] then
        swap(n[i], n[j]);
    Memo1.lines.add(inttostr(n[i]));
  end;
  Memo1.lines.add(inttostr(n[16]));
end;

// 轉成矩陣(橫轉)
procedure TForm1.Button3Click(Sender: TObject);
var
  i,j : integer;
  s : string;
begin
  memo1.Clear;
  for i :=1 to 4 do begin
    s :='';
    for j :=1 to 4 do begin
      a[i,j] :=n[4*(i-1)+j];
      s := s+ inttostr(a[i,j])+' ';
    end;
    memo1.Lines.Add(s);
  end;
end;

// 轉成矩陣(直轉)
procedure TForm1.Button9Click(Sender: TObject);
var
  i,j : integer;
  s : string;
begin
  memo1.Clear;
  for i :=1 to 4 do begin
    s :='';
    for j :=1 to 4 do begin
      a[i,j] :=n[i+4*(j-1)];
      s := s+ inttostr(a[i,j])+' ';
    end;
    memo1.Lines.Add(s);
  end;
end;

// 亂數產生B矩陣
procedure TForm1.Button6Click(Sender: TObject);
var
  i, j:integer;
  s : string;
begin
  memo2.Clear;
  for i:=1 to 16 do
    m[i]:=random(100);

  for i :=1 to 4 do begin
    s :='';
    for j :=1 to 4 do begin
      b[i,j] :=m[j+4*(i-1)];
      s := s+ inttostr(b[i,j])+' ';
    end;
    memo2.Lines.Add(s);
  end;
end;

// B矩陣排序
procedure TForm1.Button7Click(Sender: TObject);
var
  i, j : integer;
  s : string;
begin
  Memo2.clear;
  for i:=1 to 15 do begin
    for j:=i+1 to 16 do
      if m[i]>m[j] then
        swap(m[i], m[j]);
  end;

  for i :=1 to 4 do begin
    s :='';
    for j :=1 to 4 do begin
      b[i,j] :=m[4*(i-1)+j];
      s := s+ inttostr(b[i,j])+' ';
    end;
    memo2.Lines.Add(s);
  end;
end;

// +
procedure TForm1.Button4Click(Sender: TObject);
var
  i, j : integer;
  s : string;
begin
  Memo3.Clear;
  for i := 1 to 4 do begin
    s := '';
    for j := 1 to 4 do begin
      s := s + inttostr(a[i,j] + b[i,j]) + ' ';
    end;
  Memo3.Lines.Add(s);
  end;
end;

// -
procedure TForm1.Button5Click(Sender: TObject);
var
  i, j : integer;
  s : string;
begin
  Memo3.Clear;
  for i := 1 to 4 do begin
    s := '';
    for j := 1 to 4 do begin
      s := s + inttostr(a[i,j] - b[i,j]) + ' ';
    end;
  Memo3.Lines.Add(s);
  end;
end;

procedure TForm1.Button8Click(Sender: TObject);
var
  i, j, k, max, min : integer;
begin
  Memo3.clear;
  for j := 1 to 4 do begin     //列
    min := 1;
    for i := 2 to 4 do
      if a[j,i]        min := i;

    max := j;
    for k := 1 to 4 do
      if (a[k,min]>a[j,min]) and (k<>j) then  //k不能=j
        max := k;

    if max=j then
      Memo3.lines.add('鞍點在：'+inttostr(j)+', '+inttostr(min))
    else
      Memo3.lines.add('沒有鞍點');
  end;
end;

end.

很無聊時學寫Power函數


function power(base, n : integer) : int64;
var
  i : integer;
  t : int64;
begin
  t := 1;
  for i := 1 to n do
    t := t * base;
  power := t;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  showmessage(inttostr(power(4, 3)));
end;

字串及陣列寫入及讀取檔案

新增4個TButton、1個TMemo、2個TEdit


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Memo1: TMemo;
    Edit1: TEdit;
    Edit2: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  F : textfile;
begin
  AssignFile(F,'data.txt');
  ReWrite(F);

  //寫入數據
  WriteLn(F, Edit1.Text);
  WriteLn(F, Edit2.Text);
  CloseFile(F);
  Showmessage('寫入成功');
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  F : textfile;
  s1,s2 : string;

begin
  AssignFile(F,'data.txt');
  Reset(F);
  //讀取數據
  ReadLn(F, s1); //不能直接寫Edit1.Text
  ReadLn(F, s2); //不能直接寫Edit2.Text
  Edit1.Text := s1;
  Edit2.Text := s2;
  CloseFile(F);
  Showmessage('讀取成功');
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  n : array[1..100] of integer;
  i : integer;
  F : textfile;
begin
  AssignFile(F,'number.txt');
  Rewrite(F);
  for i := 1 to 100 do
  begin
    n[i] := i;
    Writeln(F,n[i]);
  end;
  CloseFile(F);
  Showmessage('寫入成功');
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  n : array[1..100] of integer;
  i : integer;
  F : textfile;
begin
  AssignFile(F,'number.txt');
  Reset(F);
  i := 0;
  while not(EOF(F)) do begin
    i := i+1;
    Readln(F, n[i]);
    Memo1.Lines.add(inttostr(n[i]));
  end;
  closeFile(F);
  Showmessage('讀取成功');
end;

end.

星期二, 10月 16, 2007

開啟資料夾並搜尋檔案及得知其檔案大小

此可以做為新增MP3歌曲的功能，只要加入某個最上層目錄，就可以自動加入所有子目錄及其音樂。

新增2個TButton、1個TEdit、1個TMemo(ScrollBars屬性ssBoth)
兩個按鈕皆點兩下加入事件


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Edit1: TEdit;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    procedure GetFileSize(sPath : string);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1 : TForm1;
  Path : string;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  Dir: String;
begin
  Dir := '';
  if SelectDirectory('選擇文件夾', '', Dir) then
  begin
    if Copy(Dir,Length(Dir),1) <> '\' then
      Dir := Dir + '\';
    Edit1.text := Dir;  //Edit1顯示路徑
    Path := Dir;  //Path全域變數記錄Dir
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  GetFileSize(Edit1.text);
end;

procedure TForm1.GetFileSize(sPath : string);
var
  hFind     : THandle;
  filename, fPath  : string;
  nSize     : Int64;
  fd        : WIN32_FIND_DATA;
begin
  hFind:=Windows.FindFirstFile(PChar(sPath + '*.*'), fd); //所有檔案都找
  if(hFind <> INVALID_HANDLE_VALUE) then
  begin
    repeat
      filename:=fd.cFileName;
      fPath := sPath + filename;
      if((filename = '.') or (filename = '..')) then //不是上層 或 上上層
        Continue;
      if(fd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) > 0 then //是否為目錄
      begin
        GetFileSize(fPath + '\'); //遞迴呼叫 跑子目錄
      end else begin
        nSize:=fd.nFileSizeHigh;
        nSize:=nSize shl 32;
        nSize:=nSize or fd.nFileSizeLow;
        Memo1.lines.add(fPath+'       Size='+inttostr(nSize)=' bytes');
      end;
    until (not Windows.FindNextFile(hFind, fd));
    Windows.FindClose(hFind);
  end;
end;

end.

星期一, 10月 15, 2007

防止軟體程式重複被執行兩次


program Project1;

uses
  ExceptionLog,
  Forms,
  windows,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.res}
var
  Mutex : THandle;

begin
  Mutex := CreateMutex(nil, false, pchar(application.title));
  if (Mutex = 0) OR (GetLastError = ERROR_ALREADY_EXISTS) then
  begin
    Application.MessageBox('不能重覆執行程式','一次只能執行一個程式',mb_ok);
    // code to searh for, and activate
    // the previous (first) instance
    //Application.terminate;
  end else begin
    Application.Initialize;
    Application.CreateForm(TForm1, Form1);
    Application.Run;
    if Mutex <> 0 then
      CloseHandle(Mutex);
  end;
end.

參數傳遞


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;

type
  TString20 = String[20];

type
  TDigits = array[1..10] of integer;

type
  TDigits1 = array of integer; //開放式宣告方式

var
  Form1: TForm1;

implementation

{$R *.dfm}
//參數傳值
function DoubleByValue(X : Integer) : Integer;
begin
  X := X *2 ;
  Result := X ;
end;

//變數參數
function DoubleByRef(var X : Integer) : Integer; //變數傳入可再改變X變數，並不會有備份變數產生
begin
  X := X * 2 ;
  Result := X ;
end;

//常數參數
function DoubleByCns(Const X : integer) : Integer;//編譯程式可以對於結構型別或字串型別的參數，產生最佳化的機器碼。也可以提供一層安全防護，避免不小心把參數以變數參數的方式，
begin
  Result := 8;
  if X = 4 then
    Result := 4;
end;

//輸出參數
procedure GetInfo(out Info : string);
begin
  Info := 'ShowInfo';
end;

//字串參數傳入
procedure Check(S : TString20); //因為不能傳入 procdure Check(S : String[20]); //語法錯誤 所以要自定型別
begin
  showmessage(S);
end;

//陣列參數傳入
procedure Sort(A : TDigits);  //因procdure Sort(A ： array[1..10] of integer)； // 語法錯誤
begin

end;

//陣列參數傳入
function Find(A : array of Char):Integer; //宣告了一個叫做Find的函式，這個函式可以接受一個任意大小的字元陣列當參數，並且傳回一個整數值
begin
  Result:=0;
end;

//預設參數值
procedure FillArray(A : Integer; B : Integer = 0); //不可以前有後沒有procedure FillArray(A : Integer = 0; B : Integer);不可以寫在一起procedure FillArray(A, B : Integer = 0);
begin

end;

procedure TForm1.Button1Click(Sender: TObject);
var  
  test: array of DifBlk;
  I, J, V, W, N, M : integer;
  MyRecord : string;
begin
  I := 4;
  V := 4;
  N := 4;
  J := DoubleByValue(I); // J= 8 ； I = 4
  W := DoubleByRef(V); // W = 8 ； V = 8
  M := DoubleByCns(N); // N = 8 ； V = 8

  GetInfo(MyRecord); //MyRecord只是一個放資料的容器，GetInfo可以把產生的資料放在裡頭 。呼叫GetInfo時候，在程式的控制權轉移到GetInfo之前，MyRecord所佔用的記憶體就會自動解除。
  showmessage(MyRecord);

  Check('CC');

  //FillArray(MyI);即等於  FillArray(MyI, 0);
end;

end.

將錯誤的Log/.及LPM/*.LPM檔案刪除

主程式修改：花費我二、三天的時間來認識anderson的程式

如何寫入程式報告的Log檔記錄


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    m_Report: TStringList;
    { Private declarations }
  public
    procedure ReportLog(str: string); overload;
    procedure ReportLog(str: string; Args: array of const); overload;
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
//---------------------------------------------------------

procedure TForm1.FormCreate(Sender: TObject);
begin
  m_Report:=TStringList.Create();
end;
//---------------------------------------------------------

procedure TForm1.FormDestroy(Sender: TObject);
begin
  m_Report.SaveToFile('Report.log');
  m_Report.Free();
  m_Report:=nil;
end;
//---------------------------------------------------------

procedure TForm1.ReportLog(str: string);
begin
  if(not Assigned(m_Report)) then
    Exit;
  m_Report.Add(FormatDateTime('yyyy"/"mm"/"dd" "hh:nn:ss ', Now())+str);
end;
//---------------------------------------------------------

procedure TForm1.ReportLog(str: string; Args: array of const);
var
  buf: string;

begin
  //Format string.
  buf:=Format(str, Args);
  //Put Log to Log Factory.
  ReportLog(buf);
end;
//---------------------------------------------------------

procedure TForm1.Button1Click(Sender: TObject);
const
  sFilename = 'test.txt';
  sPath = 'c:\';
begin
  m_Report.Clear();
  ReportLog('Prepare to clear.'); //未來修改此行
  ReportLog('Begin to show %s file(s) in %s .', [sFilename, sPath]); //sFilename改sPath
  ReportLog('End.');
end;

end.

星期五, 10月 12, 2007

正確的刪除檔案步驟


procedure TForm1.Button1Click(Sender: TObject);
bDelete : boolean;
i : integer;
filename : string;
begin
  filename := 'C:\1.txt';
  if(not SetFileAttributes(PChar(filename), FILE_ATTRIBUTE_NORMAL)) then
  begin
    showmessage('file attribute to normal error !');
  end;
  i:=0;
  bDelete:=DeleteFile(filename);
  //刪5次試試
  while((i<5) and (not bDelete)) do
  begin
    Sleep(1000);
    bDelete:=DeleteFile(PChar(filename));
    Inc(i);
  end;
end;

星期二, 10月 09, 2007

TStringList與TObject的完美搭配


var
  sl:TStringList;

begin
  if .. then
    sl.AddObject(sPath, TObject(4))  //給這個sPath對應的值4
  else
    sl.AddObject(sPath, TObject(1));  //或給這個sPath對應的值1
end;

//用到時可以
//sl.Strings[i]搭配sl.Objects[i].......(你甚至可用自定的結構喔，就像你給他更多的值，如爸爸然後加3個小孩一樣)

//傳到其它函數，可以轉換成Int64再使用
//Int64(sl.Objects[i])

以下就是一個指標結構的範例


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Edit1: TEdit;
    Button2: TButton;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    Edit5: TEdit;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    SL: tstrings;
    { Private declarations }
  public
    { Public declarations }
  end;

type
  pmyRec = ^myRec;
    myRec=Record
    item : String;
    para1 : Integer;
    para2 : Integer;
    para3 : Integer;
    para4 : Integer;
    end;
var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var

    Rec: pmyRec;
begin
    new(Rec);
    Rec.item := Edit1.text;
    Rec.para1 := strtoint(Edit2.text);
    Rec.para2 := strtoint(Edit3.text);
    Rec.para3 := strtoint(Edit4.text);
    Rec.para4 := strtoint(Edit5.text);

    SL.AddObject(Rec.item, TObject(Rec));
    memo1.Lines := SL;

    //freemem(Rec);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  SL := tstringlist.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
  i : integer;
begin
  for i := 0 to SL.Count - 1 do
    dispose(pmyRec(SL.Objects[i]));
  SL.Free;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  dispose(pmyRec(SL.Objects[1]));
  sl.Delete(1);
  memo1.Lines := SL;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  showmessage('sl(1)='+sl.strings[1]+', para1='+IntToStr(pmyRec(SL.Objects[1])^.para1));;
end;

end.

讓Delphi在編輯程式碼時，能打幾個字就自動顯示函數

ChgIME.exe，這是我們大師兄anderson寫的，沒有像windows一樣，一定要全禁掉才可以使用，他的程式可以關掉左邊Ctrl給Delphi用，然後右邊給輸入法切換使用。
ps:設定完要重開機喔~

星期五, 10月 05, 2007

拍賣大師： QooSale


要做的平台有：
@ 奇摩拍賣
@ 露天拍賣
@ 樂多拍賣
@ Hinet拍賣

須克服問題
1. 一切建立在奇摩會不會殺網頁，因為可能無法讀到結標後的資料
2. 了解奇摩延長結標等機制。
3. 先看可不可以用軟體來PO文 (若可以只要輸入商品管理就好；否則要多加拍賣管理，並要讓使用者去網頁PO文多一道程序)
4. php送Email技術 及 送資料到MySQL
5. 軟體讀取MySQL
6. 讀取網頁技術 (包括先下搜尋商品編號)
7. 有的人標價都用1元，結標處在別的地方。
8. 一次買多樣
9. 價格改變
10. 單樣買二、三個
11. 一個網頁，但標題就包括二、三種商品，裡面也有二、三種商品
12. 一個網頁，有size、長度...等問題

軟體
“商品管理” 目前技術可能無法自動PO
“拍賣管理”
“訂單管理” -> 只須輸入拍賣編號
“客戶管理” -> 不須輸入
“獲利管理”
“列印報表”

時程規畫(6個月時程規畫)
商品管理 "10月底完成" 寫入 access2007資料庫技術
拍賣管理 "11月底完成" 用idhttp讀取網頁及圖片存入資料庫技術
訂單管理 "12~1月底完成" php網頁表單及mysql上傳，軟體讀入mysql資料庫技術
客戶管理 "12~1月底完成" 軟體讀入mysql資料庫技術
獲利管理 "2月底完成" 圓餅圖、長條圖畫圖技術
備份及還原 "3月底完成"
線上更新、軟體內部加廣告(可能暫定於載入時才有，並有多一個bar)
支援vista、註冊、防止重覆執行程式、bug除錯記錄 "4月底完成"

客戶需求回報，備忘記事、商品比價、列印報表 "未來再定"

額外應該要做的功能
1。支援vista
2。線上更新
3。註冊碼
4。備忘記事
5。bug除錯記錄
6。防止重覆執行程式
7。客戶需求回報

“訂單管理”->“新增訂單” 只要輸入 拍賣編號(Yahoo)、商品編號(PChome)
當軟體開啟時會掃描已結標的客戶，並送Email給客戶(但只限特定連結到某一網頁輸入寄件資料，注意：”運送方式”及”費用”要供選擇)->而客戶輸入資料將Email到已限定的Email位址，當軟體開啟時並會掃描Email是否有已收到客戶端的Email資料。
最後結標後會去掃描評價。

數量可能要看看有無問題

欄位
商品管理(即進貨情況) (新增商品(手動輸入)、編輯商品、刪除商品、銷售排行(重點)、歷史進貨累積總數量)
 編號 | 商品名稱* | 分類 | 成本* | 累積成本 | 購入數量* | 庫存量 | 成本/單位 | 備註(進貨日期、廠商、進貨單號碼、尚未結清帳款)
右鍵 | 新增 編輯 刪除 | 退貨
圖片顯示在右邊小視窗 及 備註

 |_>銷售排行 – 應設計有銷售數量最多(依照同相同名稱去看購入數量-庫存量最多的)、銷售金額最多錢(依照同相同名稱去看購入數量-庫存量最多的，去乘以售價)、銷售獲利最多(依照同相同名稱去看購入數量-庫存量最多的，去乘以(成本-售價))、銷售金額最多的月份、銷售數量最多的月份、銷售獲利最多的月分。
 |_>歷史進貨累積總數量 

拍賣管理 (YAHOO) – 希望輸入拍賣編號就好，更好的是在商品管理就po文
 名稱 | 圖片 | 目前出價 | 直接購買價 | 剩餘時間 | 最高出價者 | 商品數量 | 出價次數 | 起標價格 | 出價增額 | 商品新舊 | 所在地區 | 開始時間 | 結束時間 | 拍賣編號
拍賣管理 (PCHOME)
 名稱 | 圖片 | 目前出價 | 直接購買價 | 剩餘時間 | 最高出價者 | 商品數量 | 出價次數 | 　　　　 | 　　　　 | 　　　　 | 所在地區 | 開始時間 | 結束時間 | 拍賣編號
一般通路管理

結標管理（分“已出貨”　及　“未出貨”）
訂單編號 | 訂單日期 | 買方帳號 | 拍賣網站 | 拍賣編號 | 拍賣名稱 | 圖片 | 運費 | 結標價 | 折扣 | 匯款日  | 帳號末5碼 | 出貨數量 | 出貨日 | 運送方式 | 收件人 | 收件地址 | 希望收件時間 | 評價 | 備註
 已出貨後 資料變到已出貨 拍賣管理判斷是否刪除(有的好像一直留下) 商品管理減少庫存量

客戶管理 (新增客戶、編輯客戶、刪除客戶、客戶歷史訂單)
拍賣帳號 | 拍賣網站 | 電話 | 手機 | Email | 曾經購買商品數量 | 曾經購買商品總金額 | 備註
        |_>客戶歷史訂單(資料庫去搜尋，在此可能有很多筆)
訂單編號 | 訂單日期 | 買方帳號 | 拍賣網站 | (拍賣編號) | 拍賣標題名稱 | 圖片 | 運費 | 結標價 | (折扣) | 匯款日 | 帳號末5碼 | 出貨日 | 運送方式 | 收件人 | 收件地址 | 希望收件時間 | 評價 | 備註

獲利管理
每月的獲利表、年度獲利表
(皆包括銷售數量、銷售金額、銷售成本及獲利) PS：還可以算獲利率，依投資成本去計算，在此投資成本只在商品而已。

軟體發行
$ 說明使用步驟、流程
$ 與一般軟體比較表
$ 免費贈送軟體推廣告

理財大師：OooMoney (手動輸入)


因為須要輸入基金淨值及匯率才能計算很多東西
所以輸入時基金要能去抓淨值及匯率(做為買入用)，且每次進入軟體也能抓淨值及匯率(做為賣出用)。

新增帳戶 | 各帳戶目前總損益表 | 年度報表 | 資產配置表 | 備份/還原

投資資產-|_
   銀行帳戶-|_
      投入
      利息
   郵局帳戶-|_
      投入
      利息
   基金帳戶-|_
      基金名稱1-|_
         投入
         配息
      基金名稱2-|_
         投入
   有價物-|_
      價值

銀行帳戶 -> 投入(資料欄位)
  編號 | 日期 | 金額(原幣) | 累計金額(原幣) | 摘要 | 折合台幣 | 累積台幣金額 | 買入匯率 | 目前賣出匯率 | 摘要 
銀行帳戶 -> 利息(資料欄位)
  編號 | 日期 | 金額(原幣) | 累計金額(原幣) | 摘要 | 折合台幣 | 累積台幣金額 | 買入匯率 | 目前賣出匯率 | 摘要 

基金帳戶 -> 投入(資料欄位)   (有目前淨值與目前匯率)
  編號 | 日期 | 金額(原幣) | 累計金額(原幣) | 投入淨值 | 投入匯率 | 目前賣出淨值 | 目前賣出匯率 | 單位數 | 累積單位數 | 手續費 | 基金帳戶 | 折合台幣 | 累積台幣金額 | 報酬 | 累計報酬 | 摘要 
        -> 投入(配息欄位)
  編號 | 日期 | 金額(原幣) | 累計金額(原幣) | 摘要 | 折合台幣 | 累積台幣金額 | 買入匯率 | 目前賣出匯率 | 摘要 

有價物 -> 價值(資料欄位)
  編號 | 購入日期 | 商品名稱 | 最初價值 | 最初累計價值 | 目前價值 | 目前累計價值 | 累計價值 | 獲利 | 累計獲利 | 摘要

轉帳 要加入收續費喔

最上面5個按鈕
分別為：
新增帳戶()
各帳戶目前損益表
年度報表(即每月)
資產配置表
備份/還原

新所帳戶包括：
銀行、郵局帳戶
基金帳戶(計價幣別) (哪家銀行、哪一隻基金、計價幣別、有無配息、外幣帳戶扣款？)
有價物(珠寶、房地產、汽車、精品、古董、名畫、有價物，有最初價值及目前價值)

未來有的帳戶
黃金帳戶
外幣帳戶
股票帳戶
證券行賣的基金帳戶(上面想法是銀行的基金帳戶)

未未來有的帳戶
選擇權
連動債
債券
期貨
權證
保險
貸款 問題
信用卡帳戶


主要概念：
新增銀行、郵局帳戶皆分有投資及利息兩個資料夾。
而基金帳戶，若有配息則有兩個資料夾，若沒有則無。
不動產：只有一個資料夾，跟無配息基金一樣

簡單化：按鈕簡單化(學ie7)、並只提供個人記帳用即可。
幫助計算複利，20年後維持此複利可達到多少錢

XML自定規則的建檔及讀取方法

新增4個TButton，並點兩下加入事件。


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, XMLIntf, msxmldom, XMLDoc, XmlTool;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
//自定規則的建檔方法1
procedure TForm1.Button1Click(Sender: TObject);
var
  XD: IXMLDocument;
begin
  XD := NewXMLDocument;
  try
    XD.StandAlone := 'yes';
    XD.Encoding := 'UTF-8';
    XD.Options := [doNodeAutoIndent];
    XD.NodeIndentStr := #9;

    //在這裡用with來寫反而比較清楚
    with XD.AddChild('Family') do
    begin
      AddChild('Father').NodeValue := 'Bill Gates';  //子標籤
      AddChild('Mother').NodeValue := 'Lin Chiling';  //子標籤
      with AddChild('My') do   //子標籤
      begin
        Attributes['Name'] := 'Mouse';  //屬性
        Attributes['Age'] := 25;  //屬性
        with AddChild('Wife') do  //子子標籤
        begin
          NodeValue := 'Cat';
          Attributes['Age'] := 23;  //屬性
        end;
        with AddChild('Child') do  //子子標籤
        begin
          NodeValue := 'Mouse II';
          Attributes['Age'] := 1;  //屬性
        end;
        with AddChild('Child') do  //子子標籤
        begin
          NodeValue := 'Mickey Mouse';
          Attributes['Age'] := 15;  //屬性
        end;
        with AddChild('Child') do  //子子標籤
        begin
          NodeValue := 'Donald Duck';
          Attributes['Age'] := 14;  //屬性
        end;
      end;
      with AddChild('Uncle') do  //子標籤
      begin
        Attributes['Age'] := 35;  //屬性
        Attributes['Sex'] := 'Male';  //屬性
        AddChild('Wife').NodeValue := 'Jolin';  //子子標籤
      end;
    end;
    XD.SaveToFile('C:\Test.xml'); //存檔
    showmessage('存檔完成');
  finally
    XD := nil;  //釋放
  end;
end;

//自定規則的建檔方法2
procedure TForm1.Button2Click(Sender: TObject);
var
  XT: TXmlTool;
begin
  XT := TXmlTool.Create;
  try
    XT['/Family//Father'] := 'Bill Gates'; //目前目錄 /Family//
    XT['Mother'] := 'Lin Chiling'; //目前目錄 /Family//
    XT['My//@Name/'] := 'Mouse'; //目前目錄 /Family//MY// 其屬性
    XT['@Age'] := 25;
    XT['Wife//'] := 'Cat'; //目前目錄 /Family//MY//Wife//
    XT['@Age'] := 23;
    XT['../Child//'] := 'Mouse II'; //目前目錄 /Family//MY//Child//
    XT['@Age'] := 1;
    XT['../Child[1]//'] := 'Mickey Mouse'; //目前目錄 /Family//MY//Child// 第2個相同名字
    XT['@Age'] := 15;
    XT['../Child[2]//'] := 'Donald Duck'; //目前目錄 /Family//MY//Child// 第3個相同名字
    XT['@Age'] := 14;
    XT['../../Uncle//@Age'] := 35; //目前目錄 /Family//Uncle// 其屬性
    XT['@Sex'] := 'Male';
    XT['Wife//'] := 'Jolin'; //目前目錄 /Family//Uncle//Wife// 其屬性
    //目錄最後可以不寫//; 如XT['Wife//']->XT['Wife']; 但外加屬性的不行XT['../../Uncle//@Age'];
    XT.SaveToFile('C:\Test.xml');
    showmessage('存檔完成');
  finally
    XT.Free;
  end;
end;

//自定規則的讀取方法1
procedure TForm1.Button3Click(Sender: TObject);
var
  XD: IXMLDocument;
  i: Integer;
begin
  XD := LoadXMLDocument('C:\Test.xml');
  try
    ShowMessage(XD.ChildNodes['Family'].ChildValues['Father']); //內容
    ShowMessage(XD.ChildNodes['Family'].ChildValues['Mother']); //內容
    ShowMessage(XD.ChildNodes['Family'].ChildNodes['My'].Attributes['Name']); //屬性值
    ShowMessage(XD.ChildNodes['Family'].ChildNodes['My'].Attributes['Age']); //屬性值
    ShowMessage(XD.ChildNodes['Family'].ChildNodes['My'].ChildValues['Wife']); //內容
    ShowMessage(XD.ChildNodes['Family'].ChildNodes['My'].ChildNodes['Wife'].Attributes['Age']); //屬性值
    for i := 0 to XD.ChildNodes['Family'].ChildNodes['My'].ChildNodes.Count-1 do
      if XD.ChildNodes['Family'].ChildNodes['My'].ChildNodes[i].NodeName = 'Child' then //如果是Child
      begin
        ShowMessage(XD.ChildNodes['Family'].ChildNodes['My'].ChildNodes[i].NodeValue); //內容
        ShowMessage(XD.ChildNodes['Family'].ChildNodes['My'].ChildNodes[i].Attributes['Age']); //屬性值
      end;
    ShowMessage(XD.ChildNodes['Family'].ChildNodes['Uncle'].Attributes['Age']); //屬性值
    ShowMessage(XD.ChildNodes['Family'].ChildNodes['Uncle'].Attributes['Sex']); //屬性值
    ShowMessage(XD.ChildNodes['Family'].ChildNodes['Uncle'].ChildValues['Wife']); //內容
  finally
    XD := nil;
  end;
end;

//自定規則的讀取方法2
procedure TForm1.Button4Click(Sender: TObject);
var
  XT: TXmlTool;
begin
  XT := TXmlTool.Create('C:\Test.xml');
  try
    ShowMessage(XT['/Family//Father']); //內容
    ShowMessage(XT['Mother']); //內容
    if XT.SubNodes['My/'].First then
      repeat
        ShowMessage('1. '+XT.SubNodes['My/'].NodeXPath + '=' + XT.SubNodes['My/'].NodeValue); //My Name、Age及Wife、Child值
        if XT.SubNodes['My/'].SubNodes.First then
          repeat
            ShowMessage('2. '+XT.SubNodes['My/'].NodeXPath + '=' + XT.SubNodes['My/'].SubNodes.NodeValue); //Wife、Child的Age值
          until not XT.SubNodes['My/'].SubNodes.Next;
      until not XT.SubNodes['My/'].Next;
    ShowMessage(XT['Uncle//@Age']);   //屬性
    ShowMessage(XT['@Sex']);   //屬性
    ShowMessage(XT['Wife']);   //內容
  finally
    XT.Free;
  end;
end;

end.

星期四, 10月 04, 2007

XML TOOL

首先新增
3個TLabel;
3個TEdit;
1個TTreeView;
1個TRichEdit; 屬性ScrollBars=ssBoth
1個TOpenDialog; 屬性Filter=XML File (*.xml)|*.xml|Any File (*.*)|*.*; 屬性Title=Load XML File
1個TSaveDialog; 屬性Filter=XML File (*.xml)|*.xml|Any File (*.*)|*.*; 屬性Title=Save XML File
2個TBitBtn; 屬性Glyph加入自己的圖示;

程式須要 XMLTBase.pas 及 XMLTool.pas


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, XMLTool, XMLIntf, XMLDoc, Clipbrd, Buttons;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    TreeView1: TTreeView;
    RichEdit1: TRichEdit;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    procedure TreeView1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
  private
    FXmlTool: TXMLTool;
    { Private declarations }
  public
    procedure RefreshViewer;
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.RefreshViewer;
  procedure DrawTree(TreeNode: TTreeNode; XPath: string);
  var
    SubNode: TTreeNode;
  begin
    if (XPath <> '') and (XPath[Length(XPath)] <> '/') then
      XPath := XPath + '/';

    repeat
      if FXmlTool.SubNodes[XPath].NodeIsText then
      begin
        SubNode := TreeView1.Items.AddChildObject(
                TreeNode,
                FXmlTool.SubNodes[XPath].NodeName + ' = ''' + FXmlTool.SubNodes[XPath].NodeText + '''',
                Pointer(FXmlTool.SubNodes[XPath].Node)
            );
      end else begin
        SubNode := TreeView1.Items.AddChildObject(
                TreeNode,
                FXmlTool.SubNodes[XPath].NodeName,
                Pointer(FXmlTool.SubNodes[XPath].Node)
            );
      end;
      if FXmlTool.SubNodes[XPath].NodeHasChild or FXmlTool.SubNodes[XPath].NodeHasAttr then
        DrawTree(SubNode, FXmlTool.SubNodes[XPath].NodeXPath);
    until not FXmlTool.SubNodes[XPath].Next;

    if XPath = Edit2.Text + '/' then
    begin
      TreeView1.Selected := TreeNode;
      TreeNode.Expanded := True;
    end;
  end;
begin
  TreeView1.Items.Clear;
  DrawTree(TreeView1.Items.AddChildObject(nil, '/', Pointer(FXmlTool.Node['/'])), '/');
  TreeView1.Items[0].Expanded := True;  // 第一層展開的
  if (TreeView1.Selected = nil) and (TreeView1.Items.Count > 0) then
    TreeView1.Selected := TreeView1.Items[0];
  TreeView1Click(nil);
end;

procedure TForm1.TreeView1Click(Sender: TObject);
begin
  if TreeView1.Selected <> nil then
  begin
    Edit2.Text := FXMLTool.NodeToXPath(IXMLNode(TreeView1.Selected.Data));  //顯示XML PATH
    Edit3.Text := FXmlTool[Edit2.Text]; //顯示選擇標籤文字
    RichEdit1.Text := FXmlTool.NodeXML[Edit2.Text];   //顯示路徑下的所有內容
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FXmlTool := TXMLTool.Create;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    FXmlTool.LoadFromFile(OpenDialog1.FileName);
    Edit1.Text := OpenDialog1.FileName; //Edit1文字為檔案路徑及檔名
    RefreshViewer;
  end;
end;

procedure TForm1.BitBtn2Click(Sender: TObject);
begin
  SaveDialog1.FileName := Edit1.Text;
  if SaveDialog1.Execute then
  begin
    FXmlTool.SaveToFile(SaveDialog1.FileName);
    Edit1.Text := SaveDialog1.FileName; //算是另存新檔的感覺，所以要更名，但覆蓋並不顯示喔!
  end;
end;

end.

輕鬆設定 hint 提示訊息

因為TMainMenu沒有ShowHint屬性，一般是顯示在StatusBar中

首先新增元件
TButton; 屬性Caption=Hint; 屬性Hint=提示!哈哈哈; 屬性ShowHint=True;
TMainMenu; (新增兩個按鈕喔N1及N2);
N1; 屬性Caption=檔案; 屬性Hint=檔案描述;
N2; 屬性Caption=開啟; 屬性Hint=開啟檔案;
TStatusBar;

事件：
TButton點兩下加入事件。


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    StatusBar1: TStatusBar;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    procedure WhenHint(sender: TObject);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Application.HintPause := 100; //游標停留多久後顯示
  Application.HintHidePause := 5000; //顯示多久
  Application.HintShortPause := 5000; //若兩個元件有Hint(應該為重覆位置)，設定其間隔顯示時間
  Application.HintColor := clBlack; //hint背景色
  Screen.HintFont.Color := clWindow; //hint字型顏色
  //Screen.HintFont.Size := 12;  //修改字型大小

end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnHint := WhenHint; //顯示Hint到StatusBar中
end;

procedure TForm1.WhenHint(sender: TObject);
begin  
  StatusBar1.SimpleText := Application.Hint;  
end;

end.

讓你的視窗搖一下 (不像MSN震動，此為亂數搖)

新增一個TButton，並點兩下加入事件即可。


procedure TForm1.WindowShake(wHandle: THandle) ;
const
  MAXDELTA = 4;
  SHAKETIMES = 500; //震動次數
var
  orect, wRect :TRect;
  deltax : integer;
  deltay : integer;
  cnt : integer;
  dx, dy : integer;
begin
  //remember original position
  GetWindowRect(wHandle,wRect);
  orect := wRect; //記錄原始的上下左右

  Randomize;
  for cnt := 0 to SHAKETIMES do
  begin
    deltax := Round(Random(MAXDELTA));  //0~3的亂數值
    deltay := Round(Random(MAXDELTA));  //0~3的亂數值

    dx := Round(1 + Random(2)); //因為+1，所以亂數值為1~2
    if dx = 2 then //將亂數值變為1 or -1
      dx := -1;

    dy := Round(1 + Random(2));//因為+1，所以亂數值為1~2
    if dy = 2 then //將亂數值變為1 or -1
      dy := -1;

    OffsetRect(wRect,dx * deltax, dy * deltay); //偏移位置dx,dy決定正負方向，deltax決定偏移位置0~3
    MoveWindow(wHandle, wRect.Left,wRect.Top,wRect.Right - wRect.Left,wRect.Bottom - wRect.Top,true);
  end;
  //return to start position
  MoveWindow(wHandle, orect.Left,oRect.Top,oRect.Right - orect.Left,oRect.Bottom - orect.Top,true);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WindowShake(Application.MainForm.Handle);
end;

截獲程序的異常錯誤

除了用try...except...end; 外還可以用ApplicationEvents控件，該控件在additional頁裡，用於捕獲異常信息，在其OnException事件裡寫上處理代碼就可以防止你的程序在運行期出現大錯誤了。
簡單實例：


procedure TForm1.ApplicationEvents1Exception(Sender: TObject;
  E: Exception);
begin
  RecordException(sender,E);//異常處理代碼
end;

procedure TForm1.RecordException(sender:tobject;E: Exception);
begin
  if (E.Message='由於將在索引、 主關鍵字、或關係中創建重複的值，請求對表的改變沒有成功。 改變該字段中的或包含重複數據的字段中的數據，刪除索引或重新定義索引以允許重複的值並再試一次。')then
  begin
    Application.MessageBox('記錄重複,請檢查輸入的數據後再進行操作','提示',MB_OK+MB_ICONINFORMATION);
    Exit;
  end;
end;

使TEdit及TMemo的右鍵失效並不能拖曳選取文字


procedure TForm1.Memo1ContextPopup(Sender: TObject; MousePos: TPoint;
  var Handled: Boolean);
begin
  Handled := True;
end;

procedure TForm1.Memo1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Abort;
end;

procedure TForm1.Edit1ContextPopup(Sender: TObject; MousePos: TPoint;
  var Handled: Boolean);
begin
  Handled := True;
end;

procedure TForm1.Edit1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Abort;
end;

如何加入Res資源檔(讓你可以將bmp、txt、dll、jpg檔...跟exe檔包在一起)

首先要有資源檔製作工具，裡面包括有：
_BuildRes.bat
Build.ini
Build.rc
ZPack.exe
及你要包的檔案(在此我是加入Wording0.txt及Wording1.txt多國語言版)

然後先編輯Build.ini，其內容如下：


[System]
Extention=.Tmp

;程式所要使用到的檔案列表，這些檔案會被ZPack包成.Tmp檔。
[Files]
0=Wording0.txt
1=Wording1.txt

然後執行
_BuildRes.bat
就會產生Build.RES及BUILD.Tmp。

這時將Build.RES複製到你主程式的目錄內。

在主程式{$R *.dfm}的後面加上下面這一行：


{$R build.res}

並加入UZPack.pas及URandomString到你的專案內：
其程式碼如下：


unit UZPack;

interface

uses
  Windows, Classes, SysUtils, {FileCtrl,} ZLib, Forms, URandomString;

function ExtractDLL(APath, ASrcFilename: String; ARenameFile: Boolean): String;
//function ExtractDLL2(APath, ASrcFilename: String; ARenameFile: Boolean): String;

implementation

//uses ULogFileOut ;

//==========================================================================
function MyUpcase(S:string):string;
var L,D:Integer;
    P,Q:PChar;
    C:char;
begin
  L:=Length(S);             P:=@S[1];
  while L>0 do begin
    Q:=CharNext(P);         D:=Q-P;
    if D=1 then begin
      C:=P^;
      if (C>='a') and (C<='z') then P^:=char(byte(C) and $DF);
    end;
    dec(L,D);     P:=Q;
  end;
  Result:=S;
end;

//==========================================================================
function FindName(F:string; G:TStream):string;
var Sz:DWord;
  L:byte;
  Fn:array[0..255] of char;
begin
 Result:='';
 F:=MyUpCase(F);
  while G.Position < G.Size do begin                     // Search file name
    G.Read(L,Sizeof(L));     G.Read(Fn,L);       Result:=StrPas(Fn);
    if (F=StrPas(Fn)) or (F='') then break;            // Find
    G.Seek(4,1);                                       // Skip
    G.Read(Sz,Sizeof(Sz));   G.Seek(Sz,1);
    Result:='';
  end;
end;

//==========================================================================
function LoadZip(Tag,Zip:TStream):DWord;
var Z:TDecompressionStream;
    L:DWord;
begin
  Tag.Size:=0;
  Zip.Read(L,Sizeof(L));
 Zip.Read(Result,Sizeof(Result));
  Z:=TDecompressionStream.Create(Zip);
  Tag.CopyFrom(Z,L);
  Tag.Seek(0,0);
  Z.Free;
end;

//==========================================================================
function Unpack(P,FileName:string; ChangeName:Boolean):TStringList;
var T:TStream;
    s,
    G,N:string;
    X:TStream;
begin
  Result:=TStringList.Create;
  try
 P:=MyUpCase(P);           ForceDirectories(P);
    T:=TResourceStream.Create(HInstance,'ZIPDATA','FINEART');
    if Assigned(T) then begin
      repeat
        N:=FindName(FileName,T);
        if N<>'' then begin
          if ChangeName then
          begin
            s := RandomAlphabetString(0, 8, True);
            G:=Format('%s%s%s',[P,s,ExtractFileExt(N)]);
          end
          else
            G:=P+N;
          X:=TFileStream.Create(G,fmCreate);
          if Assigned(X) then begin
            LoadZip(X,T);
            Result.AddObject(Format('%s=%s',[N,G]),TObject(X.Size));
            X.Free;
          end;
        end;
      until N='';
      T.Free;
    end;
  except
  end;
end;

{==============================================================================}
{   函式敘述：                                                                 }
{       將以ZPack包在程式Resource中的檔案解出來到特定目錄。                    }
{   參數：                                                                     }
{       APAth:                                                                 }
{           要解到哪個目錄。                                                   }
{       ASrcFilename:                                                          }
{           要解出哪個檔案。                                                   }
{       ARenameFile:                                                           }
{           解出來的檔案是否要換成隨機的檔名。                                 }
{   傳回值：                                                                   }
{       若成功解出，會傳回該檔案的完整路徑檔名。否則傳回空字串。               }
{==============================================================================}
function ExtractDLL(APath, ASrcFilename: String; ARenameFile: Boolean): String;
var
  L:    TStringList;
begin
  Result := ExtractFilePath(Application.ExeName) + ASrcFilename;
  L := Unpack(APath, ASrcFilename, ARenameFile);
  if L.Count > 0 then
  begin
    Result := L[0];
 Result := Copy(Result, AnsiPos('=', Result) + 1, Length(Result));
  end;
  L.Free;
  if not FileExists(Result) then
    Result := '';
end;

{
function ExtractDLL2(APath, ASrcFilename: String; ARenameFile: Boolean): String;
var
  L:    TStringList;
begin
  Result := APath + ASrcFilename;
  L := Unpack(APath, ASrcFilename, ARenameFile);
DDLOG('Unpack pathname :' + Result ) ;
  if L.Count > 0 then
  begin
    Result := L[0];
   Result := Copy(Result, AnsiPos('=', Result) + 1, Length(Result));
DDLOG('L.Count>0: ' + Result ) ;
  end;
  L.Free;
  if not FileExists(Result) then
    Result := '';
end;
}
end.


unit URandomString;

interface

function RandomAlphabetChar(Caps: Byte=0): Char;
function RandomAlphabetString(Caps: Byte=0; ALength: Integer=0;
                              WantNum: Boolean=false): String;

implementation

(*======================================================
               隨機取一個英文字母
            Parameter:
                Caps:   是否限制大小寫
                    0 : 不限
                    1 : 大寫字母
                    2 : 小寫字母
            Return:
                傳回亂數取得的英文字母
*)
function RandomAlphabetChar(Caps: Byte=0): Char;
begin
  Result:=Chr($61+Random(26));
  Case Caps of
    0:
      begin
        // 隨機決定大小寫
        if Random(2)=1 then
          Result:=UpCase(Result);
      end;
    1:
      Result:=UpCase(Result);
  end;
end;

(*======================================================
               隨機產生一個字串
            Parameter:
                Caps:   是否限制大小寫
                    0 :     不限
                    1 :     大寫字母
                    2 :     小寫字母
                Length: 字串長度，若為0則長度為1~10的不定長度值
                WantNum:是否要夾雜有數字
                    true : 要夾雜數字
                    false: 不要有數字
            Return:
                傳回隨機產生的字串
*)
function RandomAlphabetString(Caps: Byte=0; ALength: Integer=0;
                              WantNum: Boolean=false): String;
var
  i:    Integer;
  iLen: Integer;
begin
  // 要產生的字串長度
  if ALength=0 then
    iLen:=Random(10)+1
  else
    iLen:=ALength;

  Result:='';
  for i:=0 to iLen-1 do
  begin
    if WantNum then
      if Random(2)=1 then
      begin
        Result:=Result+Chr(Random(10)+$30);
        continue;
      end;
    Result:=Result+RandomAlphabetChar(Caps);
  end;
end;

end.

皆接在讀取文字檔的ULang.pas內，先按ALT+F11加入uses UZPack。
並判斷如果目錄下沒有多國語言文字檔的話，則讀取資源檔，程式碼如下：


//初始化字串檔(解檔及取得檔名) by v
function InitStringFile():boolean;
var
  sStringFileName:string;
begin
  //result:=false;
  g_cLang := GetLanguage;// 取得系統語系
  //g_cLang := '1';//
  if not (g_cLang in ['0','1','2','3']) then
    g_cLang := '2' ;// 目前只提供四種語言，內訂英文

  sStringFileName:='wording' + g_cLang + '.txt' ;
  g_sStrFile:=g_sWorkPath +sStringFileName;
  //showmessage(g_sStrFile);

  //檢查目前執行環境同目錄下,若無字串檔,則解檔案至 temp 路徑下
  if not FileExists(g_sStrFile) then
  begin
    g_sStrFile:=g_sTempPath+sStringFileName;
    if( StrIComp(PChar(ExtractDLL(g_sTempPath, sStringFileName, false)),PChar(g_sStrFile)) <> 0 ) then    // 解壓縮文字檔
    begin
      result:=False;
      //showmessage('Extract wording file failed !');
      exit;
    end ;
  end;

  result:=true;
end;

另外想解壓縮mdb放到temp目錄下，又不想刪除，可用下列的方式
新增UCommon.pas


unit UCommon;

interface

uses Windows, SysUtils;

procedure InitGlobalVariable;
function GetWorkDirectory:String;
function GetTmpDirectory(): string ;
function ExtractZpackFile(filename:String):String;

var
  g_sTempPath   : string;   // (TempPath)
  g_sWorkPath   : string;   // (WorkingPath)

implementation

uses UZPack;

procedure InitGlobalVariable;
begin
  g_sWorkPath:=GetWorkDirectory();
  g_sTempPath:=GetTmpDirectory();
  createdir(g_sTempPath+'QooFunds');  //在%temp%\下建立QooFunds資料夾
  g_sTempPath:=g_sTempPath + 'QooFunds\';
end;

function GetWorkDirectory;
var
  aBuf:     array[0..260] of Char;
begin
  GetModuleFileName(HINSTANCE, @aBuf[0], SizeOf(aBuf));
  Result := IncludeTrailingBackslash(ExtractFilePath(StrPas(aBuf)));
end;

function GetTmpDirectory(): string ;
var
  dwBuffSize : DWORD ;
  cBuffer : array[0..MAX_PATH] of char ;
begin
  dwBuffSize := MAX_PATH ;
  GetTempPath( dwBuffSize, cBuffer) ;
  Result := cBuffer ;
end ;

function ExtractZpackFile(filename:String):String;
var
  sPathName : string ;
begin
  sPathName := g_sTempPath + filename ;
  if not FileExists(sPathName) then
    if( StrIComp(PChar(ExtractDLL(g_sTempPath, filename, false)),PChar(sPathName)) <>0  ) then
    begin
    // ErrMsgBox('Extract report templete failed') ;
      Halt ;
    end ;
  Result:= sPathName;
end;

end.

project1


program Project1;

uses
  ExceptionLog,
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  UZPack in 'UZPack.pas',
  URandomString in 'URandomString.pas',
  UCommon in 'UCommon.pas';

{$R *.res}
{$R build.res}

begin
  InitGlobalVariable;

  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

主視窗開始加入


uses UZPack, UCommon;

procedure TForm1.FormCreate(Sender: TObject);
begin
  sTemplateFile:=ExtractZpackFile('我的基金.mdb');

  ADOConnection1.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0;User ID=Admin;Data Source='+sTemplateFile+';Mode=Share Deny None;Persist Security Info=False;Jet OLEDB:Engine Type=5';
  try
    ADOConnection1.Connected    := True;
  except
    Showmessage('連線失敗!');
  end;
end;

星期三, 10月 03, 2007

圖片掌形拖曳工具 (圖片中間有小手)

首先新增
1個TScrollBox; AutoScroll屬性False;
1個TImage; Cursor屬性crHandPoint; Pitcher屬性加入自己的圖片;
1個TScrollBar; Min屬性1; LargeChange屬性10;
1個TScrollBar; Min屬性1; LargeChange屬性10; Kind屬性sbVertical

事件
在兩個TScrollBar物件都點兩下。
TImage的OnMouseDown、OnMouseMove及OnMouseUp都點兩下
TForm的OnCreate


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ScrollBox1: TScrollBox;
    Image1: TImage;
    ScrollBar1: TScrollBar;
    ScrollBar2: TScrollBar;
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure ScrollBar2Change(Sender: TObject);
    procedure ScrollBar1Change(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

var CanMove:boolean;
    OldX,OldY:Integer;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  temp:Integer;
begin
  if CanMove then //可以開始移動
  begin

    //往左右移判斷
    temp:=Image1.Left+X-OldX;
    if temp > -1  then
      Image1.Left := -1
    else if temp < ScrollBox1.Width-Image1.Width then
      Image1.Left := ScrollBox1.Width-Image1.Width
    else
      Image1.Left := temp;
    ScrollBar1.Position:=-Image1.Left;

    //往上下移判斷
    temp:=Image1.Top+Y-OldY;
    if temp > -1  then
      Image1.Top := -1
    else if temp < ScrollBox1.Height-Image1.Height then
      Image1.Top := ScrollBox1.Height-Image1.Height
    else
      Image1.Top := temp;
    ScrollBar2.Position:=-Image1.Top;

  end;
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  CanMove:=true; //設定可以開始
  OldX:=X;  //OldX為滑鼠點下去的X位置
  OldY:=Y;  //OldX為滑鼠點下去的Y位置

end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  CanMove:=False; //設定不可以開始
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ScrollBox1.DoubleBuffered:=True;

  ScrollBar1.Max:=Image1.Width-ScrollBox1.Width+(ScrollBox1.Width*ScrollBox1.Width div Image1.Width);
  ScrollBar1.Pagesize:=ScrollBox1.Width*ScrollBox1.Width div Image1.Width;

  ScrollBar2.Max:=Image1.Height-ScrollBox1.Height+(ScrollBox1.Height*ScrollBox1.Height div Image1.Height);
  ScrollBar2.Pagesize:=ScrollBox1.Height*ScrollBox1.Height div Image1.Height;
end;

procedure TForm1.ScrollBar1Change(Sender: TObject);
begin
  if ScrollBar1.Position > Image1.Width-ScrollBox1.Width then
    ScrollBar1.Position:=Image1.Width-ScrollBox1.Width;
  Image1.Left:=-ScrollBar1.Position;
end;

procedure TForm1.ScrollBar2Change(Sender: TObject);
begin
  if ScrollBar2.Position > Image1.Height-ScrollBox1.Height then
    ScrollBar2.Position:=Image1.Height-ScrollBox1.Height;
  Image1.Top:=-ScrollBar2.Position;
end;

end.

訂閱：文章 (Atom)

關於我自己

Archives

Subscribe

Powered By