開發一個delphi寫的桌面圖示管理程式碼
阿新 • • 發佈：2018-12-01
參加工作了就很少有時間去玩delphi了，這個適合初學者看看，大神勿噴 工具 delhpi7.0 access資料庫 原則win下有安裝office就可用 當初不太熟悉sqlite所有沒用這做資料庫。
{***************************************************************************** * 版本資訊: * 淺諾桌面管理工具v1.0 * 檔名稱: * UseShortcutKey.pas * 內容摘要: * 桌面快捷方式管理（分類及執行） * 歷史記錄: * 2013.1.28 created by xzj * 大型修改: * 2013.2.5 modified by xzj * 快捷方式名稱不顯示快捷方式ID,相關功能做相應的修改，將ID存放在陣列naID中 * * 程式為作者原創，修改請保留作者資訊，改後程序可發至作者郵箱共同參考、共同進步， * 謝謝支援。 ******************************************************************************} unit UseShortcutKey; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, TntStdCtrls, jpeg, ExtCtrls, TntExtCtrls, TntForms, ComCtrls, TntComCtrls, ImgList, DB, ADODB, Menus, TntMenus, Buttons, RzTray, TntButtons, Spin, RzButton, Mask, RzEdit, RzBtnEdt, RzBmpBtn, RzCmboBx, RzTabs, RzTrkBar, WinSkinStore, WinSkinData; const WM_MouseEnter = $B013; WM_MouseLeave = $B014; type TFormUse = class(TForm) imglogo: TTntImage; lblName: TTntLabel; lbl1: TTntLabel; lbl2: TTntLabel; tntscrlbxType: TTntScrollBox; tntpmnType: TTntPopupMenu; tmr1: TTimer; con1: TADOConnection; qryCmd: TADOQuery; il1: TImageList; ImageTxt: TImage; ImageRAR: TImage; ImageFiles: TImage; ImageMDB: TImage; ImageXLS: TImage; ImageDOC: TImage; ImagePPT: TImage; Imagepsd: TImage; ImagePhoto: TImage; Imagepdf: TImage; ImageDPR: TImage; ImagePAS: TImage; Imagedfm: TImage; ImageDLL: TImage; ImageWZ: TImage; Image1: TImage; Image2: TImage; rztrycn1: TRzTrayIcon; tntmntmAdd: TTntMenuItem; tntpgcntrl1: TTntPageControl; pg1: TTntTabSheet; edtAdd: TTntEdit; pg2: TTntTabSheet; edtEdt: TTntEdit; tntmntmqx: TTntMenuItem; tntpmnPro: TTntPopupMenu; tntmntmEdtPro: TTntMenuItem; tntmntmDelPro: TTntMenuItem; tntmntmTail: TTntMenuItem; tntmntmList: TTntMenuItem; tntmntmdefault: TTntMenuItem; tntmntmN1: TTntMenuItem; tntmntmWc: TTntMenuItem; tntpmnOperbtn: TTntPopupMenu; tntmntmEdit: TTntMenuItem; tntmntmdelete: TTntMenuItem; lbl3: TTntLabel; edtnow: TTntEdit; lbl4: TTntLabel; tntmntmN2: TTntMenuItem; tntmntmhide: TTntMenuItem; N1: TTntMenuItem; tntmntmdelall: TTntMenuItem; Imagebat: TImage; tntmntmdelalltype: TTntMenuItem; tntmntmN3: TTntMenuItem; tntcntrlbr1: TTntControlBar; tntmntmSendLink: TTntMenuItem; tntmntmN4: TTntMenuItem; tntpmnPC: TTntPopupMenu; btnPC: TRzMenuButton; btn1: TRzShapeButton; tntpmnMN: TTntPopupMenu; tntmntmClose: TTntMenuItem; tmr2: TTimer; tntmntmAutoOpen: TTntMenuItem; tntmntmSendAll: TTntMenuItem; edtTime: TTntEdit; tmr3: TTimer; tmrRe: TTimer; edtKeyNow: TTntEdit; tmrsx: TTimer; pnl1: TPanel; grp1: TGroupBox; qrySet: TADOQuery; qryInit: TADOQuery; tntpgcntrl2: TRzPageControl; pg3: TRzTabSheet; lvPro: TTntListView; pg4: TRzTabSheet; mmo1: TTntMemo; pg5: TRzTabSheet; tntpnl1: TTntPanel; tntmntmN5: TTntMenuItem; tntmntmexit: TTntMenuItem; tntmntmHideZT: TTntMenuItem; tntmntmHideV: TTntMenuItem; grp2: TTntGroupBox; lbl5: TTntLabel; cbbFC: TRzColorComboBox; lbl6: TTntLabel; cbbFONTC: TRzColorComboBox; cbbGC: TRzColorComboBox; lbl7: TTntLabel; lbl9: TTntLabel; cbbEC: TRzColorComboBox; cbbFT: TRzComboBox; lbl8: TTntLabel; lbl11: TTntLabel; cbbHD: TRzComboBox; cbbSH: TRzComboBox; lbl10: TTntLabel; lbl12: TTntLabel; rztrckbr1: TRzTrackBar; dlgFont1: TFontDialog; lbl13: TTntLabel; btn2: TRzButtonEdit; skndt1: TSkinData; sknstr1: TSkinStore; procedure FormCreate(Sender: TObject); procedure BtnTypeClick (Sender: TObject); procedure LoadShortcutKey(Sender : TObject); procedure tmr1Timer(Sender: TObject); procedure edtAddKeyPress(Sender: TObject; var Key: Char); procedure tntmntmAddClick(Sender: TObject); procedure edtEdtKeyPress(Sender: TObject; var Key: Char); procedure Openqry(var qry1 : TADOQuery; sqltxt : string); procedure Execqry(var qry1 : TADOQuery; sqltxt : string); procedure tntmntmqxClick(Sender: TObject); procedure lvProDblClick(Sender: TObject); procedure tntmntmTailClick(Sender: TObject); procedure tntmntmListClick(Sender: TObject); procedure tntmntmdefaultClick(Sender: TObject); procedure tntmntmEdtProClick(Sender: TObject); procedure tntmntmWcClick(Sender: TObject); procedure LBWindowProc(var Message: TMessage); procedure WMDROPFILES_L(var Msg: TMessage); procedure tntmntmDelProClick(Sender: TObject); procedure FormShow(Sender: TObject); procedure tntmntmEditClick(Sender: TObject); procedure tntmntmdeleteClick(Sender: TObject); procedure tntmntmhideClick(Sender: TObject); procedure lvProMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure tntmntmdelallClick(Sender: TObject); procedure lvProEdited(Sender: TObject; Item: TTntListItem; var S: WideString); procedure lvProKeyPress(Sender: TObject; var Key: Char); procedure tntmntmdelalltypeClick(Sender: TObject); procedure CreateLink(programPath,programArg,LinkPath,Descr : string); procedure tntmntmSendLinkClick(Sender: TObject); procedure GetSystemPath(); procedure MenuBtnOnClick(Sender : TObject); procedure btn1Click(Sender: TObject); procedure tntmntmCloseClick(Sender: TObject); //procedure tmr2Timer(Sender: TObject); procedure tntmntmAutoOpenClick(Sender: TObject); procedure tntmntmSendAllClick(Sender: TObject); procedure tmr3Timer(Sender: TObject); procedure tmrReTimer(Sender: TObject); procedure tmrsxTimer(Sender: TObject); procedure cbbFCChange(Sender: TObject); procedure cbbFONTCChange(Sender: TObject); procedure cbbGCChange(Sender: TObject); procedure cbbECChange(Sender: TObject); procedure cbbFTChange(Sender: TObject); procedure cbbHDChange(Sender: TObject); procedure cbbSHChange(Sender: TObject); procedure InitForm(); procedure AddInitForm(); procedure tntmntmexitClick(Sender: TObject); procedure tntmntmHideZTClick(Sender: TObject); procedure tntmntmHideVClick(Sender: TObject); procedure rztrckbr1Change(Sender: TObject); procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure imglogoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure tntpnl1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure grp2MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure tntpgcntrl2Change(Sender: TObject); procedure btn2ButtonClick(Sender: TObject); private { Private declarations } abtnType: array[1..50] of TRzBitBtn; //分組按鈕 anID : array[0..500] of Integer; sActiveBtn : string; //當前活動的按鈕 SYS_COLOR : TColor; //窗體顏色 FONT_COLOR : TColor; //字型顏色 GROUP_COLOR : TColor; //被選中的分組字型顏色 EDITING_COLOR : TColor; //修改時介面顏色 HIDE_DIRECTION : string; //窗體隱藏方向 sTypeLoadFlag : string; //型別載入標識（用於不重複載入） procedure WMMouseEnter(var Msg: TMessage); message WM_MouseEnter; procedure QNLoadType(); public { Public declarations } end; var FormUse: TFormUse; sPath: string; sType: string; hInNow : HKL; //當前輸入法 keyValue : string; //按鍵查詢 isEditing : Boolean; //是否是編輯狀態 RWindowProc: TWndMethod; LWindowProc: TWndMethod; OldBtn : TRzBitBtn; implementation uses registry, shlobj, ActiveX, ComObj, ShellAPI; {$R *.dfm} {**************************************************************** * 過程名稱: Openqry * 功能描述: 資料庫查詢 * 引數說明: TADOQuery，string * 返 回 值: 無 * 歷史記錄: 2013.1.28 created by xzj *****************************************************************} procedure TFormUse.Openqry(var qry1 : TADOQuery; sqltxt : string); begin with qry1 do begin Close; sql.clear; sql.add(sqltxt); Open; end; end; {**************************************************************** * 過程名稱: Execqry * 功能描述: 資料庫操作 * 引數說明: TADOQuery，string * 返 回 值: 無 * 歷史記錄: 2013.1.28 created by xzj *****************************************************************} procedure TFormUse.Execqry(var qry1 : TADOQuery; sqltxt : string); begin with qry1 do begin Close; sql.clear; sql.add(sqltxt); ExecSQL; end; end; {**************************************************************** * 過程名稱: WMMouseEnter * 功能描述: 滑鼠碰到隱藏的窗體，窗體下拉 * 引數說明: TMessage * 返 回 值: 無 * 歷史記錄: 2013.1.28 created by xzj *****************************************************************} procedure TFormUse.WMMouseEnter(var Msg: TMessage); var iIndex : Integer; begin if (Top < 0) and (HIDE_DIRECTION = '向上隱藏') then begin //while(Top < 0) do //begin // iIndex := 10; // Top := Top + 2; // while(iIndex > 0) do // begin // iIndex := iIndex - 1; // end; //end; Top := 0; //為保證下拉窗體後呈現在最前面 SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); //將窗體推到最前 //發現不取消效果更好 SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); //然後取消窗體最前 end else if (Left < 0) and (HIDE_DIRECTION = '向左隱藏') then begin Left := 0; //為保證下拉窗體後呈現在最前面 SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); //將窗體推到最前 //發現不取消效果更好 SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); //然後取消窗體最前 end else if ((Left + Self.Width) > screen.Width) and (HIDE_DIRECTION = '向右隱藏') then begin Left := Screen.Width - Self.Width; //為保證下拉窗體後呈現在最前面 SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); //將窗體推到最前 //發現不取消效果更好 SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); //然後取消窗體最前 end else if ((Top + Self.Height) > Screen.Height) and (HIDE_DIRECTION = '向下隱藏') then begin Top := Screen.Height - Self.Height; //為保證下拉窗體後呈現在最前面 SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); //將窗體推到最前 //發現不取消效果更好 SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); //然後取消窗體最前 end; Tmr1.Enabled := True; end; {**************************************************************** * 過程名稱: GetTempDirectory * 功能描述: 取系統臨時路徑 * 引數說明: 無 * 返 回 值: string 路徑 * 歷史記錄: 2013.1.28 created by xzj *****************************************************************} function GetTempDirectory: string; var TempDir: array[0..255] of Char; begin GetTempPath(255, @TempDir); Result := StrPas(TempDir); end; {**************************************************************** * 過程名稱: QNLoadType * 功能描述: 載入型別選擇按鈕 * 引數說明: 無 * 返 回 值: 無 * 歷史記錄: 2013.1.28 created by xzj *****************************************************************} procedure TFormUse.QNLoadType(); var i, j,k,nRand : Integer; bmpName : string; begin Randomize; with qryCmd do begin Close; SQL.Clear; SQL.Add('select * from PRO_TYPE'); Open; end; //載入前釋放所有記憶體，防止記憶體衝突 for k := 1 to 49 do begin if abtnType[k] <> nil then begin abtnType[k].Destroy; abtnType[k] := nil; end; end; nRand := Random(97) + 1; qryCmd.First; //預設讓第一個按鈕為‘所有程式’ abtnType[1] := TRzBitBtn.Create(Self); abtnType[1].Height := 30; abtnType[1].Width := tntscrlbxType.Width - 5; abtnType[1].Top := 1; abtnType[1].Left := tntscrlbxType.Left; abtnType[1].Name := 'btn_0'; abtnType[1].Parent := tntscrlbxType; abtnType[1].Caption := '所有程式'; abtnType[1].ParentColor := True; abtnType[1].ParentFont := True; bmpName := 'emotions\' + IntToStr(nRand) + 'fixed.bmp'; abtnType[1].Glyph.LoadFromFile(bmpName); abtnType[1].OnClick := BtnTypeClick; abtnType[1].Visible := True; OldBtn := abtnType[1]; for i := 1 to qryCmd.RecordCount do begin nRand := Random(95) + 1; abtnType[i + 1] := TRzBitBtn.Create(Self); abtnType[i + 1].Height := 30; abtnType[i + 1].Width := tntscrlbxType.Width - 5; j := trunc(i / 1); abtnType[i + 1].Top := 1 + (abtnType[i + 1].Height + 1) * j; j := i mod 1; abtnType[i + 1].Left := abtnType[i + 1].Width * (j); abtnType[i + 1].Name := 'btn_' + inttostr(i + 1); abtnType[i + 1].Parent := tntscrlbxType; abtnType[i + 1].Caption := qryCmd.FieldByName('PRO_TYPE').Value; abtnType[i + 1].ParentColor := True; abtnType[i + 1].ParentFont := True; abtnType[i + 1].PopupMenu := tntpmnOperbtn; bmpName := 'emotions\' + IntToStr(nRand + 1) + 'fixed.bmp'; abtnType[i + 1].Glyph.LoadFromFile(bmpName); abtnType[i + 1].OnClick := BtnTypeClick; abtnType[i + 1].Visible := True; //nNewTop := abtnType[i + 1].Top + 31; qryCmd.next; end; tntpgcntrl1.Visible := False; end; {**************************************************************** * 過程名稱: LoadShortcutKey * 功能描述: 載入快捷方式 * 引數說明: Sender : TObject * 返 回 值: 無 * 歷史記錄: 2013.1.28 created by xzj *****************************************************************} procedure TFormUse.LoadShortcutKey(Sender : TObject); var i : Integer; lListItem: TListItem; bmp: TBitmap; sFilePath: string; begin qryCmd.First; il1.Clear; lvPro.Clear; for i := 0 to qryCmd.RecordCount - 1 do begin lListItem := lvPro.Items.Add; lListItem.Caption := Trim(qryCmd.fieldbyname('PRO_NAME').value); lListItem.ImageIndex := i; anID[lListItem.ImageIndex] := qryCmd.fieldbyname('ID').value; //讀取程式圖示 sFilePath := qryCmd.FieldByName('PRO_PATH').Value; if (LowerCase(ExtractFileExt(sFilePath))) = '' then image1.Picture := ImageFiles.Picture else if (LowerCase(ExtractFileExt(sFilePath))) = '.txt' then image1.Picture := ImageTxt.Picture else if ((LowerCase(ExtractFileExt(sFilePath))) = '.rar') or ((LowerCase(ExtractFileExt(sFilePath))) = '.zip') then image1.Picture := ImageRAR.Picture else if (LowerCase(ExtractFileExt(sFilePath))) = '.mdb' then image1.Picture := ImageMDB.Picture else if (LowerCase(ExtractFileExt(sFilePath))) = '.xls' then image1.Picture := Imagexls.Picture else if ((LowerCase(ExtractFileExt(sFilePath))) = '.doc') or ((LowerCase(ExtractFileExt(sFilePath))) = '.docx') then image1.Picture := Imagedoc.Picture else if (LowerCase(ExtractFileExt(sFilePath))) = '.ppt' then image1.Picture := Imageppt.Picture else if (LowerCase(ExtractFileExt(sFilePath))) = '.pdf' then image1.Picture := Imagepdf.Picture else if (LowerCase(ExtractFileExt(sFilePath))) = '.psd' then image1.Picture := Imagepsd.Picture else if ((LowerCase(ExtractFileExt(sFilePath))) = '.jpg') or ((LowerCase(ExtractFileExt(sFilePath))) = '.bmp') or ((LowerCase(ExtractFileExt(sFilePath))) = '.jpeg') or ((LowerCase(ExtractFileExt(sFilePath))) = '.gif') or ((LowerCase(ExtractFileExt(sFilePath))) = '.cdr') then image1.Picture := ImagePhoto.Picture else if (LowerCase(ExtractFileExt(sFilePath))) = '.dpr' then image1.Picture := Imagedpr.Picture else if (LowerCase(ExtractFileExt(sFilePath))) = '.dfm' then image1.Picture := Imagedfm.Picture else if (LowerCase(ExtractFileExt(sFilePath))) = '.pas' then image1.Picture := Imagepas.Picture else if (LowerCase(ExtractFileExt(sFilePath))) = '.dll' then image1.Picture := Imagedll.Picture else if (LowerCase(ExtractFileExt(sFilePath))) = '.bat' then image1.Picture := Imagebat.Picture else if (LowerCase(ExtractFileExt(sFilePath))) = '.exe' then image1.Picture.Icon.handle := ExtractIcon(hInstance, pchar(sFilePath), 0) else image1.Picture := Imagewz.Picture; bmp := TBitmap.Create; bmp.width := image1.Picture.Width; bmp.height := image1.Picture.Height; bmp.canvas.Draw(0, 0, image1.Picture.Graphic); bmp.SaveToFile(GetTempDirectory + 'QNsystem.bmp'); image2.Picture.LoadFromFile(GetTempDirectory + 'QNsystem.bmp'); il1.Add(image2.Picture.Bitmap, image2.Picture.bitmap); qryCmd.Next; end; qryCmd.Close; end; {**************************************************************** * 過程名稱: BtnTypeClick * 功能描述: 型別按鈕響應 * 引數說明: Sender : TObject * 返 回 值: 無 * 歷史記錄: 2013.1.28 created by xzj * 修改描述： 2013.2.3 modified by xzj * 新增按鈕顏色改變功能，當前分組變為綠色 * 2013.2.17 modified by xzj * 如果型別選擇與先前一樣則不重複載入快捷方式 * 2013.2.18 modified by xzj * 修改2.17所修改的不重複載入，編輯後重新整理問題 *****************************************************************} procedure TFormUse.BtnTypeClick(Sender : TObject); var sqltxt : string; begin keyValue := ''; //按鈕直接查詢要用的初始化 if ActiveControl.ClassType <> TRzBitBtn then Exit; if Copy(ActiveControl.Name,1,4) <> 'btn_' then Exit; sType := TRzBitBtn(Sender).Caption; if (sTypeLoadFlag = sType) and (isEditing = false) then begin tntpgcntrl2.ActivePage := pg3; Exit; end; //按鈕顏色改變 sTypeLoadFlag := sType; OldBtn.Font.Color := FONT_COLOR; OldBtn.ParentFont := True; TRzBitBtn(Sender).Font.Color := GROUP_COLOR; OldBtn := TRzBitBtn(Sender); if TRzBitBtn(Sender).Name = 'btn_0' then begin sqltxt := 'select * from PRO_LIST order by PRO_NAME'; end else begin sqltxt := 'select * from PRO_LIST where PRO_TYPE = ''' + sType + ''' order by PRO_NAME'; end; with qryCmd do begin Close; SQL.Clear; SQL.Add(sqltxt); Open; end; sActiveBtn := sType; edtnow.Text := sActiveBtn; pg3.Caption := sActiveBtn; LoadShortcutKey(Sender); tntpgcntrl2.ActivePage := pg3; end; {**************************************************************** * 過程名稱: FormCreate * 功能描述: 資料庫連線，載入分組 * 引數說明: Sender : TObject * 返 回 值: 無 * 歷史記錄: 2013.1.29 created by xzj *****************************************************************} procedure TFormUse.FormCreate(Sender: TObject); var sDir, connTmp: string; begin getdir(0, sPath); sDir := ExtractFilePath(Application.ExeName); chDir(sDir); // 設定工作目錄為程式目錄。 SetCurrentDir(sDir); connTmp := 'Provider=Microsoft.ACE.OLEDB.12.0;Data Source=' + sDir + '\LIST.accdb;Persist Security Info=False'; con1.ConnectionString := connTmp; con1.Open; TOP := 0; LEFT := 0; FormUse.Width := screen.Width div 2 - 20; FormUse.Height := screen.Height - 32; tntpgcntrl2.Align := alclient; lvPro.Align := alclient; InitForm(); QNLoadType; //載入型別按鈕 end; {**************************************************************** * 過程名稱: tmr1Timer * 功能描述: 滑鼠不在軟體介面時自動隱藏介面 * 引數說明: Sender : TObject * 返 回 值: 無 * 歷史記錄: 2013.1.29 created by xzj * 修改描述: 2013.2.1 modified by xzj * 添加發送桌面快捷方式控制 *****************************************************************} procedure TFormUse.tmr1Timer(Sender: TObject); var rc: TRECT; pt: TPOINT; begin if isEditing = True then begin Exit; end; GetWindowRect(self.Handle, rc); //取窗體的矩形區域 GetCursorPos(pt); //取得當前滑鼠所在位置 if (not PtInRect(rc, pt)) then //如果滑鼠不在窗體範圍內 begin if (HIDE_DIRECTION = '向上隱藏') then //如果目前窗體正吸附在螢幕上沿，則上移隱藏窗體 begin Top := 0 - Height + 2; end else if (HIDE_DIRECTION = '向下隱藏') then begin Top := Screen.Height - 2; end else if (HIDE_DIRECTION = '向左隱藏') then begin Left := 0 - Self.Width + 2; Top := 0; end else begin Left := Screen.Width - 2; Top := 0; end; Tmr1.Enabled := False; //窗體隱藏後定時器關閉 SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); //將窗體推到最前 end; end; {**************************************************************** * 過程名稱: edtAddKeyPress * 功能描述: 新增新分組，使用回車鍵按鈕事件來修改資料庫內容 * 引數說明: Sender: TObject; var Key: Char * 返 回 值: 無 * 歷史記錄: 2013.1.29 created by xzj * 修改描述: 2013.2.1 modified by xzj * 控制分組名不為空 *****************************************************************} procedure TFormUse.edtAddKeyPress(Sender: TObject; var Key: Char); var sqltxt : string; begin if Key = #13 then begin if edtAdd.Text = '' then begin ShowMessagePos('類名不能為空',(Self.Left + 250),(Self.Top + 300)); exit; end; sqltxt := 'select * from PRO_TYPE where PRO_TYPE = ''' + edtAdd.Text + ''' '; with qryCmd do begin Close; SQL.Clear; SQL.Add(sqltxt); Open; end; if(qryCmd.RecordCount > 0) then begin ShowMessagePos('已存在名為' + edtAdd.Text + '的類別！',(Self.Left + 250),(Self.Top + 300)); exit; end; sqltxt := 'insert into PRO_TYPE(PRO_TYPE) values(''' + edtAdd.Text + ''') '; with qryCmd do begin Close; SQL.Clear; SQL.Add(sqltxt); ExecSQL; end; edtAdd.Text := '按回車鍵確認'; QNLoadType; //重新載入分組 end; end; {**************************************************************** * 過程名稱: tntmntmAddClick * 功能描述: 新增新分組，顯示輸入框 * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.29 created by xzj *****************************************************************} procedure TFormUse.tntmntmAddClick(Sender: TObject); begin tntpgcntrl1.visible := True; tntpgcntrl1.activepage := pg1; edtAdd.SetFocus; end; {**************************************************************** * 過程名稱: edtEdtKeyPress * 功能描述: 修改分組，使用回車鍵按鈕事件來修改資料庫內容 * 引數說明: Sender: TObject; var Key: Char * 返 回 值: 無 * 歷史記錄: 2013.1.29 created by xzj *****************************************************************} procedure TFormUse.edtEdtKeyPress(Sender: TObject; var Key: Char); var sqltxt,sqlEdtType,sqlEdtList : string; begin if sActiveBtn = '' then begin ShowMessagePos('請選中要修改的類別！',(Self.Left + 250),(Self.Top + 300)); exit; end; sqlEdtType := 'update PRO_TYPE set PRO_TYPE = ''' + edtEdt.Text +''' where PRO_TYPE = ''' + sActiveBtn + ''' '; sqlEdtList := 'update PRO_LIST set PRO_TYPE = ''' + edtEdt.Text +''' where PRO_TYPE = ''' + sActiveBtn + ''' '; if Key = #13 then begin if edtEdt.Text = '' then begin ShowMessagePos('類名不能為空',(Self.Left + 250),(Self.Top + 300)); exit; end; sqltxt := 'select * from PRO_TYPE where PRO_TYPE = ''' + edtEdt.Text + ''' '; Openqry(qrycmd,sqltxt); if(qryCmd.RecordCount > 0) then begin ShowMessagePos('已存在名為' + edtEdt.Text + '的類別！',(Self.Left + 250),(Self.Top + 300)); exit; end else begin Execqry(qryCmd,sqlEdtType); Execqry(qrycmd,sqlEdtList); end; edtAdd.Text := '按回車鍵確認'; QNLoadType; //重新載入分組 end; end; {**************************************************************** * 過程名稱: tntmntmqxClick * 功能描述: 取消操作，隱藏新增和修改的page * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.29 created by xzj *****************************************************************} procedure TFormUse.tntmntmqxClick(Sender: TObject); begin tntpgcntrl1.visible := False; end; {**************************************************************** * 過程名稱: lvProDblClick * 功能描述: 雙擊快捷方式執行相應的程式 * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj * 修改描述: * 2013.1.31 modified by xzj * 處於編輯狀態不讓執行程式 *****************************************************************} procedure TFormUse.lvProDblClick(Sender: TObject); var sActive,sqltxt : string; begin if not Assigned(lvPro.Selected) then //沒有選中快捷方式，執行無效 begin Exit; end else if isEditing = True then begin ShowMessagePos('現在處於編輯狀態，請退出編輯',(Self.Left + 250),(Self.Top + 300)); exit; end else begin //獲取被選中的快捷方式在資料庫中對應的ID sActive := IntToStr(anID[lvPro.Selected.ImageIndex]); //查詢對應的快捷方式記錄 sqltxt := 'select * from PRO_LIST where ID = ' + sActive + ''; Openqry(qryCmd,sqltxt); //找到記錄中的快捷方式路徑，開啟.exe檔案 ShellExecute(handle, 'open', pchar(Trim(qryCmd.FieldByName('PRO_PATH').Value)), nil, nil, SW_SHOWNORMAL); //執行程式後隱藏窗體 if (HIDE_DIRECTION = '向上隱藏') then begin Top := 0 - Height + 2; end else if (HIDE_DIRECTION = '向下隱藏') then begin Top := Screen.Height - 2; end else if (HIDE_DIRECTION = '向左隱藏') then begin Left := 0 - Self.Width + 2; Top := 0; end else begin Left := Screen.Width - 2; Top := 0; end; //窗體隱藏後定時器關閉 Tmr1.Enabled := False; end; end; {**************************************************************** * 過程名稱: tntmntmTailClick * 功能描述: 修改檢視方式為‘詳情’ * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj *****************************************************************} procedure TFormUse.tntmntmTailClick(Sender: TObject); begin lvPro.ViewStyle := vsSmallIcon; tntmntmTail.Checked := True; tntmntmList.Checked := False; tntmntmdefault.Checked := False; end; {**************************************************************** * 過程名稱: tntmntmListClick * 功能描述: 修改檢視方式為‘列表’ * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj *****************************************************************} procedure TFormUse.tntmntmListClick(Sender: TObject); begin lvPro.ViewStyle := vsList; tntmntmTail.Checked := False; tntmntmList.Checked := True; tntmntmdefault.Checked := False; end; {**************************************************************** * 過程名稱: tntmntmdefaultClick * 功能描述: 修改檢視方式為‘預設’ * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj *****************************************************************} procedure TFormUse.tntmntmdefaultClick(Sender: TObject); begin lvPro.ViewStyle := vsIcon; tntmntmTail.Checked := False; tntmntmList.Checked := False; tntmntmdefault.Checked := True; end; {**************************************************************** * 過程名稱: tntmntmEdtProClick * 功能描述: 進入編輯狀態，做好編輯準備 * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj *****************************************************************} procedure TFormUse.tntmntmEdtProClick(Sender: TObject); begin //防止使用者多次點選編輯按鈕 if isEditing = True then begin Exit; end; tntmntmEdtPro.Checked := True; //標示進入編輯狀態 isEditing := True; //介面變色，提示使用者現在是編輯狀態 lvPro.Color := EDITING_COLOR; if tntmntmEdtPro.Checked = True then begin //快捷方式進入可編輯狀態 lvPro.ReadOnly := False; //新增快捷方式時使用拖曳方式 LWindowProc := lvPro.WindowProc; lvPro.WindowProc := LBWindowProc; DragAcceptFiles(lvPro.Handle, True); //刪除按鈕可用 tntmntmDelPro.Enabled := True; //完成按鈕可用 tntmntmWc.Enabled := True; //刪除所有按鈕可用 tntmntmdelall.Enabled := True; end; if tntmntmhide.Checked = True then tntmntmhide.Click; tntmntmhide.Enabled := False; end; {**************************************************************** * 過程名稱: tntmntmWcClick * 功能描述: 編輯完成，做的與進入編輯狀態相反 * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj *****************************************************************} procedure TFormUse.tntmntmWcClick(Sender: TObject); begin lvPro.Color := SYS_COLOR; lvPro.ParentColor := True; //lvPro.ParentFont := True; isEditing := False; tntmntmEdtPro.Checked := False; tntmntmDelPro.Enabled := False; tntmntmWc.Enabled := False; tntmntmdelall.Enabled := False; lvPro.ReadOnly := True; tntmntmhide.Enabled := True; //關閉拖曳 lvPro.WindowProc := LWindowProc; DragAcceptFiles(lvPro.Handle, False); end; {**************************************************************** * 過程名稱: tntmntmEdtProClick * 功能描述: 取快捷連結的目標檔案 * 引數說明: const linkname: string * 返 回 值: string * 歷史記錄: 2013.1.30 created by xzj *****************************************************************} function ExeFromLink(const linkname: string): string; var link: IShellLink; storage: IPersistFile; filedata: TWin32FindData; buf: array[0..MAX_PATH] of Char; widepath: WideString; begin OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLink, link)); OleCheck(link.QueryInterface(IPersistFile, storage)); widepath := linkname; Result := '無效的快捷方式！快捷連結已失效！'; if Succeeded(storage.Load(@widepath[1], STGM_READ)) then if Succeeded(link.Resolve(GetActiveWindow, SLR_NOUPDATE)) then if Succeeded(link.GetPath(buf, sizeof(buf), filedata, SLGP_UNCPRIORITY)) then Result := buf; storage := nil; link := nil; end; {**************************************************************** * 過程名稱: LBWindowProc * 功能描述: 輔助拖曳 * 引數說明: Message: TMessage * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj *****************************************************************} procedure TFormUse.LBWindowProc(var Message: TMessage); begin if Message.Msg = WM_DROPFILES then WMDROPFILES_l(Message); LWindowProc(Message); end; {**************************************************************** * 過程名稱: WMDROPFILES_L * 功能描述: 新增快捷方式 * 引數說明: Message: TMessage * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj *****************************************************************} procedure TFormUse.WMDROPFILES_L(var Msg: TMessage); var pcFileName: PChar; i, iSize, iFileCount: integer; v_ps: string; sCutPath : string; sCutName : string; sqltxt : string; begin pcFileName := ''; iFileCount := DragQueryFile(Msg.wParam, $FFFFFFFF, pcFileName, 255); for i := 0 to iFileCount - 1 do begin iSize := DragQueryFile(Msg.wParam, i, nil, 0) + 1; pcFileName := StrAlloc(iSize); DragQueryFile(Msg.wParam, i, pcFileName, iSize); // if FileExists(pcFileName) then //判斷是否存在 v_ps := pcFileName; StrDispose(pcFileName); end; DragFinish(Msg.wParam); //Delphi取快捷方式的目標路徑 if LowerCase(ExtractFileExt(v_ps)) = '.lnk' then //判斷是否為快捷字尾檔案 sCutPath := ExeFromLink(v_ps) else sCutPath := LowerCase(v_ps); sCutName := ExtractFilename(sCutPath); sqltxt := 'insert into PRO_LIST(PRO_TYPE,PRO_NAME,PRO_PATH) ' + 'values(''' + sActiveBtn + ''', ''' + copy(sCutName, 1, pos(ExtractFileExt(sCutName), sCutName) - 1) + ''', ''' + sCutPath + ''') '; Execqry(qryCmd,sqltxt); //使用滑鼠移動事件重新整理 lvPro.Tag := 1; end; {**************************************************************** * 過程名稱: tntmntmDelProClick * 功能描述: 刪除快捷方式 * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj *****************************************************************} procedure TFormUse.tntmntmDelProClick(Sender: TObject); var sqltxt : string; begin if not Assigned(lvPro.Selected) then begin Exit; end; sqltxt := 'delete from PRO_LIST where ID = ' + IntToStr(anID[lvPro.Selected.ImageIndex]) + ' '; Execqry(qryCmd,sqltxt); //使用滑鼠移動事件重新整理 lvPro.Tag := 1; end; {**************************************************************** * 過程名稱: FormShow * 功能描述: 佈置進入介面初始狀態 * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj * 修改描述： 2013.2.1 modified by xzj * 如果本程式開機自啟動，則選單按鈕開機自啟動選中 * 2013.2.21 modified by xzj * 新增隱藏項的初始化 *****************************************************************} procedure TFormUse.FormShow(Sender: TObject); var reg : TRegistry; isExist : Boolean; begin ActiveControl := abtnType[1]; abtnType[1].click; tntpgcntrl2.ActivePage := pg3; pg3.Caption := sActiveBtn; rztrycn1.Hint := '淺諾桌面管理工具v1.0'; GetSystemPath(); Reg := Tregistry.Create; Reg.RootKey := HKEY_LOCAL_MACHINE; reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Run', True); isExist := reg.ValueExists('淺諾桌面管理工具v1.0'); if isExist = True then begin tntmntmAutoOpen.Checked := True; end else begin tntmntmAutoOpen.Checked := False; end; lblName.Font.Size := 20; AddInitForm(); //skndt1.LoadFromCollection(sknstr1,4); //skndt1.Active := True; end; {**************************************************************** * 過程名稱: tntmntmEditClick * 功能描述: 顯示修改分組框 * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj *****************************************************************} procedure TFormUse.tntmntmEditClick(Sender: TObject); begin tntpgcntrl1.visible := True; pg2.Visible := True; tntpgcntrl1.activepage := pg2; pg1.Visible := False; edtnow.Text := sActiveBtn; edtEdt.SetFocus; end; {**************************************************************** * 過程名稱: tntmntmdeleteClick * 功能描述: 刪除已選中分組 * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj *****************************************************************} procedure TFormUse.tntmntmdeleteClick(Sender: TObject); var sqltxt : string; begin if Application.MessageBox(System.Pchar('是否要刪除' + sActiveBtn + '?'), '詢問', 1 + 32) = id_OK then begin sqltxt := 'delete from PRO_TYPE where PRO_TYPE = ''' + sActiveBtn + ''' '; with qryCmd do begin Close; SQL.Clear; SQL.Add('select * from PRO_LIST where PRO_TYPE = ''' + sActiveBtn + ''' '); Open; if IsEmpty then begin Close; SQL.Clear; SQL.Add(sqltxt); ExecSQL; end else begin ShowMessagePos('要刪除的類別下有程式，不可刪除！',(Self.Left + 250),(Self.Top + 300)); end; end; QNLoadType; ActiveControl := abtnType[1]; abtnType[1].Click; pg3.Caption := abtnType[1].Caption; end; end; {**************************************************************** * 過程名稱: tntmntmhideClick * 功能描述: 顯示和隱藏分組 * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.30 created by xzj *****************************************************************} procedure TFormUse.tntmntmhideClick(Sender: TObject); var sqltxt : string; begin if tntmntmhide.Checked = True then begin tntmntmhide.Checked := False; tntscrlbxType.Visible := True; sqltxt := 'update PRO_SET set SHOW_TYPE = True where ID = 1 '; end else begin tntmntmhide.Checked := True; tntscrlbxType.Visible := False; sqltxt := 'update PRO_SET set SHOW_TYPE = False where ID = 1 '; end; Execqry(qryCmd,sqltxt); if tntmntmTail.Checked = True then begin tntmntmList.Click; tntmntmTail.Click; end else if tntmntmList.Checked = True then begin tntmntmTail.Click; tntmntmList.Click; end else begin tntmntmList.Click; tntmntmdefault.Click; end; end; {**************************************************************** * 過程名稱: lvProMouseMove * 功能描述: 顯示操作幫助，修改快捷方式後重新整理 * 引數說明: Sender: TObject; Shift: TShiftState; X,Y: Integer * 返 回 值: 無 * 歷史記錄: 2013.1.31 created by xzj * 修改描述: 2013.2.21 modified by xzj * 新增滑鼠拖動窗體效果 *****************************************************************} procedure TFormUse.lvProMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var i : Integer; begin if isEditing = False then begin lvPro.Hint := '雙擊圖示可開啟檔案'; end else begin lvPro.Hint := '將快捷方式拖入本框即可新增'; //修改快捷方式後重新整理 if(lvPro.Tag = 1) then begin for i := 1 to 49 do begin if abtnType[i] <> nil then begin if abtnType[i].Caption = sActiveBtn then begin ActiveControl := abtnType[i]; abtnType[i].Click; Break; end; end; end; lvPro.Tag := 0; end; end; lvPro.ShowHint := True; { //獲取當前輸入法 hInNow := GetKeyboardLayout(0); for i := 0 to Screen.Imes.Count - 1 do begin if HKL(Screen.Imes.Objects[i]) = hInNow then begin //ShowMessage(Screen.Imes.Strings[i]); Break; end; end; } //拖動窗體 if (ssleft in Shift) then begin ReleaseCapture; Perform(WM_syscommand, $F012, 0); end; end; {**************************************************************** * 過程名稱: tntmntmdelallClick * 功能描述: 刪除所有的快捷方式，並初始化資料庫表 * 引數說明: Sender: TObject * 返 回 值: 無 * 歷史記錄: 2013.1.31 created by xzj *****************************************************************} procedure TFormUse.tntmntmdelallClick(Sender: TObject); var sqltxt : string; begin if Application.MessageBox(System.Pchar('是否要刪除所有程式?'), '詢問', 1 + 32) = id_OK then begin sqltxt := 'delete from PRO_LIST'; Execqry(qryCmd,sqltxt); sqltxt := 'Alter table[PRO_LIST] Alter column[I