在Delphi数据库中，一些朋友的SQL语句写不出来，其实就是对相关子查询不熟悉，现在我总结一下~自己总结的，不对请大家指正~：） --相关子查询与普通子查询的区别在于：相关子查询引用了外部查询中的列！这种用外部查询来限制子查询的方法使 SQL查询变得更加强大和灵活。因为相关子查询能够引用外部查询，所以它们尤其适合编写复杂的where条件！ 相关子查询不能自己单独运行，其执行顺序如下： 1.首先执行一次外部查询 2.对于外部查询中的每一行分别执行一次子查询，而且每次执行子查询时都会引用外部查询中当前行的值。 3.使用子查询的结果来确定外部查询的结果集。 如果外部查询返回100行，SQL 就将执行101次查询，一次执行外部查询，然后为外部查询返回的每一行执行一次子查询。但实际上，SQL的查询 优化器有可能会找到一种更好的方法来执行相关子查询，而不需要实际执行101次查询。相关子查询典型用法： declare @t table(rq varchar(10),hh int,ye dec(6,2)) insert into @t select '2006-01-02' ,1111 ,2.01 union all select '2006-01-05' ,1111 ,3.51 union all select '2006-01-10' ,1111 ,2.55 union all select '2006-01-02' ,2222 ,3.00 union all select '2006-01-04' ,2222 ,2.00 union all select '2006-01-05' ,3333 ,6.54 union all select '2006-01-06' ,3333 ,5.23 union all select '2006-01-07' ,3333 ,8.55select * from @t a where not exists(select 1 from @t where hh=a.hh and rq>a.rq)
来一个键盘勾子，不需要用DLL unit Unit1;interfaceuses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, ExtCtrls;type TForm1 = class(TForm) ListBox1: TListBox; Button1: TButton; Button2: TButton; Edit1: TEdit; Edit2: TEdit; Label1: TLabel; Label2: TLabel; procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure ListBox1DblClick(Sender: TObject); procedure Edit1Change(Sender: TObject); procedure Edit1KeyPress(Sender: TObject; var Key: Char); private function Keyhookresult(lP: integer; wP: integer): pchar; { Private declarations } public { Public declarations } end; var Form1: TForm1; hookkey: string; hooktimes: word; hHook: integer; implementation {$R *.DFM}function TForm1.Keyhookresult(lP: integer; wP: integer): pchar; begin result := '[Print Screen]'; { VK_0 thru VK_9 are the same as ASCII '0' thru '9' ($30 - $39) } { VK_A thru VK_Z are the same as ASCII 'A' thru 'Z' ($41 - $5A) } case lp of 14354: result := '[Alt]'; //不能识别 10688: result := '`'; 561: Result := '1'; 818: result := '2'; 1075: result := '3'; 1332: result := '4'; 1589: result := '5'; 1846: result := '6'; 2103: result := '7'; 2360: result := '8'; 2617: result := '9'; 2864: result := '0'; 3261: result := '-'; 3515: result := '='; 4177: result := 'Q'; 4439: result := 'W'; 4677: result := 'E'; 4946: result := 'R'; 5204: result := 'T'; 5465: result := 'Y'; 5717: result := 'U'; 5961: result := 'I'; 6223: result := 'O'; 6480: result := 'P'; 6875: result := '['; 7133: result := ']'; 11228: result := '\'; 7745: result := 'A'; 8019: result := 'S'; 8260: result := 'D'; 8518: result := 'F'; 8775: result := 'G'; 9032: result := 'H'; 9290: result := 'J'; 9547: result := 'K'; 9804: result := 'L'; 10170: result := ';'; 10462: result := ''''; 11354: result := 'Z'; 11608: result := 'X'; 11843: result := 'C'; 12118: result := 'V'; 12354: result := 'B'; 12622: result := 'N'; 12877: result := 'M'; 13244: result := ','; 13502: result := '.'; 13759: result := '/'; 13840: result := '[Right-Shift]'; 14624: result := '[Space]'; 283: result := '[Esc]'; 15216: result := '[F1]'; 15473: result := '[F2]'; 15730: result := '[F3]'; 15987: result := '[F4]'; 16244: result := '[F5]'; 16501: result := '[F6]'; 16758: result := '[F7]'; 17015: result := '[F8]'; 17272: result := '[F9]'; 17529: result := '[F10]'; 22394: result := '[F11]'; 22651: result := '[F12]'; 10768: Result := '[Left-Shift]'; 14868: result := '[CapsLock]'; 3592: result := '[Backspace]'; 3849: result := '[Tab]'; 7441: if wp > 30000 then result := '[Right-Ctrl]' else result := '[Left-Ctrl]'; 13679: result := '[Num /]'; 17808: result := '[NumLock]'; 300: result := '[Print Screen]'; 18065: result := '[Scroll Lock]'; 17683: result := '[Pause]'; 21088: result := '[Num0]'; 21358: result := '[Num.]'; 20321: result := '[Num1]'; 20578: result := '[Num2]'; 20835: result := '[Num3]'; 19300: result := '[Num4]'; 19557: result := '[Num5]'; 19814: result := '[Num6]'; 18279: result := '[Num7]'; 18536: result := '[Num8]'; 18793: result := '[Num9]'; 19468: result := '[*5*]'; 14186: result := '[Num *]'; 19053: result := '[Num -]'; 20075: result := '[Num +]'; 21037: result := '[Insert]'; 21294: result := '[Delete]'; 18212: result := '[Home]'; 20259: result := '[End]'; 18721: result := '[PageUp]'; 20770: result := '[PageDown]'; 18470: result := '[UP]'; 20520: result := '[DOWN]'; 19237: result := '[LEFT]'; 19751: result := '[RIGHT]'; 7181: result := '[Enter]'; end; end;//钩子回调过程 function HookProc(iCode: integer; wParam: wParam; lParam: lParam): LResult; stdcall; var s:string; begin if (PEventMsg(lparam)^.message = WM_KEYDOWN) then begin //事件消息，键盘按下 s:=format('Down:%5d %5d ',[PEventMsg(lparam)^.paramL,PEventMsg(lparam)^.paramH])+Form1.Keyhookresult(peventMsg(lparam)^.paramL, peventmsg(lparam)^.paramH); Form1.ListBox1.Items.Add(s); end else if (PEventMsg(lparam)^.message = WM_KEYUP) then begin //键盘按键 s:=format(' Up:%5d %5d ',[PEventMsg(lparam)^.paramL,PEventMsg(lparam)^.paramH])+Form1.Keyhookresult(PEventMsg(lparam)^.paramL,PEventMsg(lparam)^.paramH); Form1.ListBox1.Items.Add(s); end; end;procedure TForm1.FormCreate(Sender: TObject); begin hooktimes := 0; hHook := 0; end;procedure TForm1.Button1Click(Sender: TObject); begin inc(hooktimes); if hooktimes = 1 then begin hookkey := TimeToStr(now) + ' '; hHook := SetWindowsHookEx(WH_JOURNALRECORD, HookProc, HInstance, 0); MessageBox(0, '键盘监视启动', '信息', MB_ICONINFORMATION + MB_OK); end; end;procedure TForm1.Button2Click(Sender: TObject); begin UnHookWindowsHookEx(hHook); hHook := 0; if hooktimes <> 0 then begin MessageBox(0, '键盘监视关闭', '信息', MB_ICONINFORMATION + MB_OK); end; hooktimes := 0; end;procedure TForm1.ListBox1DblClick(Sender: TObject); begin listbox1.clear; end;procedure TForm1.Edit1Change(Sender: TObject); var i:DWORD; begin if length(edit1.text)<>1 then exit; //映射虚拟键 i:=MapVirtualKey(ord(edit1.text[1]), 0 ); edit2.text:=format('%d %x',[i,i]); end;procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); begin edit1.text:=''; end;end.
3、 {通用数据库操作无关函数--------------------------------------------------------}function G_MessageBox(text: String; flags: longint=MB_OK or MB_ICONINFORMATION; caption: String=''): integer; begin if Caption = '' then begin Caption := Application.Title; end; Result := Application.MessageBox(PChar(Text),PChar(Caption),Flags); end;function G_GetControlByName(parent: TWinControl; componentName: string): TControl; var i: integer; begin result := nil; for i:=0 to parent.ControlCount-1 do begin if LowerCase(parent.Controls[i].Name)=LowerCase(componentName) then begin result := parent.Controls[i]; break; end; end; end;function G_FormatDT(DateTime: TDateTime; Format: String='yyyy-mm-dd'): string; begin Result := FormatDateTime(format,DateTime); end;function G_FormatSqlDt(DbType: TDBType; DateTime: TDateTime; format: string='yyyy-mm-dd'): string; begin case DbType of dbAccess: Result := '#'+G_FormatDT(DateTime,format)+'#'; dbSQL, dbSybase: Result := ''''+G_FormatDT(DateTime,format)+''''; end; end;function G_FormatSqlDtEx(DbType: TDBType; fieldName: string; dataset: TDataSet; format: string='yyyy-mm-dd'): string; begin if dataset[fieldName]=NULL then result := 'null' else result := G_FormatSqlDt(DBType,G_GetFieldValue(dataset,fieldName),format); end;function G_CharSqlIndex(DbType: TDbType; strCheck,strMatch: string): string; begin case DbType of dbAccess: Result := 'InStrRev('+strCheck+','+strMatch+')'; dbSQL, dbSybase: Result := 'CharIndex('+strMatch+','+strCheck+')'; end; end;function G_ValidateValue(const Sender: TObject; tips: string): boolean; begin Result := TRUE; if ((Sender is TEdit) and (TEdit(Sender).Text='')) then Result := FALSE; if ((Sender is TDBEdit) and (TDBEdit(Sender).Text='')) then Result := FALSE; if ((Sender is TComboBox) and (TComboBox(Sender).Text='')) then Result := FALSE; if ((Sender is TDBComboBox) and (TDBComboBox(Sender).Text='')) then Result := FALSE; if ((Sender is TMemo) and (TMemo(Sender).Text='')) then Result := FALSE; if ((Sender is TDBMemo) and (TDBMemo(Sender).Text='')) then Result := FALSE; if not Result then begin G_MessageBox(Tips, MB_ICONWARNING); TWinControl(Sender).SetFocus; end; end;procedure G_SeperateString(value: string; const list: TStrings; dot: string='|'); var nPos: Integer; tmp: String; begin list.Clear; while Length(Value)>0 do begin nPos := Pos(Dot,Value); if nPos>0 then begin tmp := Copy(value,1,nPos-1); if tmp<>'' then list.Add(tmp); Delete(Value,1,nPos); end else begin if Length(value)>0 then begin list.Add(Value); value := ''; end; end; end; end;function GetChineseIndexChar(hzChar: string): string; var index: WORD; begin index := WORD(hzChar[1]) shl 8 + WORD(hzChar[2]); case index of $B0A1..$B0C4 : Result := 'a'; $B0C5..$B2C0 : Result := 'b'; $B2C1..$B4ED : Result := 'c'; $B4EE..$B6E9 : Result := 'd'; $B6EA..$B7A1 : Result := 'e'; $B7A2..$B8C0 : Result := 'f'; $B8C1..$B9FD : Result := 'g'; $B9FE..$BBF6 : Result := 'h'; $BBF7..$BFA5 : Result := 'j'; $BFA6..$C0AB : Result := 'k'; $C0AC..$C2E7 : Result := 'l'; $C2E8..$C4C2 : Result := 'm'; $C4C3..$C5B5 : Result := 'n'; $C5B6..$C5BD : Result := 'o'; $C5BE..$C6D9 : Result := 'p'; $C6DA..$C8BA : Result := 'q'; $C8BB..$C8F5 : Result := 'r'; $C8F6..$CBF9 : Result := 's'; $CBFA..$CDD9 : Result := 't'; $CDDA..$CEF3 : Result := 'w'; $CEF4..$D1B8 : Result := 'x'; $D1B9..$D4D0 : Result := 'y'; $D4D1..$D7F9 : Result := 'z'; else Result := #0; end; end;function G_GetChineseString(chinese: string): string; var I: Integer; PY: String; sTmp: string; begin sTmp := '' ; I := 1; while I <= Length(chinese) do begin PY := Copy(Chinese, I , 1); if PY >= Chr(128) then begin Inc(I); PY := PY + Copy(Chinese, I , 1); sTmp := sTmp + GetChineseIndexChar(PY); end else sTmp := sTmp + PY; Inc(I); end; Result := sTmp; end;function G_GetLocalHostName(): string; var wVersionRequested: WORD; wsaData: TWSAData; p: PHostEnt; s: array[0..128] of char; begin result := ''; try wVersionRequested := MAKEWORD(1, 1); WSAStartup(wVersionRequested, wsaData); GetHostName(@s, 128); p := GetHostByName(@s); result := p^.h_Name; WSACleanup; except end; end;function G_GetLocalHostIp(): string; var wVersionRequested: WORD; wsaData: TWSAData; p: PHostEnt; s: array[0..128] of char; begin result := ''; try wVersionRequested := MAKEWORD(1, 1); WSAStartup(wVersionRequested, wsaData); GetHostName(@s, 128); p := GetHostByName(@s); result := inet_ntoa(PInAddr(p^.h_addr_list^)^); WSACleanup(); except end; end;function G_GetSystemDisplay(var mode: TDevMode): boolean; begin Result := EnumDisplaySettings(nil, Cardinal(-1), Mode); end;function G_SetSystemDisplay(newMode: TDevMode): boolean; var lpDevMode: TDeviceMode; begin lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL or DM_DISPLAYFREQUENCY; Result := ChangeDisplaySettings(newMode, CDS_UPDATEREGISTRY) = DISP_CHANGE_SUCCESSFUL; end;procedure G_RestoreWindow(hWnd: THandle); begin SetForegroundWindow(hWnd); BringWindowToTop(hWnd); ShowWindow(hWnd,SW_SHOWNORMAL); end;{数据库相关操作函数------------------------------------------------------------}procedure G_SetDbParam(value: TDbParam; fileName: string); var pFile: file of TDbParam; begin try AssignFile(pFile,fileName); ReWrite(pFile); Write(pFile,Value); CloseFile(pFile); except end; end;function G_GetDbParam(var value: TDbParam; fileName: string): boolean; var pFile: file of TDbParam; begin Result := false; if not FileExists(fileName) then Exit; try AssignFile(pFile,fileName); Reset(pFile,fileName); Read(pFile,value); CloseFile(pFile); Result := true; except end; end;procedure G_CloseDB(const adocnn: TADOConnection); begin if adocnn.Connected then adocnn.Close; end;function G_ConnectDB(const adocnn: TADOConnection; dbParam: TDbParam): boolean; var strConn: String; begin Result := FALSE; if adocnn=nil then Exit; case dbParam.dbType of dbAccess: strConn:= 'Provider=Microsoft.Jet.OLEDB.4.0;'+ 'Data Source='+DbParam.dbName+';'+ 'User ID='+DbParam.dba+';'+ 'Password='+DbParam.pwd; dbSQL : strConn:= 'Provider=SQLOLEDB.1;'+ 'Password='+DbParam.pwd+';'+ 'User ID='+DbParam.dba+';'+ 'Initial Catalog='+DbParam.dbName+';'+ 'Data Source='+DbParam.host; dbSybase: strConn:= ''; end; try G_CloseDB(adocnn); adocnn.ConnectionString := strConn; adocnn.Connected := TRUE; Result := adocnn.Connected; except end; end;
4、 function G_RunSql(const adocmd: TADOCommand; strSql: string): boolean; begin try adocmd.CommandType := cmdText; adocmd.CommandText := strSql; adocmd.Execute; Result := TRUE; except Result := FALSE; end; end;function G_BeginTran(const adocnn: TADOConnection): boolean; begin Result := FALSE; try if adocnn.InTransaction then begin adocnn.RollbackTrans; Exit; end; adocnn.BeginTrans; Result := TRUE; except end; end;function G_CommitTran(const adocnn: TADOConnection): boolean; begin Result := FALSE; try if not adocnn.InTransaction then Exit; adocnn.CommitTrans; Result := TRUE; except G_RollTran(adocnn); end; end;function G_RollTran(const adocnn: TADOConnection): boolean; begin result := false; try if not adocnn.InTransaction then Exit; adocnn.RollbackTrans; result := true; except end; end;procedure G_FreeDS(DataSet: TDataSet); begin if DataSet.State<>dsBrowse then DataSet.Close; DataSet.Free; end;function G_CreateDS(const adocnn: TADOConnection; strSql: string): TADODataSet; begin result := TADODataSet.Create(adocnn); result.Connection := adocnn; G_BuildDS(result,strSql); end;procedure G_CloseDS(const DataSet: TDataSet); begin if DataSet.State<>dsInactive then DataSet.Close; end;function G_BuildDS(const DataSet: TADODataSet; strSql: string): integer; begin try G_CloseDS(DataSet); DataSet.CommandType := cmdText; DataSet.CommandText := strSQL; DataSet.Open; DataSet.Recordset.Properties['Update Criteria'].Value := AdCriteriaKey; Result := DataSet.RecordCount; except Result := -1; end; end;function G_BuildCDS(id,ip,userId,pwd,strSql,dsp: string; sckcnn: TSocketConnection; const dataset: TClientDataSet): integer; begin try if dataSet.State<>dsInactive then dataSet.Close; dataSet.ProviderName := dsp; result := sckcnn.AppServer.getdata(id,ip,userId,pwd,dsp,strSql); if (Result>=0) then dataSet.Open; except result := -1; end; end;function G_GetFieldValue(const DataSet: TDataSet; fieldName: string): Variant; var retValue: Variant; begin Result := Unassigned; if DataSet.State=dsInactive then Exit; retValue := DataSet[fieldName]; if retValue <> NULL then Result := retValue; end;function G_GetFieldValueEx(const field: TField): Variant; var retValue: Variant; begin Result := Unassigned; retValue := field.Value; if retValue <> NULL then Result := retValue; end;function G_FormatFieldSql(dbType: TDbType; const field: TField): string; begin case field.DataType of ftString, ftMemo, ftWideString, ftFixedChar: result := ''''+field.AsString+''''; ftDate : result := G_FormatSqlDt(dbType,G_GetFieldValueEx(field)); ftTime : G_FormatSqlDt(dbType,G_GetFieldValueEx(field),'hh:nn:ss'); ftDateTime : result := G_FormatSqlDt(dbType,G_GetFieldValueEx(field),'yyyy-mm-dd hh:nn:ss'); ftAutoInc, ftLargeint, ftSmallint, ftInteger, ftWord: result := IntToStr(G_GetFieldValueEx(field)); ftFloat, ftCurrency, ftBCD : result := FloatToStr(G_GetFieldValueEx(field)); ftBoolean: if field.AsBoolean then result := '1' else result := '0'; end; end;procedure G_SetFieldValue(const DataSet: TDataSet; fieldName: string; value: Variant); begin if (DataSet.FindField(fieldName)<>nil) and (DataSet.State<>dsInactive) then begin if DataSet.State=dsBrowse then DataSet.Edit; DataSet[fieldName] := Value; end; end;procedure G_SetDataSetLabel(const DataSet: TDataSet; dicFields: TDicFieldList); var i: integer; field: TField; begin for i:=0 to dicFields.nFields-1 do begin field := DataSet.FindField(dicFields.fields[i].name); if field<>nil then begin field.DisplayLabel := dicFields.fields[i].sName; field.Tag := 1; end; end; end;procedure G_ClonseRecord(srcDataSet,dstDataSet: TDataSet); var i: integer; begin dstDataSet.Append; for i:=0 to srcDataSet.FieldCount-1 do begin dstDataSet.Fields[i] := srcDataSet.Fields[i]; end; dstDataSet.Post; end;//删除记录集中指定主键信息记录 function DelRecords(dbType: TDBType; const adocmd: TADOCommand; const dsData: TDataSet; tbName,delKeys: string): boolean; var i: integer; strSql: string; fields: TStrings; begin fields := TStringList.Create; G_SeperateString(delKeys,fields,','); strSql := 'delete from '+tbName+' where '; for i:=0 to fields.Count-1 do begin if i=fields.Count-1 then strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i])) else strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))+' and '; end; result := G_RunSql(adocmd,strSql); fields.Free; end;{参数说明： dbType: 数据库类别，传入次参数，目的为了格式化SQL语句 adocmd: 用于执行SQL语句的 ADOCommand 对象 } function G_PostRecordToDb(dbType: TDBType; const adocmd: TADOCommand; const dsData,dsField: TDataSet; tbName, delKeys: string; operate: TOperate; delBeforeAppend: boolean): boolean; var i: integer; fields: TStrings; strSql: string; begin result := false; if (operate=opNew) and delBeforeAppend and (not DelRecords(dbType,adocmd,dsData,tbName,delKeys)) then exit; case operate of opNew : begin strSql := 'insert into '+tbName+'('; for i:=0 to dsField.FieldCount-1 do begin if i=dsField.FieldCount-1 then strSql := strSql+dsField.Fields[i].FieldName+') values(' else strSql := strSql+dsField.Fields[i].FieldName+','; end; for i:=0 to dsField.FieldCount-1 do begin if i=dsField.FieldCount-1 then strSql := strSql+G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+')' else strSql := strSql+G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+','; end; end; opModify: begin strSql := 'update '+tbName+' set '; for i:=0 to dsField.FieldCount-1 do begin if i=dsField.FieldCount-1 then strSql := strSql+dsField.Fields[i].FieldName+'='+ G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+' where ' else strSql := strSql+dsField.Fields[i].FieldName+'='+ G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+','; end; fields := TStringList.Create; G_SeperateString(delKeys,fields,','); for i:=0 to fields.Count-1 do begin if i=fields.Count-1 then strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i])) else strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))+' and '; end; fields.free; end; end; result := G_RunSql(adocmd,strSql); end;
我来凑个数 我把 fastreport，excel模板文件都存放在数据库里面了，供使用时调用用完删除还可以修改。var ts : TStream; ms : TMemoryStream; fr : TFastReport; begin try ms := TMemoryStream.Create; ts:= CreateBlobStream(FieldByName('fileBlob'),bmRead); ms.CopyFrom(ts, ts.Size); ms.SaveToFile(ExtractFilePath(Application.ExeName) + filename); fr.LoadFromFile(ExtractFilePath(Application.ExeName) + filename); fr.DesignReport; ... finally if AsSigned(ms) then ms.Free; ... end;end;
function G_GetSystemDisplay(var mode: TDevMode): boolean; //获取当前显示 function G_SetSystemDisplay(newMode: TDevMode): Boolean; //动态设置屏幕分辨率 procedure G_RestoreWindow(hWnd: THandle); //动态设置屏幕分辨率 希望楼主 天使者 能把这几个函数的代码贴上来
应大家要求，继续贴 function G_PostDataSetToDb(dbType: TDBType; const adocmd: TADOCommand; const dsData: TDataSet; tbName,delKeys: string; operate: TOperate; delBeforeAppend: boolean): boolean; var i: integer; bookMark: TBookMark; dsField: TADODataSet; begin result := false; if (operate=opNew) and delBeforeAppend and (not DelRecords(dbType,adocmd,dsData,tbName,delKeys)) then exit; result := true; dsField := G_CreateDS(adocmd.Connection,'select * from '+tbName+' where 1<0'); dsData.DisableControls; bookMark := dsData.GetBook; dsData.First; for i:=1 to dsData.RecordCount do begin if not G_PostRecordToDb(dbType,adocmd,dsData,dsField,tbName,delKeys,operate, not delBeforeAppend) then begin result := false; break; end; dsData.Next; end; dsField.Free; dsData.GotoBook(bookMark); dsData.FreeBook(bookMark); dsData.EnableControls; end;{用户功能权限操作树等相关函数 -------------------------------------------------}function G_GetActionByName(const actionLst: TActionList; actionName: string): TAction; var i: Integer; begin Result := nil; for i:=0 to actionLst.ActionCount-1 do begin if UpperCase(actionLst.Actions[i].Name)=UpperCase(actionName) then begin Result := TAction(actionLst.Actions[i]); Break; end; end; end;procedure G_FreeFuncTree(tvFunc: TTreeView); var i: Integer; begin tvFunc.OnChange := nil; for i:=0 to tvFunc.Items.Count-1 do begin Dispose(PFunc(tvFunc.Items[i].Data)); end; tvFunc.Items.Clear; end;function GetFuncParentNode(ChildNode: TTreeNode; ChildKey: string; ItemLen: Integer=1): TTreeNode; var ParentKey: string; ParentNode: TTreeNode; begin ParentKey := LeftBStr(ChildKey,Length(ChildKey)-ItemLen); ParentNode := ChildNode; while ParentNode<>nil do begin if PFunc(ParentNode.Data)^.id = ParentKey then Break; ParentNode := ParentNode.Parent; end; Result := ParentNode; end;procedure G_BuildFuncTree(tvFunc: TTreeView; funcs: TFuncLst; withLeaf: boolean; root: string=''); var i: Integer; lpFunc: PFunc; NewNode,ParentNode: TTreeNode; begin NewNode := nil; G_FreeFuncTree(tvFunc); if root<>'' then begin NewNode := tvFunc.Items.AddChild(nil,root); new(lpFunc); lpFunc.caption := root; lpFunc.id := ''; lpFunc.leaf := false; if tvFunc.Images<>nil then begin NewNode.ImageIndex := 0; NewNode.SelectedIndex := 1; end; NewNode.Data := lpFunc; end; for i:=0 to funcs.count-1 do begin if (not funcs.funcs[i].visible) or (not funcs.funcs[i].enabled) or ((funcs.funcs[i].leaf) and (not withLeaf)) then Continue; ParentNode := GetFuncParentNode(NewNode,Funcs.funcs[i].id); NewNode := tvFunc.Items.AddChild(ParentNode,Funcs.funcs[i].caption); if tvFunc.Images<>nil then begin NewNode.ImageIndex := funcs.funcs[i].treeImage; NewNode.SelectedIndex := funcs.funcs[i].treeSelImage; end; new(lpFunc); lpFunc^ := Funcs.funcs[i]; NewNode.Data := lpFunc; end; end;procedure G_LoadResImage(const ImageList: TImageList; ress: TResLst); var i: Integer; ico: TIcon; bmp: TBitmap; begin ImageList.Clear; ico := TIcon.Create; bmp := TBitmap.Create; for i:=0 to ress.count-1 do begin if FileExists(ress.ress[i].resFile) then begin if Pos('.ico',LowerCase(ress.ress[i].resFile))>0 then begin ico.LoadFromFile(ress.ress[i].resFile); ImageList.AddIcon(ico); end; if Pos('.bmp',LowerCase(ress.ress[i].resFile))>0 then begin bmp.LoadFromFile(ress.ress[i].resFile); ImageList.Add(bmp,bmp); end; end; end; ico.Free; bmp.Free; end;procedure G_BuildToolBar(ToolBar: TToolBar; ActionLst: TActionList; sysFunc,usrFunc: TFuncLst); var tmp: string; i,nCount: Integer; begin while ToolBar.ButtonCount>0 do ToolBar.Buttons[0].Free; tmp := '|'; for i:=0 to usrFunc.count-1 do begin tmp := tmp+usrFunc.funcs[i].id+'|'; end; nCount := 0; for i:=sysFunc.count-1 downto 0 do begin if (sysFunc.funcs[i].btnIndex>=0) and (sysFunc.funcs[i].enabled) then begin with TToolButton.Create(ToolBar) do begin if sysFunc.funcs[i].btnGrouped then begin with TToolButton.Create(ToolBar) do begin Parent := ToolBar; Style := tbsSeparator; Width := 8; end; end; Parent := ToolBar; Height := 20; Action := G_GetActionByName(ActionLst,sysFunc.funcs[i].name); Caption:= sysFunc.funcs[i].shortCaption; ImageIndex := sysFunc.funcs[i].toolImage; ShowHint := TRUE; Hint := sysFunc.funcs[i].re; Visible := Pos('|'+sysFunc.funcs[i].id+'|',tmp)>0; if Visible then Inc(nCount); end; end; end; ToolBar.Visible := nCount>0; end;procedure G_BuildMainMenu(mainMenu: TMainMenu; ActionLst: TActionList; sysFuncs,usrFunc: TFuncLst); var i: Integer; parentId: String; newItem,parent,group: TMenuItem; action: TAction; begin parent := mainMenu.Items; MainMenu.Items.Clear; for i:=0 to usrFunc.count-1 do begin if not usrFunc.funcs[i].visible then continue; {创建菜单项} newItem := TMenuItem.Create(MainMenu); newItem.Caption := usrFunc.funcs[i].caption; newItem.Name := 'M'+usrFunc.funcs[i].id; newItem.ImageIndex := usrFunc.funcs[i].menuImage; action := G_GetActionByName(ActionLst,usrFunc.funcs[i].name); if action<>nil then newItem.OnClick := action.OnExecute; {获取父菜单} parentId := LeftStr(newItem.Name,Length(newItem.Name)-1); while parent<>nil do begin if parent.Name=parentId then break else parent := parent.Parent; end; if parent=nil then parent := mainMenu.Items; parent.Add(newItem); {菜单有分组，则增加分组菜单项} if usrFunc.funcs[i].grouped then begin group := TMenuItem.Create(mainMenu); group.Caption := '-'; parent.Add(group); end; parent := newItem; end; end;
{基本信息树操作 ---------------------------------------------------------------}procedure G_FreeBaseTree(const tvBase: TTreeView); var node: TTreeNode; begin tvBase.OnChange := nil; node := tvBase.TopItem; while node<>nil do begin Dispose(PBaseNode(node.Data)); node := node.GetNext; end; tvBase.Items.Clear; end;function GetBaseParentNode(ChildNode: TTreeNode; ChildKey: string; ItemLen: Integer=5): TTreeNode; var ParentKey: String; ParentNode: TTreeNode; begin ParentKey := LeftBStr(ChildKey,Length(ChildKey)-ItemLen); ParentNode := ChildNode; while ParentNode<>nil do begin if PBaseNode(ParentNode.Data)^.path = ParentKey then Break; ParentNode := ParentNode.Parent; end; Result := ParentNode; end;procedure G_AddTreeNode(const tvBase: TTreeView; parent: TTreeNode; nodeData: TBaseNode); var pNode: PBaseNode; newNode: TTreeNode; begin newNode := tvBase.Items.AddChild(parent,nodeData.id+#255+nodeData.name); new(pNode); pNode^ := nodeData; newNode.Data := pNode; end;procedure G_DelTreeNode(const tvBase: TTreeView; node: TTreeNode); var nextNode: TTreeNode; begin if (node=nil) or (tvBase.Items.Count=0) then Exit; nextNode := node.getNextSibling; while (nextNode<>nil) and (nextNode.Level<node.Level) do begin Dispose(PBaseNode(nextNode.Data)); nextNode := nextNode.GetNext; end; Dispose(PBaseNode(node.Data)); node.Delete; end;procedure SetChildState(Node:TTreeNode; State:Integer); var Level:Integer; begin Level:=Node.Level; Node:=Node.getFirstChild; while (Node<>nil) and (Node.Level>Level) do begin Node.StateIndex:=State; Node:=Node.GetNext; end; end;procedure SetParentState(Node: TTreeNode); var Flag: Integer; PNode:TTreeNode; begin PNode:=Node.Parent; if PNode<>nil then begin PNode:=PNode.getFirstChild; Flag:=PNode.StateIndex; while PNode<>nil do begin if PNode.StateIndex<>Flag then Flag:=2; PNode:=PNode.getNextSibling; end; Node.Parent.StateIndex:=flag; SetParentState(Node.Parent); end; end;procedure G_SetTreeCheckBox(tvBase: TTreeView; button: TMouseButton; Shift: TShiftState; X, Y: Integer); var node:TTreeNode; myHitTest : THitTests; begin myHitTest := tvBase.GetHitTestInfoAt(X,Y); if (htOnStateIcon in MyHitTest) and (Button=mbLeft) then begin node := tvBase.GetNodeAt(X,Y); case TCheckState(node.StateIndex) of csUnchecked: begin SetChildState(node,node.StateIndex); end; csChecked:begin SetChildState(node,node.StateIndex); end; csGrayed:begin SetChildState(node,node.StateIndex); end; end; SetParentState(node); end; end;procedure G_BuildBaseTree(const tvBase: TTreeView; DataSet: TDataSet; checkBox: boolean=false); var i: Integer; nodeData: PBaseNode; NewNode,ParentNode: TTreeNode; begin G_FreeBaseTree(tvBase); NewNode := nil; for i:=1 to DataSet.RecordCount do begin new(nodeData); nodeData^.sysId := G_GetFieldValue(DataSet,'sysId'); nodeData^.path := G_GetFieldValue(DataSet,'path'); nodeData^.isNode := G_GetFieldValue(DataSet,'isNode')=1; nodeData^.id := G_GetFieldValue(DataSet,'id'); nodeData^.name := G_GetFieldValue(DataSet,'name'); ParentNode := GetBaseParentNode(NewNode,nodeData^.path); NewNode := tvBase.Items.AddChild(ParentNode,nodeData^.id+#255+nodeData^.name); if not nodeData^.isNode then begin NewNode.ImageIndex := 0; NewNode.SelectedIndex := 1; end else begin NewNode.ImageIndex := 2; NewNode.SelectedIndex := 2; end; if checkBox then NewNode.StateIndex := 1; NewNode.Data := nodeData; DataSet.Next; end; if tvBase.Items.Count>0 then tvBase.Items[0].Selected := TRUE; end;function G_GetNodeParentPath(const tvBase: TTreeView; node: TTreeNode): string; begin Result := ''; if (node=nil) or (node.Parent=nil) then Exit; if node.Parent<>nil then begin Result := PBaseNode(node.Parent.Data)^.path; end; end;function G_GetNodePath(const tvBase: TTreeView; node: TTreeNode): string; begin if node=nil then Result := '' else Result := PBaseNode(node.Data)^.path; end;procedure G_SetSelectedNodeText(const tvBase: TTreeView; id,name: string); begin if tvBase.Selected<>nil then begin tvBase.Selected.Text := id+#255+name; PBaseNode(tvBase.Selected.Data)^.id := id; PBaseNode(tvBase.Selected.Data)^.name := name; end; end;
commonfn.pas到此结束。改天再贴 commonbss.pas、DbBridge.pas以及角色管理、用户管理等单元。 procedure G_BuildDBGridTitle(const DBGrid: TDBGrid; DicFields: TDicFieldList); var i: Integer; ValueLst: TStrings; newColumn: TColumn; begin DBGrid.Columns.Clear; for i:=0 to DicFields.nFields-1 do begin if not DicFields.Fields[i].isShow then Continue; newColumn := DBGrid.Columns.Add; newColumn.Title.Alignment := taCenter; newColumn.Title.Caption := DicFields.Fields[i].sName; newColumn.FieldName := DicFields.Fields[i].name; newColumn.Width := DicFields.Fields[i].width; case DicFields.Fields[i].uiType of 'C':begin ValueLst := TStringList.Create; G_SeperateString(DicFields.Fields[i].constant,ValueLst); newColumn.PickList.AddStrings(ValueLst); newColumn.DropDownRows := 20; ValueLst.Free; newColumn.Color := clCream; newColumn.ButtonStyle := TColumnButtonStyle(cbsAuto); end; 'B':NewColumn.ButtonStyle := TColumnButtonStyle(cbsEllipsis); end; newColumn.ReadOnly := DicFields.fields[i].ctrl<3; if newColumn.ReadOnly then newColumn.Color := clReadOnly; end; if DBGrid.ReadOnly then DBGrid.Options := DBGrid.Options+[dgRowSelect]; end;procedure G_BuildDBGridEhTitle(const DBGridEh: TDBGridEh; DicFields: TDicFieldList); var i: Integer; ValueLst: TStrings; ColumnEh: TColumnEh; begin DBGridEh.Columns.Clear; DBGridEh.RowHeight := 18; for i:=0 to DicFields.nFields-1 do begin if Trim(DicFields.fields[i].sName)='' then Continue; if DicFields.fields[i].isShow then begin ColumnEh := DBGridEh.Columns.Add; ColumnEh.Title.Alignment := taCenter; ColumnEh.Title.Caption := DicFields.fields[i].sName; ColumnEh.Title.Color := $FFFFFF; ColumnEh.FieldName := DicFields.fields[i].name; ColumnEh.Width := DicFields.fields[i].width; ColumnEh.Title.TitleButton := (DBGridEh.SortLocal) and (DicFields.fields[i].userType<>'M'); case DicFields.fields[i].uiType of 'C': begin {combobox} ValueLst := TStringList.Create; G_SeperateString(DicFields.fields[i].constant,ValueLst); ColumnEh.PickList.AddStrings(ValueLst); ValueLst.Free; ColumnEh.Color := clEditWithHelp; ColumnEh.ButtonStyle := cbsAuto; end; 'B': begin {button} ColumnEh.Color := clEditWithHelp; ColumnEh.ButtonStyle := cbsEllipsis; end; end; if DicFields.fields[i].ctrl<3 then begin ColumnEh.ReadOnly := TRUE; ColumnEh.Color := clReadOnly; end; end; end; if DBGridEh.ReadOnly then DBGridEh.Options := DBGridEh.Options+[dgRowSelect]; end;procedure G_GetDBGridFields(const DBGrid: TDBGrid; var DicFields: TDicFieldList); var i: integer; begin DicFields.nFields := DBGrid.Columns.Count; SetLength(DicFields.Fields,DicFields.nFields); for i:=0 to DicFields.nFields-1 do begin DicFields.Fields[i].id := i+1; DicFields.Fields[i].name := DBGrid.Columns[i].FieldName; DicFields.Fields[i].sName:= DbGrid.Columns[i].Title.Caption; DicFields.Fields[i].width:= DbGrid.Columns[i].Width; end; end;procedure G_GetDBGridEhFields(const DBGridEh: TDBGridEh; var DicFields: TDicFieldList); {获取 DBGrid 字段信息} var i: integer; begin DicFields.nFields := DBGridEh.Columns.Count; SetLength(DicFields.Fields,DicFields.nFields); for i:=0 to DicFields.nFields-1 do begin DicFields.Fields[i].id := i+1; DicFields.Fields[i].name := DBGridEh.Columns[i].FieldName; DicFields.Fields[i].sName:= DBGridEh.Columns[i].Title.Caption; DicFields.Fields[i].width:= DBGridEh.Columns[i].Width; end; end;function G_GetDBGridColumn(const DBGrid: TDBGrid; FieldName: string): TColumn; var i: integer; begin Result := nil; for i:=0 to DBGrid.Columns.Count-1 do begin if UpperCase(DBGrid.Columns[i].FieldName)=UpperCase(FieldName) then begin Result := DBGrid.Columns[i]; Break; end; end; end;function G_GetDBGridEhColumn(const DBGridEh: TDBGridEh; FieldName: string): TColumnEh; var i: integer; begin Result := nil; for i:=0 to DBGridEh.Columns.Count-1 do begin if UpperCase(DbGridEh.Columns[i].FieldName)=UpperCase(FieldName) then begin Result := DbGridEh.Columns[i]; Break; end; end; end;procedure G_BuildDBGridEhFooterField(const DBGridEh: TDBGridEh; footers: TDBGridEhFooters); var i: integer; column: TColumnEh; begin for i:=0 to footers.nFooter-1 do begin column := G_GetDBGridEhColumn(DbGridEh,footers.footers[i].fieldName); if column<>nil then begin column.Footer.ValueType := footers.footers[i].valueType; if column.Footer.ValueType=fvtStaticText then begin column.Footer.Value := footers.footers[i].display; end; end; end; end;procedure G_DataBind(const DataSource: TDataSource; Container: TWinControl); var i: Integer; control: TControl; begin for i:=0 to Container.ControlCount-1 do begin control := Container.Controls[i]; if control is TDBEdit then TDBEdit(control).DataSource := DataSource; if control is TDBText then TDBText(control).DataSource := DataSource; if control is TDBMemo then TDBMemo(control).DataSource := DataSource; if control is TDBComboBox then TDBComboBox(control).DataSource := DataSource; if control is TDBCheckBox then TDBCheckBox(control).DataSource := DataSource; if control is TDbDateTimePicker then TDbDateTimePicker(control).Datasource := DataSource; end; end;
//------------------------------------------------------------------------------ //公用对话框函数 //------------------------------------------------------------------------------procedure InfoDlg(const Msg: String; ACaption: String = SInformation); begin Application.MessageBox(PChar(Msg), PChar(ACaption), MB_OK + MB_ICONINFORMATION); end;procedure ErrorDlg(const Msg: String; ACaption: String = SError); begin Application.MessageBox(PChar(Msg), PChar(ACaption), MB_OK + MB_ICONERROR); end;procedure WarningDlg(const Msg: String; ACaption: String = SWarning); begin Application.MessageBox(PChar(Msg), PChar(ACaption), MB_OK + MB_ICONWARNING); end;function QueryDlg(const Msg: String; ACaption: String = SQuery): Boolean; begin Result := Application.MessageBox(PChar(Msg), PChar(ACaption), MB_YESNO + MB_ICONQUESTION) = IDYES; end;function QueryNoDlg(const Msg: string; ACaption: string = SQuery): Boolean; begin Result := Application.MessageBox(PChar(Msg), PChar(ACaption), MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2) = IDYES; end;function GetAveCharSize(Canvas: TCanvas): TPoint; var I: Integer; Buffer: array[0..51] of Char; begin for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A')); for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a')); GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result)); Result.X := Result.X div 52; end;function JrInputQuery(const ACaption, APrompt: String; var Value: string): Boolean; var Form: TForm; Prompt: TLabel; Edit: TEdit; DialogUnits: TPoint; ButtonTop, ButtonWidth, ButtonHeight: Integer; begin Result := False; Form := TForm.Create(Application); with Form do try Scaled := False; Font.Name := SDefaultFontName; Font.Size := SDefaultFontSize; Font.Charset := SDefaultFontCharset; Canvas.Font := Font; DialogUnits := GetAveCharSize(Canvas); BorderStyle := bsDialog; Caption := ACaption; ClientWidth := MulDiv(180, DialogUnits.X, 4); ClientHeight := MulDiv(63, DialogUnits.Y, 8); Position := poScreenCenter; Prompt := TLabel.Create(Form); with Prompt do begin Parent := Form; AutoSize := True; Left := MulDiv(8, DialogUnits.X, 4); Top := MulDiv(8, DialogUnits.Y, 8); Caption := APrompt; end; Edit := TEdit.Create(Form); with Edit do begin Parent := Form; Left := Prompt.Left; Top := MulDiv(19, DialogUnits.Y, 8); Width := MulDiv(164, DialogUnits.X, 4); MaxLength := 255; Text := Value; SelectAll; end; ButtonTop := MulDiv(41, DialogUnits.Y, 8); ButtonWidth := MulDiv(50, DialogUnits.X, 4); ButtonHeight := MulDiv(14, DialogUnits.Y, 8); with TButton.Create(Form) do begin Parent := Form; Caption := SMsgDlgOK; ModalResult := mrOk; Default := True; SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth, ButtonHeight); end; with TButton.Create(Form) do begin Parent := Form; Caption := SMsgDlgCancel; ModalResult := mrCancel; Cancel := True; SetBounds(MulDiv(92, DialogUnits.X, 4), ButtonTop, ButtonWidth, ButtonHeight); end; if ShowModal = mrOk then begin Value := Edit.Text; Result := True; end; finally Form.Free; end; end;function JrInputBox(const ACaption, APrompt, ADefault: string): String; begin Result := ADefault; JrInputQuery(ACaption, APrompt, Result); end;//------------------------------------------------------------------------------ //扩展文件目录操作函数 //------------------------------------------------------------------------------procedure RunFile(const FileName: String; Handle: THandle = 0; Param: string = ''); begin ShellExecute(Handle, nil, PChar(FileName), PChar(Param), nil, SW_SHOWNORMAL); end;function AppPath: string; begin Result := ExtractFilePath(Application.ExeName); end;const HKLM_CURRENT_VERSION_WINDOWS = 'SoftwareMicrosoftWindowsCurrentVersion';
function RelativeKey(const Key: string): PChar; begin Result := PChar(Key); if (Key <> '') and (Key[1] = '') then Inc(Result); end;function RegReadStringDef(const RootKey: HKEY; const Key, Name, Def: string): string; var RegKey: HKEY; Size: DWORD; StrVal: string; RegKind: DWORD; begin Result := Def; if RegOpenKeyEx(RootKey, RelativeKey(Key), 0, KEY_READ, RegKey) = ERROR_SUCCESS then begin RegKind := 0; Size := 0; if RegQueryValueEx(RegKey, PChar(Name), nil, @RegKind, nil, @Size) = ERROR_SUCCESS then if RegKind in [REG_SZ, REG_EXPAND_SZ] then begin SetLength(StrVal, Size); if RegQueryValueEx(RegKey, PChar(Name), nil, @RegKind, PByte(StrVal), @Size) = ERROR_SUCCESS then begin SetLength(StrVal, StrLen(PChar(StrVal))); Result := StrVal; end; end; RegCloseKey(RegKey); end; end;procedure StrResetLength(var S: AnsiString); begin SetLength(S, StrLen(PChar(S))); end;function GetProgramFilesDir: string; begin Result := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS, 'ProgramFilesDir', ''); end;function GetWindowsDir: string; var Required: Cardinal; begin Result := ''; Required := GetWindowsDirectory(nil, 0); if Required <> 0 then begin SetLength(Result, Required); GetWindowsDirectory(PChar(Result), Required); StrResetLength(Result); end; end;function GetWindowsTempPath: string; var Required: Cardinal; begin Result := ''; Required := GetTempPath(0, nil); if Required <> 0 then begin SetLength(Result, Required); GetTempPath(Required, PChar(Result)); StrResetLength(Result); end; end; //------------------------------------------------------------------------------ //扩展字符串操作函数 //------------------------------------------------------------------------------function InStr(const sShort: string; const sLong: string): Boolean; var s1, s2: string; begin s1 := LowerCase(sShort); s2 := LowerCase(sLong); Result := Pos(s1, s2) > 0; end;function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string; var s: string; i, j: Integer; begin s := IntToStr(Value); Result := ''; j := 0; for i := Length(s) downto 1 do begin Result := s[i] + Result; Inc(j); if ((j mod SpLen) = 0) and (i <> 1) then Result := Sp + Result; end; end;function ByteToBin(Value: Byte): string; const V: Byte = 1; var i: Integer; begin for i := 7 downto 0 do if (V shl i) and Value <> 0 then Result := Result + '1' else Result := Result + '0'; end;function StrRight(Str: string; Len: Integer): string; begin if Len >= Length(Str) then Result := Str else Result := Copy(Str, Length(Str) - Len + 1, Len); end;function StrLeft(Str: string; Len: Integer): string; begin if Len >= Length(Str) then Result := Str else Result := Copy(Str, 1, Len); end;function Spc(Len: Integer): string; begin SetLength(Result, Len); FillChar(PChar(Result)^, Len, ' '); end;procedure SwapStr(var s1, s2: string); var tempstr: string; begin tempstr := s1; s1 := s2; s2 := tempstr; end;function GetSystemDir: string; var Required: Cardinal; begin Result := ''; Required := GetSystemDirectory(nil, 0); if Required <> 0 then begin SetLength(Result, Required); GetSystemDirectory(PChar(Result), Required); StrResetLength(Result); end; end;
//------------------------------------------------------------------------------ // 扩展日期时间操作函数 //------------------------------------------------------------------------------ function GetYear(Date: TDate): Word; var m, d: WORD; begin DecodeDate(Date, Result, m, d); end; function GetMonth(Date: TDate): Word; var y, d: WORD; begin DecodeDate(Date, y, Result, d); end; function GetDay(Date: TDate): Word; var y, m: WORD; begin DecodeDate(Date, y, m, Result); end;function GetHour(Time: TTime): Word; var h, m, s, ms: WORD; begin DecodeTime(Time, Result, m, s, ms); end;function GetMinute(Time: TTime): Word; var h, s, ms: WORD; begin DecodeTime(Time, h, Result, s, ms); end;function GetSecond(Time: TTime): Word; var h, m, ms: WORD; begin DecodeTime(Time, h, m, Result, ms); end;function GetMSecond(Time: TTime): Word; var h, m, s: WORD; begin DecodeTime(Time, h, m, s, Result); end;//------------------------------------------------------------------------------ // 位操作函数 //------------------------------------------------------------------------------procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean); overload; begin if IsSet then Value := Value or (1 shl Bit) else Value := Value and not(1 shl Bit); end;procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean); overload; begin if IsSet then Value := Value or (1 shl Bit) else Value := Value and not(1 shl Bit); end;procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean); overload; begin if IsSet then Value := Value or (1 shl Bit) else Value := Value and not(1 shl Bit); end;function GetBit(Value: Byte; Bit: TByteBit): Boolean; overload; begin Result := Value and (1 shl Bit) <> 0; end;function GetBit(Value: WORD; Bit: TWordBit): Boolean; overload; begin Result := Value and (1 shl Bit) <> 0; end;function GetBit(Value: DWORD; Bit: TDWordBit): Boolean; overload; begin Result := Value and (1 shl Bit) <> 0; end;//------------------------------------------------------------------------------ // 系统功能函数 //------------------------------------------------------------------------------procedure ChangeFocus(Handle: THandle; Forword: Boolean = False); begin if ForWord then PostMessage(Handle, WM_NEXTDLGCTL, 1, 0) else PostMessage(Handle, WM_NEXTDLGCTL, 0, 0); end;procedure MoveMouseIntoControl(AWinControl: TControl); var rtControl: TRect; begin rtControl := AWinControl.BoundsRect; MapWindowPoints(AWinControl.Parent.Handle, 0, rtControl, 2); SetCursorPos(rtControl.Left + (rtControl.Right - rtControl.Left) div 2, rtControl.Top + (rtControl.Bottom - rtControl.Top) div 2); end;procedure AddComboBoxTextToItems(ComboBox: TComboBox; MaxItemsCount: Integer = 10); begin if (ComboBox.Text <> '') and (ComboBox.Items.IndexOf(ComboBox.Text) < 0) then begin ComboBox.Items.Insert(0, ComboBox.Text); while (MaxItemsCount > 1) and (ComboBox.Items.Count > MaxItemsCount) do ComboBox.Items.Delete(ComboBox.Items.Count - 1); end; end;function DynamicResolution(x, y: WORD): Boolean; var lpDevMode: TDeviceMode; begin Result := EnumDisplaySettings(nil, 0, lpDevMode); if Result then begin lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT; lpDevMode.dmPelsWidth := x; lpDevMode.dmPelsHeight := y; Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL; end; end;procedure StayOnTop(Handle: HWND; OnTop: Boolean); const csOnTop: array[Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST); begin SetWindowPos(Handle, csOnTop[OnTop], 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); end;var WndLong: Integer;procedure SetHidden(Hide: Boolean); begin ShowWindow(Application.Handle, SW_HIDE); if Hide then SetWindowLong(Application.Handle, GWL_EXSTYLE, WndLong or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW or WS_EX_TOPMOST) else SetWindowLong(Application.Handle, GWL_EXSTYLE, WndLong); ShowWindow(Application.Handle, SW_SHOW); end;const csWndShowFlag: array[Boolean] of DWORD = (SW_HIDE, SW_RESTORE);procedure SetTaskBarVisible(Visible: Boolean); var wndHandle: THandle; begin wndHandle := FindWindow('Shell_TrayWnd', nil); ShowWindow(wndHandle, csWndShowFlag[Visible]); end;procedure SetDesktopVisible(Visible: Boolean); var hDesktop: THandle; begin hDesktop := FindWindow('Progman', nil); ShowWindow(hDesktop, csWndShowFlag[Visible]); end;function GetWorkRect: TRect; begin SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0) end;procedure BeginWait; begin Screen.Cursor := crHourGlass; end;procedure EndWait; begin Screen.Cursor := crDefault; end;function CheckWindows9598: Boolean; var V: TOSVersionInfo; begin V.dwOSVersionInfoSize := SizeOf(V); Result := False; if not GetVersionEx(V) then Exit; if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then Result := True; end;function GetOSString: string; var OSPlatform: string; BuildNumber: Integer; begin Result := 'Unknown Windows Version'; OSPlatform := 'Windows'; BuildNumber := 0; case Win32Platform of VER_PLATFORM_WIN32_WINDOWS: begin BuildNumber := Win32BuildNumber and $0000FFFF; case Win32MinorVersion of 0..9: begin if Trim(Win32CSDVersion) = 'B' then OSPlatform := 'Windows 95 OSR2' else OSPlatform := 'Windows 95'; end; 10..89: begin if Trim(Win32CSDVersion) = 'A' then OSPlatform := 'Windows 98' else OSPlatform := 'Windows 98 SE'; end; 90: OSPlatform := 'Windows Millennium'; end; end; VER_PLATFORM_WIN32_NT: begin if Win32MajorVersion in [3, 4] then OSPlatform := 'Windows NT' else if Win32MajorVersion = 5 then begin case Win32MinorVersion of 0: OSPlatform := 'Windows 2000'; 1: OSPlatform := 'Windows XP'; end; end; BuildNumber := Win32BuildNumber; end; VER_PLATFORM_WIN32s: begin OSPlatform := 'Win32s'; BuildNumber := Win32BuildNumber; end; end; if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) or (Win32Platform = VER_PLATFORM_WIN32_NT) then begin if Trim(Win32CSDVersion) = '' then Result := Format('%s %d.%d (Build %d)', [OSPlatform, Win32MajorVersion, Win32MinorVersion, BuildNumber]) else Result := Format('%s %d.%d (Build %d: %s)', [OSPlatform, Win32MajorVersion, Win32MinorVersion, BuildNumber, Win32CSDVersion]); end else Result := Format('%s %d.%d', [OSPlatform, Win32MajorVersion, Win32MinorVersion]) end;function GetComputeNameStr : string; var dwBuff : DWORD; CmpName : array [0..255] of Char; begin Result := ''; dwBuff := 256; FillChar(CmpName, SizeOf(CmpName), 0); if GetComputerName(CmpName, dwBuff) then Result := StrPas(CmpName); end;function GetLocalUserName: string; var Count: DWORD; begin Count := 256 + 1; // UNLEN + 1 // set buffer size to 256 + 2 characters SetLength(Result, Count); if GetUserName(PChar(Result), Count) then StrResetLength(Result) else Result := ''; end;
function GetLocalIP: 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); Result := ''; GetHostName(Buffer, SizeOf(Buffer)); phe :=GetHostByName(buffer); if phe = nil then Exit; pptr := PaPInAddr(Phe^.h_addr_list); I := 0; while pptr^[I] <> nil do begin result:=StrPas(inet_ntoa(pptr^[I]^)); Inc(I); end; WSACleanup; end;//------------------------------------------------------------------------------ // 其它过程 //------------------------------------------------------------------------------function TrimInt(Value, Min, Max: Integer): Integer; overload; begin if Value > Max then Result := Max else if Value < Min then Result := Min else Result := Value; end;function InBound(Value: Integer; Min, Max: Integer): Boolean; begin Result := (Value >= Min) and (Value <= Max); end;procedure Delay(const uDelay: DWORD); var n: DWORD; begin n := GetTickCount; while ((GetTickCount - n) <= uDelay) do Application.ProcessMessages; end;procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1); const FREQ_SCALE = $1193180; var Temp: WORD; begin Temp := FREQ_SCALE div Freq; asm in al,61h; or al,3; out 61h,al; mov al,$b6; out 43h,al; mov ax,temp; out 42h,al; mov al,ah; out 42h,al; end; Sleep(Delay); asm in al,$61; and al,$fc; out $61,al; end; end;function GetHzPy(const AHzStr: string): string; const ChinaCode: array[0..25, 0..1] of Integer = ((1601, 1636), (1637, 1832), (1833, 2077), (2078, 2273), (2274, 2301), (2302, 2432), (2433, 2593), (2594, 2786), (9999, 0000), (2787, 3105), (3106, 3211), (3212, 3471), (3472, 3634), (3635, 3722), (3723, 3729), (3730, 3857), (3858, 4026), (4027, 4085), (4086, 4389), (4390, 4557), (9999, 0000), (9999, 0000), (4558, 4683), (4684, 4924), (4925, 5248), (5249, 5589)); var i, j, HzOrd: Integer; begin i := 1; while i <= Length(AHzStr) do begin if (AHzStr[i] >= #160) and (AHzStr[i + 1] >= #160) then begin HzOrd := (Ord(AHzStr[i]) - 160) * 100 + Ord(AHzStr[i + 1]) - 160; for j := 0 to 25 do begin if (HzOrd >= ChinaCode[j][0]) and (HzOrd <= ChinaCode[j][1]) then begin Result := Result + Char(Byte('A') + j); Break; end; end; Inc(i); end else Result := Result + AHzStr[i]; Inc(i); end; end;function UpperCaseMoney(const Money: Double): String; var tmp1,rr :string; l,i,j,k:integer; r: Double; const n1: array[0..9] of string = ('零', '壹', '贰', '叁', '肆', '伍', '陆', '柒', '捌', '玖'); n2: array[0..3] of string = ('', '拾' ,'佰', '仟'); n3: array[0..2] of string = ('元', '万', '亿'); begin r:=Money; tmp1:=FormatFloat('#.00',r); l:=length(tmp1); rr:=''; if strtoint(tmp1[l])<>0 then begin rr:='分'; rr:=n1[strtoint(tmp1[l])]+rr; end; if strtoint(tmp1[l-1])<>0 then begin rr:='角'+rr; rr:=n1[strtoint(tmp1[l-1])]+rr; end; i:=l-3; j:=0;k:=0; while i>0 do begin if j mod 4=0 then begin rr:=n3[k]+rr; inc(k);if k>2 then k:=1; j:=0; end; if strtoint(tmp1[i])<>0 then rr:=n2[j]+rr; rr:=n1[strtoint(tmp1[i])]+rr; inc(j); dec(i); end; while pos('零零',rr)>0 do rr:= stringreplace(rr,'零零','零',[rfReplaceAll]); rr:=stringreplace(rr,'零亿','亿零',[rfReplaceAll]); while pos('零零',rr)>0 do rr:= stringreplace(rr,'零零','零',[rfReplaceAll]); rr:=stringreplace(rr,'零万','万零',[rfReplaceAll]); while pos('零零',rr)>0 do rr:= stringreplace(rr,'零零','零',[rfReplaceAll]); rr:=stringreplace(rr,'零元','元零',[rfReplaceAll]); while pos('零零',rr)>0 do rr:= stringreplace(rr,'零零','零',[rfReplaceAll]); rr:=stringreplace(rr,'亿万','亿',[rfReplaceAll]);
if copy(rr,length(rr)-1,2)='零' then rr:=copy(rr,1,length(rr)-2); result:=rr; end;function SoundCardExist: Boolean; begin Result := WaveOutGetNumDevs > 0; end;initialization WndLong := GetWindowLong(Application.Handle, GWL_EXSTYLE);end. Trackback: http://tb.blog.csdn.net/TrackBack.aspx?PostId=1862017
GetLocalIp，不应该只有一个IP，当有多块网卡的时候，这个是不对的。function GetLocalIpList(var IpList:TStringList):Integer; type TaPInAddr = array[0..10] of PInAddr; PaPInAddr = ^TaPInAddr; var HostName : array [0..MAX_PATH] of char; NameLen:Integer; WSData: TWSAData; lpHostEnt:PHostEnt; I:Integer; pptr: PaPInAddr; begin Result := 0; if WSAStartup(MakeWord(2,0), WSData)<>0 then Exit; try NameLen := sizeof(HostName); fillchar(HostName,NameLen,0); NameLen:=GetHostName(HostName,NameLen); if NameLen = SOCKET_ERROR then Exit; lpHostEnt := GetHostByName(HostName); if lpHostEnt = Nil then Exit; I := 0; pPtr := PaPInAddr(lpHostEnt^.h_addr_list); IpList.Clear; while pPtr^[I] <> nil do begin IpList.ADD( inet_ntoa(pptr^[I]^)); Inc(I); end; Result := IpList.Count; finally WSACleanup; end; end;
function TF_public.f_run_one: boolean; //限制程序只能运行一个实例 var errNO: integer; hMutex: HWND; begin hMutex := CreateMutex(nil, False, pchar(application.title)); errNO := GetLastError; if errNO = ERROR_ALREADY_EXISTS then begin //检测是否重复运行 application.MessageBox('本软件只能打开一次，重复运行则其中之一将退出！', pchar(application.title), MB_OK); application.Terminate; end; result := true; end;
function month_lastday(type1: string; query: tadoquery): tdatetime; //本月最后一天 var s: string; begin with query do begin close; sql.clear; if type1 = 'first' then sql.add('SELECT DATEADD(mm,DATEDIFF(mm,0,getdate()),0) as d1 '); if type1 = 'last' then sql.add('SELECT DATEADD(day, DATEDIFF(day,0,dateadd(ms,-3,DATEADD(mm, DATEDIFF(m,0,getdate())+1,0))),0) as d1 '); Open; s := fieldbyname('d1').asstring; result := StrToDate(s); end; end;
在使用Delphi中，如果我们想存放一组对象时，用ObjectList最方便
如果将TObjectList的OwnsObjects属性设为True,那么Objectlist将自动管理数组成员的生命期~
例：
UserList:=TObjectList.Create(True)
此外还有Add,Remove等方法~
将库文件a.lib转换格式生成库文件b.lib
coff2omf可以转换微软的COFF格式为Borland使用的OMF格式
在bcb6中导入即可直接调用了！另外：tdump -ee mydll.dll >1.txt
研究一下别的程序或者dll里边调用了什么函数
--相关子查询与普通子查询的区别在于：相关子查询引用了外部查询中的列！这种用外部查询来限制子查询的方法使
SQL查询变得更加强大和灵活。因为相关子查询能够引用外部查询，所以它们尤其适合编写复杂的where条件！
相关子查询不能自己单独运行，其执行顺序如下：
1.首先执行一次外部查询
2.对于外部查询中的每一行分别执行一次子查询，而且每次执行子查询时都会引用外部查询中当前行的值。
3.使用子查询的结果来确定外部查询的结果集。
如果外部查询返回100行，SQL 就将执行101次查询，一次执行外部查询，然后为外部查询返回的每一行执行一次子查询。但实际上，SQL的查询
优化器有可能会找到一种更好的方法来执行相关子查询，而不需要实际执行101次查询。相关子查询典型用法：
declare @t table(rq varchar(10),hh int,ye dec(6,2))
insert into @t select '2006-01-02' ,1111 ,2.01
union all select '2006-01-05' ,1111 ,3.51
union all select '2006-01-10' ,1111 ,2.55
union all select '2006-01-02' ,2222 ,3.00
union all select '2006-01-04' ,2222 ,2.00
union all select '2006-01-05' ,3333 ,6.54
union all select '2006-01-06' ,3333 ,5.23
union all select '2006-01-07' ,3333 ,8.55select * from @t a where not exists(select 1 from @t where hh=a.hh and rq>a.rq)
而且收集整理各种资料的事情，也早就有人在做，
大富翁离线资料、CSDN的FAQ、Delphi超级猛料、delphi未经证实葵花宝典
这些资料都已经很全了
还是别做重复劳动的好
可以做个基类使用，主要功能就是是子类的用户输入控件可以自动变色，
不必考虑种类繁多的第三方控件,
只要是有Color，OnEnter，OnExit，OnChange属性就行。
unit Ufrmbase;interfaceuses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons,typinfo;
type
Tfrmbase = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure CmpEnter(Sender: TObject); //用户获得焦点
procedure CmpExit(Sender: TObject); //用户失去焦点
public
{ Public declarations }
protected
procedure pSetComponents;
end;var
frmbase: Tfrmbase;
//以后应该是可以设置的。风格管理，可以保存在注册表中
const
ENTERC0LOR = $00CDBDB4;
EXITCOLOR = $00DAF3DD;
implementation
{$R *.dfm}
procedure Tfrmbase.CmpEnter(Sender: TObject);
var
sProp: PPropInfo;
begin
sProp := GetPropInfo(Sender.ClassInfo, 'Color');
if sProp <> nil then
SetOrdProp(Sender, sProp, ENTERC0LOR);
end;procedure Tfrmbase.CmpExit(Sender: TObject);
var
sProp: PPropInfo;
begin
sProp := GetPropInfo(Sender.ClassInfo, 'Color');
if sProp <> nil then
SetOrdProp(Sender, sProp, EXITCOLOR);
end;procedure Tfrmbase.pSetComponents;
var
i: Integer;
sColor, sEnter, sExit, sChanged: PPropInfo;
vEnter, vExit: TMethod;
mEvent: TNotifyEvent;
begin
for i := 0 to componentcount - 1 do
begin
sColor := GetPropInfo(Components[i].ClassInfo, 'Color');
sEnter := GetPropInfo(Components[i].ClassInfo, 'OnEnter');
sExit := GetPropInfo(Components[i].ClassInfo, 'OnExit');
sChanged := GetPropInfo(Components[i].ClassInfo, 'OnChange');
if (sChanged <> nil) and (sEnter <> nil) and
(sExit <> nil) and (sColor <> nil) then
begin
SetOrdProp(Components[i], sColor, EXITCOLOR);
mEvent := CmpEnter;
vEnter.Code := @mEvent;
vEnter.Data := Self;
SetMethodProp(Components[i], sEnter, vEnter);
mEvent := CmpExit;
vExit.Code := @mEvent;
vExit.Data := Self;
SetMethodProp(Components[i], sExit, vExit);
end;
end;end;procedure Tfrmbase.FormCreate(Sender: TObject);
begin
pSetComponents;
end;
end.
如果要在窗体的画布上画图，消除重画时窗体的闪烁，可以在窗体创建时设置双内存机制。
self.doublebuffered:=true;好处是：重画时（onPain()）窗体不会闪烁；
不足是：内存消耗较大；//--------------
将数据加载到内存时，我们多使用动态数组，动态数组的使用是比较好用的。
1、生存期管理是由编译负责；
2、增加长度时，重新SetLength()不会影响原有的数据；
3、从数组中删除某个元素时，可以采用将数据项向前移的方法，移动完数据后，可以重新分配数组长度（缩短）；
4、使用记录类型数据的数组时，可以在记录类型中加入管理方法，实现对记录类型数据中，对象类型数据的管理；
begin
result:=TStringList.Create;
result.Add('1');
result.Add('2');
end;procedure TForm1.Button1Click(Sender: TObject);
var
str:TStrings;
begin
// str:=TStringList.Create;内存泄露
str:=getlist;
showmessage(str.Text);
str.Free;
end;
//造成内存泄露的主要原因是程序员没有把对象与对象引用搞清楚~
我有一个单元。
unit IMCode;interfacefunction MakeSpellCode(stText: string; iMode, iCount: Integer): string;
{ iMode 二进制功能位说明
X X X X X X X X X X X X X X X X
3 2 1
1: 0 - 只取各个汉字声母的第一个字母; 1 - 全取
2: 0 - 遇到不能翻译的字符不翻译; 1 - 翻译成 '?' (本选项目针对全角字符)
3: 0 - 生成的串不包括非数字, 字母的其他字符; 1 - 包括
(控制全角的要输出非数字, 字母字符的; 半角的非数字, 字母字符)
}function GetSpellCode(szText: PChar; iMode, iCount: Integer): PChar; stdcall;implementationuses
SysUtils;type
{ 拼音代码表 }
TPYCode = record
PYCode: string[6];
end;
TFPYCodes = array [1..126, 1..191] of TPYCode;const
PYMUSICCOUNT = 405;
PyMusicCode: array [1..PYMUSICCOUNT] of string[6] = { 汉字基本发音表 } (
'a', 'ai', 'an', 'ang', 'ao', 'ba', 'bai', 'ban', 'bang', 'bao',
'bei', 'ben', 'beng', 'bi', 'bian', 'biao', 'bie', 'bin', 'bing', 'bo',
'bu', 'ca', 'cai', 'can', 'cang', 'cao', 'ce', 'ceng', 'cha', 'chai',
'chan', 'chang', 'chao', 'che', 'chen', 'cheng', 'chi', 'chong', 'chou', 'chu',
'chuai', 'chuan', 'chuang', 'chui', 'chun', 'chuo', 'ci', 'cong', 'cou', 'cu',
'cuan', 'cui', 'cun', 'cuo', 'da', 'dai', 'dan', 'dang', 'dao', 'de',
'deng', 'di', 'dian', 'diao', 'die', 'ding', 'diu', 'dong', 'dou', 'du',
'duan', 'dui', 'dun', 'duo', 'e', 'en', 'er', 'fa', 'fan', 'fang',
'fei', 'fen', 'feng', 'fu', 'fou', 'ga', 'gai', 'gan', 'gang', 'gao',
'ge', 'ji', 'gen', 'geng', 'gong', 'gou', 'gu', 'gua', 'guai', 'guan',
'guang', 'gui', 'gun', 'guo', 'ha', 'hai', 'han', 'hang', 'hao', 'he',
'hei', 'hen', 'heng', 'hong', 'hou', 'hu', 'hua', 'huai', 'huan', 'huang',
'hui', 'hun', 'huo', 'jia', 'jian', 'jiang', 'qiao', 'jiao', 'jie', 'jin',
'jing', 'jiong', 'jiu', 'ju', 'juan', 'jue', 'jun', 'ka', 'kai', 'kan',
'kang', 'kao', 'ke', 'ken', 'keng', 'kong', 'kou', 'ku', 'kua', 'kuai',
'kuan', 'kuang', 'kui', 'kun', 'kuo', 'la', 'lai', 'lan', 'lang', 'lao',
'le', 'lei', 'leng', 'li', 'lia', 'lian', 'liang', 'liao', 'lie', 'lin',
'ling', 'liu', 'long', 'lou', 'lu', 'luan', 'lue', 'lun', 'luo', 'ma',
'mai', 'man', 'mang', 'mao', 'me', 'mei', 'men', 'meng', 'mi', 'mian',
'miao', 'mie', 'min', 'ming', 'miu', 'mo', 'mou', 'mu', 'na', 'nai',
'nan', 'nang', 'nao', 'ne', 'nei', 'nen', 'neng', 'ni', 'nian', 'niang',
'niao', 'nie', 'nin', 'ning', 'niu', 'nong', 'nu', 'nuan', 'nue', 'yao',
'nuo', 'o', 'ou', 'pa', 'pai', 'pan', 'pang', 'pao', 'pei', 'pen',
'peng', 'pi', 'pian', 'piao', 'pie', 'pin', 'ping', 'po', 'pou', 'pu',
'qi', 'qia', 'qian', 'qiang', 'qie', 'qin', 'qing', 'qiong', 'qiu', 'qu',
'quan', 'que', 'qun', 'ran', 'rang', 'rao', 're', 'ren', 'reng', 'ri',
'rong', 'rou', 'ru', 'ruan', 'rui', 'run', 'ruo', 'sa', 'sai', 'san',
'sang', 'sao', 'se', 'sen', 'seng', 'sha', 'shai', 'shan', 'shang', 'shao',
'she', 'shen', 'sheng', 'shi', 'shou', 'shu', 'shua', 'shuai', 'shuan', 'shuang',
'shui', 'shun', 'shuo', 'si', 'song', 'sou', 'su', 'suan', 'sui', 'sun',
'suo', 'ta', 'tai', 'tan', 'tang', 'tao', 'te', 'teng', 'ti', 'tian',
'tiao', 'tie', 'ting', 'tong', 'tou', 'tu', 'tuan', 'tui', 'tun', 'tuo',
'wa', 'wai', 'wan', 'wang', 'wei', 'wen', 'weng', 'wo', 'wu', 'xi',
'xia', 'xian', 'xiang', 'xiao', 'xie', 'xin', 'xing', 'xiong', 'xiu', 'xu',
'xuan', 'xue', 'xun', 'ya', 'yan', 'yang', 'ye', 'yi', 'yin', 'ying',
'yo', 'yong', 'you', 'yu', 'yuan', 'yue', 'yun', 'za', 'zai', 'zan',
'zang', 'zao', 'ze', 'zei', 'zen', 'zeng', 'zha', 'zhai', 'zhan', 'zhang',
'zhao', 'zhe', 'zhen', 'zheng', 'zhi', 'zhong', 'zhou', 'zhu', 'zhua', 'zhuai',
'zhuan', 'zhuang', 'zhui', 'zhun', 'zhuo', 'zi', 'zong', 'zou', 'zu', 'zuan',
'zui', 'zun', 'zuo', '', 'ei', 'm', 'n', 'dia', 'cen', 'nou',
'jv', 'qv', 'xv', 'lv', 'nv'
);
unit Unit1;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
StdCtrls, ExtCtrls;type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
Edit2: TEdit;
Label1: TLabel;
Label2: TLabel;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure ListBox1DblClick(Sender: TObject);
procedure Edit1Change(Sender: TObject);
procedure Edit1KeyPress(Sender: TObject; var Key: Char);
private
function Keyhookresult(lP: integer; wP: integer): pchar;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
hookkey: string;
hooktimes: word;
hHook: integer;
implementation
{$R *.DFM}function TForm1.Keyhookresult(lP: integer; wP: integer): pchar;
begin
result := '[Print Screen]';
{ VK_0 thru VK_9 are the same as ASCII '0' thru '9' ($30 - $39) }
{ VK_A thru VK_Z are the same as ASCII 'A' thru 'Z' ($41 - $5A) }
case lp of
14354: result := '[Alt]'; //不能识别
10688: result := '`';
561: Result := '1';
818: result := '2';
1075: result := '3';
1332: result := '4';
1589: result := '5';
1846: result := '6';
2103: result := '7';
2360: result := '8';
2617: result := '9';
2864: result := '0';
3261: result := '-';
3515: result := '=';
4177: result := 'Q';
4439: result := 'W';
4677: result := 'E';
4946: result := 'R';
5204: result := 'T';
5465: result := 'Y';
5717: result := 'U';
5961: result := 'I';
6223: result := 'O';
6480: result := 'P';
6875: result := '[';
7133: result := ']';
11228: result := '\';
7745: result := 'A';
8019: result := 'S';
8260: result := 'D';
8518: result := 'F';
8775: result := 'G';
9032: result := 'H';
9290: result := 'J';
9547: result := 'K';
9804: result := 'L';
10170: result := ';';
10462: result := '''';
11354: result := 'Z';
11608: result := 'X';
11843: result := 'C';
12118: result := 'V';
12354: result := 'B';
12622: result := 'N';
12877: result := 'M';
13244: result := ',';
13502: result := '.';
13759: result := '/';
13840: result := '[Right-Shift]';
14624: result := '[Space]';
283: result := '[Esc]';
15216: result := '[F1]';
15473: result := '[F2]';
15730: result := '[F3]';
15987: result := '[F4]';
16244: result := '[F5]';
16501: result := '[F6]';
16758: result := '[F7]';
17015: result := '[F8]';
17272: result := '[F9]';
17529: result := '[F10]';
22394: result := '[F11]';
22651: result := '[F12]';
10768: Result := '[Left-Shift]';
14868: result := '[CapsLock]';
3592: result := '[Backspace]';
3849: result := '[Tab]';
7441:
if wp > 30000 then
result := '[Right-Ctrl]'
else
result := '[Left-Ctrl]';
13679: result := '[Num /]';
17808: result := '[NumLock]';
300: result := '[Print Screen]';
18065: result := '[Scroll Lock]';
17683: result := '[Pause]';
21088: result := '[Num0]';
21358: result := '[Num.]';
20321: result := '[Num1]';
20578: result := '[Num2]';
20835: result := '[Num3]';
19300: result := '[Num4]';
19557: result := '[Num5]';
19814: result := '[Num6]';
18279: result := '[Num7]';
18536: result := '[Num8]';
18793: result := '[Num9]';
19468: result := '[*5*]';
14186: result := '[Num *]';
19053: result := '[Num -]';
20075: result := '[Num +]';
21037: result := '[Insert]';
21294: result := '[Delete]';
18212: result := '[Home]';
20259: result := '[End]';
18721: result := '[PageUp]';
20770: result := '[PageDown]';
18470: result := '[UP]';
20520: result := '[DOWN]';
19237: result := '[LEFT]';
19751: result := '[RIGHT]';
7181: result := '[Enter]';
end;
end;//钩子回调过程
function HookProc(iCode: integer; wParam: wParam; lParam: lParam): LResult; stdcall;
var
s:string;
begin
if (PEventMsg(lparam)^.message = WM_KEYDOWN) then
begin
//事件消息，键盘按下
s:=format('Down:%5d %5d ',[PEventMsg(lparam)^.paramL,PEventMsg(lparam)^.paramH])+Form1.Keyhookresult(peventMsg(lparam)^.paramL, peventmsg(lparam)^.paramH);
Form1.ListBox1.Items.Add(s);
end
else if (PEventMsg(lparam)^.message = WM_KEYUP) then
begin
//键盘按键
s:=format(' Up:%5d %5d ',[PEventMsg(lparam)^.paramL,PEventMsg(lparam)^.paramH])+Form1.Keyhookresult(PEventMsg(lparam)^.paramL,PEventMsg(lparam)^.paramH);
Form1.ListBox1.Items.Add(s);
end;
end;procedure TForm1.FormCreate(Sender: TObject);
begin
hooktimes := 0;
hHook := 0;
end;procedure TForm1.Button1Click(Sender: TObject);
begin
inc(hooktimes);
if hooktimes = 1 then
begin
hookkey := TimeToStr(now) + ' ';
hHook := SetWindowsHookEx(WH_JOURNALRECORD, HookProc, HInstance, 0);
MessageBox(0, '键盘监视启动', '信息', MB_ICONINFORMATION + MB_OK);
end;
end;procedure TForm1.Button2Click(Sender: TObject);
begin
UnHookWindowsHookEx(hHook);
hHook := 0;
if hooktimes <> 0 then
begin
MessageBox(0, '键盘监视关闭', '信息', MB_ICONINFORMATION + MB_OK);
end;
hooktimes := 0;
end;procedure TForm1.ListBox1DblClick(Sender: TObject);
begin
listbox1.clear;
end;procedure TForm1.Edit1Change(Sender: TObject);
var
i:DWORD;
begin
if length(edit1.text)<>1 then exit;
//映射虚拟键
i:=MapVirtualKey(ord(edit1.text[1]), 0 );
edit2.text:=format('%d %x',[i,i]);
end;procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
edit1.text:='';
end;end.
{------------------- MIS框架数据类型及通用函数定义及实现 ----------------------}
{数据类型描述是对MIS框架中常用到的一些数据结构进行封装和描述，包括数据库类型、 }
{数据库参数、用户操作类型（增/删/改）、表字典、表字段字典描述等，定义和描述这些}
{数据类型目的在于方便今后开发，实现面向对象开发过程，节省接口参数传递参数数目。}
{ design by lynmison @ 2005 10 10,contact with me [email protected] }unit commonfn;interface
uses Classes, Forms, Windows, Variants, SysUtils, DB, ADODB, ADOInt,
ActnList, WinSock, Graphics, ExtCtrls,
Controls, StdCtrls, DBCtrls, DBGrids, DBGridEh, ComCtrls, StrUtils,
DbDateTimePicker, Menus, SConnect, DBClient, XTreeView;const
G_SYS_VERSIONYEAR = '2007';
G_SYS_APP = '通用商贸进销存管理系统';
G_SYS_COMPANY = '福州麦迪软件有限公司';
G_SYS_WEBSITE = 'www.mydi.com'; clReadOnly =$00EBEBEB; {只读颜色}
clEditWithHelp=$00F5FFEC; {只读，但可从调用其他数据修改}
clReadWrite =clWhite; {可读写颜色} G_SEPERATOR = #255;type
{数据库相关信息--------------------------------------------------------------}
TDbType=(dbAccess,dbSQL,dbSybase,dbOracle);
TDbParam=record
dbType : TDbType; {数据库类型}
host : string[64]; {数据库主机}
dbName : string[32]; {数据库名称}
dba : string[16]; {数据库用户帐号}
pwd : string[16]; {数据库用户密码}
reserve: integer; {保留字}
end; {系统参数表 -----------------------------------------------------------------}
TSysParam=record
sysId : string; {站点内码}
id : string; {站点编号}
station : string; {站点名称}
server : string; {远程服务器}
account : string; {远程登录账号}
pwd : string; {登录密码}
saleOption: smallint; {0-批发;1-零售;2-批发零售}
postCode : string;
addr : string;
webAddr : string;
email : string;
tel : string;
fax : string;
re : string;
autoSave : boolean;
autoTransmit: boolean;
timeTransmit: TDateTime;
delUploaded : boolean;
version : double;
end; {系统角色信息----------------------------------------------------------------}
PRole=^TRole;
TRole=record
id : string; {角色编号}
name : string; {角色名称}
re: string; {备 注}
funcs : string; {功 能 集}
end;
{操作用户信息----------------------------------------------------------------}
TUserType=(utCommon,utAdmin,utSuper); {普通用户、管理员、超级用户}
TUserState=(usUnknown=-1,usNormal,usNone,usErrPwd,usSuspend); {未知状态、正常、不存在、密码错误、停用}
PUser=^TUser;
TUser=record
id : string; {帐号}
name : string; {名称}
userType: TUserType; {类别}
pwd : string; {密码}
roles : string; {角色}
funcs : string; {功能集合}
re : string; {备注}
end; {用户操作类型----------------------------------------------------------------}
TOperate=(opNew,opModify,opBrowse);
TValueOption=(voNone,voSingle,voMulti); {基本信息取值调用类别：无，即维护、单值、多值} {功能项数据结构--------------------------------------------------------------} {菜单、工具按钮资源数据结构}
_ResType=(rtMenu{菜单资源},rtButton{按钮资源},rtTree{操作树资源});
TRes=record
resId: integer; {资源编号}
resFile: string; {资源文件名称}
end;
TResLst=record
count: integer;
ress : array of TRes;
end; {功能项数据结构}
PFunc=^TFunc;
TFunc=record
id : string; {功能编号}
name : string; {功能名称}
onAction : string; {响应描述}
caption : string; {功能标题}
shortCaption: string; {功能标题简写}
menuImage : integer; {功能菜单图标索引}
toolImage : integer; {功能按钮图标索引}
treeImage : integer; {功能树节点图标索引}
treeSelImage: integer; {功能树节点选中图标}
re : string; {说明}
grouped : boolean; {菜单是否分组}
btnIndex : integer; {工具按钮索引，-1表示无按钮}
btnGrouped : boolean; {按钮是否分组}
visible : boolean; {功能菜单是否可见}
enabled : boolean; {功能是否开放}
leaf : boolean; {是否叶子节点标记}
tag : integer; {存放标示}
end;
TFuncLst=record
count: integer;
funcs: array of TFunc;
end; {数据字典--------------------------------------------------------------------}
{表字典结构}
PDicTable=^TDicTable;
TDicTable=record
name : string; {表名称}
cName : string; {中文名称}
sType : string; {业务类别描述}
nType : integer; {业务类别代码;0-系统；1-基本信息；2—表示各类业务}
ctrl : smallint; {控制字:0-拒绝访问；1-只读；2-只写；3-可读写}
visible : smallint; {0-不可见；1-可见}
tabOrder: integer; {顺序}
re : string; {备注}
rptFiles: string; {报表文件,用"|"分割}
end;
{表字典列表}
TDicTableList=record
nTables: integer;
tables : array of TDicTable;
end; {表字段字典}
PDicField=^TDicField;
TDicField=record
tbName : string; {表代码}
id : integer; {序号}
name : string; {字段名称}
cName : string; {中文名称}
sName : string; {显示名称}
constant : string; {字段常量}
userType : char; {字段用户类型}
isShow : boolean; {是否显示}
format : string; {显示格式}
width : integer; {宽度}
uiType : char; {界面表现形式}
ctrl : smallint; {控制字}
color : TColor; {控制颜色}
query : boolean; {是否可作为查询条件}
end;
{字段列表--------------------------------------------------------------------}
TDicFieldList=record
nFields: integer;
fields : array of TDicField;
end;
{字段字典常量----------------------------------------------------------------}
PConstItem=^TConstItem;
TConstItem=record
name: string;
cName: string;
values: string;
end; {基本信息数据项--------------------------------------------------------------}
PBaseNode=^TBaseNode;
TBaseNode=record
sysId : string;
path : string;
isNode: boolean;
id : string;
name : string;
end; {报表参数--------------------------------------------------------------------}
TRptVariant=record //单个报表变量
itemName : string;
itemValue: Variant;
end;
TRptVariants=record
nItem: integer;
datas: array of TRptVariant;
end; {报表打印数据----------------------------------------------------------------}
TPrintOption=(poDesign,poPreview,poPrint);
TRptData=record
itemTable: string; {数据项目对应标代码}
itemName : string; {数据项目名称}
itemData : TDataSet; {数据集}
end;
TRptParams=record
nItem : integer; {多少项数据项目}
rptName: string; {报表名称}
option : TPrintOption; {打印选项}
datas : array of TRptData; {打印数据}
end; {DBGridEh 页脚---------------------------------------------------------------}
TDBGridEhFooter=record
fieldName: string;
valueType: TFooterValueType;
display : string;
end;
TDBGridEhFooters=record
nFooter: integer;
footers: array of TDBGridEhFooter;
end;
{资源处理代码}
procedure LoadJpegFromRes(const image: TImage; resName: string); stdcall; external 'resource.dll';
procedure LoadIconFromRes(const icon: TIcon; resName: string); stdcall; external 'resource.dll';
function G_MessageBox(text: string; flags: longint=MB_OK or MB_ICONINFORMATION;
caption: string=''): integer; //信息提示框
function G_GetControlByName(parent: TWinControl; componentName: string): TControl; //通过控件名称获取控件
function G_FormatDT(DateTime: TDateTime; Format: string='yyyy-mm-dd'): string; //格式化日期时间
function G_FormatSqlDt(DbType: TDBType; DateTime: TDateTime;
format: string='yyyy-mm-dd'): string; //格式化数据库日期时间
function G_FormatSqlDtEx(DbType: TDBType; fieldName: string; dataset: TDataSet;
format: string='yyyy-mm-dd'): string; //格式化数据库日期时间
function G_CharSqlIndex(DbType: TDbType; strCheck,strMatch: string): string; //处理字符串是否包含关系SQL
function G_ValidateValue(const Sender: TObject; tips: string): boolean; //控件录入一些值校验
procedure G_SeperateString(value: string; const list: TStrings; dot: string='|'); //分离字符串
function G_GetChineseString(chinese: string): string; //获取汉字对应英文字母function G_GetLocalHostName(): string; //获取本机名称
function G_GetLocalHostIp(): string; //获取本机IP地址function G_GetSystemDisplay(var mode: TDevMode): boolean; //获取当前显示
function G_SetSystemDisplay(newMode: TDevMode): Boolean; //动态设置屏幕分辨率
procedure G_RestoreWindow(hWnd: THandle); //动态设置屏幕分辨率{common db functions ----------------------------------------------------------}
procedure G_SetDbParam(value: TDbParam; fileName: string); //设置数据库参数
function G_GetDbParam(var value: TDbParam; fileName: string): boolean; //获取数据库参数procedure G_CloseDB(const adocnn: TADOConnection); //关闭数据库联接
function G_ConnectDB(const adocnn: TADOConnection; dbParam: TDbParam): boolean; //建立数据库联接function G_RunSql(const adocmd: TADOCommand; strSql: string): boolean; //执行SQL命令
function G_BeginTran(const adocnn: TADOConnection): boolean; //启动事务
function G_CommitTran(const adocnn: TADOConnection): boolean; //提交事务
function G_RollTran(const adocnn: TADOConnection): boolean; //回滚事务procedure G_FreeDS(DataSet: TDataSet);
function G_CreateDS(const adocnn: TADOConnection; strSql: string): TADODataSet; //创建记录集
procedure G_CloseDS(const DataSet: TDataSet); //关闭数据集
function G_BuildDS(const DataSet: TADODataSet; strSql: string): integer; //打开记录集
function G_BuildCDS(id,ip,userId,pwd,strSql,dsp: string; sckcnn: TSocketConnection;
const dataset: TClientDataSet): integer; //生成服务端记录集function G_GetFieldValue(const DataSet: TDataSet; fieldName: string): Variant; //获取记录
function G_GetFieldValueEx(const field: TField): Variant; //获取TField值
function G_FormatFieldSql(dbType: TDbType; const field: TField): string; //格式化TField值SQL
procedure G_SetFieldValue(const DataSet: TDataSet; fieldName: string; value: Variant); //设置记录值
procedure G_SetDataSetLabel(const DataSet: TDataSet; dicFields: TDicFieldList); //设置记录集显示标签
procedure G_ClonseRecord(srcDataSet,dstDataSet: TDataSet); //克隆当前记录function G_PostRecordToDb(dbType: TDBType; const adocmd: TADOCommand;
const dsData,dsField: TDataSet; tbName, delKeys: string;
operate: TOperate; delBeforeAppend: boolean): boolean; //把记录集的当前记录写入数据库
function G_PostDataSetToDb(dbType: TDBType; const adocmd: TADOCommand;
const dsData: TDataSet; tbName,delKeys: string;
operate: TOperate; delBeforeAppend: boolean): boolean; //数据集写入数据库{function operations ----------------------------------------------------------}function G_GetActionByName(const actionLst: TActionList; actionName: string): TAction; //根据功能名称,取出功能
procedure G_FreeFuncTree(tvFunc: TTreeView); //销毁树
procedure G_BuildFuncTree(tvFunc: TTreeView; funcs: TFuncLst; withLeaf: boolean; root: string=''); //生成树procedure G_LoadResImage(const ImageList: TImageList; ress: TResLst); //载入功能资源procedure G_BuildToolBar(toolBar: TToolBar; ActionLst: TActionList; sysFunc,usrFunc: TFuncLst); //生成 ToolBar 按钮
procedure G_BuildMainMenu(mainMenu: TMainMenu; ActionLst: TActionList; sysFuncs,usrFunc: TFuncLst); //生成系统菜单{base information treeview ----------------------------------------------------}procedure G_FreeBaseTree(const tvBase: TTreeView); //销毁基本信息树
procedure G_AddTreeNode(const tvBase: TTreeView; parent: TTreeNode; nodeData: TBaseNode); //增加一个节点
procedure G_DelTreeNode(const tvBase: TTreeView; node: TTreeNode); //删除指定节点
procedure G_SetTreeCheckBox(tvBase: TTreeView; button: TMouseButton; shift: TShiftState;X,Y: Integer);//设置树的CheckBox
procedure G_BuildBaseTree(const tvBase: TTreeView; DataSet: TDataSet; checkBox: boolean=false); //生成基本信息树function G_GetNodeParentPath(const tvBase: TTreeView; node: TTreeNode): string; //获取某节点其父节点路径
function G_GetNodePath(const tvBase: TTreeView; node: TTreeNode): string; //获取节点路径
procedure G_SetSelectedNodeText(const tvBase: TTreeView; id,name: string); //设置已选节点内容{数据库相关控件操作------------------------------------------------------------}
procedure G_BuildDBGridTitle(const DBGrid: TDBGrid; DicFields: TDicFieldList); //初始化 DBGrid 标题
procedure G_BuildDBGridEhTitle(const DBGridEh: TDBGridEh; DicFields: TDicFieldList); //初始化 DBGridEh 标题
procedure G_GetDBGridFields(const DBGrid: TDBGrid; var DicFields: TDicFieldList); //获取 DBGrid 字段信息
procedure G_GetDBGridEhFields(const DBGridEh: TDBGridEh; var DicFields: TDicFieldList); //获取 DBGridEh 字段信息
function G_GetDBGridColumn(const DBGrid: TDBGrid; FieldName: string): TColumn; //获取 DBGridEh 绑定字段表头
function G_GetDBGridEhColumn(const DBGridEh: TDBGridEh; FieldName: string): TColumnEh; //获取 DBGridEh 绑定字段表头
procedure G_BuildDBGridEhFooterField(const DBGridEh: TDBGridEh; footers: TDBGridEhFooters); //生成 DBGridEh 某列的页脚procedure G_DataBind(const DataSource: TDataSource; Container: TWinControl); //邦定容器数据控件
{通用数据库操作无关函数--------------------------------------------------------}function G_MessageBox(text: String; flags: longint=MB_OK or MB_ICONINFORMATION; caption: String=''): integer;
begin
if Caption = '' then
begin
Caption := Application.Title;
end;
Result := Application.MessageBox(PChar(Text),PChar(Caption),Flags);
end;function G_GetControlByName(parent: TWinControl; componentName: string): TControl;
var
i: integer;
begin
result := nil;
for i:=0 to parent.ControlCount-1 do
begin
if LowerCase(parent.Controls[i].Name)=LowerCase(componentName) then
begin
result := parent.Controls[i];
break;
end;
end;
end;function G_FormatDT(DateTime: TDateTime; Format: String='yyyy-mm-dd'): string;
begin
Result := FormatDateTime(format,DateTime);
end;function G_FormatSqlDt(DbType: TDBType; DateTime: TDateTime; format: string='yyyy-mm-dd'): string;
begin
case DbType of
dbAccess: Result := '#'+G_FormatDT(DateTime,format)+'#';
dbSQL,
dbSybase: Result := ''''+G_FormatDT(DateTime,format)+'''';
end;
end;function G_FormatSqlDtEx(DbType: TDBType; fieldName: string; dataset: TDataSet; format: string='yyyy-mm-dd'): string;
begin
if dataset[fieldName]=NULL then result := 'null'
else result := G_FormatSqlDt(DBType,G_GetFieldValue(dataset,fieldName),format);
end;function G_CharSqlIndex(DbType: TDbType; strCheck,strMatch: string): string;
begin
case DbType of
dbAccess: Result := 'InStrRev('+strCheck+','+strMatch+')';
dbSQL,
dbSybase: Result := 'CharIndex('+strMatch+','+strCheck+')';
end;
end;function G_ValidateValue(const Sender: TObject; tips: string): boolean;
begin
Result := TRUE;
if ((Sender is TEdit) and (TEdit(Sender).Text='')) then Result := FALSE;
if ((Sender is TDBEdit) and (TDBEdit(Sender).Text='')) then Result := FALSE; if ((Sender is TComboBox) and (TComboBox(Sender).Text='')) then Result := FALSE;
if ((Sender is TDBComboBox) and (TDBComboBox(Sender).Text='')) then Result := FALSE; if ((Sender is TMemo) and (TMemo(Sender).Text='')) then Result := FALSE;
if ((Sender is TDBMemo) and (TDBMemo(Sender).Text='')) then Result := FALSE;
if not Result then
begin
G_MessageBox(Tips, MB_ICONWARNING);
TWinControl(Sender).SetFocus;
end;
end;procedure G_SeperateString(value: string; const list: TStrings; dot: string='|');
var
nPos: Integer;
tmp: String;
begin
list.Clear;
while Length(Value)>0 do
begin
nPos := Pos(Dot,Value);
if nPos>0 then
begin
tmp := Copy(value,1,nPos-1);
if tmp<>'' then list.Add(tmp);
Delete(Value,1,nPos);
end
else begin
if Length(value)>0 then
begin
list.Add(Value);
value := '';
end;
end;
end;
end;function GetChineseIndexChar(hzChar: string): string;
var
index: WORD;
begin
index := WORD(hzChar[1]) shl 8 + WORD(hzChar[2]);
case index of
$B0A1..$B0C4 : Result := 'a';
$B0C5..$B2C0 : Result := 'b';
$B2C1..$B4ED : Result := 'c';
$B4EE..$B6E9 : Result := 'd';
$B6EA..$B7A1 : Result := 'e';
$B7A2..$B8C0 : Result := 'f';
$B8C1..$B9FD : Result := 'g';
$B9FE..$BBF6 : Result := 'h';
$BBF7..$BFA5 : Result := 'j';
$BFA6..$C0AB : Result := 'k';
$C0AC..$C2E7 : Result := 'l';
$C2E8..$C4C2 : Result := 'm';
$C4C3..$C5B5 : Result := 'n';
$C5B6..$C5BD : Result := 'o';
$C5BE..$C6D9 : Result := 'p';
$C6DA..$C8BA : Result := 'q';
$C8BB..$C8F5 : Result := 'r';
$C8F6..$CBF9 : Result := 's';
$CBFA..$CDD9 : Result := 't';
$CDDA..$CEF3 : Result := 'w';
$CEF4..$D1B8 : Result := 'x';
$D1B9..$D4D0 : Result := 'y';
$D4D1..$D7F9 : Result := 'z';
else
Result := #0;
end;
end;function G_GetChineseString(chinese: string): string;
var
I: Integer;
PY: String;
sTmp: string;
begin
sTmp := '' ;
I := 1;
while I <= Length(chinese) do
begin
PY := Copy(Chinese, I , 1);
if PY >= Chr(128) then
begin
Inc(I);
PY := PY + Copy(Chinese, I , 1);
sTmp := sTmp + GetChineseIndexChar(PY);
end
else
sTmp := sTmp + PY;
Inc(I);
end;
Result := sTmp;
end;function G_GetLocalHostName(): string;
var
wVersionRequested: WORD;
wsaData: TWSAData;
p: PHostEnt;
s: array[0..128] of char;
begin
result := '';
try
wVersionRequested := MAKEWORD(1, 1);
WSAStartup(wVersionRequested, wsaData);
GetHostName(@s, 128);
p := GetHostByName(@s);
result := p^.h_Name;
WSACleanup;
except
end;
end;function G_GetLocalHostIp(): string;
var
wVersionRequested: WORD;
wsaData: TWSAData;
p: PHostEnt;
s: array[0..128] of char;
begin
result := '';
try
wVersionRequested := MAKEWORD(1, 1);
WSAStartup(wVersionRequested, wsaData);
GetHostName(@s, 128);
p := GetHostByName(@s);
result := inet_ntoa(PInAddr(p^.h_addr_list^)^);
WSACleanup();
except
end;
end;function G_GetSystemDisplay(var mode: TDevMode): boolean;
begin
Result := EnumDisplaySettings(nil, Cardinal(-1), Mode);
end;function G_SetSystemDisplay(newMode: TDevMode): boolean;
var
lpDevMode: TDeviceMode;
begin
lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL or DM_DISPLAYFREQUENCY;
Result := ChangeDisplaySettings(newMode, CDS_UPDATEREGISTRY) = DISP_CHANGE_SUCCESSFUL;
end;procedure G_RestoreWindow(hWnd: THandle);
begin
SetForegroundWindow(hWnd);
BringWindowToTop(hWnd);
ShowWindow(hWnd,SW_SHOWNORMAL);
end;{数据库相关操作函数------------------------------------------------------------}procedure G_SetDbParam(value: TDbParam; fileName: string);
var
pFile: file of TDbParam;
begin
try
AssignFile(pFile,fileName);
ReWrite(pFile);
Write(pFile,Value);
CloseFile(pFile);
except
end;
end;function G_GetDbParam(var value: TDbParam; fileName: string): boolean;
var
pFile: file of TDbParam;
begin
Result := false;
if not FileExists(fileName) then Exit;
try
AssignFile(pFile,fileName);
Reset(pFile,fileName);
Read(pFile,value);
CloseFile(pFile);
Result := true;
except
end;
end;procedure G_CloseDB(const adocnn: TADOConnection);
begin
if adocnn.Connected then adocnn.Close;
end;function G_ConnectDB(const adocnn: TADOConnection; dbParam: TDbParam): boolean;
var
strConn: String;
begin
Result := FALSE;
if adocnn=nil then Exit;
case dbParam.dbType of
dbAccess: strConn:= 'Provider=Microsoft.Jet.OLEDB.4.0;'+
'Data Source='+DbParam.dbName+';'+
'User ID='+DbParam.dba+';'+
'Password='+DbParam.pwd;
dbSQL : strConn:= 'Provider=SQLOLEDB.1;'+
'Password='+DbParam.pwd+';'+
'User ID='+DbParam.dba+';'+
'Initial Catalog='+DbParam.dbName+';'+
'Data Source='+DbParam.host;
dbSybase: strConn:= '';
end;
try
G_CloseDB(adocnn);
adocnn.ConnectionString := strConn;
adocnn.Connected := TRUE;
Result := adocnn.Connected;
except
end;
end;
function G_RunSql(const adocmd: TADOCommand; strSql: string): boolean;
begin
try
adocmd.CommandType := cmdText;
adocmd.CommandText := strSql;
adocmd.Execute;
Result := TRUE;
except
Result := FALSE;
end;
end;function G_BeginTran(const adocnn: TADOConnection): boolean;
begin
Result := FALSE;
try
if adocnn.InTransaction then
begin
adocnn.RollbackTrans;
Exit;
end;
adocnn.BeginTrans;
Result := TRUE;
except
end;
end;function G_CommitTran(const adocnn: TADOConnection): boolean;
begin
Result := FALSE;
try
if not adocnn.InTransaction then Exit;
adocnn.CommitTrans;
Result := TRUE;
except
G_RollTran(adocnn);
end;
end;function G_RollTran(const adocnn: TADOConnection): boolean;
begin
result := false;
try
if not adocnn.InTransaction then Exit;
adocnn.RollbackTrans;
result := true;
except
end;
end;procedure G_FreeDS(DataSet: TDataSet);
begin
if DataSet.State<>dsBrowse then DataSet.Close;
DataSet.Free;
end;function G_CreateDS(const adocnn: TADOConnection; strSql: string): TADODataSet;
begin
result := TADODataSet.Create(adocnn);
result.Connection := adocnn;
G_BuildDS(result,strSql);
end;procedure G_CloseDS(const DataSet: TDataSet);
begin
if DataSet.State<>dsInactive then DataSet.Close;
end;function G_BuildDS(const DataSet: TADODataSet; strSql: string): integer;
begin
try
G_CloseDS(DataSet);
DataSet.CommandType := cmdText;
DataSet.CommandText := strSQL;
DataSet.Open;
DataSet.Recordset.Properties['Update Criteria'].Value := AdCriteriaKey;
Result := DataSet.RecordCount;
except
Result := -1;
end;
end;function G_BuildCDS(id,ip,userId,pwd,strSql,dsp: string; sckcnn: TSocketConnection;
const dataset: TClientDataSet): integer;
begin
try
if dataSet.State<>dsInactive then dataSet.Close;
dataSet.ProviderName := dsp;
result := sckcnn.AppServer.getdata(id,ip,userId,pwd,dsp,strSql);
if (Result>=0) then dataSet.Open;
except
result := -1;
end;
end;function G_GetFieldValue(const DataSet: TDataSet; fieldName: string): Variant;
var
retValue: Variant;
begin
Result := Unassigned;
if DataSet.State=dsInactive then Exit;
retValue := DataSet[fieldName];
if retValue <> NULL then Result := retValue;
end;function G_GetFieldValueEx(const field: TField): Variant;
var
retValue: Variant;
begin
Result := Unassigned;
retValue := field.Value;
if retValue <> NULL then Result := retValue;
end;function G_FormatFieldSql(dbType: TDbType; const field: TField): string;
begin
case field.DataType of
ftString,
ftMemo,
ftWideString,
ftFixedChar: result := ''''+field.AsString+'''';
ftDate : result := G_FormatSqlDt(dbType,G_GetFieldValueEx(field));
ftTime : G_FormatSqlDt(dbType,G_GetFieldValueEx(field),'hh:nn:ss');
ftDateTime : result := G_FormatSqlDt(dbType,G_GetFieldValueEx(field),'yyyy-mm-dd hh:nn:ss');
ftAutoInc,
ftLargeint,
ftSmallint,
ftInteger,
ftWord: result := IntToStr(G_GetFieldValueEx(field));
ftFloat,
ftCurrency,
ftBCD : result := FloatToStr(G_GetFieldValueEx(field));
ftBoolean: if field.AsBoolean then result := '1'
else result := '0';
end;
end;procedure G_SetFieldValue(const DataSet: TDataSet; fieldName: string; value: Variant);
begin
if (DataSet.FindField(fieldName)<>nil) and (DataSet.State<>dsInactive) then
begin
if DataSet.State=dsBrowse then DataSet.Edit;
DataSet[fieldName] := Value;
end;
end;procedure G_SetDataSetLabel(const DataSet: TDataSet; dicFields: TDicFieldList);
var
i: integer;
field: TField;
begin
for i:=0 to dicFields.nFields-1 do
begin
field := DataSet.FindField(dicFields.fields[i].name);
if field<>nil then
begin
field.DisplayLabel := dicFields.fields[i].sName;
field.Tag := 1;
end;
end;
end;procedure G_ClonseRecord(srcDataSet,dstDataSet: TDataSet);
var
i: integer;
begin
dstDataSet.Append;
for i:=0 to srcDataSet.FieldCount-1 do
begin
dstDataSet.Fields[i] := srcDataSet.Fields[i];
end;
dstDataSet.Post;
end;//删除记录集中指定主键信息记录
function DelRecords(dbType: TDBType; const adocmd: TADOCommand; const dsData: TDataSet;
tbName,delKeys: string): boolean;
var
i: integer;
strSql: string;
fields: TStrings;
begin
fields := TStringList.Create;
G_SeperateString(delKeys,fields,',');
strSql := 'delete from '+tbName+' where ';
for i:=0 to fields.Count-1 do
begin
if i=fields.Count-1 then
strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))
else
strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))+' and ';
end;
result := G_RunSql(adocmd,strSql);
fields.Free;
end;{参数说明：
dbType: 数据库类别，传入次参数，目的为了格式化SQL语句
adocmd: 用于执行SQL语句的 ADOCommand 对象
}
function G_PostRecordToDb(dbType: TDBType; const adocmd: TADOCommand;
const dsData,dsField: TDataSet; tbName, delKeys: string;
operate: TOperate; delBeforeAppend: boolean): boolean;
var
i: integer;
fields: TStrings;
strSql: string;
begin
result := false;
if (operate=opNew) and delBeforeAppend and (not DelRecords(dbType,adocmd,dsData,tbName,delKeys)) then exit; case operate of
opNew : begin
strSql := 'insert into '+tbName+'(';
for i:=0 to dsField.FieldCount-1 do
begin
if i=dsField.FieldCount-1 then strSql := strSql+dsField.Fields[i].FieldName+') values('
else strSql := strSql+dsField.Fields[i].FieldName+',';
end;
for i:=0 to dsField.FieldCount-1 do
begin
if i=dsField.FieldCount-1 then strSql := strSql+G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+')'
else strSql := strSql+G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+',';
end;
end;
opModify: begin
strSql := 'update '+tbName+' set ';
for i:=0 to dsField.FieldCount-1 do
begin
if i=dsField.FieldCount-1 then
strSql := strSql+dsField.Fields[i].FieldName+'='+
G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+' where '
else
strSql := strSql+dsField.Fields[i].FieldName+'='+
G_FormatFieldSql(dbType,dsData.FieldByName(dsField.Fields[i].FieldName))+',';
end;
fields := TStringList.Create;
G_SeperateString(delKeys,fields,',');
for i:=0 to fields.Count-1 do
begin
if i=fields.Count-1 then
strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))
else
strSql := strSql+fields[i]+'='+G_FormatFieldSql(dbType,dsData.FieldByName(fields[i]))+' and ';
end;
fields.free;
end;
end;
result := G_RunSql(adocmd,strSql);
end;
我把 fastreport，excel模板文件都存放在数据库里面了，供使用时调用用完删除还可以修改。var
ts : TStream;
ms : TMemoryStream;
fr : TFastReport;
begin
try
ms := TMemoryStream.Create;
ts:= CreateBlobStream(FieldByName('fileBlob'),bmRead);
ms.CopyFrom(ts, ts.Size);
ms.SaveToFile(ExtractFilePath(Application.ExeName) + filename);
fr.LoadFromFile(ExtractFilePath(Application.ExeName) + filename);
fr.DesignReport;
... finally
if AsSigned(ms) then ms.Free;
...
end;end;
function G_SetSystemDisplay(newMode: TDevMode): Boolean; //动态设置屏幕分辨率
procedure G_RestoreWindow(hWnd: THandle); //动态设置屏幕分辨率
希望楼主 天使者 能把这几个函数的代码贴上来
function G_PostDataSetToDb(dbType: TDBType; const adocmd: TADOCommand;
const dsData: TDataSet; tbName,delKeys: string;
operate: TOperate; delBeforeAppend: boolean): boolean;
var
i: integer;
bookMark: TBookMark;
dsField: TADODataSet;
begin
result := false;
if (operate=opNew) and delBeforeAppend and (not DelRecords(dbType,adocmd,dsData,tbName,delKeys)) then exit; result := true;
dsField := G_CreateDS(adocmd.Connection,'select * from '+tbName+' where 1<0');
dsData.DisableControls;
bookMark := dsData.GetBook;
dsData.First;
for i:=1 to dsData.RecordCount do
begin
if not G_PostRecordToDb(dbType,adocmd,dsData,dsField,tbName,delKeys,operate, not delBeforeAppend) then
begin
result := false;
break;
end;
dsData.Next;
end;
dsField.Free;
dsData.GotoBook(bookMark);
dsData.FreeBook(bookMark);
dsData.EnableControls;
end;{用户功能权限操作树等相关函数 -------------------------------------------------}function G_GetActionByName(const actionLst: TActionList; actionName: string): TAction;
var
i: Integer;
begin
Result := nil;
for i:=0 to actionLst.ActionCount-1 do
begin
if UpperCase(actionLst.Actions[i].Name)=UpperCase(actionName) then
begin
Result := TAction(actionLst.Actions[i]);
Break;
end;
end;
end;procedure G_FreeFuncTree(tvFunc: TTreeView);
var
i: Integer;
begin
tvFunc.OnChange := nil;
for i:=0 to tvFunc.Items.Count-1 do
begin
Dispose(PFunc(tvFunc.Items[i].Data));
end;
tvFunc.Items.Clear;
end;function GetFuncParentNode(ChildNode: TTreeNode; ChildKey: string; ItemLen: Integer=1): TTreeNode;
var
ParentKey: string;
ParentNode: TTreeNode;
begin
ParentKey := LeftBStr(ChildKey,Length(ChildKey)-ItemLen);
ParentNode := ChildNode;
while ParentNode<>nil do
begin
if PFunc(ParentNode.Data)^.id = ParentKey then Break;
ParentNode := ParentNode.Parent;
end;
Result := ParentNode;
end;procedure G_BuildFuncTree(tvFunc: TTreeView; funcs: TFuncLst; withLeaf: boolean; root: string='');
var
i: Integer;
lpFunc: PFunc;
NewNode,ParentNode: TTreeNode;
begin
NewNode := nil;
G_FreeFuncTree(tvFunc);
if root<>'' then
begin
NewNode := tvFunc.Items.AddChild(nil,root);
new(lpFunc);
lpFunc.caption := root;
lpFunc.id := '';
lpFunc.leaf := false;
if tvFunc.Images<>nil then
begin
NewNode.ImageIndex := 0;
NewNode.SelectedIndex := 1;
end;
NewNode.Data := lpFunc;
end;
for i:=0 to funcs.count-1 do
begin
if (not funcs.funcs[i].visible) or (not funcs.funcs[i].enabled) or
((funcs.funcs[i].leaf) and (not withLeaf)) then Continue;
ParentNode := GetFuncParentNode(NewNode,Funcs.funcs[i].id);
NewNode := tvFunc.Items.AddChild(ParentNode,Funcs.funcs[i].caption);
if tvFunc.Images<>nil then
begin
NewNode.ImageIndex := funcs.funcs[i].treeImage;
NewNode.SelectedIndex := funcs.funcs[i].treeSelImage;
end;
new(lpFunc);
lpFunc^ := Funcs.funcs[i];
NewNode.Data := lpFunc;
end;
end;procedure G_LoadResImage(const ImageList: TImageList; ress: TResLst);
var
i: Integer;
ico: TIcon;
bmp: TBitmap;
begin
ImageList.Clear;
ico := TIcon.Create;
bmp := TBitmap.Create;
for i:=0 to ress.count-1 do
begin
if FileExists(ress.ress[i].resFile) then
begin
if Pos('.ico',LowerCase(ress.ress[i].resFile))>0 then
begin
ico.LoadFromFile(ress.ress[i].resFile);
ImageList.AddIcon(ico);
end;
if Pos('.bmp',LowerCase(ress.ress[i].resFile))>0 then
begin
bmp.LoadFromFile(ress.ress[i].resFile);
ImageList.Add(bmp,bmp);
end;
end;
end;
ico.Free;
bmp.Free;
end;procedure G_BuildToolBar(ToolBar: TToolBar; ActionLst: TActionList; sysFunc,usrFunc: TFuncLst);
var
tmp: string;
i,nCount: Integer;
begin
while ToolBar.ButtonCount>0 do ToolBar.Buttons[0].Free; tmp := '|';
for i:=0 to usrFunc.count-1 do
begin
tmp := tmp+usrFunc.funcs[i].id+'|';
end; nCount := 0;
for i:=sysFunc.count-1 downto 0 do
begin
if (sysFunc.funcs[i].btnIndex>=0) and (sysFunc.funcs[i].enabled) then
begin
with TToolButton.Create(ToolBar) do
begin
if sysFunc.funcs[i].btnGrouped then
begin
with TToolButton.Create(ToolBar) do
begin
Parent := ToolBar;
Style := tbsSeparator;
Width := 8;
end;
end;
Parent := ToolBar;
Height := 20;
Action := G_GetActionByName(ActionLst,sysFunc.funcs[i].name);
Caption:= sysFunc.funcs[i].shortCaption;
ImageIndex := sysFunc.funcs[i].toolImage;
ShowHint := TRUE;
Hint := sysFunc.funcs[i].re;
Visible := Pos('|'+sysFunc.funcs[i].id+'|',tmp)>0;
if Visible then Inc(nCount);
end;
end;
end;
ToolBar.Visible := nCount>0;
end;procedure G_BuildMainMenu(mainMenu: TMainMenu; ActionLst: TActionList; sysFuncs,usrFunc: TFuncLst);
var
i: Integer;
parentId: String;
newItem,parent,group: TMenuItem;
action: TAction;
begin
parent := mainMenu.Items;
MainMenu.Items.Clear;
for i:=0 to usrFunc.count-1 do
begin
if not usrFunc.funcs[i].visible then continue;
{创建菜单项}
newItem := TMenuItem.Create(MainMenu);
newItem.Caption := usrFunc.funcs[i].caption;
newItem.Name := 'M'+usrFunc.funcs[i].id;
newItem.ImageIndex := usrFunc.funcs[i].menuImage;
action := G_GetActionByName(ActionLst,usrFunc.funcs[i].name);
if action<>nil then newItem.OnClick := action.OnExecute; {获取父菜单}
parentId := LeftStr(newItem.Name,Length(newItem.Name)-1);
while parent<>nil do
begin
if parent.Name=parentId then break
else parent := parent.Parent;
end;
if parent=nil then parent := mainMenu.Items;
parent.Add(newItem); {菜单有分组，则增加分组菜单项}
if usrFunc.funcs[i].grouped then
begin
group := TMenuItem.Create(mainMenu);
group.Caption := '-';
parent.Add(group);
end;
parent := newItem;
end;
end;
{基本信息树操作 ---------------------------------------------------------------}procedure G_FreeBaseTree(const tvBase: TTreeView);
var
node: TTreeNode;
begin
tvBase.OnChange := nil;
node := tvBase.TopItem;
while node<>nil do
begin
Dispose(PBaseNode(node.Data));
node := node.GetNext;
end;
tvBase.Items.Clear;
end;function GetBaseParentNode(ChildNode: TTreeNode; ChildKey: string; ItemLen: Integer=5): TTreeNode;
var
ParentKey: String;
ParentNode: TTreeNode;
begin
ParentKey := LeftBStr(ChildKey,Length(ChildKey)-ItemLen);
ParentNode := ChildNode;
while ParentNode<>nil do
begin
if PBaseNode(ParentNode.Data)^.path = ParentKey then Break;
ParentNode := ParentNode.Parent;
end;
Result := ParentNode;
end;procedure G_AddTreeNode(const tvBase: TTreeView; parent: TTreeNode; nodeData: TBaseNode);
var
pNode: PBaseNode;
newNode: TTreeNode;
begin
newNode := tvBase.Items.AddChild(parent,nodeData.id+#255+nodeData.name);
new(pNode);
pNode^ := nodeData;
newNode.Data := pNode;
end;procedure G_DelTreeNode(const tvBase: TTreeView; node: TTreeNode);
var
nextNode: TTreeNode;
begin
if (node=nil) or (tvBase.Items.Count=0) then Exit;
nextNode := node.getNextSibling;
while (nextNode<>nil) and (nextNode.Level<node.Level) do
begin
Dispose(PBaseNode(nextNode.Data));
nextNode := nextNode.GetNext;
end;
Dispose(PBaseNode(node.Data));
node.Delete;
end;procedure SetChildState(Node:TTreeNode; State:Integer);
var
Level:Integer;
begin
Level:=Node.Level;
Node:=Node.getFirstChild;
while (Node<>nil) and (Node.Level>Level) do
begin
Node.StateIndex:=State;
Node:=Node.GetNext;
end;
end;procedure SetParentState(Node: TTreeNode);
var
Flag: Integer;
PNode:TTreeNode;
begin
PNode:=Node.Parent;
if PNode<>nil then
begin
PNode:=PNode.getFirstChild;
Flag:=PNode.StateIndex;
while PNode<>nil do
begin
if PNode.StateIndex<>Flag then Flag:=2;
PNode:=PNode.getNextSibling;
end;
Node.Parent.StateIndex:=flag;
SetParentState(Node.Parent);
end;
end;procedure G_SetTreeCheckBox(tvBase: TTreeView; button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
node:TTreeNode;
myHitTest : THitTests;
begin
myHitTest := tvBase.GetHitTestInfoAt(X,Y);
if (htOnStateIcon in MyHitTest) and (Button=mbLeft) then
begin
node := tvBase.GetNodeAt(X,Y);
case TCheckState(node.StateIndex) of
csUnchecked: begin
SetChildState(node,node.StateIndex);
end;
csChecked:begin
SetChildState(node,node.StateIndex);
end;
csGrayed:begin
SetChildState(node,node.StateIndex);
end;
end;
SetParentState(node);
end;
end;procedure G_BuildBaseTree(const tvBase: TTreeView; DataSet: TDataSet; checkBox: boolean=false);
var
i: Integer;
nodeData: PBaseNode;
NewNode,ParentNode: TTreeNode;
begin
G_FreeBaseTree(tvBase);
NewNode := nil;
for i:=1 to DataSet.RecordCount do
begin
new(nodeData);
nodeData^.sysId := G_GetFieldValue(DataSet,'sysId');
nodeData^.path := G_GetFieldValue(DataSet,'path');
nodeData^.isNode := G_GetFieldValue(DataSet,'isNode')=1;
nodeData^.id := G_GetFieldValue(DataSet,'id');
nodeData^.name := G_GetFieldValue(DataSet,'name');
ParentNode := GetBaseParentNode(NewNode,nodeData^.path);
NewNode := tvBase.Items.AddChild(ParentNode,nodeData^.id+#255+nodeData^.name);
if not nodeData^.isNode then
begin
NewNode.ImageIndex := 0;
NewNode.SelectedIndex := 1;
end
else begin
NewNode.ImageIndex := 2;
NewNode.SelectedIndex := 2;
end;
if checkBox then NewNode.StateIndex := 1;
NewNode.Data := nodeData;
DataSet.Next;
end;
if tvBase.Items.Count>0 then tvBase.Items[0].Selected := TRUE;
end;function G_GetNodeParentPath(const tvBase: TTreeView; node: TTreeNode): string;
begin
Result := '';
if (node=nil) or (node.Parent=nil) then Exit;
if node.Parent<>nil then
begin
Result := PBaseNode(node.Parent.Data)^.path;
end;
end;function G_GetNodePath(const tvBase: TTreeView; node: TTreeNode): string;
begin
if node=nil then Result := ''
else Result := PBaseNode(node.Data)^.path;
end;procedure G_SetSelectedNodeText(const tvBase: TTreeView; id,name: string);
begin
if tvBase.Selected<>nil then
begin
tvBase.Selected.Text := id+#255+name;
PBaseNode(tvBase.Selected.Data)^.id := id;
PBaseNode(tvBase.Selected.Data)^.name := name;
end;
end;
procedure G_BuildDBGridTitle(const DBGrid: TDBGrid; DicFields: TDicFieldList);
var
i: Integer;
ValueLst: TStrings;
newColumn: TColumn;
begin
DBGrid.Columns.Clear;
for i:=0 to DicFields.nFields-1 do
begin
if not DicFields.Fields[i].isShow then Continue;
newColumn := DBGrid.Columns.Add;
newColumn.Title.Alignment := taCenter;
newColumn.Title.Caption := DicFields.Fields[i].sName;
newColumn.FieldName := DicFields.Fields[i].name;
newColumn.Width := DicFields.Fields[i].width; case DicFields.Fields[i].uiType of
'C':begin
ValueLst := TStringList.Create;
G_SeperateString(DicFields.Fields[i].constant,ValueLst);
newColumn.PickList.AddStrings(ValueLst);
newColumn.DropDownRows := 20;
ValueLst.Free;
newColumn.Color := clCream;
newColumn.ButtonStyle := TColumnButtonStyle(cbsAuto);
end;
'B':NewColumn.ButtonStyle := TColumnButtonStyle(cbsEllipsis);
end;
newColumn.ReadOnly := DicFields.fields[i].ctrl<3;
if newColumn.ReadOnly then newColumn.Color := clReadOnly;
end;
if DBGrid.ReadOnly then DBGrid.Options := DBGrid.Options+[dgRowSelect];
end;procedure G_BuildDBGridEhTitle(const DBGridEh: TDBGridEh; DicFields: TDicFieldList);
var
i: Integer;
ValueLst: TStrings;
ColumnEh: TColumnEh;
begin
DBGridEh.Columns.Clear;
DBGridEh.RowHeight := 18;
for i:=0 to DicFields.nFields-1 do
begin
if Trim(DicFields.fields[i].sName)='' then Continue;
if DicFields.fields[i].isShow then
begin
ColumnEh := DBGridEh.Columns.Add;
ColumnEh.Title.Alignment := taCenter;
ColumnEh.Title.Caption := DicFields.fields[i].sName;
ColumnEh.Title.Color := $FFFFFF;
ColumnEh.FieldName := DicFields.fields[i].name;
ColumnEh.Width := DicFields.fields[i].width;
ColumnEh.Title.TitleButton := (DBGridEh.SortLocal) and (DicFields.fields[i].userType<>'M');
case DicFields.fields[i].uiType of
'C': begin {combobox}
ValueLst := TStringList.Create;
G_SeperateString(DicFields.fields[i].constant,ValueLst);
ColumnEh.PickList.AddStrings(ValueLst);
ValueLst.Free;
ColumnEh.Color := clEditWithHelp;
ColumnEh.ButtonStyle := cbsAuto;
end;
'B': begin {button}
ColumnEh.Color := clEditWithHelp;
ColumnEh.ButtonStyle := cbsEllipsis;
end;
end;
if DicFields.fields[i].ctrl<3 then
begin
ColumnEh.ReadOnly := TRUE;
ColumnEh.Color := clReadOnly;
end;
end;
end;
if DBGridEh.ReadOnly then DBGridEh.Options := DBGridEh.Options+[dgRowSelect];
end;procedure G_GetDBGridFields(const DBGrid: TDBGrid; var DicFields: TDicFieldList);
var
i: integer;
begin
DicFields.nFields := DBGrid.Columns.Count;
SetLength(DicFields.Fields,DicFields.nFields);
for i:=0 to DicFields.nFields-1 do
begin
DicFields.Fields[i].id := i+1;
DicFields.Fields[i].name := DBGrid.Columns[i].FieldName;
DicFields.Fields[i].sName:= DbGrid.Columns[i].Title.Caption;
DicFields.Fields[i].width:= DbGrid.Columns[i].Width;
end;
end;procedure G_GetDBGridEhFields(const DBGridEh: TDBGridEh; var DicFields: TDicFieldList); {获取 DBGrid 字段信息}
var
i: integer;
begin
DicFields.nFields := DBGridEh.Columns.Count;
SetLength(DicFields.Fields,DicFields.nFields);
for i:=0 to DicFields.nFields-1 do
begin
DicFields.Fields[i].id := i+1;
DicFields.Fields[i].name := DBGridEh.Columns[i].FieldName;
DicFields.Fields[i].sName:= DBGridEh.Columns[i].Title.Caption;
DicFields.Fields[i].width:= DBGridEh.Columns[i].Width;
end;
end;function G_GetDBGridColumn(const DBGrid: TDBGrid; FieldName: string): TColumn;
var
i: integer;
begin
Result := nil;
for i:=0 to DBGrid.Columns.Count-1 do
begin
if UpperCase(DBGrid.Columns[i].FieldName)=UpperCase(FieldName) then
begin
Result := DBGrid.Columns[i];
Break;
end;
end;
end;function G_GetDBGridEhColumn(const DBGridEh: TDBGridEh; FieldName: string): TColumnEh;
var
i: integer;
begin
Result := nil;
for i:=0 to DBGridEh.Columns.Count-1 do
begin
if UpperCase(DbGridEh.Columns[i].FieldName)=UpperCase(FieldName) then
begin
Result := DbGridEh.Columns[i];
Break;
end;
end;
end;procedure G_BuildDBGridEhFooterField(const DBGridEh: TDBGridEh; footers: TDBGridEhFooters);
var
i: integer;
column: TColumnEh;
begin
for i:=0 to footers.nFooter-1 do
begin
column := G_GetDBGridEhColumn(DbGridEh,footers.footers[i].fieldName);
if column<>nil then
begin
column.Footer.ValueType := footers.footers[i].valueType;
if column.Footer.ValueType=fvtStaticText then
begin
column.Footer.Value := footers.footers[i].display;
end;
end;
end;
end;procedure G_DataBind(const DataSource: TDataSource; Container: TWinControl);
var
i: Integer;
control: TControl;
begin
for i:=0 to Container.ControlCount-1 do
begin
control := Container.Controls[i];
if control is TDBEdit then TDBEdit(control).DataSource := DataSource;
if control is TDBText then TDBText(control).DataSource := DataSource;
if control is TDBMemo then TDBMemo(control).DataSource := DataSource;
if control is TDBComboBox then TDBComboBox(control).DataSource := DataSource;
if control is TDBCheckBox then TDBCheckBox(control).DataSource := DataSource;
if control is TDbDateTimePicker then TDbDateTimePicker(control).Datasource := DataSource;
end;
end;
我是初学者，分享！
...{*******************************************************************************
* 模块名称: 公用函数库
* 编写人员: Chris Mao
* 编写日期: 2004.10.30
******************************************************************************}unit JrCommon;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ShellAPI, CommDlg, MMSystem, StdCtrls, Registry, JrConsts, Winsock;//------------------------------------------------------------------------------
//窗体类函数
//------------------------------------------------------------------------------
function FindFormClass(FormClassName: PChar): TFormClass;
function HasInstance(FormClassName: PChar): Boolean;//------------------------------------------------------------------------------
//公用对话框函数
//------------------------------------------------------------------------------
procedure InfoDlg(const Msg: String; ACaption: String = SInformation);
...{ 信息对话框 }procedure ErrorDlg(const Msg: String; ACaption: String = SError);
...{ 错误对话框 }procedure WarningDlg(const Msg: String; ACaption: String = SWarning);
...{ 警告对话框 }function QueryDlg(const Msg: String; ACaption: String = SQuery): Boolean;
...{ 确认对话框 }function QueryNoDlg(const Msg: string; ACaption: string = SQuery): Boolean;
...{ 确认对话框，默认按钮为"否" }function JrInputQuery(const ACaption, APrompt: String; var Value: string): Boolean;
...{ 输入对话框 }function JrInputBox(const ACaption, APrompt, ADefault: string): String;
...{ 输入对话框 }//------------------------------------------------------------------------------
//扩展文件目录操作函数
//------------------------------------------------------------------------------procedure RunFile(const FileName: String; Handle: THandle = 0; Param: string = '');
...{ 运行一个文件 }function AppPath: string;
...{ 应用程序路径 }function GetProgramFilesDir: string;
...{ 取Program Files目录 }function GetWindowsDir: string;
...{ 取Windows目录}function GetWindowsTempPath: string;
...{ 取临时文件路径 }function GetSystemDir: string;
...{ 取系统目录 }//------------------------------------------------------------------------------
//扩展字符串操作函数
//------------------------------------------------------------------------------function InStr(const sShort: string; const sLong: string): Boolean;
...{ 判断s1是否包含在s2中 }function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string;
...{ 带分隔符的整数－字符转换 }function ByteToBin(Value: Byte): string;
...{ 字节转二进制串 }function StrRight(Str: string; Len: Integer): string;
...{ 返回字符串右边的字符 }function StrLeft(Str: string; Len: Integer): string;
...{ 返回字符串左边的字符 }function Spc(Len: Integer): string;
...{ 返回空格串 }procedure SwapStr(var s1, s2: string);
...{ 交换字串 }//------------------------------------------------------------------------------
// 扩展日期时间操作函数
//------------------------------------------------------------------------------function GetYear(Date: TDate): Word;
...{ 取日期年份分量 }function GetMonth(Date: TDate): Word;
...{ 取日期月份分量 }function GetDay(Date: TDate): Word;
...{ 取日期天数分量 }function GetHour(Time: TTime): Word;
...{ 取时间小时分量 }function GetMinute(Time: TTime): Word;
...{ 取时间分钟分量 }function GetSecond(Time: TTime): Word;
...{ 取时间秒分量 }function GetMSecond(Time: TTime): Word;
...{ 取时间毫秒分量 }//------------------------------------------------------------------------------
// 位操作函数
//------------------------------------------------------------------------------
type
TByteBit = 0..7; // Byte类型位数范围
TWordBit = 0..15; // Word类型位数范围
TDWordBit = 0..31; // DWord类型位数范围procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean); overload;
...{ 设置二进制位 }procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean); overload;
...{ 设置二进制位 }procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean); overload;
...{ 设置二进制位 }function GetBit(Value: Byte; Bit: TByteBit): Boolean; overload;
...{ 取二进制位 }function GetBit(Value: WORD; Bit: TWordBit): Boolean; overload;
...{ 取二进制位 }function GetBit(Value: DWORD; Bit: TDWordBit): Boolean; overload;
...{ 取二进制位 }//------------------------------------------------------------------------------
// 系统功能函数
//------------------------------------------------------------------------------procedure ChangeFocus(Handle: THandle; Forword: Boolean = False);
...{ 改变焦点 }procedure MoveMouseIntoControl(AWinControl: TControl);
...{ 移动鼠标到控件 }procedure AddComboBoxTextToItems(ComboBox: TComboBox; MaxItemsCount: Integer = 10);
...{ 将 ComboBox 的文本内容增加到下拉列表中 }function DynamicResolution(x, y: WORD): Boolean;
...{ 动态设置分辨率 }procedure StayOnTop(Handle: HWND; OnTop: Boolean);
...{ 窗口最上方显示 }procedure SetHidden(Hide: Boolean);
...{ 设置程序是否出现在任务栏 }procedure SetTaskBarVisible(Visible: Boolean);
...{ 设置任务栏是否可见 }procedure SetDesktopVisible(Visible: Boolean);
...{ 设置桌面是否可见 }function GetWorkRect: TRect;
...{ 取桌面区域 }procedure BeginWait;
...{ 显示等待光标 }procedure EndWait;
...{ 结束等待光标 }function CheckWindows9598: Boolean;
...{ 检测是否Win95/98平台 }function GetOSString: string;
...{ 返回操作系统标识串 }function GetComputeNameStr : string;
...{ 得到本机名 }function GetLocalUserName: string;
...{ 得到本机用户名 }function GetLocalIP: String;
...{ 得到本机IP地址 }//------------------------------------------------------------------------------
// 其它过程
//------------------------------------------------------------------------------function TrimInt(Value, Min, Max: Integer): Integer; overload;
...{ 输出限制在Min..Max之间 }function InBound(Value: Integer; Min, Max: Integer): Boolean;
...{ 判断整数Value是否在Min和Max之间 }procedure Delay(const uDelay: DWORD);
...{ 延时 }procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);
...{ 在Win9X下让喇叭发声 }function GetHzPy(const AHzStr: string): string;
...{ 取汉字的拼音 }function UpperCaseMoney(const Money: Double): String;
...{ 转换为大与金额 }function SoundCardExist: Boolean;
...{ 声卡是否存在 }implementation//------------------------------------------------------------------------------
//窗体类函数
//------------------------------------------------------------------------------function FindFormClass(FormClassName: PChar): TFormClass;
begin
Result := TFormClass(GetClass(FormClassName));
end;function HasInstance(FormClassName: PChar): Boolean;
var
i: integer;
begin
Result:=False;
for i := Screen.FormCount - 1 downto 0 do begin
Result := SameText(Screen.Forms[i].ClassName, FormClassName);
if Result then begin
TForm(Screen.Forms[i]).BringToFront;
Break;
end;
end;
end;
//公用对话框函数
//------------------------------------------------------------------------------procedure InfoDlg(const Msg: String; ACaption: String = SInformation);
begin
Application.MessageBox(PChar(Msg), PChar(ACaption), MB_OK + MB_ICONINFORMATION);
end;procedure ErrorDlg(const Msg: String; ACaption: String = SError);
begin
Application.MessageBox(PChar(Msg), PChar(ACaption), MB_OK + MB_ICONERROR);
end;procedure WarningDlg(const Msg: String; ACaption: String = SWarning);
begin
Application.MessageBox(PChar(Msg), PChar(ACaption), MB_OK + MB_ICONWARNING);
end;function QueryDlg(const Msg: String; ACaption: String = SQuery): Boolean;
begin
Result := Application.MessageBox(PChar(Msg), PChar(ACaption),
MB_YESNO + MB_ICONQUESTION) = IDYES;
end;function QueryNoDlg(const Msg: string; ACaption: string = SQuery): Boolean;
begin
Result := Application.MessageBox(PChar(Msg), PChar(ACaption),
MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2) = IDYES;
end;function GetAveCharSize(Canvas: TCanvas): TPoint;
var
I: Integer;
Buffer: array[0..51] of Char;
begin
for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A'));
for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));
GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
Result.X := Result.X div 52;
end;function JrInputQuery(const ACaption, APrompt: String; var Value: string): Boolean;
var
Form: TForm;
Prompt: TLabel;
Edit: TEdit;
DialogUnits: TPoint;
ButtonTop, ButtonWidth, ButtonHeight: Integer;
begin
Result := False;
Form := TForm.Create(Application);
with Form do
try
Scaled := False;
Font.Name := SDefaultFontName;
Font.Size := SDefaultFontSize;
Font.Charset := SDefaultFontCharset;
Canvas.Font := Font;
DialogUnits := GetAveCharSize(Canvas);
BorderStyle := bsDialog;
Caption := ACaption;
ClientWidth := MulDiv(180, DialogUnits.X, 4);
ClientHeight := MulDiv(63, DialogUnits.Y, 8);
Position := poScreenCenter;
Prompt := TLabel.Create(Form);
with Prompt do
begin
Parent := Form;
AutoSize := True;
Left := MulDiv(8, DialogUnits.X, 4);
Top := MulDiv(8, DialogUnits.Y, 8);
Caption := APrompt;
end;
Edit := TEdit.Create(Form);
with Edit do
begin
Parent := Form;
Left := Prompt.Left;
Top := MulDiv(19, DialogUnits.Y, 8);
Width := MulDiv(164, DialogUnits.X, 4);
MaxLength := 255;
Text := Value;
SelectAll;
end;
ButtonTop := MulDiv(41, DialogUnits.Y, 8);
ButtonWidth := MulDiv(50, DialogUnits.X, 4);
ButtonHeight := MulDiv(14, DialogUnits.Y, 8);
with TButton.Create(Form) do
begin
Parent := Form;
Caption := SMsgDlgOK;
ModalResult := mrOk;
Default := True;
SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth,
ButtonHeight);
end;
with TButton.Create(Form) do
begin
Parent := Form;
Caption := SMsgDlgCancel;
ModalResult := mrCancel;
Cancel := True;
SetBounds(MulDiv(92, DialogUnits.X, 4), ButtonTop, ButtonWidth,
ButtonHeight);
end;
if ShowModal = mrOk then
begin
Value := Edit.Text;
Result := True;
end;
finally
Form.Free;
end;
end;function JrInputBox(const ACaption, APrompt, ADefault: string): String;
begin
Result := ADefault;
JrInputQuery(ACaption, APrompt, Result);
end;//------------------------------------------------------------------------------
//扩展文件目录操作函数
//------------------------------------------------------------------------------procedure RunFile(const FileName: String; Handle: THandle = 0; Param: string = '');
begin
ShellExecute(Handle, nil, PChar(FileName), PChar(Param), nil, SW_SHOWNORMAL);
end;function AppPath: string;
begin
Result := ExtractFilePath(Application.ExeName);
end;const
HKLM_CURRENT_VERSION_WINDOWS = 'SoftwareMicrosoftWindowsCurrentVersion';
function RelativeKey(const Key: string): PChar;
begin
Result := PChar(Key);
if (Key <> '') and (Key[1] = '') then
Inc(Result);
end;function RegReadStringDef(const RootKey: HKEY; const Key, Name, Def: string): string;
var
RegKey: HKEY;
Size: DWORD;
StrVal: string;
RegKind: DWORD;
begin
Result := Def;
if RegOpenKeyEx(RootKey, RelativeKey(Key), 0, KEY_READ, RegKey) = ERROR_SUCCESS then
begin
RegKind := 0;
Size := 0;
if RegQueryValueEx(RegKey, PChar(Name), nil, @RegKind, nil, @Size) = ERROR_SUCCESS then
if RegKind in [REG_SZ, REG_EXPAND_SZ] then
begin
SetLength(StrVal, Size);
if RegQueryValueEx(RegKey, PChar(Name), nil, @RegKind, PByte(StrVal), @Size) = ERROR_SUCCESS then
begin
SetLength(StrVal, StrLen(PChar(StrVal)));
Result := StrVal;
end;
end;
RegCloseKey(RegKey);
end;
end;procedure StrResetLength(var S: AnsiString);
begin
SetLength(S, StrLen(PChar(S)));
end;function GetProgramFilesDir: string;
begin
Result := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS, 'ProgramFilesDir', '');
end;function GetWindowsDir: string;
var
Required: Cardinal;
begin
Result := '';
Required := GetWindowsDirectory(nil, 0);
if Required <> 0 then
begin
SetLength(Result, Required);
GetWindowsDirectory(PChar(Result), Required);
StrResetLength(Result);
end;
end;function GetWindowsTempPath: string;
var
Required: Cardinal;
begin
Result := '';
Required := GetTempPath(0, nil);
if Required <> 0 then
begin
SetLength(Result, Required);
GetTempPath(Required, PChar(Result));
StrResetLength(Result);
end;
end;
//------------------------------------------------------------------------------
//扩展字符串操作函数
//------------------------------------------------------------------------------function InStr(const sShort: string; const sLong: string): Boolean;
var
s1, s2: string;
begin
s1 := LowerCase(sShort);
s2 := LowerCase(sLong);
Result := Pos(s1, s2) > 0;
end;function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string;
var
s: string;
i, j: Integer;
begin
s := IntToStr(Value);
Result := '';
j := 0;
for i := Length(s) downto 1 do
begin
Result := s[i] + Result;
Inc(j);
if ((j mod SpLen) = 0) and (i <> 1) then Result := Sp + Result;
end;
end;function ByteToBin(Value: Byte): string;
const
V: Byte = 1;
var
i: Integer;
begin
for i := 7 downto 0 do
if (V shl i) and Value <> 0 then
Result := Result + '1'
else
Result := Result + '0';
end;function StrRight(Str: string; Len: Integer): string;
begin
if Len >= Length(Str) then
Result := Str
else
Result := Copy(Str, Length(Str) - Len + 1, Len);
end;function StrLeft(Str: string; Len: Integer): string;
begin
if Len >= Length(Str) then
Result := Str
else
Result := Copy(Str, 1, Len);
end;function Spc(Len: Integer): string;
begin
SetLength(Result, Len);
FillChar(PChar(Result)^, Len, ' ');
end;procedure SwapStr(var s1, s2: string);
var
tempstr: string;
begin
tempstr := s1;
s1 := s2;
s2 := tempstr;
end;function GetSystemDir: string;
var
Required: Cardinal;
begin
Result := '';
Required := GetSystemDirectory(nil, 0);
if Required <> 0 then
begin
SetLength(Result, Required);
GetSystemDirectory(PChar(Result), Required);
StrResetLength(Result);
end;
end;
// 扩展日期时间操作函数
//------------------------------------------------------------------------------
function GetYear(Date: TDate): Word;
var
m, d: WORD;
begin
DecodeDate(Date, Result, m, d);
end;
function GetMonth(Date: TDate): Word;
var
y, d: WORD;
begin
DecodeDate(Date, y, Result, d);
end;
function GetDay(Date: TDate): Word;
var
y, m: WORD;
begin
DecodeDate(Date, y, m, Result);
end;function GetHour(Time: TTime): Word;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, Result, m, s, ms);
end;function GetMinute(Time: TTime): Word;
var
h, s, ms: WORD;
begin
DecodeTime(Time, h, Result, s, ms);
end;function GetSecond(Time: TTime): Word;
var
h, m, ms: WORD;
begin
DecodeTime(Time, h, m, Result, ms);
end;function GetMSecond(Time: TTime): Word;
var
h, m, s: WORD;
begin
DecodeTime(Time, h, m, s, Result);
end;//------------------------------------------------------------------------------
// 位操作函数
//------------------------------------------------------------------------------procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean); overload;
begin
if IsSet then
Value := Value or (1 shl Bit) else
Value := Value and not(1 shl Bit);
end;procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean); overload;
begin
if IsSet then
Value := Value or (1 shl Bit) else
Value := Value and not(1 shl Bit);
end;procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean); overload;
begin
if IsSet then
Value := Value or (1 shl Bit) else
Value := Value and not(1 shl Bit);
end;function GetBit(Value: Byte; Bit: TByteBit): Boolean; overload;
begin
Result := Value and (1 shl Bit) <> 0;
end;function GetBit(Value: WORD; Bit: TWordBit): Boolean; overload;
begin
Result := Value and (1 shl Bit) <> 0;
end;function GetBit(Value: DWORD; Bit: TDWordBit): Boolean; overload;
begin
Result := Value and (1 shl Bit) <> 0;
end;//------------------------------------------------------------------------------
// 系统功能函数
//------------------------------------------------------------------------------procedure ChangeFocus(Handle: THandle; Forword: Boolean = False);
begin
if ForWord then
PostMessage(Handle, WM_NEXTDLGCTL, 1, 0)
else
PostMessage(Handle, WM_NEXTDLGCTL, 0, 0);
end;procedure MoveMouseIntoControl(AWinControl: TControl);
var
rtControl: TRect;
begin
rtControl := AWinControl.BoundsRect;
MapWindowPoints(AWinControl.Parent.Handle, 0, rtControl, 2);
SetCursorPos(rtControl.Left + (rtControl.Right - rtControl.Left) div 2,
rtControl.Top + (rtControl.Bottom - rtControl.Top) div 2);
end;procedure AddComboBoxTextToItems(ComboBox: TComboBox; MaxItemsCount: Integer = 10);
begin
if (ComboBox.Text <> '') and (ComboBox.Items.IndexOf(ComboBox.Text) < 0) then
begin
ComboBox.Items.Insert(0, ComboBox.Text);
while (MaxItemsCount > 1) and (ComboBox.Items.Count > MaxItemsCount) do
ComboBox.Items.Delete(ComboBox.Items.Count - 1);
end;
end;function DynamicResolution(x, y: WORD): Boolean;
var
lpDevMode: TDeviceMode;
begin
Result := EnumDisplaySettings(nil, 0, lpDevMode);
if Result then
begin
lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
lpDevMode.dmPelsWidth := x;
lpDevMode.dmPelsHeight := y;
Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL;
end;
end;procedure StayOnTop(Handle: HWND; OnTop: Boolean);
const
csOnTop: array[Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST);
begin
SetWindowPos(Handle, csOnTop[OnTop], 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);
end;var
WndLong: Integer;procedure SetHidden(Hide: Boolean);
begin
ShowWindow(Application.Handle, SW_HIDE);
if Hide then
SetWindowLong(Application.Handle, GWL_EXSTYLE,
WndLong or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW or WS_EX_TOPMOST)
else
SetWindowLong(Application.Handle, GWL_EXSTYLE, WndLong);
ShowWindow(Application.Handle, SW_SHOW);
end;const
csWndShowFlag: array[Boolean] of DWORD = (SW_HIDE, SW_RESTORE);procedure SetTaskBarVisible(Visible: Boolean);
var
wndHandle: THandle;
begin
wndHandle := FindWindow('Shell_TrayWnd', nil);
ShowWindow(wndHandle, csWndShowFlag[Visible]);
end;procedure SetDesktopVisible(Visible: Boolean);
var
hDesktop: THandle;
begin
hDesktop := FindWindow('Progman', nil);
ShowWindow(hDesktop, csWndShowFlag[Visible]);
end;function GetWorkRect: TRect;
begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0)
end;procedure BeginWait;
begin
Screen.Cursor := crHourGlass;
end;procedure EndWait;
begin
Screen.Cursor := crDefault;
end;function CheckWindows9598: Boolean;
var
V: TOSVersionInfo;
begin
V.dwOSVersionInfoSize := SizeOf(V);
Result := False;
if not GetVersionEx(V) then Exit;
if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then
Result := True;
end;function GetOSString: string;
var
OSPlatform: string;
BuildNumber: Integer;
begin
Result := 'Unknown Windows Version';
OSPlatform := 'Windows';
BuildNumber := 0; case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS:
begin
BuildNumber := Win32BuildNumber and $0000FFFF;
case Win32MinorVersion of
0..9:
begin
if Trim(Win32CSDVersion) = 'B' then
OSPlatform := 'Windows 95 OSR2'
else
OSPlatform := 'Windows 95';
end;
10..89:
begin
if Trim(Win32CSDVersion) = 'A' then
OSPlatform := 'Windows 98'
else
OSPlatform := 'Windows 98 SE';
end;
90:
OSPlatform := 'Windows Millennium';
end;
end;
VER_PLATFORM_WIN32_NT:
begin
if Win32MajorVersion in [3, 4] then
OSPlatform := 'Windows NT'
else if Win32MajorVersion = 5 then
begin
case Win32MinorVersion of
0: OSPlatform := 'Windows 2000';
1: OSPlatform := 'Windows XP';
end;
end;
BuildNumber := Win32BuildNumber;
end;
VER_PLATFORM_WIN32s:
begin
OSPlatform := 'Win32s';
BuildNumber := Win32BuildNumber;
end;
end;
if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) or
(Win32Platform = VER_PLATFORM_WIN32_NT) then
begin
if Trim(Win32CSDVersion) = '' then
Result := Format('%s %d.%d (Build %d)', [OSPlatform, Win32MajorVersion,
Win32MinorVersion, BuildNumber])
else
Result := Format('%s %d.%d (Build %d: %s)', [OSPlatform, Win32MajorVersion,
Win32MinorVersion, BuildNumber, Win32CSDVersion]);
end
else
Result := Format('%s %d.%d', [OSPlatform, Win32MajorVersion, Win32MinorVersion])
end;function GetComputeNameStr : string;
var
dwBuff : DWORD;
CmpName : array [0..255] of Char;
begin
Result := '';
dwBuff := 256;
FillChar(CmpName, SizeOf(CmpName), 0);
if GetComputerName(CmpName, dwBuff) then
Result := StrPas(CmpName);
end;function GetLocalUserName: string;
var
Count: DWORD;
begin
Count := 256 + 1; // UNLEN + 1
// set buffer size to 256 + 2 characters
SetLength(Result, Count);
if GetUserName(PChar(Result), Count) then
StrResetLength(Result)
else
Result := '';
end;
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);
Result := '';
GetHostName(Buffer, SizeOf(Buffer));
phe :=GetHostByName(buffer);
if phe = nil then Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^[I] <> nil do begin
result:=StrPas(inet_ntoa(pptr^[I]^));
Inc(I);
end;
WSACleanup;
end;//------------------------------------------------------------------------------
// 其它过程
//------------------------------------------------------------------------------function TrimInt(Value, Min, Max: Integer): Integer; overload;
begin
if Value > Max then
Result := Max
else if Value < Min then
Result := Min
else
Result := Value;
end;function InBound(Value: Integer; Min, Max: Integer): Boolean;
begin
Result := (Value >= Min) and (Value <= Max);
end;procedure Delay(const uDelay: DWORD);
var
n: DWORD;
begin
n := GetTickCount;
while ((GetTickCount - n) <= uDelay) do
Application.ProcessMessages;
end;procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);
const
FREQ_SCALE = $1193180;
var
Temp: WORD;
begin
Temp := FREQ_SCALE div Freq;
asm
in al,61h;
or al,3;
out 61h,al;
mov al,$b6;
out 43h,al;
mov ax,temp;
out 42h,al;
mov al,ah;
out 42h,al;
end;
Sleep(Delay);
asm
in al,$61;
and al,$fc;
out $61,al;
end;
end;function GetHzPy(const AHzStr: string): string;
const
ChinaCode: array[0..25, 0..1] of Integer = ((1601, 1636), (1637, 1832), (1833, 2077),
(2078, 2273), (2274, 2301), (2302, 2432), (2433, 2593), (2594, 2786), (9999, 0000),
(2787, 3105), (3106, 3211), (3212, 3471), (3472, 3634), (3635, 3722), (3723, 3729),
(3730, 3857), (3858, 4026), (4027, 4085), (4086, 4389), (4390, 4557), (9999, 0000),
(9999, 0000), (4558, 4683), (4684, 4924), (4925, 5248), (5249, 5589));
var
i, j, HzOrd: Integer;
begin
i := 1;
while i <= Length(AHzStr) do
begin
if (AHzStr[i] >= #160) and (AHzStr[i + 1] >= #160) then
begin
HzOrd := (Ord(AHzStr[i]) - 160) * 100 + Ord(AHzStr[i + 1]) - 160;
for j := 0 to 25 do
begin
if (HzOrd >= ChinaCode[j][0]) and (HzOrd <= ChinaCode[j][1]) then
begin
Result := Result + Char(Byte('A') + j);
Break;
end;
end;
Inc(i);
end else Result := Result + AHzStr[i];
Inc(i);
end;
end;function UpperCaseMoney(const Money: Double): String;
var
tmp1,rr :string;
l,i,j,k:integer;
r: Double;
const
n1: array[0..9] of string = ('零', '壹', '贰', '叁', '肆',
'伍', '陆', '柒', '捌', '玖');
n2: array[0..3] of string = ('', '拾' ,'佰', '仟');
n3: array[0..2] of string = ('元', '万', '亿');
begin
r:=Money;
tmp1:=FormatFloat('#.00',r);
l:=length(tmp1);
rr:='';
if strtoint(tmp1[l])<>0 then begin
rr:='分';
rr:=n1[strtoint(tmp1[l])]+rr;
end; if strtoint(tmp1[l-1])<>0 then begin
rr:='角'+rr;
rr:=n1[strtoint(tmp1[l-1])]+rr;
end; i:=l-3;
j:=0;k:=0;
while i>0 do begin
if j mod 4=0 then begin
rr:=n3[k]+rr;
inc(k);if k>2 then k:=1;
j:=0;
end;
if strtoint(tmp1[i])<>0 then
rr:=n2[j]+rr;
rr:=n1[strtoint(tmp1[i])]+rr;
inc(j);
dec(i);
end; while pos('零零',rr)>0 do
rr:= stringreplace(rr,'零零','零',[rfReplaceAll]);
rr:=stringreplace(rr,'零亿','亿零',[rfReplaceAll]);
while pos('零零',rr)>0 do
rr:= stringreplace(rr,'零零','零',[rfReplaceAll]);
rr:=stringreplace(rr,'零万','万零',[rfReplaceAll]);
while pos('零零',rr)>0 do
rr:= stringreplace(rr,'零零','零',[rfReplaceAll]);
rr:=stringreplace(rr,'零元','元零',[rfReplaceAll]);
while pos('零零',rr)>0 do
rr:= stringreplace(rr,'零零','零',[rfReplaceAll]);
rr:=stringreplace(rr,'亿万','亿',[rfReplaceAll]);
if copy(rr,length(rr)-1,2)='零' then
rr:=copy(rr,1,length(rr)-2); result:=rr;
end;function SoundCardExist: Boolean;
begin
Result := WaveOutGetNumDevs > 0;
end;initialization
WndLong := GetWindowLong(Application.Handle, GWL_EXSTYLE);end.
Trackback: http://tb.blog.csdn.net/TrackBack.aspx?PostId=1862017
type
TaPInAddr = array[0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
HostName : array [0..MAX_PATH] of char;
NameLen:Integer;
WSData: TWSAData;
lpHostEnt:PHostEnt;
I:Integer;
pptr: PaPInAddr;
begin
Result := 0;
if WSAStartup(MakeWord(2,0), WSData)<>0 then
Exit;
try
NameLen := sizeof(HostName);
fillchar(HostName,NameLen,0);
NameLen:=GetHostName(HostName,NameLen);
if NameLen = SOCKET_ERROR then
Exit;
lpHostEnt := GetHostByName(HostName);
if lpHostEnt = Nil then
Exit;
I := 0;
pPtr := PaPInAddr(lpHostEnt^.h_addr_list);
IpList.Clear;
while pPtr^[I] <> nil do
begin
IpList.ADD( inet_ntoa(pptr^[I]^));
Inc(I);
end;
Result := IpList.Count;
finally
WSACleanup;
end;
end;
在数据库编程时,我们用adoCommand和adoDataset等时,经常出现错误,提示说"***参数无法找到",这往往是以下几个原因造成的:
1、参数名写错了；
２、参数名前面没有写“:” (我是指动态生成语句时)；
３、我经常遇到的：
就是数据库组件根本没有与数据库或数据库连结组件进行连接。
用Delphi时间不是很长，也不敢拿出什么，自己blog里一篇，对有些人可能会有用。
http://blog.csdn.net/goldli/archive/2007/12/06/1921020.aspx
用递归方法，使用 xml 文档生成 Treeview 树形视图。由于是动态生成，所以可以通过修改 xml 的逻辑来定制 Treeview 的结构，
从而实现了 xml 对 Treeview 的动态配置，而不用修改代码。 xml 文件如下：
〈?xml version=“1.0“ encoding=“gb2312“?〉
〈root topic=“频道列表“ catalog=“none“〉 〈channel topic=“操作系统“ catalog=“none“〉
〈channel topic=“Windows频道“ catalog=“windows“ /〉
〈channel topic=“DOS频道“ catalog=“dos“ /〉
〈channel topic=“Linux“ catalog=“linux“ /〉
〈/channel〉 〈channel topic=“菜鸟专区“ catalog=“cainiaozhuanqu“ /〉 〈channel topic=“应用软件“ catalog=“app“ /〉 〈channel topic=“安全专区“ catalog=“safe“ /〉 〈channel topic=“代码实验室“ catalog=“lab“ /〉 〈BBS topic=“电脑学习社区“ catalog=“none“〉
〈subBBS topic=“子社区-1“ catalog=“sub1“ /〉
〈subBBS topic=“子社区-2“ catalog=“sub2“ /〉
〈/BBS〉 〈/root〉 程序代码如下： unit tree_xml; interface uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
Forms, Dialogs, ComCtrls, StdCtrls, XMLDoc, XMLIntf; type
TForm1 = class(TForm)
TreeView1: TTreeView;
Memo1: TMemo;
Button1: TButton;
procedure TreeView1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Button1Click(Sender: TObject);
private
procedure CreateTreeview(XmlNode: IXMLNode; TreeNode: TTreeNode);
{ Private declarations }
public
{ Public declarations }
end; type
pRec = ^TData;
TData = record
sCatalog: string;
sReserved: String
end; var
Form1: TForm1; implementation
{$R *.dfm} procedure TForm1.CreateTreeview(XmlNode: IXMLNode; TreeNode: TTreeNode);
var
i: integer;
ParentTreeNode, CurrentTreeNode: TTreeNode;
pData: pRec;
begin
New(pData);
pData^.sCatalog := XmlNode.AttributeNodes[’catalog’].NodeValue;
CurrentTreeNode := TreeView1.Items.AddChildObject(TreeNode,
XmlNode.AttributeNodes[’topic’].NodeValue, pData); //pointer(...)
if XmlNode.HasChildNodes then
begin
ParentTreeNode := CurrentTreeNode;
for i:=0 to XmlNode.ChildNodes.Count-1 do
begin
CreateTreeview(XmlNode.ChildNodes[i], ParentTreeNode);
end;
end;
end; {------------------------------------------------------------------}
procedure TForm1.TreeView1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var pData: pRec;
begin
pData := Treeview1.Selected.Data;
Memo1.Lines.Add(pData^.sCatalog);
end; procedure TForm1.Button1Click(Sender: TObject);
var
oXml: TXMLDocument;
begin
oXml := TXMLDocument.Create(self);
oXml.FileName := ’_Treeview.xml’;
oXml.Active:=true;
CreateTreeview(oXml.ChildNodes.FindNode(’root’), Treeview1.Items.GetFirstNode);
Treeview1.FullExpand; //节点全部展开
oXml.Free;
end; end. 注意程序中 Treeview 的 TreeView1.Items.AddChildObject 方法，其最后一个参数用来保存该节点的相关数据，是一个指针类型的数据，使用时要格外小心。本例中，先定义一个记录类型，再定义一个指针指向它，然后作为 AddChildObject 的最后一个参数。记录类型可以保存节点的很多相关参数，本例中只用到了一个，实际使用时可以任意扩充。 ---“十万个为什么”电脑学习网-http://www.why100000.com-原创文章
张庆（网眼）2007-10-22
5555555哪位高手帮忙解决下我的问题啊,对高手来说是小Case!!在我的贴子里,很急的!!!
* 码如其人 www.cppblog.com/kwer
* 等 级：
发表于：2007-12-08 15:59:0854楼 得分:0
我来凑个数
我把 fastreport，excel模板文件都存放在数据库里面了，供使用时调用用完删除还可以修改。
---------------------------------------
能否详细点，谢谢！
var
errNO: integer;
hMutex: HWND;
begin
hMutex := CreateMutex(nil, False, pchar(application.title));
errNO := GetLastError;
if errNO = ERROR_ALREADY_EXISTS then
begin //检测是否重复运行
application.MessageBox('本软件只能打开一次，重复运行则其中之一将退出！', pchar(application.title), MB_OK);
application.Terminate;
end;
result := true;
end;
var s: string;
begin
with query do begin
close;
sql.clear;
if type1 = 'first' then
sql.add('SELECT DATEADD(mm,DATEDIFF(mm,0,getdate()),0) as d1 ');
if type1 = 'last' then
sql.add('SELECT DATEADD(day, DATEDIFF(day,0,dateadd(ms,-3,DATEADD(mm, DATEDIFF(m,0,getdate())+1,0))),0) as d1 ');
Open;
s := fieldbyname('d1').asstring;
result := StrToDate(s);
end;
end;
你能不能做成不依赖数据库的方法来？=======================================
取时间 < MSSQL2000 >
select convert(char(5),getdate(),108) --结果 09:25
select CONVERT(varchar(7),getdate(),120) --结果 2007-01select datename(weekday,getdate()) --结果 星期五==== DATEPART ( datepart , date ) ====
select DATEPART (d,getdate()) --结果 12(2007-01-12)
select datepart(Dw,getdate()) --结果 6(星期五)week (wk, ww) 日期部分反映对 SET DATEFIRST 作的更改。
任何一年的 1 月 1 日定义了 week 日期部分的开始数字，
例如：DATEPART(wk, 'Jan 1, xxxx') = 1，此处 xxxx 代表任一年。weekday (dw) 日期部分返回对应于星期中的某天的数，
例如：Sunday = 1、Saturday = 7。weekday 日期部分产生的数取决于
SET DATEFIRST 设定的值，此命令设定星期中的第一天。--月的第一天
SELECT CONVERT(CHAR(8),GETDATE(),120)+'01'
SELECT CONVERT(datetime,CONVERT(char(8),getdate(),120)+'01')--月的最后一天
SELECT DATEADD(Day,-1,CONVERT(char(8),DATEADD(Month,1,getdate()),120)+'1')最后一天
SELECT DATEADD(DD,-1,CONVERT(CHAR(8),DATEADD(MM,1,GETDATE()),120)+'01')--年的第一天
SELECT CONVERT(CHAR(4),GETDATE(),120)+'-01-01'
SELECT CONVERT(datetime,CONVERT(CHAR(4),GETDATE(),120)+'-01-01')--12月前
select CONVERT(smalldatetime,CONVERT(CHAR(8),DATEADD(MM,-12,GETDATE()),120) +'01')
Delphi 的 TDateTime 类型，是双精度的浮点数
但是他是从 1899年12月30日开始的
这和MS 开发工具中的日期类型是不同的，ms(比如MSSQL)的是从 1900年1月1日开始的
两着差两天，从前写程序的时候遇到过这个问题。
我们程序员经常会遇到数据导入导出的问题,比如要把listview里的数据导出*.xls,*.txt文件等。我看了有些代码写的
真的太多了，效率也不高。我对sql 数据库比较熟，知道有一个常用的命令 "BCP"，它可以导出所有格式(*.xls,*.txt,
*.doc,*.html,*.csv...)我下面这段代码是动态调用导出，sql_str 定义的是本单元的全局变量,接收sql语句,filename 则是调用savedialog由用户自己决定什么格式的文件名及地址。
procedure Tfrm_query_book.BitBtn1Click(Sender: TObject);
var
str:string;
filename :string;
begin
if SaveDialog1.Execute then
filename:=SaveDialog1.FileName; str:='exec master..xp_cmdshell '' bcp "' +sql_str+ ' " queryout '+filename+' -c -q -S"accountreport" -U"sa" -P"00000"''';
frm_data.book_query.Close;
frm_data.book_query.SQL.Clear ;
frm_data.book_query.sql.Add(str);
frm_data.book_query.ExecSQL ;
application.MessageBox('保存成功!','提示',mb_okcancel);
end;
省区编程时由于sql语句写错产生的错误