//返回当前键盘状态，包括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 := 'SOFTWAREMicrosoftWindowsCurrentVersion';
VER_PLATFORM_WIN32_NT: sWinKey := 'SOFTWAREMicrosoftWindows NTCurrentVersion';
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 := 'SOFTWAREMicrosoftWindowsCurrentVersion';
VER_PLATFORM_WIN32_NT: sWinKey := 'SOFTWAREMicrosoftWindows NTCurrentVersion';
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 po1 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;
