001期電子報編輯中心

發文回覆瀏覽次數：11490

推到 Plurk!

推到 Facebook!

[<<] [1] [2] [3] [4] [5] [>>]

bruce0211 版主發表：157 回覆：668 積分：279 註冊：2002-06-13 發送簡訊給我	#32 引用回覆回覆發表時間：2003-11-25 12:49:16 IP:211.21.xxx.xxx 未訂閱【文章】目錄處理函式三則:_DelTree(),_XCopy(),_Move() 【作者】源碼任務 bruce0211@yahoo.com.tw 2003/11/25 【內文】常用目錄處理函式整理 for BCB/Delphi ■ 用法參數位置同 DOS 公用程式 , 沒用到什麼特殊 API , 應該適用於各種 BCB/Delphi 版本 _DelTree() 刪除整個目錄(含子目錄) _XCopy() 複製整個目錄(含子目錄) _Move() 搬移整個目錄(含子目錄) ■ BCB 版本 private: // User declarations void __fastcall _XCopy(String ASourceDir,String ADestDir); void __fastcall _Move(String ASourceDir,String ADestDir); void __fastcall _DelTree(String ASourceDir); //--------------------------------------------------------------------------- void __fastcall TForm1::_XCopy(String ASourceDir,String ADestDir) { TSearchRec SearchRec; String Sour=ASourceDir; String Dest=ADestDir; if (Sour.SubString(Sour.Length(),1)!="\\") Sour=Sour "\\"; if (Dest.SubString(Dest.Length(),1)!="\\") Dest=Dest "\\"; if (!DirectoryExists(ASourceDir)) // 要 #include "FileCtrl.hpp" 才有這個函式 { ShowMessage("來源目錄不存在!!"); return; } if (!DirectoryExists(ADestDir)) ForceDirectories(ADestDir); if (FindFirst(Sour ".", faAnyFile, SearchRec) == 0) { do { //應該可用 if ((SearchRec.Attr & faDirectory) != 0) 取代下面的判斷 if ( (SearchRec.Attr == (faDirectory)) \|\| (SearchRec.Attr == (faDirectory \| faArchive)) \|\| (SearchRec.Attr == (faDirectory \| faReadOnly)) \|\| (SearchRec.Attr == (faDirectory \| faHidden)) ) { if ((SearchRec.Name!=".") && (SearchRec.Name!="..")) { _XCopy(Sour SearchRec.Name,Dest SearchRec.Name); //遞迴呼叫 } } else { CopyFile(((String)(Sour SearchRec.Name)).c_str(),((String)(Dest SearchRec.Name)).c_str(),false); } } while (FindNext(SearchRec) == 0); FindClose(SearchRec); } } //--------------------------------------------------------------------------- void __fastcall TForm1::_Move(String ASourceDir,String ADestDir) { TSearchRec SearchRec; String Sour=ASourceDir; String Dest=ADestDir; if (Sour.SubString(Sour.Length(),1)!="\\") Sour=Sour "\\"; if (Dest.SubString(Dest.Length(),1)!="\\") Dest=Dest "\\"; if (!DirectoryExists(ASourceDir)) // 要 #include "FileCtrl.hpp" 才有這個函式 { ShowMessage("來源目錄不存在!!"); return; } if (!DirectoryExists(ADestDir)) ForceDirectories(ADestDir); if (FindFirst(Sour ".", faAnyFile, SearchRec) == 0) { do { //應該可用 if ((SearchRec.Attr & faDirectory) != 0) 取代下面的判斷 if ( (SearchRec.Attr == (faDirectory)) \|\| (SearchRec.Attr == (faDirectory \| faArchive)) \|\| (SearchRec.Attr == (faDirectory \| faReadOnly)) \|\| (SearchRec.Attr == (faDirectory \| faHidden)) ) { if ((SearchRec.Name!=".") && (SearchRec.Name!="..")) { _XCopy(Sour SearchRec.Name,Dest SearchRec.Name); //遞迴呼叫 _DelTree(Sour SearchRec.Name); FileSetAttr(Sour SearchRec.Name,faArchive); RemoveDir(Sour SearchRec.Name); } } else { CopyFile(((String)(Sour SearchRec.Name)).c_str(),((String)(Dest SearchRec.Name)).c_str(),false); FileSetAttr(Sour SearchRec.Name,faArchive); DeleteFile(Sour SearchRec.Name); } } while (FindNext(SearchRec) == 0); FindClose(SearchRec); } FileSetAttr(Sour,faArchive); RemoveDir(Sour); } //--------------------------------------------------------------------------- void __fastcall TForm1::_DelTree(String ASourceDir) { TSearchRec SearchRec; String Sour=ASourceDir; if (Sour.SubString(Sour.Length(),1)!="\\") Sour=Sour "\\"; if (!DirectoryExists(Sour)) // 要 #include "FileCtrl.hpp" 才有這個函式 { ShowMessage("來源目錄不存在!!"); return; } if (FindFirst(Sour ".", faAnyFile, SearchRec) == 0) { do { //應該可用 if ((SearchRec.Attr & faDirectory) != 0) 取代下面的判斷 if ( (SearchRec.Attr == (faDirectory)) \|\| (SearchRec.Attr == (faDirectory \| faArchive)) \|\| (SearchRec.Attr == (faDirectory \| faReadOnly)) \|\| (SearchRec.Attr == (faDirectory \| faHidden)) ) { if ((SearchRec.Name!=".") && (SearchRec.Name!="..")) { _DelTree(Sour SearchRec.Name); //遞迴呼叫 FileSetAttr(Sour SearchRec.Name,faArchive); RemoveDir(Sour SearchRec.Name); } } else { FileSetAttr(Sour SearchRec.Name,faArchive); DeleteFile(Sour SearchRec.Name); } } while (FindNext(SearchRec) == 0); FindClose(SearchRec); } FileSetAttr(Sour,faArchive); RemoveDir(Sour); } ■ Delphi 版本 private { Private declarations } procedure _XCopy(ASourceDir:String; ADestDir:String); procedure _Move(ASourceDir:String; ADestDir:String); procedure _DelTree(ASourceDir:String); //--------------------------------------------------------------------------- procedure TForm1._XCopy(ASourceDir:String; ADestDir:String); var FileRec:TSearchrec; Sour:String; Dest:String; begin Sour:=ASourceDir; Dest:=ADestDir; if Sour[Length(Sour)]<>'\' then Sour := Sour '\'; if Dest[Length(Dest)]<>'\' then Dest := Dest '\'; if not DirectoryExists(ASourceDir) then begin ShowMessage('來源目錄不存在!!'); exit; end; if not DirectoryExists(ADestDir) then begin ForceDirectories(ADestDir); end; if FindFirst(Sour '.',faAnyfile,FileRec) = 0 then repeat if ((FileRec.Attr and faDirectory) <> 0) then begin if (FileRec.Name<>'.') and (FileRec.Name<>'..') then begin _XCopy(Sour FileRec.Name,Dest FileRec.Name); end; end else begin CopyFile(PChar(Sour FileRec.Name),PChar(Dest FileRec.Name),false); end; until FindNext(FileRec)<>0; FindClose(FileRec); end; //--------------------------------------------------------------------------- procedure TForm1._Move(ASourceDir:String; ADestDir:String); var FileRec:TSearchrec; Sour:String; Dest:String; begin Sour:=ASourceDir; Dest:=ADestDir; if Sour[Length(Sour)]<>'\' then Sour := Sour '\'; if Dest[Length(Dest)]<>'\' then Dest := Dest '\'; if not DirectoryExists(ASourceDir) then begin ShowMessage('來源目錄不存在!!'); exit; end; if not DirectoryExists(ADestDir) then begin ForceDirectories(ADestDir); end; if FindFirst(Sour '.',faAnyfile,FileRec) = 0 then repeat if ((FileRec.Attr and faDirectory) <> 0) then begin if (FileRec.Name<>'.') and (FileRec.Name<>'..') then begin _XCopy(Sour FileRec.Name,Dest FileRec.Name); _DelTree(Sour FileRec.Name); FileSetAttr(Sour FileRec.Name,faArchive); RemoveDir(Sour FileRec.Name); end; end else begin CopyFile(PChar(Sour FileRec.Name),PChar(Dest FileRec.Name),false); FileSetAttr(Sour FileRec.Name,faArchive); deletefile(Sour FileRec.Name); end; until FindNext(FileRec)<>0; FindClose(FileRec); FileSetAttr(Sour,faArchive); RemoveDir(Sour); end; //--------------------------------------------------------------------------- procedure TForm1._DelTree(ASourceDir:String); var FileRec:TSearchrec; Sour:String; begin Sour:=ASourceDir; if Sour[Length(Sour)]<>'\' then Sour := Sour '\'; if not DirectoryExists(ASourceDir) then begin ShowMessage('來源目錄不存在!!'); exit; end; if FindFirst(Sour '.',faAnyfile,FileRec) = 0 then repeat //if (FileRec.Attr = faDirectory) then if ((FileRec.Attr and faDirectory) <> 0) then begin if (FileRec.Name<>'.') and (FileRec.Name<>'..') then begin _DelTree(Sour FileRec.Name); FileSetAttr(Sour FileRec.Name,faArchive); RemoveDir(Sour FileRec.Name); end; end else begin FileSetAttr(Sour FileRec.Name,faArchive); deletefile(Sour FileRec.Name); end; until FindNext(FileRec)<>0; FindClose(FileRec); FileSetAttr(Sour,faArchive); RemoveDir(Sour); end;
bruce0211 版主發表：157 回覆：668 積分：279 註冊：2002-06-13 發送簡訊給我	#33 引用回覆回覆發表時間：2003-11-25 15:05:27 IP:211.21.xxx.xxx 未訂閱【文章】螢幕畫面處理函式二則:_ScreenSaveToFile(),_ScreenLoadFromFile() 【作者】源碼任務 bruce0211@yahoo.com.tw 2003/11/25 【內文】常用螢幕畫面處理函式整理 for BCB/Delphi ■ 用法 //-------------------------------------------------------------------- //函式名稱 : _ScreenSaveToFile([檔名],[存檔型態]) //函式用途 : 將螢幕畫面存檔 //參數說明 : [檔名]若為空字串則自動給定流水號檔名 ; [存檔型態] 0:bmp 1:jpg //函式範例 : _ScreenSaveToFile('',0); 將目前螢幕畫面存成 .bmp 檔,檔名使用流水號 //補充說明 : 可在程式中隨時呼叫本函式 , 將多個畫面分別存檔以利式樣製作剪貼 //-------------------------------------------------------------------- //函式名稱 : _ScreenLoadFromFile([桌布檔名位置]) //函式用途 : 更換螢幕桌布 //參數說明 : //函式範例 : _ScreenLoadFromFile('c:\test.bmp'); 將目前桌布換成 c:\test.bmp //補充說明 : //-------------------------------------------------------------------- ■ 注意要先 #include "jpeg.hpp" 或 uses jpeg ■ BCB 版本 //--------------------------------------------------------------------------- void __fastcall _ScreenSaveToFile(String AFileName, int AFileType) { TJPEGImage jpg = new TJPEGImage(); Graphics::TBitmap *bmp = new Graphics::TBitmap(); bmp->Width=Screen->Width; bmp->Height=Screen->Height; String my_filename; my_filename=Trim(AFileName); if (my_filename=="") { if (AFileType==0) my_filename="c:\\" FormatDateTime("mmdd_hhnnss_zzz",Now()) ".bmp"; //流水號檔名 else my_filename="c:\\" FormatDateTime("mmdd_hhnnss_zzz",Now()) ".jpg"; //流水號檔名 } HWND d; HDC dc; if((d=GetDesktopWindow())!=NULL) { dc=GetDC(d); BitBlt(bmp->Canvas->Handle,0,0,bmp->Width,bmp->Height,dc,0,0,SRCCOPY); ReleaseDC(d,dc); if (AFileType==0) bmp->SaveToFile(my_filename); else { jpg->Assign(bmp); jpg->SaveToFile(my_filename); } } delete jpg; delete bmp; } //--------------------------------------------------------------------------- void __fastcall _ScreenLoadFromFile(String ABmpFileName) { if (!FileExists(ABmpFileName)) return; SystemParametersInfo(SPI_SETDESKWALLPAPER, NULL, ABmpFileName.c_str(), SPIF_UPDATEINIFILE \| SPIF_SENDCHANGE); } ■ Delphi 版本 //--------------------------------------------------------------------------- procedure _ScreenSaveToFile(AFileName: String ; AFileType: integer); var d:HWND; dc:HDC; jpg:TJPEGImage; bmp:TBitmap; my_filename:String; begin jpg := TJPEGImage.Create; bmp := TBitmap.Create; bmp.Width:=Screen.width; bmp.Height:=Screen.height; my_filename:=Trim(AFileName); if my_filename='' then begin if AFileType=0 then my_filename:='c:\' FormatDateTime('mmdd_hhnnss_zzz',Now) '.bmp' //流水號檔名 else my_filename:='c:\' FormatDateTime('mmdd_hhnnss_zzz',Now) '.jpg' //流水號檔名 end; d:=GetDesktopWindow(); if (d<>0) then begin dc:=GetDC(d); BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,dc,0,0,SRCCOPY); ReleaseDC(d,dc); if AFileType=0 then begin bmp.SaveToFile(my_filename); end else begin jpg.Assign(bmp); jpg.SaveToFile(my_filename); end; end; jpg.Free; bmp.Free; end; //--------------------------------------------------------------------------- procedure _ScreenLoadFromFile(ABmpFileName:String); begin if not FileExists(ABmpFileName) then exit; SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar(ABmpFileName), SPIF_UPDATEINIFILE or SPIF_SENDCHANGE); end;
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#34 引用回覆回覆發表時間：2003-11-26 19:12:50 IP:192.168.xxx.xxx 未訂閱【文章】如何將Quick Report的報表轉成圖檔或PDF檔【作者】hagar 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=40801 1.BMP procedure TForm5.Button4Click(Sender: TObject); var BMP: TBitMap; StoredUnits: TQRUnit; i: integer; StoreDir: string; begin StoreDir:=''; {!!! Assign folder to store here (with ending '\'), leave blank to store in the .exe's folder} QuickRep1.Prepare; StoredUnits:=QuickRep1.Units; QuickRep1.Units:=Pixels; try for i:=1 to QuickRep1.QRPrinter.PageCount do begin BMP:=TBitMap.Create; try BMP.Width:=Round(QuickRep1.Page.Width); BMP.Height:=Round(QuickRep1.Page.Length); QuickRep1.QRPrinter.PageNumber:=i; BMP.Canvas.Draw(0, 0, QuickRep1.QRPrinter.Page); BMP.SaveToFile(StoreDir+'Page'+IntToStr(i)+'.bmp'); finally BMP.Free; end; end; finally QuickRep1.Units:=StoredUnits; end; end; 2.PDF var AFilter: TPsQRPDFFilter; begin AFilter := TPsQRPDFFilter.Create('MyRep.pdf'); try QuickRep.Prepare; QuickRep.ExportToFilter(AFilter); finally QuickRep.QRPrinter.Free; QuickRep.QRPrinter := nil; AFilter.Free; end; end; 參考資料: Save QReports pages as BMP: http://www.nsonic.de/Delphi/txt_WIS00489.htm http://groups.google.com.tw/groups?hl=zh-TW&lr=&ie=UTF-8&inlang=zh-TW&th=3293737e593a1cb0&rnum=29 http://groups.google.com.tw/groups?hl=zh-TW&lr=&ie=UTF-8&inlang=zh-TW&th=93ada631d63769a&rnum=1 其它相關 Tool 的連結: http://www.paperlessprinter.com/ http://www.leadtools.com/ http://www.wptools.de/ ------ ～～～Delphi K.Top討論區站長～～～
Ethan 版主發表：101 回覆：170 積分：78 註冊：2006-07-05 發送簡訊給我	#35 引用回覆回覆發表時間：2003-11-27 12:14:34 IP:61.218.xxx.xxx 未訂閱【文章】MaxDB by MySQL 釋放使用 (一個企業級的免費資料庫軟體) 【作者】黃書逸(Ethan) 【內文】MySQL 與 SAPDB合作後首推的MaxDB 真是可怕的一個資料庫軟體，如果不與各位分享的話就太沒仁義道德了，最令人髮指的地方就是 DBM GUI，所以大家一定要安裝看看，看了之後一定會很感動的... http://delphi.ktop.com.tw/loadfile.php?TOPICID=12882467&CC=288113 以下節錄文章中的一段... MaxDB by MySQL 釋放使用 (一個企業級的免費資料庫軟體) 筆者：黃書逸 shuyi@unix.net.tw MySQL AB 在產品線上增加了企業等級的 SAP-Certified 開放源碼資料庫 MySQL AB，目前在全球最受歡迎的開放源碼資料庫軟體，今天發佈了 MaxDB by MySQL並提供免費下載，MaxDB是一個高負荷的資料庫系統，SAP-Certified開放源碼資料庫一向以提供高效益及廣泛功能的風格被大眾所接受，MaxDB是MySQL AB旗艦型資料庫產品，現在擴展到企業市場並達到大規模的mySAP ERP環境的支援(SAP-DB http://www.sapdb.org)，和其他應用軟體與需大量運算的企業規模等級的資料庫功能。 MySQL AB獲得了完成的商用權利來開發與行銷未來的 SAP DB 版本，目前在全球已經有設置SAP DB的企業約有5,000家，其中包括：Intel、DaimlerChysler(德國郵政)、Braun、Bayer、YAMAHA、Deutsche Post和TOYOTA。 MaxDB 7.5 支援所有的 SAP Solutions 第一個釋放的MaxDB版本為7.5.00.05，也就是SAP DB 7.4版，MaxDB7.5.00.05在推出前已經有廣泛的測試並被證明可以完全支援SAP solutions，另外MySQL會提供一個MySQL Proxy介面，可以讓使用者在不同平台間的MaxDB和MySQL資料庫溝通，也就是說可以在MaxDB與MySQL間做資料庫的轉換...... 學習,從分享開始^^
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#36 引用回覆回覆發表時間：2003-11-27 19:20:29 IP:192.168.xxx.xxx 未訂閱【文章】如何動態呼叫function or procedure 【作者】Mickey 【內文】文章來源:http://delphi.ktop.com.tw/topic.php?topic_id=40505 type TMyPorcdure = procedure (Sender: TObject) of Object; TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); Procedure P1(Sender: TObject); Procedure P2(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} { TForm1 } procedure TForm1.P1(Sender: TObject); begin showmessage('In P1 Procedure'); end; procedure TForm1.P2(Sender: TObject); begin showmessage('In P2 Procedure'); end; procedure TForm1.Button1Click(Sender: TObject); var m : TMyPorcdure; s : string; p : Pointer; begin s := 'P1'; p := MethodAddress(s); if p<>nil then begin TMethod(m).Code := p; TMethod(m).Data := Self; m(Sender); end else raise Exception.CreateFmt('Procedure %s not exists',[s]); s := 'P2'; p := MethodAddress(s); if p<>nil then begin TMethod(m).Code := p; TMethod(m).Data := Self; m(Sender); end else raise Exception.CreateFmt('Procedure %s not exists',[s]); end; 相關參考資料: http://delphi.ktop.com.tw/topic.php?TOPIC_ID=39987 http://www.delphipraxis.net/post87477.html ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#37 引用回覆回覆發表時間：2003-11-27 19:23:02 IP:192.168.xxx.xxx 未訂閱【文章】使用OLE，在EXCEL中自動產生圖表、背景，並設定保護模式【作者】wivern 【內文】文章來源:http://delphi.ktop.com.tw/topic.php?topic_id=40545 之前在站上看了許多使用 OLE 來制作 Excel的文章，大部份都是在講如何填入資料，如何設定欄位的格式等，小弟因工作需要，必須在excel中產生圖表，在網路上找了許多資料，也有了一些心得，就在此拋磚引玉，提供一些小弟個人的心得，因為站上很多如何填資料的文章，所以小弟就省略這一部份，假設網友們已經填好資料，直接進入要產生圖表的部份， //一開始先定義OLE會用到的變數，建立excel的物件 Variant Excel,Workbooks,Workbook,Charts,Chart,Range; Excel=CreateOleObject("Excel.Application"); Excel.OlePropertySet("Visible",true); //秀出Excel的畫面 Workbooks=Excel.OlePropertyGet("Workbooks"); Workbook=Workbooks.OleFunction("Add"); Worksheets=Workbook.OlePropertyGet("Worksheets"); Worksheet=Worksheets.OleFunction("Add"); // 新增一worksheet Worksheet.OlePropertySet("Name","test") ;// 設定worksheet 的名稱 //取得Charts的物件 Charts=Workbook.OlePropertyGet("Charts"); . . . 先把所需資料填入cell中 . . //建立一個新的圖表，這時圖表會開在一個新的sheet裡，而整個sheet就是一個圖表 //之後會把圖表放在其他的sheet裡 Chart=Charts.OleFunction("Add"); //設定圖表的格式，65是表示含有資料標記的折線圖，後面會有圖表格式的說明 Chart.OlePropertySet("ChartType",65); //選定要製作圖表的資料來源，這個例子我是要選擇excel中從cell(1,1)到cell(10,5)的資料， //此動作就好像用滑鼠把這一部份的欄位選起來一樣 Range=Worksheet.OlePropertyGet("Range", Worksheet.OlePropertyGet("Cells",1,1), Worksheet.OlePropertyGet("Cells",10,5)); //設定圖表的資料來源，xlRows表示資料是以列來做排列，如果資料是用行來排列，就用xlColumns， //如果是用xlRows，選取範圍的第一列就是x軸每一筆資料的名稱， //第一行是y軸資料的名稱，其餘的就是圖表裡的數值 Chart.OleProcedure("SetSourceData",Range,xlRows); //設定圖表的title Chart.OlePropertySet("HasTitle",(Variant)true); //先設定圖表有title String Charttitle="test chart!!"; Chart.OlePropertyGet("ChartTitle").OlePropertySet("Text",Charttitle.c_str()); //設定圖表x軸和y軸是否要秀出title和資料名稱 Chart.OlePropertyGet("Axes",1).OlePropertySet("HasTitle",(Variant)true); //設定x軸是否要顯示資料名稱 Chart.OlePropertyGet("Axes",1).OlePropertyGet("AxisTitle").OlePropertySet("Text","時間");//設定x軸的title Chart.OlePropertyGet("Axes",2).OlePropertySet("HasTitle",(Variant)true); //設定y軸是否要顯示資料名稱 Chart.OlePropertyGet("Axes",2).OlePropertyGet("AxisTitle").OlePropertySet("Text","次數");//設定y軸的title //設定圖表要放在哪一個sheet裡 Chart.OleProcedure("Location",2,Worksheet.OlePropertyGet("Name")); //設定圖表的位置與長寬， //Worksheet.OlePropertyGet("ChartObjects",1)表示是要設定這個sheet中第一個圖表， //如要設定第二個圖表就用Worksheet.OlePropertyGet("ChartObjects",2)， //圖表的順序依在sheet中產生或放置的先後排列 Worksheet.OlePropertyGet("ChartObjects",1).OlePropertySet("Top",15); Worksheet.OlePropertyGet("ChartObjects",1).OlePropertySet("Left",20); Worksheet.OlePropertyGet("ChartObjects",1).OlePropertyGet("Width",50); Worksheet.OlePropertyGet("ChartObjects",1).OlePropertyGet("Height",30); //此時圖表已經漂漂亮亮的在sheet中囉! 底下列出圖表格式常數的定義: typedef enum XlChartType { xlColumnClustered = 51, xlColumnStacked = 52, xlColumnStacked100 = 53, xl3DColumnClustered = 54, xl3DColumnStacked = 55, xl3DColumnStacked100 = 56, xlBarClustered = 57, xlBarStacked = 58, xlBarStacked100 = 59, xl3DBarClustered = 60, xl3DBarStacked = 61, xl3DBarStacked100 = 62, xlLineStacked = 63, xlLineStacked100 = 64, xlLineMarkers = 65, xlLineMarkersStacked = 66, xlLineMarkersStacked100 = 67, xlPieOfPie = 68, xlPieExploded = 69, xl3DPieExploded = 70, xlBarOfPie = 71, xlXYScatterSmooth = 72, xlXYScatterSmoothNoMarkers = 73, xlXYScatterLines = 74, xlXYScatterLinesNoMarkers = 75, xlAreaStacked = 76, xlAreaStacked100 = 77, xl3DAreaStacked = 78, xl3DAreaStacked100 = 79, xlDoughnutExploded = 80, xlRadarMarkers = 81, xlRadarFilled = 82, xlSurface = 83, xlSurfaceWireframe = 84, xlSurfaceTopView = 85, xlSurfaceTopViewWireframe = 86, xlBubble = 15, xlBubble3DEffect = 87, xlStockHLC = 88, xlStockOHLC = 89, xlStockVHLC = 90, xlStockVOHLC = 91, xlCylinderColClustered = 92, xlCylinderColStacked = 93, xlCylinderColStacked100 = 94, xlCylinderBarClustered = 95, xlCylinderBarStacked = 96, xlCylinderBarStacked100 = 97, xlCylinderCol = 98, xlConeColClustered = 99, xlConeColStacked = 100, xlConeColStacked100 = 101, xlConeBarClustered = 102, xlConeBarStacked = 103, xlConeBarStacked100 = 104, xlConeCol = 105, xlPyramidColClustered = 106, xlPyramidColStacked = 107, xlPyramidColStacked100 = 108, xlPyramidBarClustered = 109, xlPyramidBarStacked = 110, xlPyramidBarStacked100 = 111, xlPyramidCol = 112, xl3DColumn = 0xFFFFEFFC, xlLine = 4, xl3DLine = 0xFFFFEFFB, xl3DPie = 0xFFFFEFFA, xlPie = 5, xlXYScatter = 0xFFFFEFB7, xl3DArea = 0xFFFFEFFE, xlArea = 1, xlDoughnut = 0xFFFFEFE8, xlRadar = 0xFFFFEFC9 } XlChartType; 小弟嘗試的結果，列出部份常數的意思，其餘的就看有沒有人補充囉! 5:2D的圓形圖(Pie圖) 16:泡泡圖 51:2D的直條圖 52:2D的堆疊直條圖 53:2D的100%堆疊直條圖 54:3D的直條圖 55:3D的堆疊直條圖 56:3D的100%堆疊直條圖 57:2D的橫條圖 58:2D的堆疊橫條圖 59:2D的100%堆疊橫條圖 60:3D的橫條圖 61:3D的堆疊橫條圖 62:3D的100%堆疊橫條圖 63:折線圖 65:含有資料標誌的折線圖接下來設定EXCEL的背景圖案 String BmpPath; BmpPath="C:\\background.bmp"; if(FileExists(BmpPath)) Worksheet.OleFunction("SetBackgroundPicture",BmpPath.c_str()); 保護sheet Worksheet.OleFunction("Protect","password",true,true,true,true) ; Protect函式的定義如下: template HRESULT /[VT_HRESULT:0]/ __fastcall _WorksheetDispT::Protect(VARIANT Password/[in,opt]/, VARIANT DrawingObjects/[in,opt]/, VARIANT Contents/[in,opt]/, VARIANT Scenarios/[in,opt]/, VARIANT UserInterfaceOnly/[in,opt]/) { _TDispID _dispid(this, OLETEXT("Protect"), DISPID(282)); TAutoArgs<5> _args; _args[1] = Password /[VT_VARIANT:0]/; _args[2] = DrawingObjects /[VT_VARIANT:0]/; _args[3] = Contents /[VT_VARIANT:0]/; _args[4] = Scenarios /[VT_VARIANT:0]/; _args[5] = UserInterfaceOnly /[VT_VARIANT:0]*/; return OleFunction(_dispid, _args); } 共有五個參數，第一個是解開保護的Password，第二個是設定是否要保護sheet上面的 DrawingObjects，像是圖表第三個是設定是否要保護sheet的Contents，設true的話，使用者不能修改sheet的內容第四個和第五個是設定是否要保護sheet的Scenarios和UserInterfaceOnly，不過我不是很清這兩個是保護什麼! Worksheet.OlePropertySet("EnableSelection",xlUnlockedCells); 這是要保護使用者連選取cell都不可以，不過我發現這個保護只能在用OLE製作EXCEL時有效，如果製作完，把EXCEL關掉，再打開，就又可以選取cell了，可能有什麼步驟沒做好吧~ ----------------------------------------------------- 有一點很重要，程式中用到的那些常數，像是xlRows、xlcolumns、xlUnlockedCells等，還有各種圖表格式的定義，以及OLE所提供的所有函數名稱，都是定義在excel_2k.h這個標頭檔裡，所以程式前面要加上 #include 要不然執行時會出現沒有定義變數這個錯誤，我很多功能都是看這個標頭檔學來的，如果想進一步了解OLE 製作Excel還有哪裡功能，可以試著看看這個檔，不過不容易看~我知道! 像是如果想看>"這個字串，就可以找到 class="code"> typedef enum Constants { xlAll = 0xFFFFEFF8, xlAutomatic = 0xFFFFEFF7, xlBoth = 1, xlCenter = 0xFFFFEFF4, xlChecker = 9, xlCircle = 8, xlCorner = 2, xlCrissCross = 16, xlCross = 4, xlDiamond = 2, xlDistributed = 0xFFFFEFEB, xlDoubleAccounting = 5, xlFixedValue = 1, xlFormats = 0xFFFFEFE6, xlGray16 = 17, xlGray8 = 18, xlGrid = 15, xlHigh = 0xFFFFEFE1, xlInside = 2, xlJustify = 0xFFFFEFDE, xlLightDown = 13, xlLightHorizontal = 11, xlLightUp = 14, xlLightVertical = 12, xlLow = 0xFFFFEFDA, xlManual = 0xFFFFEFD9, xlMinusValues = 3, xlModule = 0xFFFFEFD3, xlNextToAxis = 4, xlNone = 0xFFFFEFD2, xlNotes = 0xFFFFEFD0, xlOff = 0xFFFFEFCE, xlOn = 1, xlPercent = 2, xlPlus = 9, xlPlusValues = 2, xlSemiGray75 = 10, xlShowLabel = 4, xlShowLabelAndPercent = 5, xlShowPercent = 3, xlShowValue = 2, xlSimple = 0xFFFFEFC6, xlSingle = 2, xlSingleAccounting = 4, xlSolid = 1, xlSquare = 1, xlStar = 5, xlStError = 4, xlToolbarButton = 2, xlTriangle = 3, xlGray25 = 0xFFFFEFE4, xlGray50 = 0xFFFFEFE3, xlGray75 = 0xFFFFEFE2, xlBottom = 0xFFFFEFF5, xlLeft = 0xFFFFEFDD, xlRight = 0xFFFFEFC8, xlTop = 0xFFFFEFC0, xl3DBar = 0xFFFFEFFD, xl3DSurface = 0xFFFFEFF9, xlBar = 2, xlColumn = 3, xlCombination = 0xFFFFEFF1, xlCustom = 0xFFFFEFEE, xlDefaultAutoFormat = 0xFFFFFFFF, xlMaximum = 2, xlMinimum = 4, xlOpaque = 3, xlTransparent = 2, xlBidi = 0xFFFFEC78, xlLatin = 0xFFFFEC77, xlContext = 0xFFFFEC76, xlLTR = 0xFFFFEC75, xlRTL = 0xFFFFEC74, xlFullScript = 1, xlPartialScript = 2, xlMixedScript = 3, xlMixedAuthorizedScript = 4, xlVisualCursor = 2, xlLogicalCursor = 1, xlSystem = 1, xlPartial = 3, xlHindiNumerals = 3, xlBidiCalendar = 3, xlGregorian = 2, xlComplete = 4, xlScale = 3, xlClosed = 3, xlColor1 = 7, xlColor2 = 8, xlColor3 = 9, xlConstants = 2, xlContents = 2, xlBelow = 1, xlCascade = 7, xlCenterAcrossSelection = 7, xlChart4 = 2, xlChartSeries = 17, xlChartShort = 6, xlChartTitles = 18, xlClassic1 = 1, xlClassic2 = 2, xlClassic3 = 3, xl3DEffects1 = 13, xl3DEffects2 = 14, xlAbove = 0, xlAccounting1 = 4, xlAccounting2 = 5, xlAccounting3 = 6, xlAccounting4 = 17, xlAdd = 2, xlDebugCodePane = 13, xlDesktop = 9, xlDirect = 1, xlDivide = 5, xlDoubleClosed = 5, xlDoubleOpen = 4, xlDoubleQuote = 1, xlEntireChart = 20, xlExcelMenus = 1, xlExtended = 3, xlFill = 5, xlFirst = 0, xlFloating = 5, xlFormula = 5, xlGeneral = 1, xlGridline = 22, xlIcons = 1, xlImmediatePane = 12, xlInteger = 2, xlLast = 1, xlLastCell = 11, xlList1 = 10, xlList2 = 11, xlList3 = 12, xlLocalFormat1 = 15, xlLocalFormat2 = 16, xlLong = 3, xlLotusHelp = 2, xlMacrosheetCell = 7, xlMixed = 2, xlMultiply = 4, xlNarrow = 1, xlNoDocuments = 3, xlOpen = 2, xlOutside = 3, xlReference = 4, xlSemiautomatic = 2, xlShort = 1, xlSingleQuote = 2, xlStrict = 2, xlSubtract = 3, xlTextBox = 16, xlTiled = 1, xlTitleBar = 8, xlToolbar = 1, xlVisible = 12, xlWatchPane = 11, xlWide = 3, xlWorkbookTab = 6, xlWorksheet4 = 1, xlWorksheetCell = 3, xlWorksheetShort = 5, xlAllExceptBorders = 6, xlLeftToRight = 2, xlTopToBottom = 1, xlVeryHidden = 2, xlDrawingObject = 14 } Constants; typedef enum XlBorderWeight { xlHairline = 1, xlMedium = 0xFFFFEFD6, xlThick = 4, xlThin = 2 } XlBorderWeight; typedef enum XlLineStyle { xlContinuous = 1, xlDash = 0xFFFFEFED, xlDashDot = 4, xlDashDotDot = 5, xlDot = 0xFFFFEFEA, xlDouble = 0xFFFFEFE9, xlSlantDashDot = 13, xlLineStyleNone = 0xFFFFEFD2 } XlLineStyle; typedef enum XlEditionOptionsOption { xlAutomaticUpdate = 4, xlCancel = 1, xlChangeAttributes = 6, xlManualUpdate = 5, xlOpenSource = 3, xlSelect = 3, xlSendPublisher = 2, xlUpdateSubscriber = 2 } XlEditionOptionsOption; typedef enum XlChartType { xlColumnClustered = 51, xlColumnStacked = 52, xlColumnStacked100 = 53, xl3DColumnClustered = 54, xl3DColumnStacked = 55, xl3DColumnStacked100 = 56, xlBarClustered = 57, xlBarStacked = 58, xlBarStacked100 = 59, xl3DBarClustered = 60, xl3DBarStacked = 61, xl3DBarStacked100 = 62, xlLineStacked = 63, xlLineStacked100 = 64, xlLineMarkers = 65, xlLineMarkersStacked = 66, xlLineMarkersStacked100 = 67, xlPieOfPie = 68, xlPieExploded = 69, xl3DPieExploded = 70, xlBarOfPie = 71, xlXYScatterSmooth = 72, xlXYScatterSmoothNoMarkers = 73, xlXYScatterLines = 74, xlXYScatterLinesNoMarkers = 75, xlAreaStacked = 76, xlAreaStacked100 = 77, xl3DAreaStacked = 78, xl3DAreaStacked100 = 79, xlDoughnutExploded = 80, xlRadarMarkers = 81, xlRadarFilled = 82, xlSurface = 83, xlSurfaceWireframe = 84, xlSurfaceTopView = 85, xlSurfaceTopViewWireframe = 86, xlBubble = 15, xlBubble3DEffect = 87, xlStockHLC = 88, xlStockOHLC = 89, xlStockVHLC = 90, xlStockVOHLC = 91, xlCylinderColClustered = 92, xlCylinderColStacked = 93, xlCylinderColStacked100 = 94, xlCylinderBarClustered = 95, xlCylinderBarStacked = 96, xlCylinderBarStacked100 = 97, xlCylinderCol = 98, xlConeColClustered = 99, xlConeColStacked = 100, xlConeColStacked100 = 101, xlConeBarClustered = 102, xlConeBarStacked = 103, xlConeBarStacked100 = 104, xlConeCol = 105, xlPyramidColClustered = 106, xlPyramidColStacked = 107, xlPyramidColStacked100 = 108, xlPyramidBarClustered = 109, xlPyramidBarStacked = 110, xlPyramidBarStacked100 = 111, xlPyramidCol = 112, xl3DColumn = 0xFFFFEFFC, xlLine = 4, xl3DLine = 0xFFFFEFFB, xl3DPie = 0xFFFFEFFA, xlPie = 5, xlXYScatter = 0xFFFFEFB7, xl3DArea = 0xFFFFEFFE, xlArea = 1, xlDoughnut = 0xFFFFEFE8, xlRadar = 0xFFFFEFC9 } XlChartType; typedef enum XlChartItem { xlDataLabel = 0, xlChartArea = 2, xlSeries = 3, xlChartTitle = 4, xlWalls = 5, xlCorners = 6, xlDataTable = 7, xlTrendline = 8, xlErrorBars = 9, xlXErrorBars = 10, xlYErrorBars = 11, xlLegendEntry = 12, xlLegendKey = 13, xlShape = 14, xlMajorGridlines = 15, xlMinorGridlines = 16, xlAxisTitle = 17, xlUpBars = 18, xlPlotArea = 19, xlDownBars = 20, xlAxis = 21, xlSeriesLines = 22, xlFloor = 23, xlLegend = 24, xlHiLoLines = 25, xlDropLines = 26, xlRadarAxisLabels = 27, xlNothing = 28, xlLeaderLines = 29, xlDisplayUnitLabel = 30, xlPivotChartFieldButton = 31, xlPivotChartDropZone = 32 } XlChartItem; typedef enum XlRowCol { xlColumns = 2, xlRows = 1 } XlRowCol; typedef enum XlEnableSelection { xlNoRestrictions = 0, xlUnlockedCells = 1, xlNoSelection = 0xFFFFEFD2 } XlEnableSelection; typedef enum XlOrientation { xlDownward = 0xFFFFEFB6, xlHorizontal = 0xFFFFEFE0, xlUpward = 0xFFFFEFB5, xlVertical = 0xFFFFEFBA } XlOrientation; 這樣就可以用這些常數了，像是設定圖表格式時，可以用xlLineMarkers來取代65~ 如果不include也可以，就用數字來代替常數，像是xlRows就是1，xlColumns是2，xlUnlockedCells是1等等 Borland除了excel_2k.h這個檔之外，還有excel_97.h，excel_xp.h這些檔，不過這些有哪些功能不一樣我就不清楚了! ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#38 引用回覆回覆發表時間：2003-11-27 19:25:47 IP:192.168.xxx.xxx 未訂閱【文章】如何讓DBGrid按滑鼠右鍵的時候不會影響RowSelect ? 【作者】Justmade 【內文】文章來源:http://delphi.ktop.com.tw/topic.php?topic_id=33637 不用另外繼承，試試將以下程式碼替代 http://delphi.ktop.com.tw/topic.php?TOPIC_ID=33719 範例的程式碼 unit CDSMDForm; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, shellapi, StdCtrls, Grids, DBGrids, DB, DBTables, DBCtrls, DBClient, Provider, jpeg, ExtCtrls; type TDBGrid= class(DBGrids.TDBGrid) protected Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; end; TForm1 = class(TForm) DataSource1: TDataSource; DBGrid1: TDBGrid; DataSource2: TDataSource; DataSetProvider1: TDataSetProvider; DataSetProvider2: TDataSetProvider; Query1: TQuery; Query2: TQuery; ClientDataSet1: TClientDataSet; ClientDataSet2: TClientDataSet; DBGrid2: TDBGrid; procedure DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); const // 這個整數值將按照布林值返回，並送入陣列 CtrlState : array[Boolean] of Integer=(DFCS_BUTTONCHECK,DFCS_BUTTONCHECK or DFCS_CHECKED); begin //確保只有在邏輯欄位才能插入元件 if Column.Field.DataType = ftBoolean then begin DBGrid1.Canvas.FillRect(Rect); DrawFrameControl(DBGrid1.Canvas.Handle,Rect,DFC_BUTTON,CtrlState[Column.Field.AsBoolean]); end; end; { TDBGrid } procedure TDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button <> mbRight then inherited; end; end. 並將 DBGrid1 的 poMultiSelect 設 True 便可見右按不會影響 selection 了另你可換一個有 Boolean Field 的 Table 也可看到不會出現格線不見的情形。其實看你的多個問題覺得你好像不是用標準的 DBGrid,若時的話你應說清楚免得大家在浪費時間。另你若間題還不能解決你最好做一個簡單的程式包含你的數個間題然後上傳，這樣會比較清楚。 ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#39 引用回覆回覆發表時間：2003-11-27 19:28:00 IP:192.168.xxx.xxx 未訂閱【文章】如何判斷TrayIcon的程式是否正在執行? 【作者】Rain 【內文】文章來源:http://delphi.ktop.com.tw/topic.php?topic_id=33946 使用GetModuleFileNameEx即可取得進程路徑( 記得要uses PSAPI單元)，如果你的那個應用程式名稱是知道的，則可以不用FindWindow或EnumWindows，在下面的程式中用if StrPas(ProcessEntry32.szExeFile) = 'yourAppName.exe'替代 if ProcessEntry32.th32ProcessID = AProcessID語句即可給出完整的程式如下： uses tlhelp32, ShellAPI, PSAPI; procedure TForm1.Button1Click(Sender: TObject); var Found: Boolean; AProcessID: DWORD; AWnd, AHandle: THandle; ProcessEntry32: TProcessEntry32; APath: array [0..MAX_PATH] of Char; begin AWnd := FindWindow('TMainForm', nil); if AWnd = 0 then Exit; GetWindowThreadProcessId(AWnd, @AProcessID); AHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); try ProcessEntry32.dwSize := Sizeof(ProcessEntry32); Found := Process32First(AHandle, ProcessEntry32); while Found do begin //if StrPas(ProcessEntry32.szExeFile) = ' yourAppName.exe' then ; if ProcessEntry32.th32ProcessID = AProcessID then begin GetModuleFileNameEx(OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessEntry32.th32ProcessID), 0, @APath[0], SizeOf(APath));//取得進程路徑 TerminateProcess(OpenProcess(PROCESS_ALL_ACCESS, True, ProcessEntry32.th32ProcessID), 0);//結束進程 ShellExecute(Handle, 'open', APath, nil, nil, SW_SHOW);//重新運行程式 //Break; end; Found := Process32Next(AHandle, ProcessEntry32); end; finally CloseHandle(AHandle); end; end; ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#40 引用回覆回覆發表時間：2003-11-27 19:30:38 IP:192.168.xxx.xxx 未訂閱【文章】在image中如何放大缩小jpg文件? 【作者】sos_admin 【內文】文章來源:http://delphi.ktop.com.tw/topic.php?topic_id=38057 1. unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, ExtCtrls,jpeg; type TForm1 = class(TForm) Image1: TImage; BitBtn1: TBitBtn; procedure FormCreate(Sender: TObject); procedure BitBtn1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; jpgw,jpgh:integer; implementation {$R .dfm} procedure TForm1.FormCreate(Sender: TObject); var jpg:Tjpegimage; begin jpg:=Tjpegimage.Create; jpg.LoadFromFile('c:\1.jpg'); jpgw:=jpg.Width ; jpgh:=jpg.Height ; image1.Width:=jpgw; image1.Height :=jpgh; image1.Picture.Assign(jpg); image1.Stretch:=true; image1.AutoSize:=false; jpg.Free ; end; //i为正数放大，反之缩小 procedure imagesize(image:Timage;i:integer); begin if i>0 then begin image.Width:=jpgwi ; image.Height:=jpgh*i ; end; if i<0 then begin image.Width:=jpgw div abs(i) ; image.Height:=jpgh div abs(-i) ; end; end; procedure TForm1.BitBtn1Click(Sender: TObject); begin //在原图基础上缩小为原图的1/10 imagesize(image1,-10); end; end. 2. 看下面的方法： //无损调整 > src="http://delphi.ktop.com.tw/loadfile.php?TOPICID=11955987&CC=267393"> ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#41 引用回覆回覆發表時間：2003-12-04 20:24:28 IP:192.168.xxx.xxx 未訂閱【文章】如何防止程式重覆執行? 【作者】axsoft / jessechan 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=36333 1.程式碼下載:http://delphi.ktop.com.tw/loadfile.php?TOPICID=11492747&CC=257033 //--------------------------------------------------------------------------- // 程式名稱: CreateMutexDemo.cpp // 作者: axsoft // 執行環境: windows XP SPS C Builder 5 Update1 //--------------------------------------------------------------------------- #include #pragma hdrstop USERES("Project1.res"); USEFORM("Unit1.cpp", Form1); //--------------------------------------------------------------------------- WINAPI WinMain(HINSTANCE, HINSTANCE, LPSTR, int) { HANDLE mutexhandle=CreateMutex(NULL,false,"我的應用程式"); if((mutexhandle!=NULL) && (GetLastError()== ERROR_ALREADY_EXISTS)) { Application->MessageBox("程式重複起動","確認",MB_ICONSTOP); CloseHandle(mutexhandle); return -1; } try { Application->Initialize(); Application->CreateForm(__classid(TForm1), &Form1); Application->Run(); } catch (Exception &exception) { Application->ShowException(&exception); } if(mutexhandle!=NULL) CloseHandle(mutexhandle); return 0; } //--------------------------------------------------------------------------- 2. 如何寫一個Windows應用程式，讓他只執行一次。 -------------------------------------------------------------------------------- 作者:szu (michael liang) 資料來源:高市資教-陽光之都 BBS http://bbs.kh.edu.tw/treasure/Programs/M.991654847.A/M.995983133.A.html 第一種方法(利用FindWindow()): 環境 C Builder Application->Title = ""; HWND hPrevApp = ::FindWindow(NULL, "Title"); //或是寫成HWND hPrevApp = ::FindWindow("Class", NULL); //或是寫成HWND hPrevApp = ::FindWindow("Class", "Title"); if(hPrevApp) { PostMessage(hPrevApp, WM_SYSCOMMAND, SC_RESTORE, 0); return 0; } else { Application->Title = "Title"; } ------------------------------------------------------------------------- 第二種方法(利用FindWindow()): if(FindWindow(NULL, 應用程式的Title)) { return 0; } ------------------------------------------------------------------------- 第三種方法(利用Global Atom Table): ATOM atom; if(GlobalFindAtom("PROGRAM_RUNNING") == 0) { atom = GlobalAddAtom("PROGRAM_RUNNING"); } else { return 0; } 在程式最後請加上 GlobalDeleteAtom(atom); ------------------------------------------------------------------------ 第四種方法(利用Mutex): HANDLE handle = CreateMutex(NULL, false, "MutexName"); DWORD error = GetLastError(); if(error == ERROR_ALREADY_EXISTS ) { return 0; } 記得在程式最後面加入 ReleaseMutex(handle); ------------------------------------------------------------------------ 第五種方法(利用Semaphore): HANDLE handle = CreateSemaphore(NULL, 1, 1, "SemaphoreName"); DWORD error = GetLastError(); if(error == ERROR_ALREADY_EXISTS ) { return 0; } 記得在程式最後面加入 ReleaseSemaphore(handle, 1, NULL); -------------------------------------------------------------------- 以上程式受到智慧財產權的保護， permission to use, copy, modify, and distribute. 但請註明來源出處，不可用於商業用途。 -------------------------------------------------------------------- 3. 我想這個問題已被討論很多次了, 我也曾在這個版上提出同樣的問題, 下面是我找了一些資料加上 RaynorPao 等熱心人士的指點, 所整理的一個心得. 要防止程式重複執行, 在 VB 中的 App 中有一個 preInstance 可以輕易得知目前的程式是否為第一個 instance, 不幸在 BCB 中卻沒有類似的機制, 不過我們可用 CreateMutex 的方法來測試同樣的 Mutex Object 是否已被 create 來確保程式是第一次執行, 其宣告如下, HANDLE CreateMutex( LPSECURITY_ATTRIBUTES lpMutexAttributes, BOOL bInitialOwner, LPCTSTR lpName ); 詳細用法請參考 BCB 的 help 或 MSDN, 這裡我想要提出來的是一般大家在用這個 API 時 lpName 經常使用任意取的名字, 或是直接用 Form 的 Caption, 這樣固然方便但是不能確保名字是唯一, 每次都要想不同的名字又太累, 所以我建議可以做個小修改, AnsiString asTemp00 = (long)(GetWindowLong(Application->Handle,GWL_HINSTANCE)); CreateMutex(NULL,false,asTemp00.c_str()); if (GetLastError() == ERROR_ALREADY_EXISTS) Application->Terminate(); 以程式的 Instance Handle 來個名稱就萬無一失了, 有一點要注意的是在程式結束時要記得 ReleaseMutex(). 另外不知有沒有人想要做到如果之前已有一個 Instance 在執行的話, 就先把之前的程式結束掉, 以後者取代之. 因為如果用 FindWindow 想要去取得前一個程式的 Handle 的話, 找到的總會是自己, 所以必須另找方法, 我所想到的方法是在程式執行時先以 Instance 為 key 把自己的 Handle 存起來, 如此第二個程式在執行時發現已有自己的同類在執行就去讀取它的 Handle, 而對它送出 WM_CLOSE 的 message, 實作如下, #include #include #pragma hdrstop #include "Unit1.h" //--------------------------------------------------------------------------- #pragma package(smart_init) #pragma resource ".dfm" TForm1 Form1; HWND hMutex; //--------------------------------------------------------------------------- __fastcall TForm1::TForm1(TComponent* Owner) : TForm(Owner) { TRegistry * rgpSystem = new TRegistry;; Caption = Now(); AnsiString asTemp00 = (long)(GetWindowLong(Application->Handle,GWL_HINSTANCE)); rgpSystem->OpenKey(asTemp00,true); CreateMutex(NULL,false,asTemp00.c_str()); if (GetLastError() == ERROR_ALREADY_EXISTS) SendMessage((HWND)rgpSystem->ReadInteger("Handle"),WM_CLOSE,NULL,NULL); rgpSystem->WriteInteger("Handle",(int)(this->Handle)); rgpSystem->CloseKey(); delete rgpSystem; } //--------------------------------------------------------------------------- void __fastcall TForm1::FormClose(TObject *Sender, TCloseAction &Action) { ReleaseMutex(hMutex); } //--------------------------------------------------------------------------- 這些 code 沒有用到什麼高深的理論, 可是我想還算實用, 野人獻曝, 謹供大家參考. 參考網址:http://delphi.ktop.com.tw/topic.php?topic_id=24297 http://delphi.ktop.com.tw/topic.php?topic_id=24350 ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#42 引用回覆回覆發表時間：2003-12-04 20:28:53 IP:192.168.xxx.xxx 未訂閱【文章】如何將寫好的Form快速轉成一個元件? 【作者】bruce0211 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=40137 我發現使用 Form 為 base 的元件可能是所有元件設計中最簡單的方式(因為設計核心時是在一般專案中設計並測試,且可放入任何你想要的元件,如果不是以 Form 為 base 的元件,光想想我們要設計將兩個元件聚合成為一個新元件就已經多不直多困難) 1.設計帶有 Form 的元件,如萬年曆,獨立的對話盒等等,通常這種類型的元件在 user 主 form 中是一不可視元件,也就是插到 Delphi 中只是一個 ICON 而已 (如標準的檔案開啟對話盒元件 TOpenDialog) ,需要用時再利用 if OpenDialog1.Execute then ... 這種方式去呼叫 2.由於這類元件不需在主畫面佔據位置,而是被獨立呼叫(就像是 ShowModal),所以設計元件時可以一般方法設計(可放入許多及任何元件的組合在裡面),如我要設計萬年曆,先用一般方式開一 Project1 專案,以及萬年曆的 unit1.pas & unit1.dfm , 將萬年曆內容寫好,並可 compiler 測試 ok (叫做 project1.exe),我們便可丟掉 project1.* 的檔案,只留下 unit1.pas 及 unit1.dfm 這兩個萬年曆的核心 3.開始設計元件,元件類別繼承自 TComponent , 也就是拿 TComponent 當藥引子,替 TComponent 增加一個公開的方法 "Execute" , 以及 Date 屬性 , 執行 Execute 時, TComponent 實際上是去呼叫完整的萬年曆程式,再將日期回傳以下為 TMyCalendar 的元件內容 , 可以看出萬年曆程式碼並未寫在裡面,而是另外呼叫 MyCalendarSource.pas (也就是上面舉例的 Unit1.pas) , 而MyCalendarSource.pas 之 Form 名稱叫 FormMyCalendar (也就是上面舉例的 Unit1.dfm) , 整個TMyCalendar 只是當作藥引子 , 實際上萬年曆的程式碼是寫在 MyCalendarSource.pas 中的其他類似的元件也可依樣畫葫蘆,先用一般方法設計專案設計 Form,測試 OK 後 , 留下 Form 這個部分的程式碼,再套到這個藥引子中 unit MyCalendar; interface uses SysUtils, Classes, Forms, MyCalendarSource; type TMyCalendar = class(TComponent) private { Private declarations } FDate: TDateTime; FRocYear: string; FRocMonth: string; FRocDay:string; procedure DateToRoc(ADate:TDateTime); protected { Protected declarations } public { Public declarations } constructor Create(AOwner : TComponent); override; destructor Destroy; override; function Execute: boolean; overload;//本元件公開的方法 function Execute(ALeft,ATop: integer): boolean; overload; ;//本元件公開的方法(可指定萬年曆出現的座標位置,復疊函式) published { Published declarations } property Date:TDateTime read FDate; //本元件公開的屬性,日期 property RocYear:string read FRocYear; //本元件公開的屬性,民國年 property RocMonth:string read FRocMonth; //本元件公開的屬性,民國月 property RocDay:string read FRocDay;//本元件公開的屬性,民國日 end; procedure Register; implementation constructor TMyCalendar.Create(AOwner : TComponent); begin inherited Create(AOwner); FDate := SysUtils.Date; DateToRoc(FDate); end; destructor TMyCalendar.Destroy; begin inherited Destroy; end; function TMyCalendar.Execute: boolean; var r:integer; begin FormMyCalendar:=TFormMyCalendar.Create(nil); try r:=FormMyCalendar.ShowModal; if r=1 then //mrOK; begin FDate:=FormMyCalendar.SelectDate; DateToRoc(FDate); result:=true; end else result:=false; finally FormMyCalendar.Release; end; end; function TMyCalendar.Execute(ALeft,ATop: integer): boolean; var r:integer; begin FormMyCalendar:=TFormMyCalendar.Create(nil); FormMyCalendar.Position:=poDesigned; FormMyCalendar.Top:=ATop; FormMyCalendar.Left:=ALeft; try r:=FormMyCalendar.ShowModal; if r=1 then //mrOK; begin FDate:=FormMyCalendar.SelectDate; result:=true; end else result:=false; finally FormMyCalendar.Release; end; end; procedure TMyCalendar.DateToRoc(ADate:TDateTime); var TmpYear, TmpMonth, TmpDay : Word; begin DecodeDate(ADate, TmpYear, TmpMonth, TmpDay); FRocYear:=FormatFloat('00',TmpYear-1911); FRocMonth:=FormatFloat('00',TmpMonth); FRocDay:=FormatFloat('00',TmpDay); end; procedure Register; begin RegisterComponents('MyWay', [TMyCalendar]); end; end. ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#43 引用回覆回覆發表時間：2003-12-04 20:34:54 IP:192.168.xxx.xxx 未訂閱【文章】如何使滑鼠的中間滾輪在DBGrid中可以滾動資料? 【作者】mathewzhao / pwq 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=40777 1. 本人已經解決此問題,現在方法貼出如下: Type TDBGrid = class(TDBGrid) private FOldGridWnd : TWndMethod; procedure NewGridWnd (var Message : TMessage); public constructor Create(AOwner: TComponent); override; end; //////////////////////////////////////////紅色部分代友需放在以下代碼前 TMDFMainForm = class(TForm) ...... end; implementation {$R .dfm} constructor TNDBGrid.Create(AOwner: TComponent); begin inherited; FOldGridWnd := WindowProc; WindowProc := NewGridWnd; end; procedure TDBGrid.NewGridWnd(var Message: TMessage); var IsNeg : Boolean; begin if Message.Msg = WM_MOUSEWHEEL then begin IsNeg := Short(Message.WParamHi) < 0; if IsNeg and (DataSource.DataSet<>nil) and DataSource.DataSet.Active then DataSource.DataSet.MoveBy(1) else if not IsNeg and (DataSource.DataSet<>nil) and DataSource.DataSet.Active then DataSource.DataSet.MoveBy(-1) end else FOldGridWnd(Message); end; ........ end. 2. 參考一下這篇文章: http://www.yesky.com/SoftChannel/72342371928440832/20030619/1709082.shtml 讓Delphi的DBGrid支持鼠標輪* 劉東榮現在的大多數的鼠標都有鼠標輪,比如,當我們瀏覽網頁時,鼠標輪上下移動,網頁就自動上下滾動。鼠標輪的確給我們的操作帶來很多方便,但是,在Delphi的大多數控件中都只支持 MouseDown,MouseUp,MouseMove等事件,而不直接支持MouseWheel事件,我們在幫助客戶設計一個查看程序時就碰到這樣的問題。這個查看程序的數據是放在一個DBGrid中的,數據比較多,超出整個屏幕,如果用鼠標輪上下移動,則DBGrid的光標只在可見範圍內移動,超出屏幕的數據必須用鍵盤或右側的滾動條,給用戶造成極大不方便,客戶強烈要求支持鼠標輪操作。但是查看DBGrid的事件屬性沒有對鼠標輪的支持,怎麼辦呢？我們知道,Windows操作系統是消息驅動的,因此,如果鼠標輪上下滾動,必然會有相應的事件發生,經過查找資料,我們得知當鼠標輪上下滾動時發生的是WM_MOUSEWHEEL事件,既然這樣,我們如果捕獲這個事件,不就可以處理鼠標輪事件了嗎？說幹就幹,那就讓我們來為DBGrid增加一個OnMouseWheel事件,製作一個支持鼠標輪的新的DBGrid組件。讓我們新建一個應用,就叫MyDBGrid吧,選擇菜單File─New Application,然後再選擇菜單File-New-Component 因為我們的新組件是從DBGrid繼承的,所以,Ancestor Type選擇 TDBGrid,Class Name就填我們的組件名稱TmyDbGrid,生成的組件放在Samples頁,點擊OK,則組件的框架就生成了。現在我們開始做最關鍵的部分。當鼠標輪上下滾動時,發出了WM_MOUSEWHEEL消息,MOUSEWHEEL消息有幾個參數, 1.fwKeys= LOWORD(wParam),表明各種虛擬鍵是否按下,有如下值: 值說明 MK_CONTROL 按下CTRL鍵 MK_LBUTTON 按下鼠標左鍵 MK_MBUTTON 按下鼠標中鍵 MK_RBUTTON 按下鼠標右鍵 MK_SHIFT 按下Shift鍵 2.zDelta = (short) HIWORD(wParam) 鼠標輪滾動的距離,如果向前則為正,向後為負。 3.xPos ＝(short) LOWORD(lParam) yPos＝ (short) HIWORD(lParam) 鼠標的位置。 3. Delphi已經定義了兩個和鼠標輪相關的事件,叫TmouseWheelEvent, TmouseWheelUpDownEvent,分別代表鼠標輪事件和鼠標輪上,下滾動事件。因此,我們先在TmyDbGrid中定義三個私有的事件變量: fMouseWheel:TMouseWheelEvent; fMouseWheelUp:TMouseWheelUpDownEvent; //鼠標輪上滾事件 fMouseWheelDown: TMouseWheelUpDownEvent; //鼠標輪下滾事件然後定義publised中定義事件屬性: property OnMouseWheel:TMouseWheelEvent read fMouseWheel write fMouseWheel; property OnMouseWheelUp:TMouseWheelUpDownEvent read fMouseWheelUp write fMouseWheelUp; property OnMouseWheelDown:TMouseWheelUpDownEvent read fMouseWheelDown write fMouseWheelDown; 然後重載TDBGrid的WndProc函數, procedure WndProc(var Msg: TMessage);override; 我們在WndProc中捕獲鼠標輪的消息,如下: [code] var MousePoint:TPoint; Handled:Boolean; shift:TShiftState; begin if(Msg.Msg=WM_MOUSEWHEEL) then //捕獲鼠標輪事件 begin MousePoint.X:=LOWORD(Msg.lParam); MousePoint.Y:=HIWORD(Msg.lParam); Handled:=false; if(Msg.wParam>0) then //上滾 fMouseWheelUp(self,shift,MousePoint,Handled) else //下滾 fMouseWheelDown(self,shift,MousePoint,Handled); fMouseWheel(self,shift,HIWORD(Msg.wParam),MousePoint,Handled); if Handled then exit; end; inherited; end; 這樣,我們就基本可以處理鼠標輪事件了,編譯我們的組件,然後選擇菜單Components-Inatll Component,將我們的組件安裝在Samples頁下。讓我們來試驗一下我們做的組件,新建一個應用,然後選擇Samples下的MyDBGrid組件,其它的用法,和DBGRrid完全一樣,但你可以看見,在你的MyDbGrid的事件中,已經有OnMouseWheel, OnMouseWheelUp, OnMouseWheelDown的選項了。這樣,你可以在OnMouseWheel, OnMouseWheelUp, OnMouseWheelDown中處理你的動作了,我們也完成了客戶的要求,當客戶移動鼠標輪時,我們在OnMouseWheelUp中加入相應代碼,圓滿解決了客戶的要求。～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#44 引用回覆回覆發表時間：2003-12-04 20:36:26 IP:192.168.xxx.xxx 未訂閱【文章】請問如何得知對方電腦所分享的所有目錄呢? 【作者】japhenchen 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=39584 跑net view \\servername >> nv.txt 或\\ip 就可以顯示對方的共享名稱並且轉向輸出到nv.txt檔~~ 不過，有更好的解決方法 procedure TForm1.Button2Click(Sender: TObject); type TNetResourceArray = ^TNetResource; var NetResource : TNetResource; hr,ecount,BUFSIZE,x: dword; hEnum: THandle; buf : POINTER; ResArray : TNetResourceArray; ResList : TStringList; username: string ; begin username:='\\192.168.1.1'; FillChar(NetResource, SizeOf(NetResource), 0); NetResource.lpRemoteName:=@username[1]; resList:=TStringList.Create; hr:=wnetOpenEnum(RESOURCE_GLOBALNET,RESOURCETYPE_ANY,RESOURCEUSAGE_CONNECTABLE,@NetResource,hEnum); if hr=NO_ERROR then while true do begin BUFSIZE:=8192; GETMEM(BUF,BUFSIZE); ecount := $FFFFFFFF; hr := WNetEnumResource(hEnum,ecount,pointer(buf),bufsize); case hr of ERROR_NO_MORE_ITEMS: break; NO_ERROR : begin ResArray:=TNetResourceArray(buf); for x:= 0 to ecount-1 do begin ResList.Add(ResArray^.lpRemoteName); inc(resArray); end; end; else break; end; end; wnetCloseEnum(hEnum); FreeMem(buf,bufsize); if reslist.count >0 then showmessage(reslist.Text); freeandnil(ResList); end; ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#45 引用回覆回覆發表時間：2003-12-08 13:33:18 IP:211.76.xxx.xxx 未訂閱【文章】如何判斷是否有該磁碟機? 【作者】hagar 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=20772 function HasDrive(DriveLetter: Char): Boolean; var ld : DWORD; i : integer; sl: TStringList; begin ld := GetLogicalDrives; sl := TStringList.Create; try for i := 0 to 25 do begin if (ld and (1 shl i)) <> 0 then sl.Add(Char(Ord('A') i)); end; Result := (sl.IndexOf(DriveLetter) <> -1); finally sl.Free; end; end; 用法: procedure TForm1.Button1Click(Sender: TObject); begin if HasDrive('C') then ShowMessage('Drive C is valid') else ShowMessage('Drive C is invalid'); end; ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#46 引用回覆回覆發表時間：2003-12-09 06:52:39 IP:192.168.xxx.xxx 未訂閱【文章】讀取Windows的TTF字體輪廓向量資料【作者】朱朝陽【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=30747 資料來源: http://www2.ccw.com.cn/2000/0031/0031b12.asp 讀取Windows的 TTF字體輪廓向量資料西安飛機工業公司設計部朱朝陽 ---- Windows系統的TTF字體具有字體優美、可無級縮放等優點，最適合應用在CAD類圖形處理等軟體中。直接分析TTF字體的檔格式並讀出每個字的輪廓向量是相當困難的，我們可以借助API函數來方便地獲得這些資料。 ---- 調用函數GetGlyphOutline可以得到一個字的輪廓向量或者點陣圖。 ---- 函數原型如下： DWORD GetGlyphOutline( HDC hdc, // 設備控制碼 UINT uChar, // 將要讀取的字元 UINT uFormat, // 返回資料的格式 LPGLYPHMETRICS lpgm, // GLYPHMETRICS結構位址 DWORD cbBuffer, // 數據緩衝區的大小 LPVOID lpvBuffer, // 資料緩衝區的位址 CONST MAT2 ＊lpmat2 // 轉置矩陣的地址 ); ---- 其中，參數uFormat取值如下： GGO_NATIVE －要求函數返回字元的輪廓向量資料； GGO_METRICS －函數僅返回GLYPHMETRICS結構至lpgm；參數lpgm指向GLYPHMETRICS結構，該結構描述字元的位置。參數lpmat2指向字元的轉置矩陣。 ---- 本文以下C＋＋ Builder程式示範如何在畫布上以指定的大小繪製字串。 ---- 首先，建立一個新專案，在主視窗上放置一個Image控制項，一個Edit控制項，一個Button控制項；然後，在Button的點擊事件中加入如下代碼：＃include < stdlib.h > void __fastcall TForm1::Button1Click(TObject ＊Sender) { TRect ClipRect = Rect(0,0,Image1－>Width,Image1－>Height); Image1－>Picture = 0; StretchTextRect(Image1－>Canvas, ClipRect, Edit1－>Text); } ---- 添加如下子程式： //－－－－－－－－－－－－－－－－－－－－－ void TForm1::StretchTextRect(TCanvas ＊pCanvas, TRect ClipRect, AnsiString Text) { pCanvas－>Font－>Size = 100; pCanvas－>Font－>Name = “宋體"; pCanvas－>Pen－>Color = clBlack; pCanvas－>Pen－>Mode = pmCopy; pCanvas－>Pen－>Style = psSolid; pCanvas－>Pen－>Width = 1; int XSize = ClipRect.Width() / Text.Length(); int YSize = ClipRect.Height(); MAT2 mat2; // 轉置矩陣，不用變換 mat2.eM11.value = 1;mat2.eM11.fract = 0; mat2.eM12.value = 0;mat2.eM12.fract = 0; mat2.eM21.value = 0;mat2.eM21.fract = 0; mat2.eM22.value = 1;mat2.eM22.fract = 0; GLYPHMETRICS gm,gmm; // 首先獲得字元的位置矩陣，存入gm GetGlyphOutlineA(pCanvas－>Handle,0x0b0a1, GGO_METRICS,＆gm,0,NULL,＆mat2); char ＊ptr = Text.c_str(); TRect TheRect; for(int i = 0;i < Text.Length();) { int c1 = (unsigned char)＊ptr; int c2 = (unsigned char)＊(ptr ＋ 1); UINT nChar; TheRect.Left = i ＊ XSize ＋ ClipRect.Left; TheRect.Top = ClipRect.Top; TheRect.Right = (i ＋ 2) ＊ XSize ＋ ClipRect.Left; TheRect.Bottom = ClipRect.Top ＋ YSize; if(c1 > 127) { // 當前字元是漢字 nChar = c1 ＊ 256 ＋ c2; ptr＋=2;i＋=2; } else { // 字母或數位 nChar = c1; ptr＋＋;i＋＋; } // 獲得當前字元資料的陣列的大小 DWORD cbBuffer = GetGlyphOutlineA(pCanvas－> Handle,nChar,GGO_NATIVE,＆gmm,0,NULL,＆mat2); if(cbBuffer == GDI_ERROR) break; void ＊lpBuffer = malloc(cbBuffer); if(lpBuffer != NULL) { // 讀入數據置緩衝區 if(GetGlyphOutlineA(pCanvas－> Handle,nChar,GGO_NATIVE, ＆gmm,cbBuffer,lpBuffer,＆mat2) != GDI_ERROR) { // 分析資料並繪製字元 TMemoryStream ＊MBuffer = new TMemoryStream(); MBuffer－>Write(lpBuffer,cbBuffer); MBuffer－>Position = 0; for(;MBuffer－>Position < MBuffer－>Size;) { int CurPos = MBuffer－>Position; TTPOLYGONHEADER polyheader; int ptn = 0; MBuffer－>Read(＆polyheader,sizeof(polyheader)); ptn＋＋; for(int j = 0;j < (int)(polyheader.cb － sizeof(polyheader));) { WORD wtype,cpfx; MBuffer－>Read(＆wtype,sizeof(WORD)); MBuffer－>Read(＆cpfx,sizeof(WORD)); MBuffer－>Position ＋= cpfx ＊ sizeof(POINTFX); j ＋= sizeof(WORD) ＊ 2 ＋ cpfx ＊ sizeof(POINTFX); if(wtype == TT_PRIM_LINE) ptn ＋= cpfx; else ptn ＋= (cpfx － 1) ＊ 3 ＋ 1; } TPoint ＊pts = new TPoint[ptn＋1]; // 存儲多邊形頂點 MBuffer－>Position = CurPos; ptn = 0; MBuffer－>Read(＆polyheader,sizeof(polyheader)); TPoint pt0 = POINTFX2TPoint(polyheader.pfxStart,TheRect,＆gm); pts[ptn＋＋] = pt0; for(int j = 0;j < (int)(polyheader.cb － sizeof(polyheader));) { TPoint pt1; WORD wtype,cpfx; MBuffer－>Read(＆wtype,sizeof(WORD)); MBuffer－>Read(＆cpfx,sizeof(WORD)); POINTFX ＊pPfx = new POINTFX[cpfx]; MBuffer－>Read((void ＊)pPfx,cpfx ＊ sizeof(POINTFX)); j ＋= sizeof(WORD) ＊ 2 ＋ cpfx ＊ sizeof(POINTFX); if(wtype == TT_PRIM_LINE) { // 直線段 for(int i = 0;i < cpfx;i＋＋) { pt1 = POINTFX2TPoint(pPfx[i],TheRect,＆gm); pts[ptn＋＋] = pt1; } } else { // Bezier曲線 TPoint p0,p1,p2,p3,p11,p22,pp0,pp1,pp2,pt11,pt22; int i; for(i = 0;i < cpfx－1;i＋＋) { pt11 = POINTFX2TPoint(pPfx[i],TheRect,＆gm); pt22 = POINTFX2TPoint(pPfx[i＋1],TheRect,＆gm); pp0 = pts[ptn－1]; pp1 = pt11; pp2.x = (pt11.x ＋ pt22.x)/2; pp2.y = (pt11.y ＋ pt22.y)/2; p0 = pp0; p1.x = pp0.x/3 ＋ 2 ＊ pp1.x/3; p1.y = pp0.y/3 ＋ 2 ＊ pp1.y/3; p2.x = 2 ＊ pp1.x/3 ＋ pp2.x/3; p2.y = 2 ＊ pp1.y/3 ＋ pp2.y/3; p3 = pp2; for(float t = 0.0f;t <= 1.0f;t ＋= 0.5f) { float x = (1－t)＊(1－t)＊(1－t)＊p0.x＋ 3＊t＊(1－t)＊(1－t)＊p1.x＋ 3＊t＊t ＊(1－t)＊p2.x ＋ t＊t＊t＊p3.x; float y = (1－t)＊(1－t)＊(1－t)＊p0.y ＋ 3＊t＊(1－t)＊(1－t)＊p1.y＋3 ＊t＊t＊(1－t)＊p2.y ＋ t＊t＊t＊p3.y; pts[ptn].x = x; pts[ptn].y = y; ptn＋＋; } } pt1 = POINTFX2TPoint(pPfx[i],TheRect,＆gm); pts[ptn＋＋] = pt1; } delete pPfx; } pts[ptn] = pts[0]; // 封閉多邊形 pCanvas－>Brush－>Color = clWhite; pCanvas－>Pen－>Mode = pmXor; pCanvas－>Pen－>Style = psClear; pCanvas－>Brush－>Style = bsSolid; pCanvas－>Polygon(pts,ptn); delete pts; } delete MBuffer; } free(lpBuffer); } } } //－－－－－－－－－－－－－－－－－－－－－ TPoint TForm1::POINTFX2TPoint(POINTFX pf, TRect TheRect,GLYPHMETRICS ＊gm) { TPoint point; float fx,fy; fx = pf.x.value ＋ pf.x.fract / 65536.0f ＋ 0.5f; fx = fx / (float)(gm－>gmBlackBoxX ＋ gm－>gmptGlyphOrigin.x) ＊ (float)TheRect.Width() ＋ (float)TheRect.Left; fy = pf.y.value ＋ pf.y.fract / 65536.0f ＋ 0.5f; fy = ((float)gm－>gmBlackBoxY － fy) / (float)(gm－>gmBlackBoxX ＋ gm－>gmptGlyphOrigin.x) ＊ (float)TheRect.Height() ＋ (float)TheRect.Top; point.x = int(fx); point.y = int(fy); return point; } ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#47 引用回覆回覆發表時間：2003-12-12 06:55:18 IP:192.168.xxx.xxx 未訂閱【文章】如何開啟Excel並限制只能編輯某一頁sheet? 【作者】timhuang 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=29580 下面的程式範例為新開一個excel檔案後, 將 Sheet1, Sheet2 定為保護, 並切至 Sheet3 讓使用者輸入!! procedure TForm1.Button1Click(Sender: TObject); var ex, wb, ws: variant; begin ex := CreateOleObject('Excel.Application'); wb := ex.WorkBooks.Add; ex.visible := true; wb.Sheets['Sheet3'].Select; //利用 workbook 的 sheets 給定名稱或是指定第幾個都可以, 再利用 select 來進行選取的動作 //下面的兩行是以文件保護的方式來不讓使用者修改 wb.Sheets['Sheet1'].Protect(DrawingObjects:=True, Contents:=True, Scenarios:=True); wb.Sheets['Sheet2'].Protect(DrawingObjects:=True, Contents:=True, Scenarios:=True); end; ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#48 引用回覆回覆發表時間：2003-12-16 21:04:24 IP:211.76.xxx.xxx 未訂閱【文章】TComm安裝與16進制傳送接收程式【作者】bt1 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=35700 本RS232的元件是由書本[c++ Builder與RS232串列通訊控制]內ch4所附的元件. 安裝方式: step1:把TComm資料夾copy到C:\Program Files\Borland\CBuilder5 step2:開啟BCB5 step3:進入Compoment--->Install Component--->在Into existing package中的Unit file name中按 Browse按鈕,設路徑為C:\Program Files\Borland\CBuilder5\TComm 選Comm.cpp step4: 安裝完,關閉BCB5,並儲存檔案. step5:開啟BCB5,可以在上面一排元件中的system中看到TComm元件(一個9pin的Rs232端子,下方數字1010) setp6:安裝完成. [運用] 開啟: Comm1->PortOpen = true; 傳送: Comm1->OutputByte(ByteSend); 接收: ByteReceive=Comm1->ReadInputByte(); 關閉: Comm1->PortOpen=false; 全域變數的宣告: DynamicArray ByteSend,ByteReceive; String rdata[255]; [範例]16進制傳送和接收功能說明: Button1:傳送資料 Timer1:自動接收資料 //--------------------------------------------------------------------------- #include #pragma hdrstop #include #include "Unit1.h" //--------------------------------------------------------------------------- #pragma package(smart_init) #pragma link "Comm" #pragma resource ".dfm" TForm1 Form1; DynamicArray ByteSend,ByteReceive; String rdata[255]; long i; //--------------------------------------------------------------------------- __fastcall TForm1::TForm1(TComponent* Owner) : TForm(Owner) { Comm1->PortOpen = true; ShowMessage("Comm1已開啟"); Timer1->Enabled=true; //自動接收 } //--------------------------------------------------------------------------- void Delay(DWORD DT) { long tt; tt=GetTickCount(); while (GetTickCount()-ttProcessMessages(); if ((GetTickCount()-tt)<=0) tt=GetTickCount(); } } //--------------------------------------------------------------------------- void __fastcall TForm1::Button1Click(TObject Sender) { ByteSend.Length =4; ByteSend[0] = 0x01; ByteSend[1] = 0x03; ByteSend[2] = 0x0c; ByteSend[3] = 0x00; Comm1->OutputByte(ByteSend);//傳送出去 Delay(1000); //延遲100毫秒 //--------------------------------------------------------------------------- void __fastcall TForm1::Timer1Timer(TObject Sender) { Delay(100); //延遲100毫秒 ByteReceive=Comm1->ReadInputByte(); for(i=0;i ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#49 引用回覆回覆發表時間：2003-12-20 20:24:56 IP:192.168.xxx.xxx 未訂閱【文章】如何抓取WINDOWS系統預設的輸入法【作者】P.D. 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=42278 一些常用的輸入法設定, 直接引用就可以, 但 TsysUt 是formname, 請自行修正 private function GetIMEList(dCombobox: TComboBox): integer; function GetImeFileName: string; function SetActiveIme(sWanted: string): boolean; function SetFirstIme: boolean; function SetCloseIme: boolean; function SetKey2Ime(aObj: TWinControl): boolean; .... // 取得window內所有的輸入法 function TSysUt.GetIMEList(dCombobox: TComboBox): integer; var iHandleCount: integer; pList: array[1..nHKL_LIST] of HKL; szImeFileName: array[0..MAX_PATH] of char; sImeFileName: string; i: integer; begin // 看看是否安裝了這個輸入法 iHandleCount:= GetKeyboardLayoutList(nHKL_LIST, pList); for i:= 1 to iHandleCount do begin ImmGetDescription(pList[i], szImeFileName, MAX_PATH); sImeFileName := trim(AnsiUpperCase(StrPas(szImeFileName))); dCombobox.Items.Add(sImeFileName); end; dCombobox.Items.Strings[0]:= ''; result:= iHandleCount; end; //偵測目前作用中的輸入法檔案名稱 function TSysUT.GetImeFileName: string; var szImeFileName: array[0..MAX_PATH] of char; begin if ImmGetDescription(GetKeyboardLayout(0), szImeFileName, MAX_PATH) <> 0 then result:= AnsiUpperCase(StrPas(szImeFileName)) else result:= ''; end; // 切換到指定的輸入法 function TSysUT.SetActiveIme(sWanted: string): boolean; var iHandleCount: integer; pList: array[1..nHKL_LIST] of HKL; szImeFileName: array[0..MAX_PATH] of char; sImeFileName: string; bInstalled: boolean; i: integer; begin result:= False; sWanted:= AnsiUpperCase(sWanted); // 看看是否安裝了這個輸入法 bInstalled:= False; iHandleCount:= GetKeyboardLayoutList(nHKL_LIST, pList); for i:= 1 to iHandleCount do begin ImmGetDescription(pList[i], szImeFileName, MAX_PATH); sImeFileName := AnsiUpperCase(StrPas(szImeFileName)); if pos(sWanted,sImeFileName)>0 then begin bInstalled:= True; break; end; end; // 如果這個輸入法已安裝了, 讓那個輸入法的鍵盤分佈(KeyLayout)作用 if bInstalled then begin ActivateKeyboardLayout(pList[i], 0); result:= True; end; end; // 切換到第一個輸入法 function TSysUT.SetFirstIme: boolean; var iHandleCount: integer; pList: array[1..nHKL_LIST] of HKL; szImeFileName: array[0..MAX_PATH] of char; begin iHandleCount:= GetKeyboardLayoutList(nHKL_LIST, pList); if iHandleCount>=2 then begin ImmGetDescription(pList[2], szImeFileName, MAX_PATH); ActivateKeyboardLayout(pList[2], 0); result:= True; end else result:= False; end; // 回英數輸入法, 本輸入法假設第一組為英數 function TSysUT.SetCloseIme: boolean; var iHandleCount: integer; pList: array[1..nHKL_LIST] of HKL; szImeFileName: array[0..MAX_PATH] of char; begin U_VarDef.ChangeIME:= SysUT.GetImeFileName; iHandleCount:= GetKeyboardLayoutList(nHKL_LIST, pList); if iHandleCount>0 then begin ImmGetDescription(pList[1], szImeFileName, MAX_PATH); ActivateKeyboardLayout(pList[1], 0); result:= True; end else result:= False; end; //模擬ctrl-space來切換中英文 function TSysUT.SetKey2Ime(aObj: TWinControl): boolean; begin ImmSimulateHotKey(aObj.Handle, IME_THOTKEY_IME_NONIME_TOGGLE); result:= True; end; // 取得window所有輸入法用法 GetIMEList(combobox1); // 切換到注音 (字串須依window不同版本所提供, 可用上述function查得 SetActiveIme('注音'); ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#50 引用回覆回覆發表時間：2003-12-24 07:40:38 IP:192.168.xxx.xxx 未訂閱【文章】不用標題欄也可以移動表單【作者】未知【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=37720 不用標題欄也可以移動表單一般情況下，移動一個表單需要將滑鼠放置在標題欄上才能拖動表單，d什l非要使用標題欄呢？其實我們可以使用一個巧妙的方法來實現將滑鼠放置在表單上按下就可拖動表單，下面先看實現代碼。在Form1的“Private”部分聲明過程：在private部分加入下列代碼： procedure wmnchittest(var msg:twmnchittest); message wm_nchittest; 在程式部分加入以下代碼： procedure TForm1.wmnchittest(var msg:twmnchittest); begin inherited; if (htclient=msg.result) then msg.result:=htcaption; end; 上面的關鍵代碼雖然只有兩行，但它實現了滑鼠直接拖動表單的目的。代碼的原理是利用表單的WM_NCHITTEST消息，這個消息是當游標移動、滑鼠按下或釋放時發生的，當程式檢測到滑鼠在表單中按下的消息後（消息的值dhtClient），將滑鼠在標題欄上按下時{生的消息（值dhtCaption）傳遞出去，這樣就巧妙的欺騙程式認d是標題欄被按下，當然就可拖動表單了。 ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#51 引用回覆回覆發表時間：2003-12-27 22:27:15 IP:192.168.xxx.xxx 未訂閱【文章】如何像ie一樣儲存完整網頁(包含圖片...) 【作者】hagar 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=42605 下面的這一段程式碼只能儲存網頁的原始碼: uses ActiveX; procedure TForm1.Button1Click(Sender: TObject); begin (WebBrowser1.Document as IPersistFile).Save('C:\test.htm', False); end; 以下的這一段程式就可以儲存完整的網頁內容(包含圖片...) 但是會出現對話匡 begin WebBrowser1.ExecWB(OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT, EmptyParam, EmptyParam); end; 參考資料:http://groups.google.com.tw/groups?hl=zh-TW&lr=&ie=UTF-8&oe=UTF-8&th=878502bb87a888e6&rnum=11 ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#52 引用回覆回覆發表時間：2003-12-27 22:28:07 IP:192.168.xxx.xxx 未訂閱【文章】如何取得 WebBrowser 內所有的連結【作者】hagar 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=42605 procedure TForm1.Button1Click(Sender: TObject); var i: Integer; begin for i := 0 to Webbrowser1.OleObject.Document.links.Length - 1 do Listbox1.Items.Add(Webbrowser1.OleObject.Document.Links.Item(i)); end; {*****************} { if there are frames } procedure TForm1.Button2Click(Sender: TObject); var u : variant; v : IDispatch; s : string; procedure RecurseLinks(htmlDoc: variant); var BodyElement : variant; ElementCo: variant; HTMLFrames: variant; HTMLWnd : variant; j, i : integer; begin if VarIsEmpty(htmlDoc) then exit; BodyElement := htmlDoc.body; if BodyElement.tagName = 'BODY' then begin ElementCo := htmlDoc.links; j := ElementCo.Length - 1; for i := 0 to j do begin u := ElementCo.item(i); s := u.href; listLinks.Items.Add(s); end; end; HTMLFrames := htmlDoc.Frames; j := HTMLFrames.length - 1; for i := 0 to j do begin HTMLWnd := HTMLFrames.Item(i); RecurseLinks(HTMLWnd.Document); end; end; // RecurseLinks begin v := WebBrowser1.document; listLinks.Clear; RecurseLinks(v); end; 參考資料: http://www.swissdelphicenter.ch/en/showcode.php?id=479 ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#53 引用回覆回覆發表時間：2004-01-10 22:18:13 IP:192.168.xxx.xxx 未訂閱【文章】HTML與ActiveForm間的參數如何傳遞? 【作者】mi86018 【內文】http://delphi.ktop.com.tw/topic.php?topic_id=22699 [問題] 我利用ActiveForm撰寫了一個OCX檔,然後利用下列方式在HTML中設定Active Form的Color屬性,讓User讀取網頁時出現不同的色彩 ,如果我想自己加上一個TEST的屬性,來作其他參數傳遞不知是否可行? 請問是否有人這樣使用過. classid="clsid:FC5F3xxx-2xxx-4xx4-Bxxx-3xxxxx9xxxxx" codebase="http://www.xxx.xxx.tw/AAAA.cab#version=1,0,0,54" width=380 height=298 param name="Color" value="129" param name="TEST" value="參數傳遞" <=自行編輯的TEST屬性,用來傳遞資料 [回覆] 寫好的Activex ocx 在HTML引用的程式碼如下: <OBJECT " classid="clsid:4BBF9074-8799-41D9-B4E8-BF93C4372E6B" codebase="./PrintBarcodeProj1.inf" width=117 height=47 align=center hspace=0 vspace=0 ><font color=red>"> </OBJECT></font> 紅色這行..就是要從Html要傳入ocx的參數。而在Delphi中的ActiveX Form中點選 View -> Type Library 然後點選有個像紅色棒棒糖的Interface然後點滑鼠右鍵，New一個新的property，如圖一。圖一幫新的property去個名字，及資料型態，此property即為你要從Html傳進來的參數。取好名字之後Delphi會自動將Get和Put兩個Property設為同一名字，如下圖二。圖二新增完之後記得按下Type Library中裡那一排工具列裡面的Refresh。按下之後，在ActiveX form的程式碼就會多出兩個函式，如下： function Get_BarcodeStr: WideString; safecall; procedure Set_BarcodeStr(const Value: WideString); safecall; 在這兩個函式裡面，要加上下面的程式碼，當然也可以加入一些你自己需要的程式。 function TActiveXForm1.Get_BarcodeStr: WideString; begin Result := WideString(BarcodeStr); end; procedure TActiveXForm1.Set_BarcodeStr(const Value: WideString); begin BarcodeStr := Value; end; 之後，就可以在你自己寫的其他函式裡面用的這個從Html傳進來的參數了，用法如下：例如我在Timer裡面用道： procedure TActiveXForm1.Timer1Timer(Sender: TObject); var str:String; begin Timer1.Enabled:=False; str := get_BarcodeStr; if (length(str) = 0) then exit else showmessage(str); end; 將這個form包成ocx，Deploy之後，在Html語法記得加上文章最上面的那行 "> 這樣這個網頁就能將參數傳進這個ocx了!! ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#54 引用回覆回覆發表時間：2004-01-10 22:21:12 IP:192.168.xxx.xxx 未訂閱【文章】推薦一個介紹RS232串列通訊的網站【作者】領航天使【內文】串口通塈{ http://www.gjwtech.com/serialcomm.htm ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#55 引用回覆回覆發表時間：2004-01-10 22:28:53 IP:192.168.xxx.xxx 未訂閱【文章】如何判斷執行檔執行中?如何刪除執行工作? 【作者】ko 【內文】http://delphi.ktop.com.tw/topic.php?topic_id=34139 unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Edit1: TEdit; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} uses TlHelp32; var spid:Integer; PH : THandle; function ApplicationUse(fName : string) : boolean; var hSS: THandle; ProcEntry32: PROCESSENTRY32; iCount: Integer; begin Result := False; iCount := 0; hSS := CreateToolHelp32Snapshot(TH32CS_SNAPALL, 0); ProcEntry32.dwSize := sizeof(ProcEntry32); //----------------- if Process32First(hSS, ProcEntry32) then begin repeat // Application.MessageBox((ProcEntry32.szExeFile),'...'); if UpperCase(ProcEntry32.szExeFile) = UpperCase(fName) then begin spid := ProcEntry32.th32ProcessID; Inc(iCount); if iCount >= 1 then begin Result := True; Break; end; end; until not Process32Next(hSS, ProcEntry32); CloseHandle(hSS); end; //-------------- if Result then Exit; end; function KillSelectedProcess(PID:integer):String; var lpExitCode : DWord; hProcess : Cardinal; begin hProcess := Int64(PID); PH := OpenProcess(PROCESS_TERMINATE or PROCESS_QUERY_INFORMATION,FALSE, hProcess); if PH <> 0 then begin if GetExitCodeProcess(PH, lpExitCode) then TerminateProcess(PH, lpExitCode) else Result := 'Could not retreive the ExitCode for this process.'; CloseHandle(PH); end else Result := 'Could not get access to this process.' end; procedure TForm1.Button1Click(Sender: TObject); begin if ApplicationUse(edit1.text) then begin KillSelectedProcess(spid); end; end; end. ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#56 引用回覆回覆發表時間：2004-01-10 22:37:20 IP:192.168.xxx.xxx 未訂閱【文章】combobox中下拉後的內容不夠寬怎辦? 【作者】hagar 【內文】http://delphi.ktop.com.tw/topic.php?topic_id=24612 procedure SetComboDropDownWidth(ComboBox: TComboBox; Width: Longint = -1); var I, TextLen: Longint; begin if Width < ComboBox.Width then begin ComboBox.Canvas.Handle := GetDC(ComboBox.Handle); try for I := 0 to ComboBox.Items.Count -1 do begin TextLen := ComboBox.Canvas.TextWidth(ComboBox.Items[I]); if TextLen > Width then Width := TextLen; end; (* Standard ComboBox drawing is Rect.Left 2, adding the extra spacing offsets this *) Inc(Width, 10); finally ReleaseDC(ComboBox.Handle, ComboBox.Canvas.Handle); end; end; SendMessage(ComboBox.Handle, CB_SETDROPPEDWIDTH, Width, 0); end; -- ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#57 引用回覆回覆發表時間：2004-01-15 21:28:28 IP:192.168.xxx.xxx 未訂閱【文章】如何出現網路上的芳鄰選擇視窗? 【作者】Miles 【內文】http://delphi.ktop.com.tw/topic.php?topic_id=41923 unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Edit1: TEdit; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} Uses ShellAPI, ShlObj; function BrowseForComputer(const Title : String) : String; var BrowseInfo : TBROWSEINFO; IDRoot : PItemIDList; Path : array[0..MAX_PATH] of char; begin SHGetSpecialFolderLocation(Application.Handle, CSIDL_NETWORK, IDRoot); FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); FillChar(Path, sizeof(Path), #0); BrowseInfo.hwndOwner := Application.Handle; BrowseInfo.pidlRoot := IDRoot; BrowseInfo.lpszTitle := PChar(Title); BrowseInfo.pszDisplayName := @Path; BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER; SHBrowseForFolder(BrowseInfo); Result := String(Path); end; procedure TForm1.Button1Click(Sender: TObject); begin Edit1.Text := BrowseForComputer('網路芳鄰選我'); end; end. ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#58 引用回覆回覆發表時間：2004-01-28 20:57:20 IP:211.76.xxx.xxx 未訂閱【文章】幾個有用的日期轉換函數(包含UNIXTIME轉換) 【作者】Trevor J Carlsen 【內文】來源:http://www.bsdg.org/swag/DATETIME/0015.PAS.html Unit TCDate; { Author: Trevor J Carlsen Released into the public domain } { PO Box 568 } { Port Hedland } { Western Australia 6721 } { Voice 61 91 732 026 } Interface Uses Dos; Type Date = Word; UnixTimeStamp = LongInt; Const WeekDays : Array[0..6] of String[9] = ('Sunday','Monday','Tuesday','Wednesday','Thursday', 'Friday','Saturday'); months : Array[1..12] of String[9] = ('January','February','March','April','May','June','July', 'August','September','October','November','December'); Function DayofTheWeek(pd : date): Byte; { Returns the day of the week For any date Sunday = 0 .. Sat = 6 } { pd = a packed date as returned by the Function PackedDate } { eg... Writeln('today is ',WeekDays[DayofTheWeek(today))]; } Function PackedDate(yr,mth,d: Word): date; { Packs a date into a Word which represents the number of days since } { Dec 31,1899 01-01-1900 = 1 } Function UnixTime(yr,mth,d,hr,min,sec: Word): UnixTimeStamp; { Packs a date and time into a four Byte unix style Variable which } { represents the number of seconds that have elapsed since midnight } { on Jan 1st 1970. } Procedure UnPackDate(Var yr,mth,d: Word; pd : date); { Unpacks a Word returned by the Function PackedDate into its } { respective parts of year, month and day } Procedure UnPackUnix(Var yr,mth,d,hr,min,sec: Word; uts: UnixTimeStamp); { Unpacks a UnixTimeStamp Variable into its Component parts. } Function DateStr(pd: date; Format: Byte): String; { Unpacks a Word returned by the Function PackedDate into its } { respective parts of year, month and day and then returns a String } { Formatted according to the specifications required. } { if the Format is > 9 then the day of the week is prefixed to the } { returned String. } { Formats supported are: } { 0: dd/mm/yy } { 1: mm/dd/yy } { 2: dd/mm/yyyy } { 3: mm/dd/yyyy } { 4: [d]d xxx yyyy (xxx is alpha month of 3 Chars) } { 5: xxx [d]d, yyyy } { 6: [d]d FullAlphaMth yyyy } { 7: FullAlphaMth [d]d, yyyy } { 8: [d]d-xxx-yy } { 9: xxx [d]d, 'yy } Function ValidDate(yr,mth,d : Word; Var errorcode : Byte): Boolean; { Validates the date and time data to ensure no out of range errors } { can occur and returns an error code to the calling Procedure. A } { errorcode of zero is returned if no invalid parameter is detected. } { Errorcodes are as follows: } { Year out of range (< 1901 or > 2078) bit 0 of errorcode is set. } { Month < 1 or > 12 bit 1 of errorcode is set. } { Day < 1 or > 31 bit 2 of errorcode is set. } { Day out of range For month bit 2 of errorcode is set. } Procedure ParseDateString(Var dstr; Var y,m,d : Word; Format : Byte); { Parses a date String in several Formats into its Component parts } { It is the Programmer's responsibility to ensure that the String } { being parsed is a valid date String in the Format expected. } { Formats supported are: } { 0: dd/mm/yy[yy] } { 1: mm/dd/yy[yy] } Function NumbofDaysInMth(y,m : Word): Byte; { returns the number of days in any month } Function IncrMonth(pd: date; n: Word): date; { Increments pd by n months. } Function today : date; { returns the number of days since 01-01-1900 } Function ordDate (Y,M,D : Word):LongInt; { returns ordinal Date yyddd } Function Dateord (S : String) : String; { returns Date as 'yymmdd' } {============================================================================= } Implementation Const TDays : Array[Boolean,0..12] of Word = ((0,31,59,90,120,151,181,212,243,273,304,334,365), (0,31,60,91,121,152,182,213,244,274,305,335,366)); UnixDatum = LongInt(25568); SecsPerDay = 86400; SecsPerHour = LongInt(3600); SecsPerMin = LongInt(60); MinsPerHour = 60; Function DayofTheWeek(pd : date): Byte; begin DayofTheWeek := pd mod 7; end; { DayofTheWeek } Function PackedDate(yr,mth,d : Word): date; { valid For all years 1901 to 2078 } Var temp : Word; lyr : Boolean; begin lyr := (yr mod 4 = 0); if yr >= 1900 then dec(yr,1900); temp := yr * Word(365) (yr div 4) - ord(lyr); inc(temp,TDays[lyr][mth-1]); inc(temp,d); PackedDate := temp; end; { PackedDate } Function UnixTime(yr,mth,d,hr,min,sec: Word): UnixTimeStamp; { Returns the number of seconds since 00:00 01/01/1970 } begin UnixTime := SecsPerDay * (PackedDate(yr,mth,d) - UnixDatum) SecsPerHour * hr SecsPerMin * min sec; end; { UnixTime } Procedure UnPackDate(Var yr,mth,d: Word; pd : date); { valid For all years 1901 to 2078 } Var julian : Word; lyr : Boolean; begin d := pd; yr := (LongInt(d) * 4) div 1461; julian := d - (yr * 365 (yr div 4)); inc(yr,1900); lyr := (yr mod 4 = 0); inc(julian,ord(lyr)); mth := 0; While julian > TDays[lyr][mth] do inc(mth); d := julian - TDays[lyr][mth-1]; end; { UnPackDate } Procedure UnPackUnix(Var yr,mth,d,hr,min,sec: Word; uts: UnixTimeStamp); Var temp : UnixTimeStamp; begin UnPackDate(yr,mth,d,date(uts div SecsPerDay) UnixDatum); temp := uts mod SecsPerDay; hr := temp div SecsPerHour; min := (temp mod SecsPerHour) div MinsPerHour; sec := temp mod SecsPerMin; end; { UnPackUnix } Function DateStr(pd: date; Format: Byte): String; Var y,m,d : Word; YrStr : String[5]; MthStr : String[11]; DayStr : String[8]; TempStr : String[5]; begin UnpackDate(y,m,d,pd); str(y,YrStr); str(m,MthStr); str(d,DayStr); TempStr := ''; if Format > 9 then TempStr := copy(WeekDays[DayofTheWeek(pd)],1,3) ' '; if (Format mod 10) < 4 then begin if m < 10 then MthStr := '0' MthStr; if d < 10 then DayStr := '0' DayStr; end; Case Format mod 10 of { Force Format to a valid value } 0: DateStr := TempStr DayStr '/' MthStr '/' copy(YrStr,3,2); 1: DateStr := TempStr MthStr '/' DayStr '/' copy(YrStr,3,2); 2: DateStr := TempStr DayStr '/' MthStr '/' YrStr; 3: DateStr := TempStr MthStr '/' DayStr '/' YrStr; 4: DateStr := TempStr DayStr ' ' copy(months[m],1,3) ' ' YrStr; 5: DateStr := TempStr copy(months[m],1,3) ' ' DayStr ' ' YrStr; 6: DateStr := TempStr DayStr ' ' months[m] ' ' YrStr; 7: DateStr := TempStr months[m] ' ' DayStr ' ' YrStr; 8: DateStr := TempStr DayStr '-' copy(months[m],1,3) '-' copy(YrStr,3,2); 9: DateStr := TempStr copy(months[m],1,3) ' ' DayStr ', ''' copy(YrStr,3,2); end; { Case } end; { DateStr } Function ValidDate(yr,mth,d : Word; Var errorcode : Byte): Boolean; begin errorcode := 0; if (yr < 1901) or (yr > 2078) then errorcode := (errorcode or 1); if (d < 1) or (d > 31) then errorcode := (errorcode or 2); if (mth < 1) or (mth > 12) then errorcode := (errorcode or 4); Case mth of 4,6,9,11: if d > 30 then errorcode := (errorcode or 2); 2: if d > (28 ord((yr mod 4) = 0)) then errorcode := (errorcode or 2); end; {Case } ValidDate := (errorcode = 0); if errorcode <> 0 then Write(#7); end; { ValidDate } Procedure ParseDateString(Var dstr; Var y,m,d : Word; Format : Byte); Var left,middle : Word; errcode : Integer; st : String Absolute dstr; begin val(copy(st,1,2),left,errcode); val(copy(st,4,2),middle,errcode); val(copy(st,7,4),y,errcode); Case Format of 0: begin d := left; m := middle; end; 1: begin d := middle; m := left; end; end; { Case } end; { ParseDateString } Function NumbofDaysInMth(y,m : Word): Byte; { valid For the years 1901 - 2078 } begin Case m of 1,3,5,7,8,10,12: NumbofDaysInMth := 31; 4,6,9,11 : NumbofDaysInMth := 30; 2 : NumbofDaysInMth := 28 ord((y mod 4) = 0); end; end; { NumbofDaysInMth } Function IncrMonth(pd: date; n: Word): date; Var y,m,d : Word; begin UnpackDate(y,m,d,pd); dec(m); inc(m,n); inc(y,m div 12); { if necessary increment year } m := succ(m mod 12); if d > NumbofDaysInMth(y,m) then d := NumbofDaysInMth(y,m); IncrMonth := PackedDate(y,m,d); end; { IncrMonth } Function today : date; Var y,m,d,dw : Word; begin GetDate(y,m,d,dw); today := PackedDate(y,m,d); end; { today } Function ordDate (Y,M,D : Word): LongInt; { returns ordinal Date as yyddd } Var LYR : Boolean; TEMP : LongInt; begin LYR := (Y mod 4 = 0) and (Y <> 1900); Dec (Y,1900); TEMP := LongInt(Y) * 1000; Inc (TEMP,TDays[LYR][M-1]); { Compute # days through last month } Inc (TEMP,D); { # days this month } ordDate := TEMP end; { ordDate } Function Dateord (S : String) : String; { returns Date as 'yymmdd' } Var LYR : Boolean; Y,M,D : Word; TEMP : LongInt; N : Integer; StoP : Boolean; SW,ST : String[6]; begin Val (Copy(S,1,2),Y,N); Val (Copy(S,3,3),TEMP,N); Inc (Y,1900); LYR := (Y mod 4 = 0) and (Y <> 1900); Dec (Y,1900); N := 0; StoP := False; While not StoP and (TDays[LYR][N] < TEMP) do Inc (N); M := N; { month } D := TEMP-TDays[LYR][M-1]; { subtract # days thru this month } Str(Y:2,SW); Str(M:2,ST); if ST[1] = ' ' then ST[1] := '0'; SW := SW ST; Str(D:2,ST); if ST[1] = ' ' then ST[1] := '0'; SW := SW ST; Dateord := SW end; { Dateord } end. { Unit TCDate } ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#59 引用回覆回覆發表時間：2004-02-14 08:22:34 IP:192.168.xxx.xxx 未訂閱【文章】如何知道檔案是否被其他程式存取中? 【作者】hagar 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=37666 問題如下: 我開一個A程式,裡面有個Multi Thread來監看底下的一個子目錄,一但此子目錄有檔案,則呼叫一個副程式來讀檔,但現在問題來了,那個副程式只知道有檔案在此目錄下(使用FindFile的方式),但卻不知道此檔案是否已經讀寫完畢了,這樣就會發生,檔案還未存取完畢,副程式就已經讀檔完成,變成副程式讀的檔(文字檔)是不完全的,請問這要怎麼實作才會比較好? dllee回答如下: hagar 版主所用的方法就是開檔而已，在 Windows 的開檔方式中德的 AccessMode 設定可以設定檔案是否可以被同時存取，或是只允許可以讓別人同時讀，或只允許別人寫但不能讀，或是完全不允許別人可以讀寫。而判斷一個檔是否已經被使用但沒有關閉，就是對那個檔案作「開檔」的動作，同時指定 AccessMode 是別人不可以讀也不可以寫，只有我可以讀也可以寫。這樣，當這個檔案可以正常開啟時，就表示沒有其他函式在使用，如果有其他函式在使用，則會傳回 INVALID_HANDLE_VALUE 表示開檔不成功！當然開檔不成功也有可能是檔案本來就不存在，所以 hagar 版主在一開始就有判斷檔案存不存在。其實，解決的方法有很多種，因為您把問題指定檔案是否處理完成，所以我想 hagar 版主的方式就可以解決。如果所有的程式都是您自己開發，則問題可以是兩個(以上)的程式或執行緒之間資料、訊息交換的問題，在此您只需在處理檔案的執行緒或程式在處理檔案是發一個訊息給其他模組去收，或將一個旗標打開讓別人可以存取，例如另開一個檔案作資料交換或用 ■【發表】跨行程共享記憶體 - Memory mapping file http://delphi.ktop.com.tw/topic.php?TOPIC_ID=37041 或 ■【Delphi】【分享】ShareMemRep 1.0 - 最佳的共享內存管理器替代方案 http://delphi.ktop.com.tw/topic.php?TOPIC_ID=35228 都可以。等處理檔案的執行緒處理完檔案，再以同樣的方式通知其他模組。這樣，就不需要以「開檔」的方式來判斷檔是是否已處理完畢。程式範例 function IsFileInUse(FileName: TFileName): Boolean; var HFileRes: HFILE; begin Result := False; if not FileExists(FileName) then Exit; HFileRes := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); Result := (HFileRes = INVALID_HANDLE_VALUE); if not Result then CloseHandle(HFileRes); end; ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#60 引用回覆回覆發表時間：2004-02-14 08:25:00 IP:192.168.xxx.xxx 未訂閱【文章】如何讓DBGRID的各欄位自動調整寬度? 【作者】pedro 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=44580 DBGrid的各Column的Width其實是由DataSet的欄位DisplayWidth帶出來的, 而這個DisplayWidth值是由資料庫的Schema定義欄位大小時給的, 例如整數是4. 如果資料表的欄位數很多, 一般都會超過DBGrid可視範圍. 所以說, DBGrid的Column寬度由資料表定義決定. 但是若您想用程式碼調整下面片段程式碼您可以參考看看 var TotalGridDisplayWidth:Integer; procedure TForm1.FormCreate(Sender: TObject); var i:Integer; x:double; begin TotalGridDisplayWidth:=0; for i:=0 to DBGrid1.Columns.Count-1 do begin TotalGridDisplayWidth:=TotalGridDisplayWidth DBGrid1.Columns.Items[i].Width; end; for i:=0 to DBGrid1.Columns.Count-1 do begin x:=DBGrid1.Columns[i].Width / TotalGridDisplayWidth; DBGrid1.Columns[i].Width:=Round((DBGrid1.Width-50)*x); end; end; ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#61 引用回覆回覆發表時間：2004-02-23 08:37:48 IP:192.168.xxx.xxx 未訂閱【文章】如何傳網址給已開啟的IE? 【作者】qoo1234 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=45284 Q: 我已將IE開啟，但是每次Delphi程式被執行時需傳送不同網址給IE，1.如何得知IE已開啟，且將網址傳入IE重新更新? A: //傳網址給IE網址列 procedure TForm1.Button1Click(Sender: TObject); var IE,toolbar,combo,comboboxex,edit,worker,toolbarwindow: HWND; begin IE := FindWindow('IEFrame', nil); worker := FindWindowEx(IE,0,'WorkerW',nil); //注意版本差異 (有些用WorkerA) toolbar := FindWindowEx(worker,0,'reBarwindow32',nil); comboboxex := FindWindowEx(toolbar, 0, 'comboboxex32', nil); combo := FindWindowEx(comboboxex,0,'ComboBox',nil); edit := FindWindowEx(combo,0,'Edit',nil); toolbarwindow := FindWindowEx(comboboxex, 0, 'toolbarwindow32', nil); if IE <> 0 then begin SendMessage(edit , WM_SETTEXT, 0, Integer(PChar('http://delphi.ktop.com.tw'))); end else ShowMessage('IE瀏覽器不存在'); end; ------ ～～～Delphi K.Top討論區站長～～～

[<<] [1] [2] [3] [4] [5] [>>]

系統時間：2024-06-27 0:29:33

聯絡我們 | Delphi K.Top討論版

本站聲明

1. 本論壇為無營利行為之開放平台，所有文章都是由網友自行張貼，如牽涉到法律糾紛一切與本站無關。
2. 假如網友發表之內容涉及侵權，而損及您的利益，請立即通知版主刪除。
3. 請勿批評中華民國元首及政府或批評各政黨，是藍是綠本站無權干涉，但這裡不是政治性論壇！

bruce0211 版主發表：157 回覆：668 積分：279 註冊：2002-06-13 發送簡訊給我	#32 引用回覆回覆發表時間：2003-11-25 12:49:16 IP:211.21.xxx.xxx 未訂閱【文章】目錄處理函式三則:_DelTree(),_XCopy(),_Move() 【作者】源碼任務 bruce0211@yahoo.com.tw 2003/11/25 【內文】常用目錄處理函式整理 for BCB/Delphi ■ 用法參數位置同 DOS 公用程式 , 沒用到什麼特殊 API , 應該適用於各種 BCB/Delphi 版本 _DelTree() 刪除整個目錄(含子目錄) _XCopy() 複製整個目錄(含子目錄) _Move() 搬移整個目錄(含子目錄) ■ BCB 版本 private: // User declarations void __fastcall _XCopy(String ASourceDir,String ADestDir); void __fastcall _Move(String ASourceDir,String ADestDir); void __fastcall _DelTree(String ASourceDir); //--------------------------------------------------------------------------- void __fastcall TForm1::_XCopy(String ASourceDir,String ADestDir) { TSearchRec SearchRec; String Sour=ASourceDir; String Dest=ADestDir; if (Sour.SubString(Sour.Length(),1)!="\\") Sour=Sour "\\"; if (Dest.SubString(Dest.Length(),1)!="\\") Dest=Dest "\\"; if (!DirectoryExists(ASourceDir)) // 要 #include "FileCtrl.hpp" 才有這個函式 { ShowMessage("來源目錄不存在!!"); return; } if (!DirectoryExists(ADestDir)) ForceDirectories(ADestDir); if (FindFirst(Sour ".", faAnyFile, SearchRec) == 0) { do { //應該可用 if ((SearchRec.Attr & faDirectory) != 0) 取代下面的判斷 if ( (SearchRec.Attr == (faDirectory)) \|\| (SearchRec.Attr == (faDirectory \| faArchive)) \|\| (SearchRec.Attr == (faDirectory \| faReadOnly)) \|\| (SearchRec.Attr == (faDirectory \| faHidden)) ) { if ((SearchRec.Name!=".") && (SearchRec.Name!="..")) { _XCopy(Sour SearchRec.Name,Dest SearchRec.Name); //遞迴呼叫 } } else { CopyFile(((String)(Sour SearchRec.Name)).c_str(),((String)(Dest SearchRec.Name)).c_str(),false); } } while (FindNext(SearchRec) == 0); FindClose(SearchRec); } } //--------------------------------------------------------------------------- void __fastcall TForm1::_Move(String ASourceDir,String ADestDir) { TSearchRec SearchRec; String Sour=ASourceDir; String Dest=ADestDir; if (Sour.SubString(Sour.Length(),1)!="\\") Sour=Sour "\\"; if (Dest.SubString(Dest.Length(),1)!="\\") Dest=Dest "\\"; if (!DirectoryExists(ASourceDir)) // 要 #include "FileCtrl.hpp" 才有這個函式 { ShowMessage("來源目錄不存在!!"); return; } if (!DirectoryExists(ADestDir)) ForceDirectories(ADestDir); if (FindFirst(Sour ".", faAnyFile, SearchRec) == 0) { do { //應該可用 if ((SearchRec.Attr & faDirectory) != 0) 取代下面的判斷 if ( (SearchRec.Attr == (faDirectory)) \|\| (SearchRec.Attr == (faDirectory \| faArchive)) \|\| (SearchRec.Attr == (faDirectory \| faReadOnly)) \|\| (SearchRec.Attr == (faDirectory \| faHidden)) ) { if ((SearchRec.Name!=".") && (SearchRec.Name!="..")) { _XCopy(Sour SearchRec.Name,Dest SearchRec.Name); //遞迴呼叫 _DelTree(Sour SearchRec.Name); FileSetAttr(Sour SearchRec.Name,faArchive); RemoveDir(Sour SearchRec.Name); } } else { CopyFile(((String)(Sour SearchRec.Name)).c_str(),((String)(Dest SearchRec.Name)).c_str(),false); FileSetAttr(Sour SearchRec.Name,faArchive); DeleteFile(Sour SearchRec.Name); } } while (FindNext(SearchRec) == 0); FindClose(SearchRec); } FileSetAttr(Sour,faArchive); RemoveDir(Sour); } //--------------------------------------------------------------------------- void __fastcall TForm1::_DelTree(String ASourceDir) { TSearchRec SearchRec; String Sour=ASourceDir; if (Sour.SubString(Sour.Length(),1)!="\\") Sour=Sour "\\"; if (!DirectoryExists(Sour)) // 要 #include "FileCtrl.hpp" 才有這個函式 { ShowMessage("來源目錄不存在!!"); return; } if (FindFirst(Sour ".", faAnyFile, SearchRec) == 0) { do { //應該可用 if ((SearchRec.Attr & faDirectory) != 0) 取代下面的判斷 if ( (SearchRec.Attr == (faDirectory)) \|\| (SearchRec.Attr == (faDirectory \| faArchive)) \|\| (SearchRec.Attr == (faDirectory \| faReadOnly)) \|\| (SearchRec.Attr == (faDirectory \| faHidden)) ) { if ((SearchRec.Name!=".") && (SearchRec.Name!="..")) { _DelTree(Sour SearchRec.Name); //遞迴呼叫 FileSetAttr(Sour SearchRec.Name,faArchive); RemoveDir(Sour SearchRec.Name); } } else { FileSetAttr(Sour SearchRec.Name,faArchive); DeleteFile(Sour SearchRec.Name); } } while (FindNext(SearchRec) == 0); FindClose(SearchRec); } FileSetAttr(Sour,faArchive); RemoveDir(Sour); } ■ Delphi 版本 private { Private declarations } procedure _XCopy(ASourceDir:String; ADestDir:String); procedure _Move(ASourceDir:String; ADestDir:String); procedure _DelTree(ASourceDir:String); //--------------------------------------------------------------------------- procedure TForm1._XCopy(ASourceDir:String; ADestDir:String); var FileRec:TSearchrec; Sour:String; Dest:String; begin Sour:=ASourceDir; Dest:=ADestDir; if Sour[Length(Sour)]<>'\' then Sour := Sour '\'; if Dest[Length(Dest)]<>'\' then Dest := Dest '\'; if not DirectoryExists(ASourceDir) then begin ShowMessage('來源目錄不存在!!'); exit; end; if not DirectoryExists(ADestDir) then begin ForceDirectories(ADestDir); end; if FindFirst(Sour '.',faAnyfile,FileRec) = 0 then repeat if ((FileRec.Attr and faDirectory) <> 0) then begin if (FileRec.Name<>'.') and (FileRec.Name<>'..') then begin _XCopy(Sour FileRec.Name,Dest FileRec.Name); end; end else begin CopyFile(PChar(Sour FileRec.Name),PChar(Dest FileRec.Name),false); end; until FindNext(FileRec)<>0; FindClose(FileRec); end; //--------------------------------------------------------------------------- procedure TForm1._Move(ASourceDir:String; ADestDir:String); var FileRec:TSearchrec; Sour:String; Dest:String; begin Sour:=ASourceDir; Dest:=ADestDir; if Sour[Length(Sour)]<>'\' then Sour := Sour '\'; if Dest[Length(Dest)]<>'\' then Dest := Dest '\'; if not DirectoryExists(ASourceDir) then begin ShowMessage('來源目錄不存在!!'); exit; end; if not DirectoryExists(ADestDir) then begin ForceDirectories(ADestDir); end; if FindFirst(Sour '.',faAnyfile,FileRec) = 0 then repeat if ((FileRec.Attr and faDirectory) <> 0) then begin if (FileRec.Name<>'.') and (FileRec.Name<>'..') then begin _XCopy(Sour FileRec.Name,Dest FileRec.Name); _DelTree(Sour FileRec.Name); FileSetAttr(Sour FileRec.Name,faArchive); RemoveDir(Sour FileRec.Name); end; end else begin CopyFile(PChar(Sour FileRec.Name),PChar(Dest FileRec.Name),false); FileSetAttr(Sour FileRec.Name,faArchive); deletefile(Sour FileRec.Name); end; until FindNext(FileRec)<>0; FindClose(FileRec); FileSetAttr(Sour,faArchive); RemoveDir(Sour); end; //--------------------------------------------------------------------------- procedure TForm1._DelTree(ASourceDir:String); var FileRec:TSearchrec; Sour:String; begin Sour:=ASourceDir; if Sour[Length(Sour)]<>'\' then Sour := Sour '\'; if not DirectoryExists(ASourceDir) then begin ShowMessage('來源目錄不存在!!'); exit; end; if FindFirst(Sour '.',faAnyfile,FileRec) = 0 then repeat //if (FileRec.Attr = faDirectory) then if ((FileRec.Attr and faDirectory) <> 0) then begin if (FileRec.Name<>'.') and (FileRec.Name<>'..') then begin _DelTree(Sour FileRec.Name); FileSetAttr(Sour FileRec.Name,faArchive); RemoveDir(Sour FileRec.Name); end; end else begin FileSetAttr(Sour FileRec.Name,faArchive); deletefile(Sour FileRec.Name); end; until FindNext(FileRec)<>0; FindClose(FileRec); FileSetAttr(Sour,faArchive); RemoveDir(Sour); end;
bruce0211 版主發表：157 回覆：668 積分：279 註冊：2002-06-13 發送簡訊給我	#33 引用回覆回覆發表時間：2003-11-25 15:05:27 IP:211.21.xxx.xxx 未訂閱【文章】螢幕畫面處理函式二則:_ScreenSaveToFile(),_ScreenLoadFromFile() 【作者】源碼任務 bruce0211@yahoo.com.tw 2003/11/25 【內文】常用螢幕畫面處理函式整理 for BCB/Delphi ■ 用法 //-------------------------------------------------------------------- //函式名稱 : _ScreenSaveToFile([檔名],[存檔型態]) //函式用途 : 將螢幕畫面存檔 //參數說明 : [檔名]若為空字串則自動給定流水號檔名 ; [存檔型態] 0:bmp 1:jpg //函式範例 : _ScreenSaveToFile('',0); 將目前螢幕畫面存成 .bmp 檔,檔名使用流水號 //補充說明 : 可在程式中隨時呼叫本函式 , 將多個畫面分別存檔以利式樣製作剪貼 //-------------------------------------------------------------------- //函式名稱 : _ScreenLoadFromFile([桌布檔名位置]) //函式用途 : 更換螢幕桌布 //參數說明 : //函式範例 : _ScreenLoadFromFile('c:\test.bmp'); 將目前桌布換成 c:\test.bmp //補充說明 : //-------------------------------------------------------------------- ■ 注意要先 #include "jpeg.hpp" 或 uses jpeg ■ BCB 版本 //--------------------------------------------------------------------------- void __fastcall _ScreenSaveToFile(String AFileName, int AFileType) { TJPEGImage jpg = new TJPEGImage(); Graphics::TBitmap *bmp = new Graphics::TBitmap(); bmp->Width=Screen->Width; bmp->Height=Screen->Height; String my_filename; my_filename=Trim(AFileName); if (my_filename=="") { if (AFileType==0) my_filename="c:\\" FormatDateTime("mmdd_hhnnss_zzz",Now()) ".bmp"; //流水號檔名 else my_filename="c:\\" FormatDateTime("mmdd_hhnnss_zzz",Now()) ".jpg"; //流水號檔名 } HWND d; HDC dc; if((d=GetDesktopWindow())!=NULL) { dc=GetDC(d); BitBlt(bmp->Canvas->Handle,0,0,bmp->Width,bmp->Height,dc,0,0,SRCCOPY); ReleaseDC(d,dc); if (AFileType==0) bmp->SaveToFile(my_filename); else { jpg->Assign(bmp); jpg->SaveToFile(my_filename); } } delete jpg; delete bmp; } //--------------------------------------------------------------------------- void __fastcall _ScreenLoadFromFile(String ABmpFileName) { if (!FileExists(ABmpFileName)) return; SystemParametersInfo(SPI_SETDESKWALLPAPER, NULL, ABmpFileName.c_str(), SPIF_UPDATEINIFILE \| SPIF_SENDCHANGE); } ■ Delphi 版本 //--------------------------------------------------------------------------- procedure _ScreenSaveToFile(AFileName: String ; AFileType: integer); var d:HWND; dc:HDC; jpg:TJPEGImage; bmp:TBitmap; my_filename:String; begin jpg := TJPEGImage.Create; bmp := TBitmap.Create; bmp.Width:=Screen.width; bmp.Height:=Screen.height; my_filename:=Trim(AFileName); if my_filename='' then begin if AFileType=0 then my_filename:='c:\' FormatDateTime('mmdd_hhnnss_zzz',Now) '.bmp' //流水號檔名 else my_filename:='c:\' FormatDateTime('mmdd_hhnnss_zzz',Now) '.jpg' //流水號檔名 end; d:=GetDesktopWindow(); if (d<>0) then begin dc:=GetDC(d); BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,dc,0,0,SRCCOPY); ReleaseDC(d,dc); if AFileType=0 then begin bmp.SaveToFile(my_filename); end else begin jpg.Assign(bmp); jpg.SaveToFile(my_filename); end; end; jpg.Free; bmp.Free; end; //--------------------------------------------------------------------------- procedure _ScreenLoadFromFile(ABmpFileName:String); begin if not FileExists(ABmpFileName) then exit; SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar(ABmpFileName), SPIF_UPDATEINIFILE or SPIF_SENDCHANGE); end;
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#34 引用回覆回覆發表時間：2003-11-26 19:12:50 IP:192.168.xxx.xxx 未訂閱【文章】如何將Quick Report的報表轉成圖檔或PDF檔【作者】hagar 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=40801 1.BMP procedure TForm5.Button4Click(Sender: TObject); var BMP: TBitMap; StoredUnits: TQRUnit; i: integer; StoreDir: string; begin StoreDir:=''; {!!! Assign folder to store here (with ending '\'), leave blank to store in the .exe's folder} QuickRep1.Prepare; StoredUnits:=QuickRep1.Units; QuickRep1.Units:=Pixels; try for i:=1 to QuickRep1.QRPrinter.PageCount do begin BMP:=TBitMap.Create; try BMP.Width:=Round(QuickRep1.Page.Width); BMP.Height:=Round(QuickRep1.Page.Length); QuickRep1.QRPrinter.PageNumber:=i; BMP.Canvas.Draw(0, 0, QuickRep1.QRPrinter.Page); BMP.SaveToFile(StoreDir+'Page'+IntToStr(i)+'.bmp'); finally BMP.Free; end; end; finally QuickRep1.Units:=StoredUnits; end; end; 2.PDF var AFilter: TPsQRPDFFilter; begin AFilter := TPsQRPDFFilter.Create('MyRep.pdf'); try QuickRep.Prepare; QuickRep.ExportToFilter(AFilter); finally QuickRep.QRPrinter.Free; QuickRep.QRPrinter := nil; AFilter.Free; end; end; 參考資料: Save QReports pages as BMP: http://www.nsonic.de/Delphi/txt_WIS00489.htm http://groups.google.com.tw/groups?hl=zh-TW&lr=&ie=UTF-8&inlang=zh-TW&th=3293737e593a1cb0&rnum=29 http://groups.google.com.tw/groups?hl=zh-TW&lr=&ie=UTF-8&inlang=zh-TW&th=93ada631d63769a&rnum=1 其它相關 Tool 的連結: http://www.paperlessprinter.com/ http://www.leadtools.com/ http://www.wptools.de/ ------ ～～～Delphi K.Top討論區站長～～～
Ethan 版主發表：101 回覆：170 積分：78 註冊：2006-07-05 發送簡訊給我	#35 引用回覆回覆發表時間：2003-11-27 12:14:34 IP:61.218.xxx.xxx 未訂閱【文章】MaxDB by MySQL 釋放使用 (一個企業級的免費資料庫軟體) 【作者】黃書逸(Ethan) 【內文】MySQL 與 SAPDB合作後首推的MaxDB 真是可怕的一個資料庫軟體，如果不與各位分享的話就太沒仁義道德了，最令人髮指的地方就是 DBM GUI，所以大家一定要安裝看看，看了之後一定會很感動的... http://delphi.ktop.com.tw/loadfile.php?TOPICID=12882467&CC=288113 以下節錄文章中的一段... MaxDB by MySQL 釋放使用 (一個企業級的免費資料庫軟體) 筆者：黃書逸 shuyi@unix.net.tw MySQL AB 在產品線上增加了企業等級的 SAP-Certified 開放源碼資料庫 MySQL AB，目前在全球最受歡迎的開放源碼資料庫軟體，今天發佈了 MaxDB by MySQL並提供免費下載，MaxDB是一個高負荷的資料庫系統，SAP-Certified開放源碼資料庫一向以提供高效益及廣泛功能的風格被大眾所接受，MaxDB是MySQL AB旗艦型資料庫產品，現在擴展到企業市場並達到大規模的mySAP ERP環境的支援(SAP-DB http://www.sapdb.org)，和其他應用軟體與需大量運算的企業規模等級的資料庫功能。 MySQL AB獲得了完成的商用權利來開發與行銷未來的 SAP DB 版本，目前在全球已經有設置SAP DB的企業約有5,000家，其中包括：Intel、DaimlerChysler(德國郵政)、Braun、Bayer、YAMAHA、Deutsche Post和TOYOTA。 MaxDB 7.5 支援所有的 SAP Solutions 第一個釋放的MaxDB版本為7.5.00.05，也就是SAP DB 7.4版，MaxDB7.5.00.05在推出前已經有廣泛的測試並被證明可以完全支援SAP solutions，另外MySQL會提供一個MySQL Proxy介面，可以讓使用者在不同平台間的MaxDB和MySQL資料庫溝通，也就是說可以在MaxDB與MySQL間做資料庫的轉換...... 學習,從分享開始^^
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#36 引用回覆回覆發表時間：2003-11-27 19:20:29 IP:192.168.xxx.xxx 未訂閱【文章】如何動態呼叫function or procedure 【作者】Mickey 【內文】文章來源:http://delphi.ktop.com.tw/topic.php?topic_id=40505 type TMyPorcdure = procedure (Sender: TObject) of Object; TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); Procedure P1(Sender: TObject); Procedure P2(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} { TForm1 } procedure TForm1.P1(Sender: TObject); begin showmessage('In P1 Procedure'); end; procedure TForm1.P2(Sender: TObject); begin showmessage('In P2 Procedure'); end; procedure TForm1.Button1Click(Sender: TObject); var m : TMyPorcdure; s : string; p : Pointer; begin s := 'P1'; p := MethodAddress(s); if p<>nil then begin TMethod(m).Code := p; TMethod(m).Data := Self; m(Sender); end else raise Exception.CreateFmt('Procedure %s not exists',[s]); s := 'P2'; p := MethodAddress(s); if p<>nil then begin TMethod(m).Code := p; TMethod(m).Data := Self; m(Sender); end else raise Exception.CreateFmt('Procedure %s not exists',[s]); end; 相關參考資料: http://delphi.ktop.com.tw/topic.php?TOPIC_ID=39987 http://www.delphipraxis.net/post87477.html ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#37 引用回覆回覆發表時間：2003-11-27 19:23:02 IP:192.168.xxx.xxx 未訂閱【文章】使用OLE，在EXCEL中自動產生圖表、背景，並設定保護模式【作者】wivern 【內文】文章來源:http://delphi.ktop.com.tw/topic.php?topic_id=40545 之前在站上看了許多使用 OLE 來制作 Excel的文章，大部份都是在講如何填入資料，如何設定欄位的格式等，小弟因工作需要，必須在excel中產生圖表，在網路上找了許多資料，也有了一些心得，就在此拋磚引玉，提供一些小弟個人的心得，因為站上很多如何填資料的文章，所以小弟就省略這一部份，假設網友們已經填好資料，直接進入要產生圖表的部份， //一開始先定義OLE會用到的變數，建立excel的物件 Variant Excel,Workbooks,Workbook,Charts,Chart,Range; Excel=CreateOleObject("Excel.Application"); Excel.OlePropertySet("Visible",true); //秀出Excel的畫面 Workbooks=Excel.OlePropertyGet("Workbooks"); Workbook=Workbooks.OleFunction("Add"); Worksheets=Workbook.OlePropertyGet("Worksheets"); Worksheet=Worksheets.OleFunction("Add"); // 新增一worksheet Worksheet.OlePropertySet("Name","test") ;// 設定worksheet 的名稱 //取得Charts的物件 Charts=Workbook.OlePropertyGet("Charts"); . . . 先把所需資料填入cell中 . . //建立一個新的圖表，這時圖表會開在一個新的sheet裡，而整個sheet就是一個圖表 //之後會把圖表放在其他的sheet裡 Chart=Charts.OleFunction("Add"); //設定圖表的格式，65是表示含有資料標記的折線圖，後面會有圖表格式的說明 Chart.OlePropertySet("ChartType",65); //選定要製作圖表的資料來源，這個例子我是要選擇excel中從cell(1,1)到cell(10,5)的資料， //此動作就好像用滑鼠把這一部份的欄位選起來一樣 Range=Worksheet.OlePropertyGet("Range", Worksheet.OlePropertyGet("Cells",1,1), Worksheet.OlePropertyGet("Cells",10,5)); //設定圖表的資料來源，xlRows表示資料是以列來做排列，如果資料是用行來排列，就用xlColumns， //如果是用xlRows，選取範圍的第一列就是x軸每一筆資料的名稱， //第一行是y軸資料的名稱，其餘的就是圖表裡的數值 Chart.OleProcedure("SetSourceData",Range,xlRows); //設定圖表的title Chart.OlePropertySet("HasTitle",(Variant)true); //先設定圖表有title String Charttitle="test chart!!"; Chart.OlePropertyGet("ChartTitle").OlePropertySet("Text",Charttitle.c_str()); //設定圖表x軸和y軸是否要秀出title和資料名稱 Chart.OlePropertyGet("Axes",1).OlePropertySet("HasTitle",(Variant)true); //設定x軸是否要顯示資料名稱 Chart.OlePropertyGet("Axes",1).OlePropertyGet("AxisTitle").OlePropertySet("Text","時間");//設定x軸的title Chart.OlePropertyGet("Axes",2).OlePropertySet("HasTitle",(Variant)true); //設定y軸是否要顯示資料名稱 Chart.OlePropertyGet("Axes",2).OlePropertyGet("AxisTitle").OlePropertySet("Text","次數");//設定y軸的title //設定圖表要放在哪一個sheet裡 Chart.OleProcedure("Location",2,Worksheet.OlePropertyGet("Name")); //設定圖表的位置與長寬， //Worksheet.OlePropertyGet("ChartObjects",1)表示是要設定這個sheet中第一個圖表， //如要設定第二個圖表就用Worksheet.OlePropertyGet("ChartObjects",2)， //圖表的順序依在sheet中產生或放置的先後排列 Worksheet.OlePropertyGet("ChartObjects",1).OlePropertySet("Top",15); Worksheet.OlePropertyGet("ChartObjects",1).OlePropertySet("Left",20); Worksheet.OlePropertyGet("ChartObjects",1).OlePropertyGet("Width",50); Worksheet.OlePropertyGet("ChartObjects",1).OlePropertyGet("Height",30); //此時圖表已經漂漂亮亮的在sheet中囉! 底下列出圖表格式常數的定義: typedef enum XlChartType { xlColumnClustered = 51, xlColumnStacked = 52, xlColumnStacked100 = 53, xl3DColumnClustered = 54, xl3DColumnStacked = 55, xl3DColumnStacked100 = 56, xlBarClustered = 57, xlBarStacked = 58, xlBarStacked100 = 59, xl3DBarClustered = 60, xl3DBarStacked = 61, xl3DBarStacked100 = 62, xlLineStacked = 63, xlLineStacked100 = 64, xlLineMarkers = 65, xlLineMarkersStacked = 66, xlLineMarkersStacked100 = 67, xlPieOfPie = 68, xlPieExploded = 69, xl3DPieExploded = 70, xlBarOfPie = 71, xlXYScatterSmooth = 72, xlXYScatterSmoothNoMarkers = 73, xlXYScatterLines = 74, xlXYScatterLinesNoMarkers = 75, xlAreaStacked = 76, xlAreaStacked100 = 77, xl3DAreaStacked = 78, xl3DAreaStacked100 = 79, xlDoughnutExploded = 80, xlRadarMarkers = 81, xlRadarFilled = 82, xlSurface = 83, xlSurfaceWireframe = 84, xlSurfaceTopView = 85, xlSurfaceTopViewWireframe = 86, xlBubble = 15, xlBubble3DEffect = 87, xlStockHLC = 88, xlStockOHLC = 89, xlStockVHLC = 90, xlStockVOHLC = 91, xlCylinderColClustered = 92, xlCylinderColStacked = 93, xlCylinderColStacked100 = 94, xlCylinderBarClustered = 95, xlCylinderBarStacked = 96, xlCylinderBarStacked100 = 97, xlCylinderCol = 98, xlConeColClustered = 99, xlConeColStacked = 100, xlConeColStacked100 = 101, xlConeBarClustered = 102, xlConeBarStacked = 103, xlConeBarStacked100 = 104, xlConeCol = 105, xlPyramidColClustered = 106, xlPyramidColStacked = 107, xlPyramidColStacked100 = 108, xlPyramidBarClustered = 109, xlPyramidBarStacked = 110, xlPyramidBarStacked100 = 111, xlPyramidCol = 112, xl3DColumn = 0xFFFFEFFC, xlLine = 4, xl3DLine = 0xFFFFEFFB, xl3DPie = 0xFFFFEFFA, xlPie = 5, xlXYScatter = 0xFFFFEFB7, xl3DArea = 0xFFFFEFFE, xlArea = 1, xlDoughnut = 0xFFFFEFE8, xlRadar = 0xFFFFEFC9 } XlChartType; 小弟嘗試的結果，列出部份常數的意思，其餘的就看有沒有人補充囉! 5:2D的圓形圖(Pie圖) 16:泡泡圖 51:2D的直條圖 52:2D的堆疊直條圖 53:2D的100%堆疊直條圖 54:3D的直條圖 55:3D的堆疊直條圖 56:3D的100%堆疊直條圖 57:2D的橫條圖 58:2D的堆疊橫條圖 59:2D的100%堆疊橫條圖 60:3D的橫條圖 61:3D的堆疊橫條圖 62:3D的100%堆疊橫條圖 63:折線圖 65:含有資料標誌的折線圖接下來設定EXCEL的背景圖案 String BmpPath; BmpPath="C:\\background.bmp"; if(FileExists(BmpPath)) Worksheet.OleFunction("SetBackgroundPicture",BmpPath.c_str()); 保護sheet Worksheet.OleFunction("Protect","password",true,true,true,true) ; Protect函式的定義如下: template HRESULT /[VT_HRESULT:0]/ __fastcall _WorksheetDispT::Protect(VARIANT Password/[in,opt]/, VARIANT DrawingObjects/[in,opt]/, VARIANT Contents/[in,opt]/, VARIANT Scenarios/[in,opt]/, VARIANT UserInterfaceOnly/[in,opt]/) { _TDispID _dispid(this, OLETEXT("Protect"), DISPID(282)); TAutoArgs<5> _args; _args[1] = Password /[VT_VARIANT:0]/; _args[2] = DrawingObjects /[VT_VARIANT:0]/; _args[3] = Contents /[VT_VARIANT:0]/; _args[4] = Scenarios /[VT_VARIANT:0]/; _args[5] = UserInterfaceOnly /[VT_VARIANT:0]*/; return OleFunction(_dispid, _args); } 共有五個參數，第一個是解開保護的Password，第二個是設定是否要保護sheet上面的 DrawingObjects，像是圖表第三個是設定是否要保護sheet的Contents，設true的話，使用者不能修改sheet的內容第四個和第五個是設定是否要保護sheet的Scenarios和UserInterfaceOnly，不過我不是很清這兩個是保護什麼! Worksheet.OlePropertySet("EnableSelection",xlUnlockedCells); 這是要保護使用者連選取cell都不可以，不過我發現這個保護只能在用OLE製作EXCEL時有效，如果製作完，把EXCEL關掉，再打開，就又可以選取cell了，可能有什麼步驟沒做好吧~ ----------------------------------------------------- 有一點很重要，程式中用到的那些常數，像是xlRows、xlcolumns、xlUnlockedCells等，還有各種圖表格式的定義，以及OLE所提供的所有函數名稱，都是定義在excel_2k.h這個標頭檔裡，所以程式前面要加上 #include 要不然執行時會出現沒有定義變數這個錯誤，我很多功能都是看這個標頭檔學來的，如果想進一步了解OLE 製作Excel還有哪裡功能，可以試著看看這個檔，不過不容易看~我知道! 像是如果想看>"這個字串，就可以找到 class="code"> typedef enum Constants { xlAll = 0xFFFFEFF8, xlAutomatic = 0xFFFFEFF7, xlBoth = 1, xlCenter = 0xFFFFEFF4, xlChecker = 9, xlCircle = 8, xlCorner = 2, xlCrissCross = 16, xlCross = 4, xlDiamond = 2, xlDistributed = 0xFFFFEFEB, xlDoubleAccounting = 5, xlFixedValue = 1, xlFormats = 0xFFFFEFE6, xlGray16 = 17, xlGray8 = 18, xlGrid = 15, xlHigh = 0xFFFFEFE1, xlInside = 2, xlJustify = 0xFFFFEFDE, xlLightDown = 13, xlLightHorizontal = 11, xlLightUp = 14, xlLightVertical = 12, xlLow = 0xFFFFEFDA, xlManual = 0xFFFFEFD9, xlMinusValues = 3, xlModule = 0xFFFFEFD3, xlNextToAxis = 4, xlNone = 0xFFFFEFD2, xlNotes = 0xFFFFEFD0, xlOff = 0xFFFFEFCE, xlOn = 1, xlPercent = 2, xlPlus = 9, xlPlusValues = 2, xlSemiGray75 = 10, xlShowLabel = 4, xlShowLabelAndPercent = 5, xlShowPercent = 3, xlShowValue = 2, xlSimple = 0xFFFFEFC6, xlSingle = 2, xlSingleAccounting = 4, xlSolid = 1, xlSquare = 1, xlStar = 5, xlStError = 4, xlToolbarButton = 2, xlTriangle = 3, xlGray25 = 0xFFFFEFE4, xlGray50 = 0xFFFFEFE3, xlGray75 = 0xFFFFEFE2, xlBottom = 0xFFFFEFF5, xlLeft = 0xFFFFEFDD, xlRight = 0xFFFFEFC8, xlTop = 0xFFFFEFC0, xl3DBar = 0xFFFFEFFD, xl3DSurface = 0xFFFFEFF9, xlBar = 2, xlColumn = 3, xlCombination = 0xFFFFEFF1, xlCustom = 0xFFFFEFEE, xlDefaultAutoFormat = 0xFFFFFFFF, xlMaximum = 2, xlMinimum = 4, xlOpaque = 3, xlTransparent = 2, xlBidi = 0xFFFFEC78, xlLatin = 0xFFFFEC77, xlContext = 0xFFFFEC76, xlLTR = 0xFFFFEC75, xlRTL = 0xFFFFEC74, xlFullScript = 1, xlPartialScript = 2, xlMixedScript = 3, xlMixedAuthorizedScript = 4, xlVisualCursor = 2, xlLogicalCursor = 1, xlSystem = 1, xlPartial = 3, xlHindiNumerals = 3, xlBidiCalendar = 3, xlGregorian = 2, xlComplete = 4, xlScale = 3, xlClosed = 3, xlColor1 = 7, xlColor2 = 8, xlColor3 = 9, xlConstants = 2, xlContents = 2, xlBelow = 1, xlCascade = 7, xlCenterAcrossSelection = 7, xlChart4 = 2, xlChartSeries = 17, xlChartShort = 6, xlChartTitles = 18, xlClassic1 = 1, xlClassic2 = 2, xlClassic3 = 3, xl3DEffects1 = 13, xl3DEffects2 = 14, xlAbove = 0, xlAccounting1 = 4, xlAccounting2 = 5, xlAccounting3 = 6, xlAccounting4 = 17, xlAdd = 2, xlDebugCodePane = 13, xlDesktop = 9, xlDirect = 1, xlDivide = 5, xlDoubleClosed = 5, xlDoubleOpen = 4, xlDoubleQuote = 1, xlEntireChart = 20, xlExcelMenus = 1, xlExtended = 3, xlFill = 5, xlFirst = 0, xlFloating = 5, xlFormula = 5, xlGeneral = 1, xlGridline = 22, xlIcons = 1, xlImmediatePane = 12, xlInteger = 2, xlLast = 1, xlLastCell = 11, xlList1 = 10, xlList2 = 11, xlList3 = 12, xlLocalFormat1 = 15, xlLocalFormat2 = 16, xlLong = 3, xlLotusHelp = 2, xlMacrosheetCell = 7, xlMixed = 2, xlMultiply = 4, xlNarrow = 1, xlNoDocuments = 3, xlOpen = 2, xlOutside = 3, xlReference = 4, xlSemiautomatic = 2, xlShort = 1, xlSingleQuote = 2, xlStrict = 2, xlSubtract = 3, xlTextBox = 16, xlTiled = 1, xlTitleBar = 8, xlToolbar = 1, xlVisible = 12, xlWatchPane = 11, xlWide = 3, xlWorkbookTab = 6, xlWorksheet4 = 1, xlWorksheetCell = 3, xlWorksheetShort = 5, xlAllExceptBorders = 6, xlLeftToRight = 2, xlTopToBottom = 1, xlVeryHidden = 2, xlDrawingObject = 14 } Constants; typedef enum XlBorderWeight { xlHairline = 1, xlMedium = 0xFFFFEFD6, xlThick = 4, xlThin = 2 } XlBorderWeight; typedef enum XlLineStyle { xlContinuous = 1, xlDash = 0xFFFFEFED, xlDashDot = 4, xlDashDotDot = 5, xlDot = 0xFFFFEFEA, xlDouble = 0xFFFFEFE9, xlSlantDashDot = 13, xlLineStyleNone = 0xFFFFEFD2 } XlLineStyle; typedef enum XlEditionOptionsOption { xlAutomaticUpdate = 4, xlCancel = 1, xlChangeAttributes = 6, xlManualUpdate = 5, xlOpenSource = 3, xlSelect = 3, xlSendPublisher = 2, xlUpdateSubscriber = 2 } XlEditionOptionsOption; typedef enum XlChartType { xlColumnClustered = 51, xlColumnStacked = 52, xlColumnStacked100 = 53, xl3DColumnClustered = 54, xl3DColumnStacked = 55, xl3DColumnStacked100 = 56, xlBarClustered = 57, xlBarStacked = 58, xlBarStacked100 = 59, xl3DBarClustered = 60, xl3DBarStacked = 61, xl3DBarStacked100 = 62, xlLineStacked = 63, xlLineStacked100 = 64, xlLineMarkers = 65, xlLineMarkersStacked = 66, xlLineMarkersStacked100 = 67, xlPieOfPie = 68, xlPieExploded = 69, xl3DPieExploded = 70, xlBarOfPie = 71, xlXYScatterSmooth = 72, xlXYScatterSmoothNoMarkers = 73, xlXYScatterLines = 74, xlXYScatterLinesNoMarkers = 75, xlAreaStacked = 76, xlAreaStacked100 = 77, xl3DAreaStacked = 78, xl3DAreaStacked100 = 79, xlDoughnutExploded = 80, xlRadarMarkers = 81, xlRadarFilled = 82, xlSurface = 83, xlSurfaceWireframe = 84, xlSurfaceTopView = 85, xlSurfaceTopViewWireframe = 86, xlBubble = 15, xlBubble3DEffect = 87, xlStockHLC = 88, xlStockOHLC = 89, xlStockVHLC = 90, xlStockVOHLC = 91, xlCylinderColClustered = 92, xlCylinderColStacked = 93, xlCylinderColStacked100 = 94, xlCylinderBarClustered = 95, xlCylinderBarStacked = 96, xlCylinderBarStacked100 = 97, xlCylinderCol = 98, xlConeColClustered = 99, xlConeColStacked = 100, xlConeColStacked100 = 101, xlConeBarClustered = 102, xlConeBarStacked = 103, xlConeBarStacked100 = 104, xlConeCol = 105, xlPyramidColClustered = 106, xlPyramidColStacked = 107, xlPyramidColStacked100 = 108, xlPyramidBarClustered = 109, xlPyramidBarStacked = 110, xlPyramidBarStacked100 = 111, xlPyramidCol = 112, xl3DColumn = 0xFFFFEFFC, xlLine = 4, xl3DLine = 0xFFFFEFFB, xl3DPie = 0xFFFFEFFA, xlPie = 5, xlXYScatter = 0xFFFFEFB7, xl3DArea = 0xFFFFEFFE, xlArea = 1, xlDoughnut = 0xFFFFEFE8, xlRadar = 0xFFFFEFC9 } XlChartType; typedef enum XlChartItem { xlDataLabel = 0, xlChartArea = 2, xlSeries = 3, xlChartTitle = 4, xlWalls = 5, xlCorners = 6, xlDataTable = 7, xlTrendline = 8, xlErrorBars = 9, xlXErrorBars = 10, xlYErrorBars = 11, xlLegendEntry = 12, xlLegendKey = 13, xlShape = 14, xlMajorGridlines = 15, xlMinorGridlines = 16, xlAxisTitle = 17, xlUpBars = 18, xlPlotArea = 19, xlDownBars = 20, xlAxis = 21, xlSeriesLines = 22, xlFloor = 23, xlLegend = 24, xlHiLoLines = 25, xlDropLines = 26, xlRadarAxisLabels = 27, xlNothing = 28, xlLeaderLines = 29, xlDisplayUnitLabel = 30, xlPivotChartFieldButton = 31, xlPivotChartDropZone = 32 } XlChartItem; typedef enum XlRowCol { xlColumns = 2, xlRows = 1 } XlRowCol; typedef enum XlEnableSelection { xlNoRestrictions = 0, xlUnlockedCells = 1, xlNoSelection = 0xFFFFEFD2 } XlEnableSelection; typedef enum XlOrientation { xlDownward = 0xFFFFEFB6, xlHorizontal = 0xFFFFEFE0, xlUpward = 0xFFFFEFB5, xlVertical = 0xFFFFEFBA } XlOrientation; 這樣就可以用這些常數了，像是設定圖表格式時，可以用xlLineMarkers來取代65~ 如果不include也可以，就用數字來代替常數，像是xlRows就是1，xlColumns是2，xlUnlockedCells是1等等 Borland除了excel_2k.h這個檔之外，還有excel_97.h，excel_xp.h這些檔，不過這些有哪些功能不一樣我就不清楚了! ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#38 引用回覆回覆發表時間：2003-11-27 19:25:47 IP:192.168.xxx.xxx 未訂閱【文章】如何讓DBGrid按滑鼠右鍵的時候不會影響RowSelect ? 【作者】Justmade 【內文】文章來源:http://delphi.ktop.com.tw/topic.php?topic_id=33637 不用另外繼承，試試將以下程式碼替代 http://delphi.ktop.com.tw/topic.php?TOPIC_ID=33719 範例的程式碼 unit CDSMDForm; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, shellapi, StdCtrls, Grids, DBGrids, DB, DBTables, DBCtrls, DBClient, Provider, jpeg, ExtCtrls; type TDBGrid= class(DBGrids.TDBGrid) protected Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; end; TForm1 = class(TForm) DataSource1: TDataSource; DBGrid1: TDBGrid; DataSource2: TDataSource; DataSetProvider1: TDataSetProvider; DataSetProvider2: TDataSetProvider; Query1: TQuery; Query2: TQuery; ClientDataSet1: TClientDataSet; ClientDataSet2: TClientDataSet; DBGrid2: TDBGrid; procedure DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); const // 這個整數值將按照布林值返回，並送入陣列 CtrlState : array[Boolean] of Integer=(DFCS_BUTTONCHECK,DFCS_BUTTONCHECK or DFCS_CHECKED); begin //確保只有在邏輯欄位才能插入元件 if Column.Field.DataType = ftBoolean then begin DBGrid1.Canvas.FillRect(Rect); DrawFrameControl(DBGrid1.Canvas.Handle,Rect,DFC_BUTTON,CtrlState[Column.Field.AsBoolean]); end; end; { TDBGrid } procedure TDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button <> mbRight then inherited; end; end. 並將 DBGrid1 的 poMultiSelect 設 True 便可見右按不會影響 selection 了另你可換一個有 Boolean Field 的 Table 也可看到不會出現格線不見的情形。其實看你的多個問題覺得你好像不是用標準的 DBGrid,若時的話你應說清楚免得大家在浪費時間。另你若間題還不能解決你最好做一個簡單的程式包含你的數個間題然後上傳，這樣會比較清楚。 ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#39 引用回覆回覆發表時間：2003-11-27 19:28:00 IP:192.168.xxx.xxx 未訂閱【文章】如何判斷TrayIcon的程式是否正在執行? 【作者】Rain 【內文】文章來源:http://delphi.ktop.com.tw/topic.php?topic_id=33946 使用GetModuleFileNameEx即可取得進程路徑( 記得要uses PSAPI單元)，如果你的那個應用程式名稱是知道的，則可以不用FindWindow或EnumWindows，在下面的程式中用if StrPas(ProcessEntry32.szExeFile) = 'yourAppName.exe'替代 if ProcessEntry32.th32ProcessID = AProcessID語句即可給出完整的程式如下： uses tlhelp32, ShellAPI, PSAPI; procedure TForm1.Button1Click(Sender: TObject); var Found: Boolean; AProcessID: DWORD; AWnd, AHandle: THandle; ProcessEntry32: TProcessEntry32; APath: array [0..MAX_PATH] of Char; begin AWnd := FindWindow('TMainForm', nil); if AWnd = 0 then Exit; GetWindowThreadProcessId(AWnd, @AProcessID); AHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); try ProcessEntry32.dwSize := Sizeof(ProcessEntry32); Found := Process32First(AHandle, ProcessEntry32); while Found do begin //if StrPas(ProcessEntry32.szExeFile) = ' yourAppName.exe' then ; if ProcessEntry32.th32ProcessID = AProcessID then begin GetModuleFileNameEx(OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessEntry32.th32ProcessID), 0, @APath[0], SizeOf(APath));//取得進程路徑 TerminateProcess(OpenProcess(PROCESS_ALL_ACCESS, True, ProcessEntry32.th32ProcessID), 0);//結束進程 ShellExecute(Handle, 'open', APath, nil, nil, SW_SHOW);//重新運行程式 //Break; end; Found := Process32Next(AHandle, ProcessEntry32); end; finally CloseHandle(AHandle); end; end; ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#40 引用回覆回覆發表時間：2003-11-27 19:30:38 IP:192.168.xxx.xxx 未訂閱【文章】在image中如何放大缩小jpg文件? 【作者】sos_admin 【內文】文章來源:http://delphi.ktop.com.tw/topic.php?topic_id=38057 1. unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, ExtCtrls,jpeg; type TForm1 = class(TForm) Image1: TImage; BitBtn1: TBitBtn; procedure FormCreate(Sender: TObject); procedure BitBtn1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; jpgw,jpgh:integer; implementation {$R .dfm} procedure TForm1.FormCreate(Sender: TObject); var jpg:Tjpegimage; begin jpg:=Tjpegimage.Create; jpg.LoadFromFile('c:\1.jpg'); jpgw:=jpg.Width ; jpgh:=jpg.Height ; image1.Width:=jpgw; image1.Height :=jpgh; image1.Picture.Assign(jpg); image1.Stretch:=true; image1.AutoSize:=false; jpg.Free ; end; //i为正数放大，反之缩小 procedure imagesize(image:Timage;i:integer); begin if i>0 then begin image.Width:=jpgwi ; image.Height:=jpgh*i ; end; if i<0 then begin image.Width:=jpgw div abs(i) ; image.Height:=jpgh div abs(-i) ; end; end; procedure TForm1.BitBtn1Click(Sender: TObject); begin //在原图基础上缩小为原图的1/10 imagesize(image1,-10); end; end. 2. 看下面的方法： //无损调整 > src="http://delphi.ktop.com.tw/loadfile.php?TOPICID=11955987&CC=267393"> ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#41 引用回覆回覆發表時間：2003-12-04 20:24:28 IP:192.168.xxx.xxx 未訂閱【文章】如何防止程式重覆執行? 【作者】axsoft / jessechan 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=36333 1.程式碼下載:http://delphi.ktop.com.tw/loadfile.php?TOPICID=11492747&CC=257033 //--------------------------------------------------------------------------- // 程式名稱: CreateMutexDemo.cpp // 作者: axsoft // 執行環境: windows XP SPS C Builder 5 Update1 //--------------------------------------------------------------------------- #include #pragma hdrstop USERES("Project1.res"); USEFORM("Unit1.cpp", Form1); //--------------------------------------------------------------------------- WINAPI WinMain(HINSTANCE, HINSTANCE, LPSTR, int) { HANDLE mutexhandle=CreateMutex(NULL,false,"我的應用程式"); if((mutexhandle!=NULL) && (GetLastError()== ERROR_ALREADY_EXISTS)) { Application->MessageBox("程式重複起動","確認",MB_ICONSTOP); CloseHandle(mutexhandle); return -1; } try { Application->Initialize(); Application->CreateForm(__classid(TForm1), &Form1); Application->Run(); } catch (Exception &exception) { Application->ShowException(&exception); } if(mutexhandle!=NULL) CloseHandle(mutexhandle); return 0; } //--------------------------------------------------------------------------- 2. 如何寫一個Windows應用程式，讓他只執行一次。 -------------------------------------------------------------------------------- 作者:szu (michael liang) 資料來源:高市資教-陽光之都 BBS http://bbs.kh.edu.tw/treasure/Programs/M.991654847.A/M.995983133.A.html 第一種方法(利用FindWindow()): 環境 C Builder Application->Title = ""; HWND hPrevApp = ::FindWindow(NULL, "Title"); //或是寫成HWND hPrevApp = ::FindWindow("Class", NULL); //或是寫成HWND hPrevApp = ::FindWindow("Class", "Title"); if(hPrevApp) { PostMessage(hPrevApp, WM_SYSCOMMAND, SC_RESTORE, 0); return 0; } else { Application->Title = "Title"; } ------------------------------------------------------------------------- 第二種方法(利用FindWindow()): if(FindWindow(NULL, 應用程式的Title)) { return 0; } ------------------------------------------------------------------------- 第三種方法(利用Global Atom Table): ATOM atom; if(GlobalFindAtom("PROGRAM_RUNNING") == 0) { atom = GlobalAddAtom("PROGRAM_RUNNING"); } else { return 0; } 在程式最後請加上 GlobalDeleteAtom(atom); ------------------------------------------------------------------------ 第四種方法(利用Mutex): HANDLE handle = CreateMutex(NULL, false, "MutexName"); DWORD error = GetLastError(); if(error == ERROR_ALREADY_EXISTS ) { return 0; } 記得在程式最後面加入 ReleaseMutex(handle); ------------------------------------------------------------------------ 第五種方法(利用Semaphore): HANDLE handle = CreateSemaphore(NULL, 1, 1, "SemaphoreName"); DWORD error = GetLastError(); if(error == ERROR_ALREADY_EXISTS ) { return 0; } 記得在程式最後面加入 ReleaseSemaphore(handle, 1, NULL); -------------------------------------------------------------------- 以上程式受到智慧財產權的保護， permission to use, copy, modify, and distribute. 但請註明來源出處，不可用於商業用途。 -------------------------------------------------------------------- 3. 我想這個問題已被討論很多次了, 我也曾在這個版上提出同樣的問題, 下面是我找了一些資料加上 RaynorPao 等熱心人士的指點, 所整理的一個心得. 要防止程式重複執行, 在 VB 中的 App 中有一個 preInstance 可以輕易得知目前的程式是否為第一個 instance, 不幸在 BCB 中卻沒有類似的機制, 不過我們可用 CreateMutex 的方法來測試同樣的 Mutex Object 是否已被 create 來確保程式是第一次執行, 其宣告如下, HANDLE CreateMutex( LPSECURITY_ATTRIBUTES lpMutexAttributes, BOOL bInitialOwner, LPCTSTR lpName ); 詳細用法請參考 BCB 的 help 或 MSDN, 這裡我想要提出來的是一般大家在用這個 API 時 lpName 經常使用任意取的名字, 或是直接用 Form 的 Caption, 這樣固然方便但是不能確保名字是唯一, 每次都要想不同的名字又太累, 所以我建議可以做個小修改, AnsiString asTemp00 = (long)(GetWindowLong(Application->Handle,GWL_HINSTANCE)); CreateMutex(NULL,false,asTemp00.c_str()); if (GetLastError() == ERROR_ALREADY_EXISTS) Application->Terminate(); 以程式的 Instance Handle 來個名稱就萬無一失了, 有一點要注意的是在程式結束時要記得 ReleaseMutex(). 另外不知有沒有人想要做到如果之前已有一個 Instance 在執行的話, 就先把之前的程式結束掉, 以後者取代之. 因為如果用 FindWindow 想要去取得前一個程式的 Handle 的話, 找到的總會是自己, 所以必須另找方法, 我所想到的方法是在程式執行時先以 Instance 為 key 把自己的 Handle 存起來, 如此第二個程式在執行時發現已有自己的同類在執行就去讀取它的 Handle, 而對它送出 WM_CLOSE 的 message, 實作如下, #include #include #pragma hdrstop #include "Unit1.h" //--------------------------------------------------------------------------- #pragma package(smart_init) #pragma resource ".dfm" TForm1 Form1; HWND hMutex; //--------------------------------------------------------------------------- __fastcall TForm1::TForm1(TComponent* Owner) : TForm(Owner) { TRegistry * rgpSystem = new TRegistry;; Caption = Now(); AnsiString asTemp00 = (long)(GetWindowLong(Application->Handle,GWL_HINSTANCE)); rgpSystem->OpenKey(asTemp00,true); CreateMutex(NULL,false,asTemp00.c_str()); if (GetLastError() == ERROR_ALREADY_EXISTS) SendMessage((HWND)rgpSystem->ReadInteger("Handle"),WM_CLOSE,NULL,NULL); rgpSystem->WriteInteger("Handle",(int)(this->Handle)); rgpSystem->CloseKey(); delete rgpSystem; } //--------------------------------------------------------------------------- void __fastcall TForm1::FormClose(TObject *Sender, TCloseAction &Action) { ReleaseMutex(hMutex); } //--------------------------------------------------------------------------- 這些 code 沒有用到什麼高深的理論, 可是我想還算實用, 野人獻曝, 謹供大家參考. 參考網址:http://delphi.ktop.com.tw/topic.php?topic_id=24297 http://delphi.ktop.com.tw/topic.php?topic_id=24350 ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#42 引用回覆回覆發表時間：2003-12-04 20:28:53 IP:192.168.xxx.xxx 未訂閱【文章】如何將寫好的Form快速轉成一個元件? 【作者】bruce0211 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=40137 我發現使用 Form 為 base 的元件可能是所有元件設計中最簡單的方式(因為設計核心時是在一般專案中設計並測試,且可放入任何你想要的元件,如果不是以 Form 為 base 的元件,光想想我們要設計將兩個元件聚合成為一個新元件就已經多不直多困難) 1.設計帶有 Form 的元件,如萬年曆,獨立的對話盒等等,通常這種類型的元件在 user 主 form 中是一不可視元件,也就是插到 Delphi 中只是一個 ICON 而已 (如標準的檔案開啟對話盒元件 TOpenDialog) ,需要用時再利用 if OpenDialog1.Execute then ... 這種方式去呼叫 2.由於這類元件不需在主畫面佔據位置,而是被獨立呼叫(就像是 ShowModal),所以設計元件時可以一般方法設計(可放入許多及任何元件的組合在裡面),如我要設計萬年曆,先用一般方式開一 Project1 專案,以及萬年曆的 unit1.pas & unit1.dfm , 將萬年曆內容寫好,並可 compiler 測試 ok (叫做 project1.exe),我們便可丟掉 project1.* 的檔案,只留下 unit1.pas 及 unit1.dfm 這兩個萬年曆的核心 3.開始設計元件,元件類別繼承自 TComponent , 也就是拿 TComponent 當藥引子,替 TComponent 增加一個公開的方法 "Execute" , 以及 Date 屬性 , 執行 Execute 時, TComponent 實際上是去呼叫完整的萬年曆程式,再將日期回傳以下為 TMyCalendar 的元件內容 , 可以看出萬年曆程式碼並未寫在裡面,而是另外呼叫 MyCalendarSource.pas (也就是上面舉例的 Unit1.pas) , 而MyCalendarSource.pas 之 Form 名稱叫 FormMyCalendar (也就是上面舉例的 Unit1.dfm) , 整個TMyCalendar 只是當作藥引子 , 實際上萬年曆的程式碼是寫在 MyCalendarSource.pas 中的其他類似的元件也可依樣畫葫蘆,先用一般方法設計專案設計 Form,測試 OK 後 , 留下 Form 這個部分的程式碼,再套到這個藥引子中 unit MyCalendar; interface uses SysUtils, Classes, Forms, MyCalendarSource; type TMyCalendar = class(TComponent) private { Private declarations } FDate: TDateTime; FRocYear: string; FRocMonth: string; FRocDay:string; procedure DateToRoc(ADate:TDateTime); protected { Protected declarations } public { Public declarations } constructor Create(AOwner : TComponent); override; destructor Destroy; override; function Execute: boolean; overload;//本元件公開的方法 function Execute(ALeft,ATop: integer): boolean; overload; ;//本元件公開的方法(可指定萬年曆出現的座標位置,復疊函式) published { Published declarations } property Date:TDateTime read FDate; //本元件公開的屬性,日期 property RocYear:string read FRocYear; //本元件公開的屬性,民國年 property RocMonth:string read FRocMonth; //本元件公開的屬性,民國月 property RocDay:string read FRocDay;//本元件公開的屬性,民國日 end; procedure Register; implementation constructor TMyCalendar.Create(AOwner : TComponent); begin inherited Create(AOwner); FDate := SysUtils.Date; DateToRoc(FDate); end; destructor TMyCalendar.Destroy; begin inherited Destroy; end; function TMyCalendar.Execute: boolean; var r:integer; begin FormMyCalendar:=TFormMyCalendar.Create(nil); try r:=FormMyCalendar.ShowModal; if r=1 then //mrOK; begin FDate:=FormMyCalendar.SelectDate; DateToRoc(FDate); result:=true; end else result:=false; finally FormMyCalendar.Release; end; end; function TMyCalendar.Execute(ALeft,ATop: integer): boolean; var r:integer; begin FormMyCalendar:=TFormMyCalendar.Create(nil); FormMyCalendar.Position:=poDesigned; FormMyCalendar.Top:=ATop; FormMyCalendar.Left:=ALeft; try r:=FormMyCalendar.ShowModal; if r=1 then //mrOK; begin FDate:=FormMyCalendar.SelectDate; result:=true; end else result:=false; finally FormMyCalendar.Release; end; end; procedure TMyCalendar.DateToRoc(ADate:TDateTime); var TmpYear, TmpMonth, TmpDay : Word; begin DecodeDate(ADate, TmpYear, TmpMonth, TmpDay); FRocYear:=FormatFloat('00',TmpYear-1911); FRocMonth:=FormatFloat('00',TmpMonth); FRocDay:=FormatFloat('00',TmpDay); end; procedure Register; begin RegisterComponents('MyWay', [TMyCalendar]); end; end. ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#43 引用回覆回覆發表時間：2003-12-04 20:34:54 IP:192.168.xxx.xxx 未訂閱【文章】如何使滑鼠的中間滾輪在DBGrid中可以滾動資料? 【作者】mathewzhao / pwq 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=40777 1. 本人已經解決此問題,現在方法貼出如下: Type TDBGrid = class(TDBGrid) private FOldGridWnd : TWndMethod; procedure NewGridWnd (var Message : TMessage); public constructor Create(AOwner: TComponent); override; end; //////////////////////////////////////////紅色部分代友需放在以下代碼前 TMDFMainForm = class(TForm) ...... end; implementation {$R .dfm} constructor TNDBGrid.Create(AOwner: TComponent); begin inherited; FOldGridWnd := WindowProc; WindowProc := NewGridWnd; end; procedure TDBGrid.NewGridWnd(var Message: TMessage); var IsNeg : Boolean; begin if Message.Msg = WM_MOUSEWHEEL then begin IsNeg := Short(Message.WParamHi) < 0; if IsNeg and (DataSource.DataSet<>nil) and DataSource.DataSet.Active then DataSource.DataSet.MoveBy(1) else if not IsNeg and (DataSource.DataSet<>nil) and DataSource.DataSet.Active then DataSource.DataSet.MoveBy(-1) end else FOldGridWnd(Message); end; ........ end. 2. 參考一下這篇文章: http://www.yesky.com/SoftChannel/72342371928440832/20030619/1709082.shtml 讓Delphi的DBGrid支持鼠標輪* 劉東榮現在的大多數的鼠標都有鼠標輪,比如,當我們瀏覽網頁時,鼠標輪上下移動,網頁就自動上下滾動。鼠標輪的確給我們的操作帶來很多方便,但是,在Delphi的大多數控件中都只支持 MouseDown,MouseUp,MouseMove等事件,而不直接支持MouseWheel事件,我們在幫助客戶設計一個查看程序時就碰到這樣的問題。這個查看程序的數據是放在一個DBGrid中的,數據比較多,超出整個屏幕,如果用鼠標輪上下移動,則DBGrid的光標只在可見範圍內移動,超出屏幕的數據必須用鍵盤或右側的滾動條,給用戶造成極大不方便,客戶強烈要求支持鼠標輪操作。但是查看DBGrid的事件屬性沒有對鼠標輪的支持,怎麼辦呢？我們知道,Windows操作系統是消息驅動的,因此,如果鼠標輪上下滾動,必然會有相應的事件發生,經過查找資料,我們得知當鼠標輪上下滾動時發生的是WM_MOUSEWHEEL事件,既然這樣,我們如果捕獲這個事件,不就可以處理鼠標輪事件了嗎？說幹就幹,那就讓我們來為DBGrid增加一個OnMouseWheel事件,製作一個支持鼠標輪的新的DBGrid組件。讓我們新建一個應用,就叫MyDBGrid吧,選擇菜單File─New Application,然後再選擇菜單File-New-Component 因為我們的新組件是從DBGrid繼承的,所以,Ancestor Type選擇 TDBGrid,Class Name就填我們的組件名稱TmyDbGrid,生成的組件放在Samples頁,點擊OK,則組件的框架就生成了。現在我們開始做最關鍵的部分。當鼠標輪上下滾動時,發出了WM_MOUSEWHEEL消息,MOUSEWHEEL消息有幾個參數, 1.fwKeys= LOWORD(wParam),表明各種虛擬鍵是否按下,有如下值: 值說明 MK_CONTROL 按下CTRL鍵 MK_LBUTTON 按下鼠標左鍵 MK_MBUTTON 按下鼠標中鍵 MK_RBUTTON 按下鼠標右鍵 MK_SHIFT 按下Shift鍵 2.zDelta = (short) HIWORD(wParam) 鼠標輪滾動的距離,如果向前則為正,向後為負。 3.xPos ＝(short) LOWORD(lParam) yPos＝ (short) HIWORD(lParam) 鼠標的位置。 3. Delphi已經定義了兩個和鼠標輪相關的事件,叫TmouseWheelEvent, TmouseWheelUpDownEvent,分別代表鼠標輪事件和鼠標輪上,下滾動事件。因此,我們先在TmyDbGrid中定義三個私有的事件變量: fMouseWheel:TMouseWheelEvent; fMouseWheelUp:TMouseWheelUpDownEvent; //鼠標輪上滾事件 fMouseWheelDown: TMouseWheelUpDownEvent; //鼠標輪下滾事件然後定義publised中定義事件屬性: property OnMouseWheel:TMouseWheelEvent read fMouseWheel write fMouseWheel; property OnMouseWheelUp:TMouseWheelUpDownEvent read fMouseWheelUp write fMouseWheelUp; property OnMouseWheelDown:TMouseWheelUpDownEvent read fMouseWheelDown write fMouseWheelDown; 然後重載TDBGrid的WndProc函數, procedure WndProc(var Msg: TMessage);override; 我們在WndProc中捕獲鼠標輪的消息,如下: [code] var MousePoint:TPoint; Handled:Boolean; shift:TShiftState; begin if(Msg.Msg=WM_MOUSEWHEEL) then //捕獲鼠標輪事件 begin MousePoint.X:=LOWORD(Msg.lParam); MousePoint.Y:=HIWORD(Msg.lParam); Handled:=false; if(Msg.wParam>0) then //上滾 fMouseWheelUp(self,shift,MousePoint,Handled) else //下滾 fMouseWheelDown(self,shift,MousePoint,Handled); fMouseWheel(self,shift,HIWORD(Msg.wParam),MousePoint,Handled); if Handled then exit; end; inherited; end; 這樣,我們就基本可以處理鼠標輪事件了,編譯我們的組件,然後選擇菜單Components-Inatll Component,將我們的組件安裝在Samples頁下。讓我們來試驗一下我們做的組件,新建一個應用,然後選擇Samples下的MyDBGrid組件,其它的用法,和DBGRrid完全一樣,但你可以看見,在你的MyDbGrid的事件中,已經有OnMouseWheel, OnMouseWheelUp, OnMouseWheelDown的選項了。這樣,你可以在OnMouseWheel, OnMouseWheelUp, OnMouseWheelDown中處理你的動作了,我們也完成了客戶的要求,當客戶移動鼠標輪時,我們在OnMouseWheelUp中加入相應代碼,圓滿解決了客戶的要求。～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#44 引用回覆回覆發表時間：2003-12-04 20:36:26 IP:192.168.xxx.xxx 未訂閱【文章】請問如何得知對方電腦所分享的所有目錄呢? 【作者】japhenchen 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=39584 跑net view \\servername >> nv.txt 或\\ip 就可以顯示對方的共享名稱並且轉向輸出到nv.txt檔~~ 不過，有更好的解決方法 procedure TForm1.Button2Click(Sender: TObject); type TNetResourceArray = ^TNetResource; var NetResource : TNetResource; hr,ecount,BUFSIZE,x: dword; hEnum: THandle; buf : POINTER; ResArray : TNetResourceArray; ResList : TStringList; username: string ; begin username:='\\192.168.1.1'; FillChar(NetResource, SizeOf(NetResource), 0); NetResource.lpRemoteName:=@username[1]; resList:=TStringList.Create; hr:=wnetOpenEnum(RESOURCE_GLOBALNET,RESOURCETYPE_ANY,RESOURCEUSAGE_CONNECTABLE,@NetResource,hEnum); if hr=NO_ERROR then while true do begin BUFSIZE:=8192; GETMEM(BUF,BUFSIZE); ecount := $FFFFFFFF; hr := WNetEnumResource(hEnum,ecount,pointer(buf),bufsize); case hr of ERROR_NO_MORE_ITEMS: break; NO_ERROR : begin ResArray:=TNetResourceArray(buf); for x:= 0 to ecount-1 do begin ResList.Add(ResArray^.lpRemoteName); inc(resArray); end; end; else break; end; end; wnetCloseEnum(hEnum); FreeMem(buf,bufsize); if reslist.count >0 then showmessage(reslist.Text); freeandnil(ResList); end; ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#45 引用回覆回覆發表時間：2003-12-08 13:33:18 IP:211.76.xxx.xxx 未訂閱【文章】如何判斷是否有該磁碟機? 【作者】hagar 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=20772 function HasDrive(DriveLetter: Char): Boolean; var ld : DWORD; i : integer; sl: TStringList; begin ld := GetLogicalDrives; sl := TStringList.Create; try for i := 0 to 25 do begin if (ld and (1 shl i)) <> 0 then sl.Add(Char(Ord('A') i)); end; Result := (sl.IndexOf(DriveLetter) <> -1); finally sl.Free; end; end; 用法: procedure TForm1.Button1Click(Sender: TObject); begin if HasDrive('C') then ShowMessage('Drive C is valid') else ShowMessage('Drive C is invalid'); end; ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#46 引用回覆回覆發表時間：2003-12-09 06:52:39 IP:192.168.xxx.xxx 未訂閱【文章】讀取Windows的TTF字體輪廓向量資料【作者】朱朝陽【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=30747 資料來源: http://www2.ccw.com.cn/2000/0031/0031b12.asp 讀取Windows的 TTF字體輪廓向量資料西安飛機工業公司設計部朱朝陽 ---- Windows系統的TTF字體具有字體優美、可無級縮放等優點，最適合應用在CAD類圖形處理等軟體中。直接分析TTF字體的檔格式並讀出每個字的輪廓向量是相當困難的，我們可以借助API函數來方便地獲得這些資料。 ---- 調用函數GetGlyphOutline可以得到一個字的輪廓向量或者點陣圖。 ---- 函數原型如下： DWORD GetGlyphOutline( HDC hdc, // 設備控制碼 UINT uChar, // 將要讀取的字元 UINT uFormat, // 返回資料的格式 LPGLYPHMETRICS lpgm, // GLYPHMETRICS結構位址 DWORD cbBuffer, // 數據緩衝區的大小 LPVOID lpvBuffer, // 資料緩衝區的位址 CONST MAT2 ＊lpmat2 // 轉置矩陣的地址 ); ---- 其中，參數uFormat取值如下： GGO_NATIVE －要求函數返回字元的輪廓向量資料； GGO_METRICS －函數僅返回GLYPHMETRICS結構至lpgm；參數lpgm指向GLYPHMETRICS結構，該結構描述字元的位置。參數lpmat2指向字元的轉置矩陣。 ---- 本文以下C＋＋ Builder程式示範如何在畫布上以指定的大小繪製字串。 ---- 首先，建立一個新專案，在主視窗上放置一個Image控制項，一個Edit控制項，一個Button控制項；然後，在Button的點擊事件中加入如下代碼：＃include < stdlib.h > void __fastcall TForm1::Button1Click(TObject ＊Sender) { TRect ClipRect = Rect(0,0,Image1－>Width,Image1－>Height); Image1－>Picture = 0; StretchTextRect(Image1－>Canvas, ClipRect, Edit1－>Text); } ---- 添加如下子程式： //－－－－－－－－－－－－－－－－－－－－－ void TForm1::StretchTextRect(TCanvas ＊pCanvas, TRect ClipRect, AnsiString Text) { pCanvas－>Font－>Size = 100; pCanvas－>Font－>Name = “宋體"; pCanvas－>Pen－>Color = clBlack; pCanvas－>Pen－>Mode = pmCopy; pCanvas－>Pen－>Style = psSolid; pCanvas－>Pen－>Width = 1; int XSize = ClipRect.Width() / Text.Length(); int YSize = ClipRect.Height(); MAT2 mat2; // 轉置矩陣，不用變換 mat2.eM11.value = 1;mat2.eM11.fract = 0; mat2.eM12.value = 0;mat2.eM12.fract = 0; mat2.eM21.value = 0;mat2.eM21.fract = 0; mat2.eM22.value = 1;mat2.eM22.fract = 0; GLYPHMETRICS gm,gmm; // 首先獲得字元的位置矩陣，存入gm GetGlyphOutlineA(pCanvas－>Handle,0x0b0a1, GGO_METRICS,＆gm,0,NULL,＆mat2); char ＊ptr = Text.c_str(); TRect TheRect; for(int i = 0;i < Text.Length();) { int c1 = (unsigned char)＊ptr; int c2 = (unsigned char)＊(ptr ＋ 1); UINT nChar; TheRect.Left = i ＊ XSize ＋ ClipRect.Left; TheRect.Top = ClipRect.Top; TheRect.Right = (i ＋ 2) ＊ XSize ＋ ClipRect.Left; TheRect.Bottom = ClipRect.Top ＋ YSize; if(c1 > 127) { // 當前字元是漢字 nChar = c1 ＊ 256 ＋ c2; ptr＋=2;i＋=2; } else { // 字母或數位 nChar = c1; ptr＋＋;i＋＋; } // 獲得當前字元資料的陣列的大小 DWORD cbBuffer = GetGlyphOutlineA(pCanvas－> Handle,nChar,GGO_NATIVE,＆gmm,0,NULL,＆mat2); if(cbBuffer == GDI_ERROR) break; void ＊lpBuffer = malloc(cbBuffer); if(lpBuffer != NULL) { // 讀入數據置緩衝區 if(GetGlyphOutlineA(pCanvas－> Handle,nChar,GGO_NATIVE, ＆gmm,cbBuffer,lpBuffer,＆mat2) != GDI_ERROR) { // 分析資料並繪製字元 TMemoryStream ＊MBuffer = new TMemoryStream(); MBuffer－>Write(lpBuffer,cbBuffer); MBuffer－>Position = 0; for(;MBuffer－>Position < MBuffer－>Size;) { int CurPos = MBuffer－>Position; TTPOLYGONHEADER polyheader; int ptn = 0; MBuffer－>Read(＆polyheader,sizeof(polyheader)); ptn＋＋; for(int j = 0;j < (int)(polyheader.cb － sizeof(polyheader));) { WORD wtype,cpfx; MBuffer－>Read(＆wtype,sizeof(WORD)); MBuffer－>Read(＆cpfx,sizeof(WORD)); MBuffer－>Position ＋= cpfx ＊ sizeof(POINTFX); j ＋= sizeof(WORD) ＊ 2 ＋ cpfx ＊ sizeof(POINTFX); if(wtype == TT_PRIM_LINE) ptn ＋= cpfx; else ptn ＋= (cpfx － 1) ＊ 3 ＋ 1; } TPoint ＊pts = new TPoint[ptn＋1]; // 存儲多邊形頂點 MBuffer－>Position = CurPos; ptn = 0; MBuffer－>Read(＆polyheader,sizeof(polyheader)); TPoint pt0 = POINTFX2TPoint(polyheader.pfxStart,TheRect,＆gm); pts[ptn＋＋] = pt0; for(int j = 0;j < (int)(polyheader.cb － sizeof(polyheader));) { TPoint pt1; WORD wtype,cpfx; MBuffer－>Read(＆wtype,sizeof(WORD)); MBuffer－>Read(＆cpfx,sizeof(WORD)); POINTFX ＊pPfx = new POINTFX[cpfx]; MBuffer－>Read((void ＊)pPfx,cpfx ＊ sizeof(POINTFX)); j ＋= sizeof(WORD) ＊ 2 ＋ cpfx ＊ sizeof(POINTFX); if(wtype == TT_PRIM_LINE) { // 直線段 for(int i = 0;i < cpfx;i＋＋) { pt1 = POINTFX2TPoint(pPfx[i],TheRect,＆gm); pts[ptn＋＋] = pt1; } } else { // Bezier曲線 TPoint p0,p1,p2,p3,p11,p22,pp0,pp1,pp2,pt11,pt22; int i; for(i = 0;i < cpfx－1;i＋＋) { pt11 = POINTFX2TPoint(pPfx[i],TheRect,＆gm); pt22 = POINTFX2TPoint(pPfx[i＋1],TheRect,＆gm); pp0 = pts[ptn－1]; pp1 = pt11; pp2.x = (pt11.x ＋ pt22.x)/2; pp2.y = (pt11.y ＋ pt22.y)/2; p0 = pp0; p1.x = pp0.x/3 ＋ 2 ＊ pp1.x/3; p1.y = pp0.y/3 ＋ 2 ＊ pp1.y/3; p2.x = 2 ＊ pp1.x/3 ＋ pp2.x/3; p2.y = 2 ＊ pp1.y/3 ＋ pp2.y/3; p3 = pp2; for(float t = 0.0f;t <= 1.0f;t ＋= 0.5f) { float x = (1－t)＊(1－t)＊(1－t)＊p0.x＋ 3＊t＊(1－t)＊(1－t)＊p1.x＋ 3＊t＊t ＊(1－t)＊p2.x ＋ t＊t＊t＊p3.x; float y = (1－t)＊(1－t)＊(1－t)＊p0.y ＋ 3＊t＊(1－t)＊(1－t)＊p1.y＋3 ＊t＊t＊(1－t)＊p2.y ＋ t＊t＊t＊p3.y; pts[ptn].x = x; pts[ptn].y = y; ptn＋＋; } } pt1 = POINTFX2TPoint(pPfx[i],TheRect,＆gm); pts[ptn＋＋] = pt1; } delete pPfx; } pts[ptn] = pts[0]; // 封閉多邊形 pCanvas－>Brush－>Color = clWhite; pCanvas－>Pen－>Mode = pmXor; pCanvas－>Pen－>Style = psClear; pCanvas－>Brush－>Style = bsSolid; pCanvas－>Polygon(pts,ptn); delete pts; } delete MBuffer; } free(lpBuffer); } } } //－－－－－－－－－－－－－－－－－－－－－ TPoint TForm1::POINTFX2TPoint(POINTFX pf, TRect TheRect,GLYPHMETRICS ＊gm) { TPoint point; float fx,fy; fx = pf.x.value ＋ pf.x.fract / 65536.0f ＋ 0.5f; fx = fx / (float)(gm－>gmBlackBoxX ＋ gm－>gmptGlyphOrigin.x) ＊ (float)TheRect.Width() ＋ (float)TheRect.Left; fy = pf.y.value ＋ pf.y.fract / 65536.0f ＋ 0.5f; fy = ((float)gm－>gmBlackBoxY － fy) / (float)(gm－>gmBlackBoxX ＋ gm－>gmptGlyphOrigin.x) ＊ (float)TheRect.Height() ＋ (float)TheRect.Top; point.x = int(fx); point.y = int(fy); return point; } ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#47 引用回覆回覆發表時間：2003-12-12 06:55:18 IP:192.168.xxx.xxx 未訂閱【文章】如何開啟Excel並限制只能編輯某一頁sheet? 【作者】timhuang 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=29580 下面的程式範例為新開一個excel檔案後, 將 Sheet1, Sheet2 定為保護, 並切至 Sheet3 讓使用者輸入!! procedure TForm1.Button1Click(Sender: TObject); var ex, wb, ws: variant; begin ex := CreateOleObject('Excel.Application'); wb := ex.WorkBooks.Add; ex.visible := true; wb.Sheets['Sheet3'].Select; //利用 workbook 的 sheets 給定名稱或是指定第幾個都可以, 再利用 select 來進行選取的動作 //下面的兩行是以文件保護的方式來不讓使用者修改 wb.Sheets['Sheet1'].Protect(DrawingObjects:=True, Contents:=True, Scenarios:=True); wb.Sheets['Sheet2'].Protect(DrawingObjects:=True, Contents:=True, Scenarios:=True); end; ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#48 引用回覆回覆發表時間：2003-12-16 21:04:24 IP:211.76.xxx.xxx 未訂閱【文章】TComm安裝與16進制傳送接收程式【作者】bt1 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=35700 本RS232的元件是由書本[c++ Builder與RS232串列通訊控制]內ch4所附的元件. 安裝方式: step1:把TComm資料夾copy到C:\Program Files\Borland\CBuilder5 step2:開啟BCB5 step3:進入Compoment--->Install Component--->在Into existing package中的Unit file name中按 Browse按鈕,設路徑為C:\Program Files\Borland\CBuilder5\TComm 選Comm.cpp step4: 安裝完,關閉BCB5,並儲存檔案. step5:開啟BCB5,可以在上面一排元件中的system中看到TComm元件(一個9pin的Rs232端子,下方數字1010) setp6:安裝完成. [運用] 開啟: Comm1->PortOpen = true; 傳送: Comm1->OutputByte(ByteSend); 接收: ByteReceive=Comm1->ReadInputByte(); 關閉: Comm1->PortOpen=false; 全域變數的宣告: DynamicArray ByteSend,ByteReceive; String rdata[255]; [範例]16進制傳送和接收功能說明: Button1:傳送資料 Timer1:自動接收資料 //--------------------------------------------------------------------------- #include #pragma hdrstop #include #include "Unit1.h" //--------------------------------------------------------------------------- #pragma package(smart_init) #pragma link "Comm" #pragma resource ".dfm" TForm1 Form1; DynamicArray ByteSend,ByteReceive; String rdata[255]; long i; //--------------------------------------------------------------------------- __fastcall TForm1::TForm1(TComponent* Owner) : TForm(Owner) { Comm1->PortOpen = true; ShowMessage("Comm1已開啟"); Timer1->Enabled=true; //自動接收 } //--------------------------------------------------------------------------- void Delay(DWORD DT) { long tt; tt=GetTickCount(); while (GetTickCount()-ttProcessMessages(); if ((GetTickCount()-tt)<=0) tt=GetTickCount(); } } //--------------------------------------------------------------------------- void __fastcall TForm1::Button1Click(TObject Sender) { ByteSend.Length =4; ByteSend[0] = 0x01; ByteSend[1] = 0x03; ByteSend[2] = 0x0c; ByteSend[3] = 0x00; Comm1->OutputByte(ByteSend);//傳送出去 Delay(1000); //延遲100毫秒 //--------------------------------------------------------------------------- void __fastcall TForm1::Timer1Timer(TObject Sender) { Delay(100); //延遲100毫秒 ByteReceive=Comm1->ReadInputByte(); for(i=0;i ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#49 引用回覆回覆發表時間：2003-12-20 20:24:56 IP:192.168.xxx.xxx 未訂閱【文章】如何抓取WINDOWS系統預設的輸入法【作者】P.D. 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=42278 一些常用的輸入法設定, 直接引用就可以, 但 TsysUt 是formname, 請自行修正 private function GetIMEList(dCombobox: TComboBox): integer; function GetImeFileName: string; function SetActiveIme(sWanted: string): boolean; function SetFirstIme: boolean; function SetCloseIme: boolean; function SetKey2Ime(aObj: TWinControl): boolean; .... // 取得window內所有的輸入法 function TSysUt.GetIMEList(dCombobox: TComboBox): integer; var iHandleCount: integer; pList: array[1..nHKL_LIST] of HKL; szImeFileName: array[0..MAX_PATH] of char; sImeFileName: string; i: integer; begin // 看看是否安裝了這個輸入法 iHandleCount:= GetKeyboardLayoutList(nHKL_LIST, pList); for i:= 1 to iHandleCount do begin ImmGetDescription(pList[i], szImeFileName, MAX_PATH); sImeFileName := trim(AnsiUpperCase(StrPas(szImeFileName))); dCombobox.Items.Add(sImeFileName); end; dCombobox.Items.Strings[0]:= ''; result:= iHandleCount; end; //偵測目前作用中的輸入法檔案名稱 function TSysUT.GetImeFileName: string; var szImeFileName: array[0..MAX_PATH] of char; begin if ImmGetDescription(GetKeyboardLayout(0), szImeFileName, MAX_PATH) <> 0 then result:= AnsiUpperCase(StrPas(szImeFileName)) else result:= ''; end; // 切換到指定的輸入法 function TSysUT.SetActiveIme(sWanted: string): boolean; var iHandleCount: integer; pList: array[1..nHKL_LIST] of HKL; szImeFileName: array[0..MAX_PATH] of char; sImeFileName: string; bInstalled: boolean; i: integer; begin result:= False; sWanted:= AnsiUpperCase(sWanted); // 看看是否安裝了這個輸入法 bInstalled:= False; iHandleCount:= GetKeyboardLayoutList(nHKL_LIST, pList); for i:= 1 to iHandleCount do begin ImmGetDescription(pList[i], szImeFileName, MAX_PATH); sImeFileName := AnsiUpperCase(StrPas(szImeFileName)); if pos(sWanted,sImeFileName)>0 then begin bInstalled:= True; break; end; end; // 如果這個輸入法已安裝了, 讓那個輸入法的鍵盤分佈(KeyLayout)作用 if bInstalled then begin ActivateKeyboardLayout(pList[i], 0); result:= True; end; end; // 切換到第一個輸入法 function TSysUT.SetFirstIme: boolean; var iHandleCount: integer; pList: array[1..nHKL_LIST] of HKL; szImeFileName: array[0..MAX_PATH] of char; begin iHandleCount:= GetKeyboardLayoutList(nHKL_LIST, pList); if iHandleCount>=2 then begin ImmGetDescription(pList[2], szImeFileName, MAX_PATH); ActivateKeyboardLayout(pList[2], 0); result:= True; end else result:= False; end; // 回英數輸入法, 本輸入法假設第一組為英數 function TSysUT.SetCloseIme: boolean; var iHandleCount: integer; pList: array[1..nHKL_LIST] of HKL; szImeFileName: array[0..MAX_PATH] of char; begin U_VarDef.ChangeIME:= SysUT.GetImeFileName; iHandleCount:= GetKeyboardLayoutList(nHKL_LIST, pList); if iHandleCount>0 then begin ImmGetDescription(pList[1], szImeFileName, MAX_PATH); ActivateKeyboardLayout(pList[1], 0); result:= True; end else result:= False; end; //模擬ctrl-space來切換中英文 function TSysUT.SetKey2Ime(aObj: TWinControl): boolean; begin ImmSimulateHotKey(aObj.Handle, IME_THOTKEY_IME_NONIME_TOGGLE); result:= True; end; // 取得window所有輸入法用法 GetIMEList(combobox1); // 切換到注音 (字串須依window不同版本所提供, 可用上述function查得 SetActiveIme('注音'); ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#50 引用回覆回覆發表時間：2003-12-24 07:40:38 IP:192.168.xxx.xxx 未訂閱【文章】不用標題欄也可以移動表單【作者】未知【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=37720 不用標題欄也可以移動表單一般情況下，移動一個表單需要將滑鼠放置在標題欄上才能拖動表單，d什l非要使用標題欄呢？其實我們可以使用一個巧妙的方法來實現將滑鼠放置在表單上按下就可拖動表單，下面先看實現代碼。在Form1的“Private”部分聲明過程：在private部分加入下列代碼： procedure wmnchittest(var msg:twmnchittest); message wm_nchittest; 在程式部分加入以下代碼： procedure TForm1.wmnchittest(var msg:twmnchittest); begin inherited; if (htclient=msg.result) then msg.result:=htcaption; end; 上面的關鍵代碼雖然只有兩行，但它實現了滑鼠直接拖動表單的目的。代碼的原理是利用表單的WM_NCHITTEST消息，這個消息是當游標移動、滑鼠按下或釋放時發生的，當程式檢測到滑鼠在表單中按下的消息後（消息的值dhtClient），將滑鼠在標題欄上按下時{生的消息（值dhtCaption）傳遞出去，這樣就巧妙的欺騙程式認d是標題欄被按下，當然就可拖動表單了。 ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#51 引用回覆回覆發表時間：2003-12-27 22:27:15 IP:192.168.xxx.xxx 未訂閱【文章】如何像ie一樣儲存完整網頁(包含圖片...) 【作者】hagar 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=42605 下面的這一段程式碼只能儲存網頁的原始碼: uses ActiveX; procedure TForm1.Button1Click(Sender: TObject); begin (WebBrowser1.Document as IPersistFile).Save('C:\test.htm', False); end; 以下的這一段程式就可以儲存完整的網頁內容(包含圖片...) 但是會出現對話匡 begin WebBrowser1.ExecWB(OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT, EmptyParam, EmptyParam); end; 參考資料:http://groups.google.com.tw/groups?hl=zh-TW&lr=&ie=UTF-8&oe=UTF-8&th=878502bb87a888e6&rnum=11 ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#52 引用回覆回覆發表時間：2003-12-27 22:28:07 IP:192.168.xxx.xxx 未訂閱【文章】如何取得 WebBrowser 內所有的連結【作者】hagar 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=42605 procedure TForm1.Button1Click(Sender: TObject); var i: Integer; begin for i := 0 to Webbrowser1.OleObject.Document.links.Length - 1 do Listbox1.Items.Add(Webbrowser1.OleObject.Document.Links.Item(i)); end; {*****************} { if there are frames } procedure TForm1.Button2Click(Sender: TObject); var u : variant; v : IDispatch; s : string; procedure RecurseLinks(htmlDoc: variant); var BodyElement : variant; ElementCo: variant; HTMLFrames: variant; HTMLWnd : variant; j, i : integer; begin if VarIsEmpty(htmlDoc) then exit; BodyElement := htmlDoc.body; if BodyElement.tagName = 'BODY' then begin ElementCo := htmlDoc.links; j := ElementCo.Length - 1; for i := 0 to j do begin u := ElementCo.item(i); s := u.href; listLinks.Items.Add(s); end; end; HTMLFrames := htmlDoc.Frames; j := HTMLFrames.length - 1; for i := 0 to j do begin HTMLWnd := HTMLFrames.Item(i); RecurseLinks(HTMLWnd.Document); end; end; // RecurseLinks begin v := WebBrowser1.document; listLinks.Clear; RecurseLinks(v); end; 參考資料: http://www.swissdelphicenter.ch/en/showcode.php?id=479 ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#53 引用回覆回覆發表時間：2004-01-10 22:18:13 IP:192.168.xxx.xxx 未訂閱【文章】HTML與ActiveForm間的參數如何傳遞? 【作者】mi86018 【內文】http://delphi.ktop.com.tw/topic.php?topic_id=22699 [問題] 我利用ActiveForm撰寫了一個OCX檔,然後利用下列方式在HTML中設定Active Form的Color屬性,讓User讀取網頁時出現不同的色彩 ,如果我想自己加上一個TEST的屬性,來作其他參數傳遞不知是否可行? 請問是否有人這樣使用過. classid="clsid:FC5F3xxx-2xxx-4xx4-Bxxx-3xxxxx9xxxxx" codebase="http://www.xxx.xxx.tw/AAAA.cab#version=1,0,0,54" width=380 height=298 param name="Color" value="129" param name="TEST" value="參數傳遞" <=自行編輯的TEST屬性,用來傳遞資料 [回覆] 寫好的Activex ocx 在HTML引用的程式碼如下: <OBJECT " classid="clsid:4BBF9074-8799-41D9-B4E8-BF93C4372E6B" codebase="./PrintBarcodeProj1.inf" width=117 height=47 align=center hspace=0 vspace=0 ><font color=red>"> </OBJECT></font> 紅色這行..就是要從Html要傳入ocx的參數。而在Delphi中的ActiveX Form中點選 View -> Type Library 然後點選有個像紅色棒棒糖的Interface然後點滑鼠右鍵，New一個新的property，如圖一。圖一幫新的property去個名字，及資料型態，此property即為你要從Html傳進來的參數。取好名字之後Delphi會自動將Get和Put兩個Property設為同一名字，如下圖二。圖二新增完之後記得按下Type Library中裡那一排工具列裡面的Refresh。按下之後，在ActiveX form的程式碼就會多出兩個函式，如下： function Get_BarcodeStr: WideString; safecall; procedure Set_BarcodeStr(const Value: WideString); safecall; 在這兩個函式裡面，要加上下面的程式碼，當然也可以加入一些你自己需要的程式。 function TActiveXForm1.Get_BarcodeStr: WideString; begin Result := WideString(BarcodeStr); end; procedure TActiveXForm1.Set_BarcodeStr(const Value: WideString); begin BarcodeStr := Value; end; 之後，就可以在你自己寫的其他函式裡面用的這個從Html傳進來的參數了，用法如下：例如我在Timer裡面用道： procedure TActiveXForm1.Timer1Timer(Sender: TObject); var str:String; begin Timer1.Enabled:=False; str := get_BarcodeStr; if (length(str) = 0) then exit else showmessage(str); end; 將這個form包成ocx，Deploy之後，在Html語法記得加上文章最上面的那行 "> 這樣這個網頁就能將參數傳進這個ocx了!! ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#54 引用回覆回覆發表時間：2004-01-10 22:21:12 IP:192.168.xxx.xxx 未訂閱【文章】推薦一個介紹RS232串列通訊的網站【作者】領航天使【內文】串口通塈{ http://www.gjwtech.com/serialcomm.htm ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#55 引用回覆回覆發表時間：2004-01-10 22:28:53 IP:192.168.xxx.xxx 未訂閱【文章】如何判斷執行檔執行中?如何刪除執行工作? 【作者】ko 【內文】http://delphi.ktop.com.tw/topic.php?topic_id=34139 unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Edit1: TEdit; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} uses TlHelp32; var spid:Integer; PH : THandle; function ApplicationUse(fName : string) : boolean; var hSS: THandle; ProcEntry32: PROCESSENTRY32; iCount: Integer; begin Result := False; iCount := 0; hSS := CreateToolHelp32Snapshot(TH32CS_SNAPALL, 0); ProcEntry32.dwSize := sizeof(ProcEntry32); //----------------- if Process32First(hSS, ProcEntry32) then begin repeat // Application.MessageBox((ProcEntry32.szExeFile),'...'); if UpperCase(ProcEntry32.szExeFile) = UpperCase(fName) then begin spid := ProcEntry32.th32ProcessID; Inc(iCount); if iCount >= 1 then begin Result := True; Break; end; end; until not Process32Next(hSS, ProcEntry32); CloseHandle(hSS); end; //-------------- if Result then Exit; end; function KillSelectedProcess(PID:integer):String; var lpExitCode : DWord; hProcess : Cardinal; begin hProcess := Int64(PID); PH := OpenProcess(PROCESS_TERMINATE or PROCESS_QUERY_INFORMATION,FALSE, hProcess); if PH <> 0 then begin if GetExitCodeProcess(PH, lpExitCode) then TerminateProcess(PH, lpExitCode) else Result := 'Could not retreive the ExitCode for this process.'; CloseHandle(PH); end else Result := 'Could not get access to this process.' end; procedure TForm1.Button1Click(Sender: TObject); begin if ApplicationUse(edit1.text) then begin KillSelectedProcess(spid); end; end; end. ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#56 引用回覆回覆發表時間：2004-01-10 22:37:20 IP:192.168.xxx.xxx 未訂閱【文章】combobox中下拉後的內容不夠寬怎辦? 【作者】hagar 【內文】http://delphi.ktop.com.tw/topic.php?topic_id=24612 procedure SetComboDropDownWidth(ComboBox: TComboBox; Width: Longint = -1); var I, TextLen: Longint; begin if Width < ComboBox.Width then begin ComboBox.Canvas.Handle := GetDC(ComboBox.Handle); try for I := 0 to ComboBox.Items.Count -1 do begin TextLen := ComboBox.Canvas.TextWidth(ComboBox.Items[I]); if TextLen > Width then Width := TextLen; end; (* Standard ComboBox drawing is Rect.Left 2, adding the extra spacing offsets this *) Inc(Width, 10); finally ReleaseDC(ComboBox.Handle, ComboBox.Canvas.Handle); end; end; SendMessage(ComboBox.Handle, CB_SETDROPPEDWIDTH, Width, 0); end; -- ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#57 引用回覆回覆發表時間：2004-01-15 21:28:28 IP:192.168.xxx.xxx 未訂閱【文章】如何出現網路上的芳鄰選擇視窗? 【作者】Miles 【內文】http://delphi.ktop.com.tw/topic.php?topic_id=41923 unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Edit1: TEdit; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} Uses ShellAPI, ShlObj; function BrowseForComputer(const Title : String) : String; var BrowseInfo : TBROWSEINFO; IDRoot : PItemIDList; Path : array[0..MAX_PATH] of char; begin SHGetSpecialFolderLocation(Application.Handle, CSIDL_NETWORK, IDRoot); FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); FillChar(Path, sizeof(Path), #0); BrowseInfo.hwndOwner := Application.Handle; BrowseInfo.pidlRoot := IDRoot; BrowseInfo.lpszTitle := PChar(Title); BrowseInfo.pszDisplayName := @Path; BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER; SHBrowseForFolder(BrowseInfo); Result := String(Path); end; procedure TForm1.Button1Click(Sender: TObject); begin Edit1.Text := BrowseForComputer('網路芳鄰選我'); end; end. ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#58 引用回覆回覆發表時間：2004-01-28 20:57:20 IP:211.76.xxx.xxx 未訂閱【文章】幾個有用的日期轉換函數(包含UNIXTIME轉換) 【作者】Trevor J Carlsen 【內文】來源:http://www.bsdg.org/swag/DATETIME/0015.PAS.html Unit TCDate; { Author: Trevor J Carlsen Released into the public domain } { PO Box 568 } { Port Hedland } { Western Australia 6721 } { Voice 61 91 732 026 } Interface Uses Dos; Type Date = Word; UnixTimeStamp = LongInt; Const WeekDays : Array[0..6] of String[9] = ('Sunday','Monday','Tuesday','Wednesday','Thursday', 'Friday','Saturday'); months : Array[1..12] of String[9] = ('January','February','March','April','May','June','July', 'August','September','October','November','December'); Function DayofTheWeek(pd : date): Byte; { Returns the day of the week For any date Sunday = 0 .. Sat = 6 } { pd = a packed date as returned by the Function PackedDate } { eg... Writeln('today is ',WeekDays[DayofTheWeek(today))]; } Function PackedDate(yr,mth,d: Word): date; { Packs a date into a Word which represents the number of days since } { Dec 31,1899 01-01-1900 = 1 } Function UnixTime(yr,mth,d,hr,min,sec: Word): UnixTimeStamp; { Packs a date and time into a four Byte unix style Variable which } { represents the number of seconds that have elapsed since midnight } { on Jan 1st 1970. } Procedure UnPackDate(Var yr,mth,d: Word; pd : date); { Unpacks a Word returned by the Function PackedDate into its } { respective parts of year, month and day } Procedure UnPackUnix(Var yr,mth,d,hr,min,sec: Word; uts: UnixTimeStamp); { Unpacks a UnixTimeStamp Variable into its Component parts. } Function DateStr(pd: date; Format: Byte): String; { Unpacks a Word returned by the Function PackedDate into its } { respective parts of year, month and day and then returns a String } { Formatted according to the specifications required. } { if the Format is > 9 then the day of the week is prefixed to the } { returned String. } { Formats supported are: } { 0: dd/mm/yy } { 1: mm/dd/yy } { 2: dd/mm/yyyy } { 3: mm/dd/yyyy } { 4: [d]d xxx yyyy (xxx is alpha month of 3 Chars) } { 5: xxx [d]d, yyyy } { 6: [d]d FullAlphaMth yyyy } { 7: FullAlphaMth [d]d, yyyy } { 8: [d]d-xxx-yy } { 9: xxx [d]d, 'yy } Function ValidDate(yr,mth,d : Word; Var errorcode : Byte): Boolean; { Validates the date and time data to ensure no out of range errors } { can occur and returns an error code to the calling Procedure. A } { errorcode of zero is returned if no invalid parameter is detected. } { Errorcodes are as follows: } { Year out of range (< 1901 or > 2078) bit 0 of errorcode is set. } { Month < 1 or > 12 bit 1 of errorcode is set. } { Day < 1 or > 31 bit 2 of errorcode is set. } { Day out of range For month bit 2 of errorcode is set. } Procedure ParseDateString(Var dstr; Var y,m,d : Word; Format : Byte); { Parses a date String in several Formats into its Component parts } { It is the Programmer's responsibility to ensure that the String } { being parsed is a valid date String in the Format expected. } { Formats supported are: } { 0: dd/mm/yy[yy] } { 1: mm/dd/yy[yy] } Function NumbofDaysInMth(y,m : Word): Byte; { returns the number of days in any month } Function IncrMonth(pd: date; n: Word): date; { Increments pd by n months. } Function today : date; { returns the number of days since 01-01-1900 } Function ordDate (Y,M,D : Word):LongInt; { returns ordinal Date yyddd } Function Dateord (S : String) : String; { returns Date as 'yymmdd' } {============================================================================= } Implementation Const TDays : Array[Boolean,0..12] of Word = ((0,31,59,90,120,151,181,212,243,273,304,334,365), (0,31,60,91,121,152,182,213,244,274,305,335,366)); UnixDatum = LongInt(25568); SecsPerDay = 86400; SecsPerHour = LongInt(3600); SecsPerMin = LongInt(60); MinsPerHour = 60; Function DayofTheWeek(pd : date): Byte; begin DayofTheWeek := pd mod 7; end; { DayofTheWeek } Function PackedDate(yr,mth,d : Word): date; { valid For all years 1901 to 2078 } Var temp : Word; lyr : Boolean; begin lyr := (yr mod 4 = 0); if yr >= 1900 then dec(yr,1900); temp := yr * Word(365) (yr div 4) - ord(lyr); inc(temp,TDays[lyr][mth-1]); inc(temp,d); PackedDate := temp; end; { PackedDate } Function UnixTime(yr,mth,d,hr,min,sec: Word): UnixTimeStamp; { Returns the number of seconds since 00:00 01/01/1970 } begin UnixTime := SecsPerDay * (PackedDate(yr,mth,d) - UnixDatum) SecsPerHour * hr SecsPerMin * min sec; end; { UnixTime } Procedure UnPackDate(Var yr,mth,d: Word; pd : date); { valid For all years 1901 to 2078 } Var julian : Word; lyr : Boolean; begin d := pd; yr := (LongInt(d) * 4) div 1461; julian := d - (yr * 365 (yr div 4)); inc(yr,1900); lyr := (yr mod 4 = 0); inc(julian,ord(lyr)); mth := 0; While julian > TDays[lyr][mth] do inc(mth); d := julian - TDays[lyr][mth-1]; end; { UnPackDate } Procedure UnPackUnix(Var yr,mth,d,hr,min,sec: Word; uts: UnixTimeStamp); Var temp : UnixTimeStamp; begin UnPackDate(yr,mth,d,date(uts div SecsPerDay) UnixDatum); temp := uts mod SecsPerDay; hr := temp div SecsPerHour; min := (temp mod SecsPerHour) div MinsPerHour; sec := temp mod SecsPerMin; end; { UnPackUnix } Function DateStr(pd: date; Format: Byte): String; Var y,m,d : Word; YrStr : String[5]; MthStr : String[11]; DayStr : String[8]; TempStr : String[5]; begin UnpackDate(y,m,d,pd); str(y,YrStr); str(m,MthStr); str(d,DayStr); TempStr := ''; if Format > 9 then TempStr := copy(WeekDays[DayofTheWeek(pd)],1,3) ' '; if (Format mod 10) < 4 then begin if m < 10 then MthStr := '0' MthStr; if d < 10 then DayStr := '0' DayStr; end; Case Format mod 10 of { Force Format to a valid value } 0: DateStr := TempStr DayStr '/' MthStr '/' copy(YrStr,3,2); 1: DateStr := TempStr MthStr '/' DayStr '/' copy(YrStr,3,2); 2: DateStr := TempStr DayStr '/' MthStr '/' YrStr; 3: DateStr := TempStr MthStr '/' DayStr '/' YrStr; 4: DateStr := TempStr DayStr ' ' copy(months[m],1,3) ' ' YrStr; 5: DateStr := TempStr copy(months[m],1,3) ' ' DayStr ' ' YrStr; 6: DateStr := TempStr DayStr ' ' months[m] ' ' YrStr; 7: DateStr := TempStr months[m] ' ' DayStr ' ' YrStr; 8: DateStr := TempStr DayStr '-' copy(months[m],1,3) '-' copy(YrStr,3,2); 9: DateStr := TempStr copy(months[m],1,3) ' ' DayStr ', ''' copy(YrStr,3,2); end; { Case } end; { DateStr } Function ValidDate(yr,mth,d : Word; Var errorcode : Byte): Boolean; begin errorcode := 0; if (yr < 1901) or (yr > 2078) then errorcode := (errorcode or 1); if (d < 1) or (d > 31) then errorcode := (errorcode or 2); if (mth < 1) or (mth > 12) then errorcode := (errorcode or 4); Case mth of 4,6,9,11: if d > 30 then errorcode := (errorcode or 2); 2: if d > (28 ord((yr mod 4) = 0)) then errorcode := (errorcode or 2); end; {Case } ValidDate := (errorcode = 0); if errorcode <> 0 then Write(#7); end; { ValidDate } Procedure ParseDateString(Var dstr; Var y,m,d : Word; Format : Byte); Var left,middle : Word; errcode : Integer; st : String Absolute dstr; begin val(copy(st,1,2),left,errcode); val(copy(st,4,2),middle,errcode); val(copy(st,7,4),y,errcode); Case Format of 0: begin d := left; m := middle; end; 1: begin d := middle; m := left; end; end; { Case } end; { ParseDateString } Function NumbofDaysInMth(y,m : Word): Byte; { valid For the years 1901 - 2078 } begin Case m of 1,3,5,7,8,10,12: NumbofDaysInMth := 31; 4,6,9,11 : NumbofDaysInMth := 30; 2 : NumbofDaysInMth := 28 ord((y mod 4) = 0); end; end; { NumbofDaysInMth } Function IncrMonth(pd: date; n: Word): date; Var y,m,d : Word; begin UnpackDate(y,m,d,pd); dec(m); inc(m,n); inc(y,m div 12); { if necessary increment year } m := succ(m mod 12); if d > NumbofDaysInMth(y,m) then d := NumbofDaysInMth(y,m); IncrMonth := PackedDate(y,m,d); end; { IncrMonth } Function today : date; Var y,m,d,dw : Word; begin GetDate(y,m,d,dw); today := PackedDate(y,m,d); end; { today } Function ordDate (Y,M,D : Word): LongInt; { returns ordinal Date as yyddd } Var LYR : Boolean; TEMP : LongInt; begin LYR := (Y mod 4 = 0) and (Y <> 1900); Dec (Y,1900); TEMP := LongInt(Y) * 1000; Inc (TEMP,TDays[LYR][M-1]); { Compute # days through last month } Inc (TEMP,D); { # days this month } ordDate := TEMP end; { ordDate } Function Dateord (S : String) : String; { returns Date as 'yymmdd' } Var LYR : Boolean; Y,M,D : Word; TEMP : LongInt; N : Integer; StoP : Boolean; SW,ST : String[6]; begin Val (Copy(S,1,2),Y,N); Val (Copy(S,3,3),TEMP,N); Inc (Y,1900); LYR := (Y mod 4 = 0) and (Y <> 1900); Dec (Y,1900); N := 0; StoP := False; While not StoP and (TDays[LYR][N] < TEMP) do Inc (N); M := N; { month } D := TEMP-TDays[LYR][M-1]; { subtract # days thru this month } Str(Y:2,SW); Str(M:2,ST); if ST[1] = ' ' then ST[1] := '0'; SW := SW ST; Str(D:2,ST); if ST[1] = ' ' then ST[1] := '0'; SW := SW ST; Dateord := SW end; { Dateord } end. { Unit TCDate } ～～～Delphi K.Top討論區站長～～～ ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#59 引用回覆回覆發表時間：2004-02-14 08:22:34 IP:192.168.xxx.xxx 未訂閱【文章】如何知道檔案是否被其他程式存取中? 【作者】hagar 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=37666 問題如下: 我開一個A程式,裡面有個Multi Thread來監看底下的一個子目錄,一但此子目錄有檔案,則呼叫一個副程式來讀檔,但現在問題來了,那個副程式只知道有檔案在此目錄下(使用FindFile的方式),但卻不知道此檔案是否已經讀寫完畢了,這樣就會發生,檔案還未存取完畢,副程式就已經讀檔完成,變成副程式讀的檔(文字檔)是不完全的,請問這要怎麼實作才會比較好? dllee回答如下: hagar 版主所用的方法就是開檔而已，在 Windows 的開檔方式中德的 AccessMode 設定可以設定檔案是否可以被同時存取，或是只允許可以讓別人同時讀，或只允許別人寫但不能讀，或是完全不允許別人可以讀寫。而判斷一個檔是否已經被使用但沒有關閉，就是對那個檔案作「開檔」的動作，同時指定 AccessMode 是別人不可以讀也不可以寫，只有我可以讀也可以寫。這樣，當這個檔案可以正常開啟時，就表示沒有其他函式在使用，如果有其他函式在使用，則會傳回 INVALID_HANDLE_VALUE 表示開檔不成功！當然開檔不成功也有可能是檔案本來就不存在，所以 hagar 版主在一開始就有判斷檔案存不存在。其實，解決的方法有很多種，因為您把問題指定檔案是否處理完成，所以我想 hagar 版主的方式就可以解決。如果所有的程式都是您自己開發，則問題可以是兩個(以上)的程式或執行緒之間資料、訊息交換的問題，在此您只需在處理檔案的執行緒或程式在處理檔案是發一個訊息給其他模組去收，或將一個旗標打開讓別人可以存取，例如另開一個檔案作資料交換或用 ■【發表】跨行程共享記憶體 - Memory mapping file http://delphi.ktop.com.tw/topic.php?TOPIC_ID=37041 或 ■【Delphi】【分享】ShareMemRep 1.0 - 最佳的共享內存管理器替代方案 http://delphi.ktop.com.tw/topic.php?TOPIC_ID=35228 都可以。等處理檔案的執行緒處理完檔案，再以同樣的方式通知其他模組。這樣，就不需要以「開檔」的方式來判斷檔是是否已處理完畢。程式範例 function IsFileInUse(FileName: TFileName): Boolean; var HFileRes: HFILE; begin Result := False; if not FileExists(FileName) then Exit; HFileRes := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); Result := (HFileRes = INVALID_HANDLE_VALUE); if not Result then CloseHandle(HFileRes); end; ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#60 引用回覆回覆發表時間：2004-02-14 08:25:00 IP:192.168.xxx.xxx 未訂閱【文章】如何讓DBGRID的各欄位自動調整寬度? 【作者】pedro 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=44580 DBGrid的各Column的Width其實是由DataSet的欄位DisplayWidth帶出來的, 而這個DisplayWidth值是由資料庫的Schema定義欄位大小時給的, 例如整數是4. 如果資料表的欄位數很多, 一般都會超過DBGrid可視範圍. 所以說, DBGrid的Column寬度由資料表定義決定. 但是若您想用程式碼調整下面片段程式碼您可以參考看看 var TotalGridDisplayWidth:Integer; procedure TForm1.FormCreate(Sender: TObject); var i:Integer; x:double; begin TotalGridDisplayWidth:=0; for i:=0 to DBGrid1.Columns.Count-1 do begin TotalGridDisplayWidth:=TotalGridDisplayWidth DBGrid1.Columns.Items[i].Width; end; for i:=0 to DBGrid1.Columns.Count-1 do begin x:=DBGrid1.Columns[i].Width / TotalGridDisplayWidth; DBGrid1.Columns[i].Width:=Round((DBGrid1.Width-50)*x); end; end; ------ ～～～Delphi K.Top討論區站長～～～
領航天使站長發表：12216 回覆：4186 積分：4084 註冊：2001-07-25 發送簡訊給我	#61 引用回覆回覆發表時間：2004-02-23 08:37:48 IP:192.168.xxx.xxx 未訂閱【文章】如何傳網址給已開啟的IE? 【作者】qoo1234 【內文】來源:http://delphi.ktop.com.tw/topic.php?topic_id=45284 Q: 我已將IE開啟，但是每次Delphi程式被執行時需傳送不同網址給IE，1.如何得知IE已開啟，且將網址傳入IE重新更新? A: //傳網址給IE網址列 procedure TForm1.Button1Click(Sender: TObject); var IE,toolbar,combo,comboboxex,edit,worker,toolbarwindow: HWND; begin IE := FindWindow('IEFrame', nil); worker := FindWindowEx(IE,0,'WorkerW',nil); //注意版本差異 (有些用WorkerA) toolbar := FindWindowEx(worker,0,'reBarwindow32',nil); comboboxex := FindWindowEx(toolbar, 0, 'comboboxex32', nil); combo := FindWindowEx(comboboxex,0,'ComboBox',nil); edit := FindWindowEx(combo,0,'Edit',nil); toolbarwindow := FindWindowEx(comboboxex, 0, 'toolbarwindow32', nil); if IE <> 0 then begin SendMessage(edit , WM_SETTEXT, 0, Integer(PChar('http://delphi.ktop.com.tw'))); end else ShowMessage('IE瀏覽器不存在'); end; ------ ～～～Delphi K.Top討論區站長～～～