| function GetKbStatus():string; //返回當前鍵盤狀態，包括NumLoce、Caps Lock、Insert //每個狀態信息佔兩個字符，順序為:NumLoce、Caps Lock、Insert //Copy Right 549@11:29 2003-7-22 var Status:string; KeyStates:TKeyboardState; begin GetKeyboardState(KeyStates); if Odd(KeyStates[VK_NUMLOCK])then Status:='數字' else Status:='光標'; if Odd(KeyStates[VK_CAPITAL]) then Status:=status+'大寫' else Status:=status+'小寫'; if Odd(KeyStates[VK_INSERT]) then Status:=status+'插入' else Status:=status+'改寫'; Result:=Status; end;小技巧： const ErrHead='操作出現錯誤，錯誤信息為：'+#13 try ... except on E: Exception do showmessage(ErrHead+E.Message+#13+'當前操作為：xxxxx'); end; 可以讓用戶看到更多的錯誤信息，有助於客戶反饋程序錯誤。俺寫得比較菜的，但是經常用的就是：//>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> //執行Sql //輸入參數：SqlString, ADOQuery //類型： string, TADOQuery PRocedure TMainForm.ExeSql(SqlString: string; ADOQuery: TADOQuery); begin with ADOQuery do begin Connection := DM.DBAccinfo;//這個是我的，可以添加用的connection //或者用use也可以。 if Active then Active := False; Open; SQL.Clear; SQL.Add(SqlString); ExecSQL; Close; end; end;可能大家都知道這個。不過，我見過的代碼裡面，好像很少人這麼來寫這麼獨立出來一個過程。這個保證我自己原創…… //Open Adoquery //根據reallike(愛翔(只有lizzy可以叫其他人不能)) 的過程改編 //支持多行sql //可根據需要自己修改成只支持單行sql的過程，或者exesql過程 //Delphi6下測試通過。 procedure OpenSql(SqlString: tstrings; ADOQuery: TADOQuery); var i:integer; begin with ADOQuery do begin Close; SQL.Clear; for i:=0 to sqlstring.Count-1 do SQL.Add(SqlString[i]); try Open; except on e:exception do showmessage('錯誤：信息如下'+#13+e.Message); end; end; end; 這個是單行sql的 procedure OpenSql1(SqlString: string; ADOQuery: TADOQuery); begin with ADOQuery do begin Close; SQL.Clear; SQL.Add(SqlString); try Open; except on e:exception do showmessage('錯誤：信息如下'+#13+e.Message); end; end; end; 嗬嗬，謝謝幫我修理這個東西。不過你不使用Execsql嗎？我一般都在這個過程外面加try也就是引用他的地方。也就是Try Exesql(sqlstring, Adoquery1) except //錯誤提示，亂七八糟的東西。 end to: reallike(愛翔(只有lizzy可以叫其他人不能)) ExecSql的我也做了 //ExecSql Adoquery //支持多行sql //可根據需要自己修改成只支持單行sql的過程，或者exesql過程 //Delphi6下測試通過。 procedure ExeSql(SqlString: tstrings; ADOQuery: TADOQuery); var i:integer; begin with ADOQuery do begin Close; SQL.Clear; for i:=0 to sqlstring.Count-1 do SQL.Add(SqlString[i]); try ExecSql; except on e:exception do showmessage('錯誤：信息如下'+#13+e.Message); end; end; end; //我覺得except放在哪裡都一樣，放在外面好一點，因為，你可以添加一些其他的調試信息 //你說呢？ //有沒有人把執行單行和執行多行的這兩個過程合併成一個，那樣就好了。 我也來兩個，可以根據自己的需要進行增刪，不過是針對DBGridEh的：//動態建立Col procedure BuildCol(vFieldName: string; vCaption: string; vWidth: Integer; var vGrid: TDBGridEh; iTag: Integer = 0; FooterType: TFooterValueType = fvtNon; FooterText: string = ''; boolReadOnly: Boolean = True; vColor: TColor = clBtnFace); var cCol: TDBGridColumnEh; cFooterCol: TColumnFooterEh; begin cCol := TDBGridColumnEh.Create(vGrid.Columns); cCol.FieldName := vFieldName; cCol.Width := vWidth; cCol.Title.Caption := vCaption; cCol.Title.Alignment := taCenter; cCol.Title.Color := vColor; cCol.ReadOnly := boolReadOnly; //如果tag值為-1，則打印dbgrid時不打印該列 cCol.Tag := iTag; if FooterType <> fvtNon then begin cFooterCol := cCol.Footers.Add; cFooterCol.ValueType := FooterType; if FooterType = fvtStaticText then begin vGrid.FooterRowCount := 1; cFooterCol.Value := FooterText; end; //cCol.Footer.FieldName:=; end; end;procedure TitleBtnClick(Sender: TObject; ACol: Integer; Column: TColumnEh; cdsHelper: TClientDataSetHelper); var cdsTmp: TClientDataSet; begin with (Sender as TDBGridEh) do begin cdsTmp := (DataSource.DataSet as TClientDataSet); if not cdsTmp.Active then Exit; //設置當前行的排序方式 if Column.Title.SortMarker = smNoneEh then begin Column.Title.SortMarker := smUpEh; cdsHelper.SortByField(Column.FieldName, soAscending); end else if Column.Title.SortMarker = smUpEh then begin Column.Title.SortMarker := smDownEh; cdsHelper.SortByField(Column.FieldName, soDescending); end else begin Column.Title.SortMarker := smNoneEh; cdsHelper.SortByField(Column.FieldName, soNoSort); end; end; end;將DBGrid中各列的位置以及寬度記錄入Ini文件，以及從Ini文件讀取DBGrid中各列位置以及寬度的函數 procedure f_ReadIni(const Now_DBGrid:TDBGrid;Form_Name:String); var FilePath:String; MyIniFile:Tinifile; Grid_Name,Field_Name:String; Width:integer; i,j,n:integer; Column:Array[0..100] of String; Widths:Array[0..100] of integer; begin FilePath := ExtractFilePath(application.ExeName); MyIniFile:=TiniFile.Create(FilePath+'gsp.ini'); Grid_Name :=Form_Name+','+Now_DBGrid.Name; n:= Now_DBGrid.Columns.Count-1 ; for i:=0 to 100 do column[i]:=''; for i:=0 to n do begin Field_Name:=Now_DBGrid.Columns[i].FieldName; j:=MyIniFile.ReadInteger(Grid_Name,Field_Name,i); Column[j]:=Field_Name; Widths[j] :=MyIniFile.ReadInteger(Grid_Name,Field_Name+'_Width',Now_DBGrid.Columns[i].Width); end; for i:=0 to n do begin Now_DBGrid.Columns[i].FieldName := Column[i]; Now_DBGrid.Columns[i].Width := Widths[i]; end; MyIniFile.Destroy; end;procedure f_WriteIni(const Now_DBGrid:TDBGrid;Form_Name:String); var FilePath:String; MyIniFile:Tinifile; Grid_Name,Field_Name:String; Width:Integer; i:integer; begin FilePath := ExtractFilePath(Application.ExeName); MyIniFile:=TiniFile.Create(FilePath+'gsp.ini'); Grid_Name :=Form_Name+','+Now_DBGrid.Name; for i:=0 to Now_DBGrid.Columns.Count-1 do begin Field_Name := Now_DBGrid.Columns[i].FieldName; Width := Now_DBGrid.Columns[i].Width; MyIniFile.WriteInteger(Grid_Name,Field_Name,i); MyIniFile.WriteInteger(Grid_Name,Field_Name+'_Width',Width); end; MyIniFile.Destroy; end;很久以前寫得的，現在我都用類封裝了。 unit MyFunc;interface uses Windows, SysUtils, MMSystem, WinSvc, Registry;function CopyStrLeft(ch: Char; str: string): string; function CopyStrRight(ch: Char; str: string): string; function GetSelfPath: string; procedure HideTask(bHide: Boolean); function SoundCardInstalled: Boolean; function GetHostip: String; procedure DisableSvc(SvcName: string); function GetRegisteredOwner: string; function GetRegisteredOrganization: string;implementationfunction RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';function CopyStrLeft(ch: Char; str: string): string; begin Result:= Copy(str, 1, Pos(ch, str)-1) end;function CopyStrRight(ch: Char; str: string): string; begin Result:= Copy(str, Pos(ch, str)+1, Length(str)-Pos(Ch, str)+1) end;function GetSelfPath: string; begin Result:= ExtractFilePath(ParamStr(0)) end;procedure HideTask(bHide: Boolean); begin if bHide then RegisterServiceProcess(GetCurrentProcessID, 1) else RegisterServiceProcess(GetCurrentProcessID, 0); end;function SoundCardInstalled: Boolean; begin Result:= WaveOutGetNumDevs >0 end;function GetHostIP: String; type TaPInAddr = Array[0..10] of PInAddr; PaPInAddr = ^TaPInAddr; var phe: PHostEnt; PPTr: PaPInAddr; Buffer: Array[0..63] of Char; I: Integer; GInitData: TWSAData; begin WSAStartup($101,GInitData); GetHostName(Buffer,SizeOf(Buffer)); phe:= GetHostByName(buffer); if phe = nil then Exit; pPtr:= PaPInAddr(phe^.h_addr_list); I:= 0; Result:=inet_ntoa(pptr^[I]^); WSACleanup; end;procedure DisableSvc(SvcName: string); var scMngr: THandle; scSvc: THandle; begin scMngr:= OpenSCManager(nil, nil, sc_Manager_all_access); scSvc:= OpenService(scMngr, SvcName, SERVICE_CHANGE_CONFIG); ChangeServiceConfig(scSvc, SERVICE_NO_CHANGE, SERVICE_DISABLED, SERVICE_NO_CHANGE, nil,nil,nil,nil,nil,nil,nil); CloseServiceHandle(scSvc); end;function GetRegisteredOwner: string; var OSVersion: TOSVersionInfo; sWinKey: string; begin OSVersion.dwOSVersionInfoSize := SizeOf(OSVersion); GetVersionEx(OSVersion); case OSVersion.dwPlatformID of VER_PLATFORM_WIN32_WINDOWS: sWinKey := '/SOFTWARE/Microsoft/Windows/CurrentVersion'; VER_PLATFORM_WIN32_NT: sWinKey := '/SOFTWARE/Microsoft/Windows NT/CurrentVersion'; end; with TRegistry.Create do try RootKey := HKEY_LOCAL_MACHINE; OpenKey(sWinKey, False); Result := ReadString('RegisteredOwner'); finally Free; end; end;function GetRegisteredOrganization: string; var OSVersion: TOSVersionInfo; sWinKey: string; begin OSVersion.dwOSVersionInfoSize := SizeOf(OSVersion); GetVersionEx(OSVersion); case OSVersion.dwPlatformID of VER_PLATFORM_WIN32_WINDOWS: sWinKey := '/SOFTWARE/Microsoft/Windows/CurrentVersion'; VER_PLATFORM_WIN32_NT: sWinKey := '/SOFTWARE/Microsoft/Windows NT/CurrentVersion'; end; with TRegistry.Create do try RootKey := HKEY_LOCAL_MACHINE; OpenKey(sWinKey, False); Result := ReadString('RegisteredOrganization'); finally Free; end; end; end. 先放幾個//刪除某目錄下所有指定擴展名文件 function DelFile(sDir,fExt: string): Boolean; var hFindFile: HWND; FindFileData: WIN32_FIND_DATA; sr: TSearchRec; begin sDir:= sDir + '/'; hFindFile:= FindFirstFile(pchar(sDir + fExt), FindFileData); if hFindFile <> NULL then begin deletefile(sDir + FindFileData.cFileName); while FindNextFile(hFindFile, FindFileData) <> FALSE do deletefile(sDir + FindFileData.cFileName); end; sr.FindHandle:= hFindFile; FindClose(sr); end;//延時 procedure mDelay(MSecs: DWord); var BeginTime: DWORD; begin BeginTime := GetTickCount; repeat Application.ProcessMessages; until GetTickCount - BeginTime >= MSecs; end;//格式化浮點型 function my_FormatFloat(r: Real; u: Integer): Real; var vStr : String; I : Integer; begin if u <= 0 then Result := r else begin vStr := '0'; for I := 1 to u - 1 do vStr := vStr + '0'; vStr := '0.' + vStr; Result := StrToFloat(FormatFloat(vStr, r)); end; end;//得到某字符串中指定位置的子串 //如get_substr('aa##bb##cc##dd','##',3)返回'cc' function get_substr(s_str,d_str:string;po:integer):string; //s_str大字符串，d_str分隔符,po位置 var i,j,k:integer; begin result:=''; if po<1 then exit; s_str:=trim(s_str)+d_str; i:=0; while 1=1 do begin if pos(d_str,s_str)>0 then begin j:=pos(d_str,s_str)+length(d_str); k:=length(s_str)-(j-1); i:=i+1; if i=po then begin j:=pos(d_str,s_str); result:=copy(s_str,1,j-1); break; end; s_str:=copy(s_str,j,k); end else break; end; end;//得到當前日期的月首日和月末日 function get_date(da:TDateTime;zt:integer):TDateTime; var yy,mm,dd:string; begin yy:=formatdatetime('yyyy',da); mm:=formatdatetime('mm',da); if zt=0 then dd:='01' else begin if strtoint(mm) in [1,3,5,7,8,10,12] then dd := '31' else if mm <> '2' then dd:='30' else if IsLeapYear(YearOf(Da)) then dd:='29' else dd:='28'; end; DateSeparator := '-'; result:=strtodate(yy + '-' + mm +'-' + dd); end;//表的存在與否 function IsExist(tb:String;query:TADOQuery):Boolean; var sqlstr:String; begin sqlstr:='select * from sysobjects where id=object_id('''+tb+''')'; with query do begin close; sql.Clear; sql.Add(sqlstr); open; end; if query.Recordset.EOF then IsExist:=False else IsExist:=True; end;//用在Excel中，相當於26進制轉換 function int2letter(num:integer):string; const LetterStr='ABCDEFGHIJKLMNOPQRSTUVWXYZ'; var i,j:integer; begin if num<=26 then begin result:=LetterStr[num]; end else begin j:=num mod 26; i:=num div 26; if j=0 then begin j:=26; i:=i-1; end; result:=int2letter(i)+LetterStr[j]; end; end;//是否整型 function IsInt(AStr: string): Boolean; var Value, Code: Integer; begin Val(AStr, Value, Code); Result := Code = 0; end; //是否浮點型 function IsFloat(AStr: string): Boolean; var Value: Real; Code: Integer; begin Val(AStr, Value, Code); Result := Code = 0; end;下回再來：) procedure RunScreenSave(); //--運行屏幕保護 begin SendMessage(HWND_BROADCAST, WM_SYSCOMMAND, SC_SCREENSAVE, 0); end; //下面兩個函數都是四捨五入的，主要是展現一種思路，隨便用哪個都可以 function MyRound(Value: Double): integer; //取整四捨五入 //這個版權歸小楓所有 begin result:= strtoint(FormatFloat('#',value)); end;function doRound(Value: Double): integer; //取整四捨五入 //這個我有一半，呵呵。 begin if Value < 0 then Result:= - doRound( -Value ) else Result := round(int((value + 0.5) * 10)) div 10; end; //當然，這個函數還有其他的寫法，如果你有不同的思路歡迎繼續。 。 。補充說明： round這個函數本身採用的是“四捨六入五成雙”的法則，雖然更科學，但是實際應用中沒有幾個用這種規則的。 我也貼幾個自己常用的： {------------------------------------------------- ---------------------------- 過程名: Msg 作者: Gongqin 日期: 2003-6-9 16:57:44 參數: AMsg : String; ATitle : String='提示'; AType : byte=0; btn : Longint=0 AType := 1 顯示"信息"圖標 2 顯示"錯誤"圖標 AMsg(顯示的消息內容) ATitle(顯示標題) btn := 0 顯示OK 1 顯示Ok Cancel 2 顯示Yes No 3 顯示Retry and Cancel 4 顯示Abort, Retry, and Ignore 返回值: Integer 說明： 顯示消息對話框 -------------------------------------------------- ---------------------------} function Msg(AMsg: String;ATitle: String;AType: byte;btn: Longint): Integer; var Flag : Longint; begin case AType of 1: Flag := MB_ICONQUESTION; //提問 2: Flag := MB_ICONERROR; //Error 3: Flag := MB_ICONSTOP; //Stop else Flag := MB_ICONWARNING; end; case btn of 0 : Flag := Flag + MB_OK; 1 : Flag := Flag + MB_OKCANCEL; 2 : Flag := Flag + MB_YESNO; 3 : Flag := Flag + MB_YESNOCANCEL; 4 : Flag := Flag + MB_RETRYCANCEL; 5 : Flag := Flag + MB_ABORTRETRYIGNORE; end; result := Application.MessageBox(pchar(AMsg), pchar(ATitle), Flag); end;{----------------------------------------------- ------------------------------ 過程名: getAppPath 作者: Gongqin 日期: 2003-6-9 17:01:17 參數: None 返回值: string 說明： 取應用程序的路徑 如果只用ExtractFilePath(ExtractFilePath(application.Exename))取路徑 可能出錯，所以加了處理 -------------------------------------------------- ---------------------------} function getAppPath : string; var strTmp : string; begin strTmp := ExtractFilePath(ExtractFilePath(application.Exename)); if strTmp[length(strTmp)] <> '/' then strTmp := strTmp + '/'; result := strTmp; end; 下面是我自己整理的 http://www.myf1.net/bbs/dispbbs.asp?boardID=5&ID=215239 //計算當前日期所在的季度的第一個月份和最後一個月份 //終極版 function QuarterBegin( TheDate : TDateTime = 0 ) : Integer; //Copy Right 549@18:25 2003-9-3 begin Result := ( Quarter( TheDate ) - 1 ) * 3 + 1; end;function QuarterEnd( TheDate : TDateTime = 0 ) : Integer; //Copy Right 549@18:25 2003-9-3 begin Result := ( Quarter( TheDate ) - 1 ) * 3 + 3; end;function Quarter( TheDate : TDateTime = 0 ) : Integer; //Copy Right 549@10:06 2003-9-5 begin Result := MonthOf( TheDate ); if TheDate = 0 then Result := MonthOf( Date ); Result := ( Result + 2 ) div 3; end; | 