請教如何讓現有的程式縮於System Tray? |
|
答題得分者是：hagar
|
|
oxpretaa
一般會員   發表：3 回覆：2 積分：1 註冊：2004-05-25 發送簡訊給我 |
請教各位前輩：
小弟在會員發表區發現了一個自已想要的程式，後來想要把他變成能夠縮於右下角，於是套用了版主的
程式，想利用這個方法順利的加在右下角的工作列中，後來出現錯誤了…程式就在下頭…
unit MailLogin_u; interface { 新增支援郵件網站：修改siteinfo.Lines } uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, OleCtrls, SHDocVw, ExtCtrls, Buttons, AccountListForm_u,
Menus, ImgList, ShellAPI; type
TMailServiceInfo = record
Domain:string;
URL:string;
PageTitle:string;
FormName,IDFieldName,PasswordFieldName:OleVariant;
ID:string;
Password:string;
end; type
TForm1 = class(TForm)
wb: TWebBrowser;
account: TComboBox;
CtrlPanel: TPanel;
Label1: TLabel;
login_btn: TSpeedButton;
exit_btn: TSpeedButton;
accountlist_btn: TSpeedButton;
siteinfo: TMemo;
mark: TLabel;
ImageList1: TImageList;
PopupMenu1: TPopupMenu;
Timer1: TTimer;
Button1: TButton;
open1: TMenuItem;
close1: TMenuItem;
procedure wbDocumentComplete(Sender: TObject; const pDisp: IDispatch;
var URL: OleVariant);
procedure FormResize(Sender: TObject);
procedure login_btnClick(Sender: TObject);
procedure accountChange(Sender: TObject);
procedure exit_btnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure accountlist_btnClick(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure markClick(Sender: TObject);
procedure markMouseEnter(Sender: TObject);
procedure markMouseLeave(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure open1Click(Sender: TObject);
procedure close1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private FAccountFilename:TFileName;
FMail:TMailServiceInfo;
FPasswordList:TStrings;
procedure ReadAccounts;
procedure SaveAccounts;
procedure SetMailInfo;
public
procedure WndProc(var Msg : TMessage); override;
{ Public declarations } IconData : TNotifyIconData;
IconCount : integer;
end; var
Form1: TForm1; implementation {$R *.dfm}
type GetDirection = (getBefore, getAfter);
function GetSubstring(AStr:string; Direction:GetDirection; Delim:char):string;
var i:integer;
begin
i:=Pos(Delim,AStr);
if i>0 then
case Direction of
getBefore:Result:=Copy(AStr,1,i-1);
getAfter:Result:=Copy(AStr,i 1,Length(AStr)-i);
end
else Result:='';
end;
// 此為Tray程式觸發進入點
procedure TForm1.WndProc(var Msg : TMessage);
var
p : TPoint;
begin
case Msg.Msg of
WM_USER 1:
case Msg.lParam of
WM_RBUTTONDOWN: begin // 在圖上按了左鍵
GetCursorPos(p);
PopupMenu1.Popup(p.x, p.y);
end;
WM_LBUTTONDOWN: begin // 在圖上按了右鍵
open1Click(form1);
end;
end;
end;
inherited;
end; procedure TForm1.ReadAccounts;
var i:integer;
begin
if FileExists(FAccountFilename) then
begin
FPasswordList.LoadFromFile(FAccountFilename);
account.Clear;
for i:=0 to FPasswordList.Count-1 do
begin
account.Items.Add(GetSubstring(FPasswordList[i],getBefore,':'));
FPasswordList[i]:=GetSubstring(FPasswordList[i],getAfter,':');
end;
end;
account.Text:='Choose your account...';
end; procedure TForm1.SaveAccounts;
var ss:TStrings;
i:integer;
begin
ss:=TStringList.Create;
ss.Clear;
try
for i:=0 to account.Items.Count-1 do
ss.Add(account.Items[i] ':' FPasswordList[i]);
ss.SaveToFile(FAccountFilename);
finally
ss.Free;
end;
end; procedure TForm1.SetMailInfo;
var s,FormParam:string;
begin
FMail.ID:=GetSubstring(account.Text,getBefore,'@');
FMail.Domain:=LowerCase(GetSubstring(account.Text,getAfter,'@'));
if FMail.Domain='hotmail.com' then FMail.ID:=FMail.ID '@hotmail.com';
s:=siteinfo.Lines.Values[FMail.Domain];
FMail.URL:=GetSubstring(s,getBefore,'|');
s:=GetSubstring(s,getAfter,'|');
FMail.PageTitle:=GetSubstring(s,getBefore,'|');
s:=GetSubstring(s,getAfter,'|');
FormParam:=GetSubstring(s,getBefore,'|');
s:=GetSubstring(s,getAfter,'|');
FMail.IDFieldName:=GetSubstring(s,getBefore,'|');
FMail.PasswordFieldName:=GetSubstring(s,getAfter,'|');
//處理FormName的狀況：字串或Index值
if FormParam[1]='#' then FMail.FormName:=StrToInt(Copy(FormParam,2,Length(FormParam)-1)) else FMail.FormName:=FormParam; FMail.Password:=FPasswordList[account.ItemIndex];
end; procedure TForm1.wbDocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var doc,wform:OleVariant;
begin
doc:=wb.OleObject.Document;
if Pos(FMail.PageTitle,doc.title)>0 then
begin
wform:=doc.Forms.Item(FMail.FormName);
wform.Item(FMail.IDFieldName,0).value:=FMail.ID;
wform.Item(FMail.PasswordFieldName,0).value:=FMail.Password;
wform.submit;
FMail.PageTitle:='';
end;
end; procedure TForm1.FormResize(Sender: TObject);
begin
wb.Top:=CtrlPanel.Height;
wb.Left:=0;
wb.Width:=Width-8;
wb.Height:=Height-CtrlPanel.Height-32;
exit_btn.Left:=wb.Left wb.Width-exit_btn.Width;
accountlist_btn.Left:=exit_btn.Left-accountlist_btn.Width-4;
mark.Left:=accountlist_btn.Left-mark.Width-12;
end; procedure TForm1.login_btnClick(Sender: TObject);
begin
self.SetMailInfo;
wb.Navigate(FMail.URL);
end; procedure TForm1.accountChange(Sender: TObject);
begin
if account.ItemIndex>=0 then login_btn.Enabled:=true;
end; procedure TForm1.exit_btnClick(Sender: TObject);
begin
close;
end; procedure TForm1.FormCreate(Sender: TObject);
begin
FPasswordList:=TStringList.Create;
FAccountFilename:=ChangeFileExt(Application.ExeName,'.INI');
end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FPasswordList.Free;
end; procedure TForm1.accountlist_btnClick(Sender: TObject);
var i:integer;
begin
AccountListForm:=TAccountListForm.Create(self);
for i:=0 to account.Items.Count-1 do
AccountListForm.accs.Strings.Add(account.Items[i] '=' FPasswordList[i]);
for i:=1 to siteinfo.Lines.Count-1 do
AccountListForm.domain.Items.Add('@' siteinfo.Lines.Names[i]);
try
if AccountListForm.ShowModal=mrOK then
begin
account.Clear;
FPasswordList.Clear;
for i:=0 to AccountListForm.accs.Strings.Count-1 do
begin
account.Items.Add(AccountListForm.accs.Strings.Names[i]);
FPasswordList.Add(AccountListForm.accs.Strings.Values[account.Items[i]]);
end;
SaveAccounts;
end;
finally
AccountListForm.Free;
end;
end; procedure TForm1.FormActivate(Sender: TObject);
begin
if FileExists(FAccountFilename) then
ReadAccounts
else
begin
ShowMessage(#13 ' 您還沒有指定帳號… ' #13);
accountlist_btn.Click;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var ico:ticon;
begin
ico:=ticon.create;
imagelist1.GetIcon(0,ico);
BorderIcons := [biSystemMenu];
IconCount := 0;
IconData.cbSize := sizeof(IconData);
IconData.Wnd := Handle;
IconData.uID := 100;
IconData.uFlags := NIF_MESSAGE NIF_ICON NIF_TIP;
IconData.uCallbackMessage := WM_USER 1;
IconData.hIcon := ico.handle;
StrPCopy(IconData.szTip, Application.Title);
Shell_NotifyIcon(NIM_ADD, @IconData);
Timer1.Interval := 1000;
Timer1.Enabled := true;
ico.free;
end;
// 避免按了X結束程式
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caNone;
Form1.Hide;
end;
// 一秒跑一次,改圖示用
procedure TForm1.Timer1Timer(Sender: TObject);
var ico:ticon;
begin
ico:=ticon.create;
imagelist1.GetIcon(IconCount,ico);
IconData.hIcon := ico.handle;
inc(IconCount);
if IconCount > 1 then
IconCount := 0;
StrPCopy(IconData.szTip, TimeToStr(Now));
Shell_NotifyIcon(NIM_MODIFY, @IconData);
ico.free;
end;
// 開啟視窗
procedure TForm1.open1Click(Sender: TObject);
begin
Form1.Show;
ShowWindow(Application.Handle, SW_HIDE);
end;
// 結束程式用
procedure TForm1.close1Click(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, @IconData);
Application.ProcessMessages;
Application.Terminate;
end; procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.hide;
end; procedure TForm1.markClick(Sender: TObject);
begin
FMail.PageTitle:='';
wb.Navigate('http://delphi.ktop.com.tw');
end; procedure TForm1.markMouseEnter(Sender: TObject);
begin
mark.Font.Color:=clBlue;
end; procedure TForm1.markMouseLeave(Sender: TObject);
begin
mark.Font.Color:=clGreen;
end; end. 在run完後出現了以下的錯誤訊息…
[error]MailLogin_u.pas(69):Field definition not allowed after methods or properties
[error]MailLogin_u.pas(252):Identifier redeclared:'TForm1.FormCreate'
[error]MailLogin_u.pas(265):Unsafe code '@operator'
[Warning]MailLogin_u.pas(272):Identifier redeclared:'TForm1.FormClose'
[error]MailLogin_u.pas(287):Unsafe code '@operator'
[error]MailLogin_u.pas(299):Unsafe code '@operator'
[Fatal Error]MailLogin.dpr(6):Could not compile used unit'MaiLogin_u.pas' 可以請各位前輩幫小弟看一下嗎?
對不起小弟是初學者，如果這樣問問題有錯誤，請各位前輩多多見諒。
p.s如果有更好的方法，可以請前輩們不吾賜教嗎!!謝謝
|
|
hagar
版主   發表：143 回覆：4056 積分：4445 註冊：2002-04-14 發送簡訊給我 |
紅色為修改部份
unit MailLogin_u; interface { 新增支援郵件網站：修改siteinfo.Lines } uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, OleCtrls, SHDocVw, ExtCtrls, Buttons, AccountListForm_u,
Menus, ImgList, ShellAPI; type
TMailServiceInfo = record
Domain:string;
URL:string;
PageTitle:string;
FormName,IDFieldName,PasswordFieldName:OleVariant;
ID:string;
Password:string;
end; type
TForm1 = class(TForm)
wb: TWebBrowser;
account: TComboBox;
CtrlPanel: TPanel;
Label1: TLabel;
login_btn: TSpeedButton;
exit_btn: TSpeedButton;
accountlist_btn: TSpeedButton;
siteinfo: TMemo;
mark: TLabel;
ImageList1: TImageList;
PopupMenu1: TPopupMenu;
Timer1: TTimer;
Button1: TButton;
open1: TMenuItem;
close1: TMenuItem;
procedure wbDocumentComplete(Sender: TObject; const pDisp: IDispatch;
var URL: OleVariant);
procedure FormResize(Sender: TObject);
procedure login_btnClick(Sender: TObject);
procedure accountChange(Sender: TObject);
procedure exit_btnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure accountlist_btnClick(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure markClick(Sender: TObject);
procedure markMouseEnter(Sender: TObject);
procedure markMouseLeave(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure open1Click(Sender: TObject);
procedure close1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
FAccountFilename:TFileName;
FMail:TMailServiceInfo;
FPasswordList:TStrings; procedure ReadAccounts;
procedure SaveAccounts;
procedure SetMailInfo;
public
IconData : TNotifyIconData;
IconCount : integer; // 變數宣告要在 procedure 前面
procedure WndProc(var Msg : TMessage); override;
{ Public declarations }
end; var
Form1: TForm1; implementation {$R *.dfm}
type GetDirection = (getBefore, getAfter); function GetSubstring(AStr:string; Direction:GetDirection; Delim:char):string;
var i:integer;
begin
i:=Pos(Delim,AStr);
if i>0 then
case Direction of
getBefore:Result:=Copy(AStr,1,i-1);
getAfter:Result:=Copy(AStr,i 1,Length(AStr)-i);
end
else Result:='';
end;
// 此為Tray程式觸發進入點
procedure TForm1.WndProc(var Msg : TMessage);
var
p : TPoint;
begin
case Msg.Msg of
WM_USER 1:
case Msg.lParam of
WM_RBUTTONDOWN: begin // 在圖上按了左鍵
GetCursorPos(p);
PopupMenu1.Popup(p.x, p.y);
end;
WM_LBUTTONDOWN: begin // 在圖上按了右鍵
open1Click(form1);
end;
end;
end;
inherited;
end; procedure TForm1.ReadAccounts;
var i:integer;
begin
if FileExists(FAccountFilename) then
begin
FPasswordList.LoadFromFile(FAccountFilename);
account.Clear;
for i:=0 to FPasswordList.Count-1 do
begin
account.Items.Add(GetSubstring(FPasswordList[i],getBefore,':'));
FPasswordList[i]:=GetSubstring(FPasswordList[i],getAfter,':');
end;
end;
account.Text:='Choose your account...';
end; procedure TForm1.SaveAccounts;
var ss:TStrings;
i:integer;
begin
ss:=TStringList.Create;
ss.Clear;
try
for i:=0 to account.Items.Count-1 do
ss.Add(account.Items[i] ':' FPasswordList[i]);
ss.SaveToFile(FAccountFilename);
finally
ss.Free;
end;
end; procedure TForm1.SetMailInfo;
var s,FormParam:string;
begin
FMail.ID:=GetSubstring(account.Text,getBefore,'@');
FMail.Domain:=LowerCase(GetSubstring(account.Text,getAfter,'@'));
if FMail.Domain='hotmail.com' then FMail.ID:=FMail.ID '@hotmail.com';
s:=siteinfo.Lines.Values[FMail.Domain];
FMail.URL:=GetSubstring(s,getBefore,'|');
s:=GetSubstring(s,getAfter,'|');
FMail.PageTitle:=GetSubstring(s,getBefore,'|');
s:=GetSubstring(s,getAfter,'|');
FormParam:=GetSubstring(s,getBefore,'|');
s:=GetSubstring(s,getAfter,'|');
FMail.IDFieldName:=GetSubstring(s,getBefore,'|');
FMail.PasswordFieldName:=GetSubstring(s,getAfter,'|');
//處理FormName的狀況：字串或Index值
if FormParam[1]='#' then FMail.FormName:=StrToInt(Copy(FormParam,2,Length(FormParam)-1)) else FMail.FormName:=FormParam; FMail.Password:=FPasswordList[account.ItemIndex];
end; procedure TForm1.wbDocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var doc,wform:OleVariant;
begin
doc:=wb.OleObject.Document;
if Pos(FMail.PageTitle,doc.title)>0 then
begin
wform:=doc.Forms.Item(FMail.FormName);
wform.Item(FMail.IDFieldName,0).value:=FMail.ID;
wform.Item(FMail.PasswordFieldName,0).value:=FMail.Password;
wform.submit;
FMail.PageTitle:='';
end;
end; procedure TForm1.FormResize(Sender: TObject);
begin
wb.Top:=CtrlPanel.Height;
wb.Left:=0;
wb.Width:=Width-8;
wb.Height:=Height-CtrlPanel.Height-32;
exit_btn.Left:=wb.Left wb.Width-exit_btn.Width;
accountlist_btn.Left:=exit_btn.Left-accountlist_btn.Width-4;
mark.Left:=accountlist_btn.Left-mark.Width-12;
end; procedure TForm1.login_btnClick(Sender: TObject);
begin
self.SetMailInfo;
wb.Navigate(FMail.URL);
end; procedure TForm1.accountChange(Sender: TObject);
begin
if account.ItemIndex>=0 then login_btn.Enabled:=true;
end; procedure TForm1.exit_btnClick(Sender: TObject);
begin
close;
end; // FormCreate 實作了兩次，將它合為一個
procedure TForm1.FormCreate(Sender: TObject);
var
ico:ticon;
begin
FPasswordList:=TStringList.Create;
FAccountFilename:=ChangeFileExt(Application.ExeName,'.INI'); ico:=ticon.create;
imagelist1.GetIcon(0,ico);
BorderIcons := [biSystemMenu];
IconCount := 0;
IconData.cbSize := sizeof(IconData);
IconData.Wnd := Handle;
IconData.uID := 100;
IconData.uFlags := NIF_MESSAGE NIF_ICON NIF_TIP;
IconData.uCallbackMessage := WM_USER 1;
IconData.hIcon := ico.handle;
StrPCopy(IconData.szTip, Application.Title);
Shell_NotifyIcon(NIM_ADD, @IconData);
Timer1.Interval := 1000;
Timer1.Enabled := true;
ico.free;
end; procedure TForm1.accountlist_btnClick(Sender: TObject);
var i:integer;
begin
AccountListForm:=TAccountListForm.Create(self);
for i:=0 to account.Items.Count-1 do
AccountListForm.accs.Strings.Add(account.Items[i] '=' FPasswordList[i]);
for i:=1 to siteinfo.Lines.Count-1 do
AccountListForm.domain.Items.Add('@' siteinfo.Lines.Names[i]);
try
if AccountListForm.ShowModal=mrOK then
begin
account.Clear;
FPasswordList.Clear;
for i:=0 to AccountListForm.accs.Strings.Count-1 do
begin
account.Items.Add(AccountListForm.accs.Strings.Names[i]);
FPasswordList.Add(AccountListForm.accs.Strings.Values[account.Items[i]]);
end;
SaveAccounts;
end;
finally
AccountListForm.Free;
end;
end; procedure TForm1.FormActivate(Sender: TObject);
begin
if FileExists(FAccountFilename) then
ReadAccounts
else
begin
ShowMessage(#13 ' 您還沒有指定帳號… ' #13);
accountlist_btn.Click;
end;
end; // 避免按了X結束程式
// FormClose 也實作了兩個，將它合為一個
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FPasswordList.Free; Action := caNone;
Form1.Hide;
end; // 一秒跑一次,改圖示用
procedure TForm1.Timer1Timer(Sender: TObject);
var ico:ticon;
begin
ico:=ticon.create;
imagelist1.GetIcon(IconCount,ico);
IconData.hIcon := ico.handle;
inc(IconCount);
if IconCount > 1 then
IconCount := 0;
StrPCopy(IconData.szTip, TimeToStr(Now));
Shell_NotifyIcon(NIM_MODIFY, @IconData);
ico.free;
end;
// 開啟視窗
procedure TForm1.open1Click(Sender: TObject);
begin
Form1.Show;
ShowWindow(Application.Handle, SW_HIDE);
end;
// 結束程式用
procedure TForm1.close1Click(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, @IconData);
Application.ProcessMessages;
Application.Terminate;
end; procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.hide;
end; procedure TForm1.markClick(Sender: TObject);
begin
FMail.PageTitle:='';
wb.Navigate('http://delphi.ktop.com.tw');
end; procedure TForm1.markMouseEnter(Sender: TObject);
begin
mark.Font.Color:=clBlue;
end; procedure TForm1.markMouseLeave(Sender: TObject);
begin
mark.Font.Color:=clGreen;
end; end.
--
 歡迎光臨 KTop 研究院! 發表人 - hagar 於 2004/08/27 12:57:47
|
|
oxpretaa
一般會員 發表：3 回覆：2 積分：1 註冊：2004-05-25 發送簡訊給我 |
發表時間：2004-08-27 12:25:45
IP:203.72.xxx.xxx 未訂閱
系統時間：2025-02-23 23:41:38
聯絡我們 | Delphi K.Top討論版
| 本站聲明 |
|
1. 本論壇為無營利行為之開放平台，所有文章都是由網友自行張貼，如牽涉到法律糾紛一切與本站無關。 2. 假如網友發表之內容涉及侵權，而損及您的利益，請立即通知版主刪除。 3. 請勿批評中華民國元首及政府或批評各政黨，是藍是綠本站無權干涉，但這裡不是政治性論壇！ |