delphi小技巧集錦

2019-11-18 18:06:48

字體：大中小

來源：轉載

供稿：網友

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;

implementation

function 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;

上一篇：Delphi中使用純正的面向對象方法

下一篇：對使用Delphi制作DLL復用文件的建議