天
天宇天蓝
Unregistered / Unconfirmed
GUEST, unregistred user!
新老朋友们，好久不见了。
我现在写程序都是这样写：
我写一个一类：TGlobal，这个类继承自Tform ，然后程序所有的类都继承于这个类。在这个类中写一个段代码。可以为每一个Dbgrid添加上鼠标滚动事件，
var
OldMouseWheel:array of TWndMethod;
procedure
Procedure NewMouseWheel(Var Msg :TMessage); virtual; //鼠标滚动
实现是这样的：在TGlobal的Create时为每一个Dbgrid重新赋值
for i:=0 to ComponentCount -1 do
begin
if Components Is TDBGrid then
begin
Setlength(OldMouseWheel,high(OldMouseWheel)+1+1);
OldMouseWheel[high(OldMouseWheel)]:=TDBGrid(Components).WindowProc;
TDBGrid(Components).Tag:=high(OldMouseWheel);
TDBGrid(Components).WindowProc:= NewMouseWheel;
if Not Assigned(TDBGrid(Components).OnTitleClick) then
TDBGrid(Components).OnTitleClick:=DBGridTitleClick;
if Not Assigned(TDBGrid(Components).OnDrawColumnCell) then
TDBGrid(Components).OnDrawColumnCell :=Dbgrid_DrawColumnCell;
end;
end;
每一个Dbgrid的消息实现是：
procedure TGlobal.NewMouseWheel(var Msg: TMessage);
var I:integer;
begin
if Msg.Msg = WM_MouseWheel then
begin
if Msg.wParam > 0 then
begin
for i:=0 to ComponentCount -1 do
if (Components Is TDBGrid)and((Components as TDBGrid).Focused ) then
begin
SendMessage(TDBGrid(Components).Handle,WM_VSCROLL,SB_LINEUP,0);
(Components as TDBGrid).Refresh;
end
else
OldMouseWheel[TDBGrid(Components).Tag ](msg);
end
else
begin
for i:=0 to ComponentCount -1 do
if (Components Is TDBGrid)and((Components as TDBGrid).Focused ) then
begin
SendMessage((Components as TDBGrid).Handle,WM_VSCROLL,SB_LINEDOWN,0);
(Components as TDBGrid).Refresh;
end
else
OldMouseWheel[TDBGrid(Components).Tag ](msg);
end;
end
else
begin
for i:=0 to high(OldMouseWheel) do //问题所在
OldMouseWheel(msg); //问题所在
end;
end;
在消息重发的时候，不知道向哪一个Dbgrid发。这样就导致Form只能支持一个Dbgrid，而不能支持多个Dbgrid，请问高后，如何实现能支持多个DBgrid？
付源码：
{*******************************************************}
{ }
{ 一个函数单元 }
{ }
{ 版权所有 (C) 2005 石家庄华园电脑科技有限公司 }
{ }
{ 创建者：王彦鹏 }
{ }
{ 创建日期:2005-8-29 }
{ 版本：1.00 }
{*******************************************************}
unit Global_Class;
interface
uses Windows, Classes, Forms, ExtCtrls, Graphics, StdCtrls,
Messages, Controls, DBGrids, DB, ADODB, registry, SysUtils, typinfo,
WinSock,nb30,shellapi,WHintWindow ,ComCtrls,Grids;
const
ConfigFile='language.ini';
type
PASTAT = ^TASTAT;
TASTAT = record
adapter : TAdapterStatus;
name_buf : TNameBuffer;
end;
type
LanguageType = (Chinese, English); ///语言
TCPUID = array[0..3] of Longint; //CPUID
TVendor = array [0..11] of char; //CPU版本
MacAdd = array [0..5] of byte; //网卡MAC地址
HardIDENTITY=array[0..23] of byte; //硬件标识,网卡和CpuID的合成。
type
TMouseEnter_Event = procedure(Sender: TObject) of object;
TMouseLeave_Event = procedure(Sender: TObject) of object;
DbgridWheel_Event= Procedure (Var Msg :TMessage) of object;
TGlobal=class(TForm )
private
//DefaultLanguage:LanguageType;
FMouseEnter:TMouseEnter_Event;
FMouseLeave:TMouseLeave_Event;
OldMouseWheel:array of TWndMethod;
procedure SetLanguage(Value:LanguageType);
function DefaultLanguage: LanguageType; //当前默认语言.
Procedure NewMouseWheel(Var Msg :TMessage); virtual; //鼠标滚动
function GetPYIndexChar(hzchar: string): Char; //返回一个字符（汉字）的第一个拼音。
protected
HintWindow:TxyHintWindow;
function ImgToBmp(Img: TImage): TBitmap; //把Image中的图像转换为Bmp.
procedure ObjectMouseDown(Sender: TWinControl; Button: TMouseButton;
Shift: TShiftState; X, Y: integer); //使一个控件可拖动。
function Pyin(str: string): string; //返回一个字符串的第一个拼音字符串。
procedure PaintBorder(Sender: TForm; col: TColor); //画边框。
procedure FormSlectNexe(Sender: TObject; var Key: Char); //回车选择下一控件
function Isnull(Sender: TComponent; HintInfo: string; CheckValue: byte =
0;Icon
char=IDI_INFORMATION): boolean; //检查一个输入控件的值是否为空。
procedure SortQuery(Column: TColumn); //DBGrid排序.
procedure BrushBmp(Sender: TWinControl; BrushImg: TImage); //在指定的控件上画图。
function GetRegValue(RootKey:HKEY;Key, SubKey: string): Variant; //读注册指定的键值。
procedure SetRegValue(RootKey:HKEY;Key, SubKey, Value: string); //设置注册表指定的键为指定的值。
function GetCObjectS(Cbx: TComboBox): string;
function GetFileVerSion(FileName: string): string;
Function Version:string;
function WriteErrLog(LogText: string;FileName:string='Log.Txt'): integer;
procedure WriteDefaultLanguage(MainComp: TComponent; PartName: string);
procedure ReadDefaultLanguage(mainComp: TComponent; PartName: string;
Language: LanguageType);
function GetLocalIP(HostName:string='LocalHost'):string; //得到本机IP地址。
function GetLocalHostName:string; //得到本机机器名
procedure GetCPUVendor(var CpuVerd : TVendor); //得到CPU的厂商信息
procedure GetCPUID(Var CPUID:TCPUID); //得到CPU的序列号。
function Getmac:MacAdd ; //得到Mac地址。
Function GetHostMac(const IPAddress: String):MacAdd; //得到局域网上的主机MAC地址
function SumAdd(Buffchar):Word; //计算累加和，双字节累加和。
Function GetHardIDENTITY(HardInfo:HardIDENTITY):integer;
Function AppName:string; // 当前程序名称
Function AppPath:string; //当前路径
property Language:LanguageType read DefaultLanguage write SetLanguage;
function GetIniStrValue(MainKey, Key: PChar): string;
procedure OpenUrl(const Url: string);
procedure RunFile(const FName: string; Handle: THandle=0;
const Param: string='');
procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER; //鼠标移入的消息
procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE; //鼠标移出的消息
function ReadIniConfig(const Ident:string; Default: string=''): string;virtual ;abstract;
function ReadIniFile(const Section,Ident:string;
Default:string=''):string;virtual;abstract; //读Ini文件
function WriteIniFile(const Section,Ident,Value:string):boolean;virtual;abstract; //写字符串到INI文件。
Function MsgBox(const Ident, Txt,Caption:string;Buton:Integer):integer;overload;virtual;abstract; //一个Messagebox的封装
Function MsgBox(const Txt,Caption:string;Buton:Integer):integer;overload; virtual;abstract; //一个Messagebox的封装
procedure DBGridTitleClick(Column: TColumn);virtual; //Dbgrid 的点击Title默认处理
procedure Dbgrid_DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState); virtual; //Dbgrid 的重画默认处理;
Function ChmHelp(lpHelpFile:string;wCommand:Longint; dwData:string):HWND;
procedure FreeTreeViewData(TreeView:TTreeView ); //释放TreeView的节点信息。
Procedure FreeNodeData(ParentNode:TTreeNode); //释放ParentNode下的节点信息
procedure ClearInputInfo; //清空本窗体所有的输入的框内容
public
constructor create(AOwnet:TComponent) ;
destructor Destroy;virtual ;
function GetLastErrStr(LastErrID: Integer; var ErrStr: PChar): Integer;overload; //返回最后一个错误原因
function GetLastErrStr(LastErrID: Integer): string;overload; //返回最后一个错误原因
Function FormatSqlValue(const Value:string):string; //格式化一个Sql语句
published
property OnMouseEnter:TMouseEnter_Event read FMouseEnter write FMouseEnter ;
property OnMouseLeave:TMouseLeave_Event read FMouseLeave write FMouseLeave;
end;
function SendARP(DestIP,SrcIP: DWORD; pMacAddr: puLong;
PhyAddrLen: puLong): DWORD; stdCall; external 'IPHLPAPI.DLL'
function HtmlHelpA (hwndcaller:Longint;lpHelpFile:string;wCommand:Longint;
dwData:string):HWND;STDCALL;EXTERNAL 'hhctrl.ocx' //调用Chm格式的帮助文件。
implementation
{-------------------------------------------------------------------------------
过程名: 把Image的图像转换为Bmp
功能：
作者: 王彦鹏
日期: 2005.08.29
参数: Img: TImage
传入参数：
传出参数：
返回值: TBitmap
-------------------------------------------------------------------------------}
Function TGlobal.ImgToBmp(Img: TImage): TBitmap;
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
if Img.Picture.Graphic = nil then
begin
Result := Bmp;
exit;
end;
Bmp.Width := Img.Picture.Graphic.Width;
Bmp.Height := Img.Picture.Graphic.Height;
Bmp.Canvas.Draw(0, 0, Img.Picture.Graphic);
Result := Bmp;
end;
{-------------------------------------------------------------------------------
过程名: GetPYIndexChar
功能： 返回一个字符（汉字）的第一个拼音。
作者: 王彦鹏
日期: 2005.08.29
参数: hzchar: string
传入参数：
传出参数：
返回值: Char
-------------------------------------------------------------------------------}
Function TGlobal.GetPYIndexChar(hzchar: string): Char;
begin
if hzchar = '' then
begin
Result := Char(32);
exit;
end;
case Word(hzchar[1]) shl 8 + Word(hzchar[2]) 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 := Char(32);
end;
end;
{-------------------------------------------------------------------------------
过程名: Pyin
功能： 返回一个字符串的第一个拼音字符串。
作者: 王彦鹏
日期: 2005.08.29
参数: str: string
传入参数：
传出参数：
返回值: string
-------------------------------------------------------------------------------}
Function TGlobal.Pyin(str: string): string;
var
i: integer;
PY: string;
s: string;
begin
s := '';
i := 1;
while i <= Length(str) do
begin
PY := Copy(str, i, 1);
if PY >= Chr(128) then
begin
Inc(i);
PY := PY + Copy(str, i, 1);
s := s + GetPYIndexChar(PY);
end
else
s := s + PY;
Inc(i);
end;
Result := s;
end;
{-------------------------------------------------------------------------------
过程名: PaintBorder
功能： 为一个可视的窗体画一个边框。
作者: 王彦鹏
日期: 2005.08.29
参数: Sender: TForm; col: TColor
传入参数：
传出参数：
返回值: 无
-------------------------------------------------------------------------------}
Procedure TGlobal.PaintBorder(Sender: TForm; col: TColor);
var
Dc: Hdc;
Pen: Hpen;
Oldpen: Hpen;
OldBrush: HBRUSH;
begin
Dc := GetWindowDC(Sender.Handle);
Pen := CreatePen(PS_SOLID, 2, col);
Oldpen := SelectObject(Dc, Pen);
OldBrush := SelectObject(Dc, GetStockObject(NULL_BRUSH));
Rectangle(Dc, 0, 0, Sender.Width, (Sender).Height);
SelectObject(Dc, OldBrush);
SelectObject(Dc, Oldpen);
DeleteObject(Pen);
ReleaseDC((Sender).Handle, Sender.Canvas.Handle);
Sender.Update;
end;
{-------------------------------------------------------------------------------
过程名: FormSlectNexe
功能： 回车选择下一个控件
作者: 王彦鹏
日期: 2005.08.29
参数: Sender: TWinControl; HintInfo: string; CheckValue: byte = 0
传入参数：
传出参数：
返回值: boolean
-------------------------------------------------------------------------------}
Procedure TGlobal.FormSlectNexe(Sender: TObject ; var Key: Char);
begin
if Key = #13 then
begin
Postmessage(TWinControl(Sender).Handle, WM_KEYDOWN, VK_TAB, 0);
Key := #0;
end;
end;
{-------------------------------------------------------------------------------
过程名: Isnull
功能： 检查一个可输入框是否为空
作者: 王彦鹏
日期: 2005.08.29
参数: Sender: TWinControl; HintInfo: string; CheckValue: byte = 0
传入参数： 如果CheckValue<>0 时检查是不是 0 ，如果输入框值为 0 也视为空。
传出参数：
返回值: boolean
-------------------------------------------------------------------------------}
Function TGlobal.Isnull(Sender: TComponent ; HintInfo: string; CheckValue: byte =
0;Iconchar=IDI_INFORMATION): boolean;
const
PropertyNames: array[0..0] of PChar = ('Text');
var
PropIndex: Integer;
PropInfoPtr: PPropInfo;
PropOldValue: string;
begin
for PropIndex := Low(PropertyNames) to High(PropertyNames) do
begin
PropInfoPtr := GetPropInfo(Sender, PropertyNames[PropIndex]);
if PropInfoPtr = nil then continue;
if PropInfoPtr^.PropType^.Kind = tklString then
begin
PropOldValue := GetStrProp(Sender, PropInfoPtr);
if CheckValue =0 then
begin
if (PropOldValue ='') then
begin
//Application.MessageBox(pchar(HintInfo), '提示', 64);
if Not Assigned(HintWindow ) then
HintWindow:=TxyHintWindow.Create(self);
HintWindow.ShouHintW(TWinControl(Sender),HintInfo,Icon);
if Sender is TWinControl then
begin
if TWinControl(sender).CanFocus then
begin
TWinControl(sender).SetFocus;
Abort;
end
else
Abort;
end;
end;
end
else
if (PropOldValue ='') or (StrToInt(PropOldValue) =0) then
begin
Application.MessageBox(pchar(HintInfo), '提示', 64);
if Sender is TWinControl then
begin
if TWinControl(sender).CanFocus then
begin
TWinControl(sender).SetFocus;
Abort;
end
else
Abort;
end;
end;
end;
end;
result:=true;
end;
{-------------------------------------------------------------------------------
过程名: SortQuery
功能： 使一个控件可拖动。
作者: 王彦鹏
日期: 2005.08.29
参数: Column: TColumn
传入参数：
传出参数：
返回值: 无
-------------------------------------------------------------------------------}
Procedure TGlobal.ObjectMouseDown(Sender: TWinControl; Button: TMouseButton;
Shift: TShiftState; X, Y: integer);
begin
ReleaseCapture;
SendMessage(Sender.Handle, WM_SYSCOMMAND, $F012, 0);
end;
{-------------------------------------------------------------------------------
过程名: SortQuery
意义: 一个让DBGrid点击Title可以正反排序的过程。
作者: 王彦鹏
日期: 2005-11-1 15:34:28
参数: Column: TColumn
传出参数:
返回值: 无
返回值类型:
-------------------------------------------------------------------------------}
Procedure TGlobal.SortQuery(Column: TColumn);
var
SqlStr, myFieldName, TempStr: string;
OrderPos: integer;
SavedParams: TParameters;
const
//▽△
Descchar='▽';
AscChar='△';
procedure RestoryColunmCaption;
var i:integer;
S:string;
begin
for i:=0 to TDBGrid(Column.Grid).Columns.Count -1 do
begin
s:=TDBGrid(Column.Grid).Columns.Title.Caption;
delete(s,pos(Descchar,TDBGrid(Column.Grid).Columns.Title.Caption),length(Descchar));
TDBGrid(Column.Grid).Columns.Title.Caption:=s;
s:=TDBGrid(Column.Grid).Columns.Title.Caption;
delete(s,pos(AscChar,TDBGrid(Column.Grid).Columns.Title.Caption),length(AscChar));
TDBGrid(Column.Grid).Columns.Title.Caption:=s;
end;
end;
begin
RestoryColunmCaption;
if not(Assigned(Column.field)) then
exit;
if not (Column.Field.FieldKind in [fkData, fkLookup]) then
exit;
if Column.Field.FieldKind = fkData then
myFieldName := UpperCase(Column.Field.FieldName)
else
myFieldName := UpperCase(Column.Field.KeyFields);
while Pos(myFieldName, ';') <> 0 do
myFieldName := Copy(myFieldName, 1, Pos(myFieldName, ';') - 1)
+ ',' + Copy(myFieldName, Pos(myFieldName, ';') + 1, 100);
with TADOQuery(TDBGrid(Column.Grid).DataSource.DataSet) do
begin
SqlStr := UpperCase(sql.Text);
if ParamCount > 0 then
begin
SavedParams := TParameters.Create(nil, nil);
SavedParams.Assign(Parameters);
end;
OrderPos := Pos('ORDER', SqlStr);
if (OrderPos = 0) or
(Pos(myFieldName, Copy(SqlStr, OrderPos, 100)) = 0) then
begin
TempStr := ' Order By ' + myFieldName + ' Asc';
Column.Title.Caption:=Column.Title.Caption +ascchar;
end
else
if Pos('ASC', SqlStr) = 0 then
begin
TempStr := ' Order By ' + myFieldName + ' Asc';
Column.Title.Caption:=Column.Title.Caption +ascchar;
end
else
begin
TempStr := ' Order By ' + myFieldName + ' Desc';
Column.Title.Caption:=Column.Title.Caption +Descchar ;
end;
if OrderPos <> 0 then
SqlStr := Copy(SqlStr, 1, OrderPos - 1);
SqlStr := SqlStr + TempStr;
Active := false;
sql.Clear;
sql.Text := SqlStr;
if ParamCount > 0 then
begin
if SavedParams <> nil then
begin
Parameters.AssignValues(SavedParams);
SavedParams.Free;
end;
end;
open;
end;
end;
{-------------------------------------------------------------------------------
过程名: BrushBmp
意义: 在指定的控件上画图
作者: 王彦鹏
日期: 2005-11-1 15:35:47
参数: Sender: TWinControl; BrushImg: TImage
传出参数:
返回值: 无
返回值类型:
-------------------------------------------------------------------------------}
Procedure TGlobal.BrushBmp(Sender: TWinControl; BrushImg: TImage);
begin
if BrushImg <> nil then
Sender.Brush.bitmap := BrushImg.Picture.bitmap;
end;
{-------------------------------------------------------------------------------
过程名: GetRegValue
意义:
作者: 王彦鹏
日期: 2005-11-1 15:36:28
参数: Key, SubKey: string
传出参数:
返回值: Variant
返回值类型:Variant (Type)
-------------------------------------------------------------------------------}
Function TGlobal.GetRegValue(RootKey:HKEY;Key, SubKey: string): Variant;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
Reg.RootKey:=RootKey;
if Reg.OpenKey(Key, true) then
begin
Result := Reg.ReadString(SubKey);
end;
Reg.Free;
end;
{-------------------------------------------------------------------------------
过程名: GetCObjectS
意义:
作者: 王彦鹏
日期: 2005-11-1 15:36:42
参数: Cbx: TComboBox
传出参数:
返回值: string
返回值类型:string (Type)
-------------------------------------------------------------------------------}
Procedure TGlobal.SetRegValue(RootKey:HKEY;Key, SubKey, Value: string);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
Reg.RootKey:=RootKey;
if Reg.OpenKey(Key, true) then
begin
Reg.WriteString(SubKey, Value);
end;
Reg.Free;
end;
{-------------------------------------------------------------------------------
过程名: GetFileVerSion
意义:
作者: 王彦鹏
日期: 2005-11-1 15:37:02
参数: var V1, V2, V3, V4: dword; FileName: string
传出参数:
返回值: boolean
返回值类型:boolean (Type)
-------------------------------------------------------------------------------}
Function TGlobal.GetCObjectS(Cbx: TComboBox): string;
begin
case Cbx.ItemIndex of
-1: Result := '';
else
begin
if Cbx.Items.Objects[Cbx.ItemIndex] <> nil then
Result := inttostr(integer(Cbx.Items.Objects[Cbx.ItemIndex]))
else
Result := '0';
end;
end;
end;
{-------------------------------------------------------------------------------
过程名: GetFileVerSion
意义: 返回文件的版本号。
作者: 王彦鹏
日期: 2005-11-1 15:40:23
参数: FileName: string
传出参数:
返回值: string
返回值类型:string (Type)
-------------------------------------------------------------------------------}
Function TGlobal.GetFileVerSion(FileName: string): string;
var
VerInfoSize: dword;
VerInfo: Pointer;
VerValueSize: dword;
VerValue: PVSFixedFileInfo;
Dummy: dword;
V1, V2, V3, V4: dword;
begin
VerInfoSize := GetFileVersionInfoSize(pchar(FileName), Dummy);
GetMem(VerInfo, VerInfoSize);
GetFileVersionInfo(pchar(FileName), 0, VerInfoSize, VerInfo);
if VerInfo = nil then
begin
result:='1.0.0.0';
exit;
end;
VerQueryValue(VerInfo, '/', Pointer(VerValue), VerValueSize);
with VerValue^ do
begin
V1 := dwFileVersionMS shr 16;
V2 := dwFileVersionMS and $FFFF;
V3 := dwFileVersionLS shr 16;
V4 := dwFileVersionLS and $FFFF;
end;
FreeMem(VerInfo, VerInfoSize);
result := format('%d.%d.%d.%d', [v1,v2,v3, v4]);
end;
Function GetModuleName(Module: HMODULE): string;
var
ModName: array[0..MAX_PATH] of Char;
begin
SetString(Result, ModName, GetModuleFileName(Module, ModName, SizeOf(ModName)));
end;
{-------------------------------------------------------------------------------
过程名: WriteErrLog
意义: 写日志。文件名为Log.Txt
作者: 王彦鹏
日期: 2005-11-1 15:40:49
参数: LogText: string
传出参数:
返回值: integer
返回值类型:integer (Type)
-------------------------------------------------------------------------------}
Function TGlobal.WriteErrLog(LogText: string;FileName:string='Log.Txt'): integer;
var FileHandle: thandle;
FileSize: integer;
FileB: pchar;
begin
try
FileName := 'Log.Txt';
if ExtractFilePath(FileName) = '' then
begin
CreateDir(ExtractFilePath(GetModuleName(0)) + 'Log');
FileName := ExtractFilePath(GetModuleName(0)) + 'Log/' + FileName;
end;
if not FileExists(filename) then
begin
FileHandle := FileCreate(FileName);
CloseHandle(FileHandle);
end;
LogText := LogText + ' 时间：' + formatdatetime('yyyy-MM-dd hh:mm:ss', now);
LogText := LogText + #13 + #10;
GetMem(Fileb, 1024);
fillchar(Fileb[0], 1024, #0);
move(LogText[1], fileb[0], length(LogText));
FileHandle := FileOpen(filename, fmOpenWrite);
FileSize := FileSeek(FileHandle, 0, 2);
if FileSize > 2048 * 1000 then
begin
FileClose(FileHandle);
DeleteFile(FileName);
FileHandle := FileCreate(FileName);
end;
FileWrite(filehandle, fileb[0], length(LogText));
FileClose(FileHandle);
result := 0;
except
result := 1;
end;
end;
{-------------------------------------------------------------------------------
过程名: WriteResource
意义: 一个把本窗体上的所有控件的标题写入一个文件。
作者: 王彦鹏
日期: 2005-11-1 15:43:30
参数: 无
传出参数:
返回值: integer
返回值类型:integer (Type)
-------------------------------------------------------------------------------}
Procedure TGlobal.WriteDefaultLanguage(MainComp: TComponent; PartName: string);
const
PropertyNames: array[0..4] of PChar = ('Caption', 'Text', 'Hint', 'Title','Lines');
var
Comp: TComponent;
CompIndex, PropIndex: Integer;
PropInfoPtr: PPropInfo;
PropOldValue: string;
begin
with MainComp do
begin
for CompIndex := 0 to ComponentCount - 1 do
begin
Comp := Components[CompIndex];
for PropIndex := Low(PropertyNames) to High(PropertyNames) do
begin
PropInfoPtr := GetPropInfo(Comp, PropertyNames[PropIndex]);
if PropInfoPtr = nil then continue;
case PropInfoPtr^.PropType^.Kind of
tkLString :
begin
PropOldValue := GetStrProp(Comp, PropInfoPtr);
if (PropOldValue <> '') then
begin
//PropNewValue := 'test';
WritePrivateProfileString(pchar(PartName), pchar(Comp.Name+'.'+PropertyNames[PropIndex ] + '_CHS'), pchar(PropOldValue), pchar(AppPath +ConfigFile));
WritePrivateProfileString(pchar(PartName), pchar(Comp.Name+'.'+PropertyNames[PropIndex ] + '_EnS'), '', pchar(AppPath +ConfigFile));
//SetStrProp(Comp, PropertyNames[PropIndex], PropNewValue);
end;
end;
tkClass:
begin
end;
end;
WriteDefaultLanguage(comp, PartName + '.' + Comp.Name);
end;
end;
WritePrivateProfileString('Languages','Languages','Chines', pchar(AppPath +ConfigFile))
end;
end;
Procedure TGlobal.ReadDefaultLanguage(mainComp: TComponent; PartName: string; Language: LanguageType);
const
PropertyNames: array[0..3] of PChar = ('Caption', 'Text', 'Hint', 'Title');
var
Comp: TComponent;
CompIndex, PropIndex: Integer;
PropInfoPtr: PPropInfo;
PropNewValue: pchar;
begin
PropNewValue := AllocMem(1024);
with MainComp do
begin
for CompIndex := 0 to ComponentCount - 1 do
begin
Comp := Components[CompIndex];
for PropIndex := Low(PropertyNames) to High(PropertyNames) do
begin
PropInfoPtr := GetPropInfo(Comp, PropertyNames[PropIndex]);
if PropInfoPtr = nil then continue;
if PropInfoPtr^.PropType^.Kind = tklString then
begin
fillchar(PropNewValue[0], 1024, 0);
if Language = Chinese then
GetPrivateProfileString(
pchar(PartName), // []中标题的名字
pchar(Comp.Name+'.'+PropertyNames[PropIndex ] + '_CHS'), // =号前的名字
'', // 如果没有找到字符串时，返回的默认值
PropNewValue, //存放取得字符
255, //取得字符的允许最大长度
pchar(AppPath +ConfigFile) // 调用的文件名
)
else
GetPrivateProfileString(
pchar(PartName), // []中标题的名字
pchar(Comp.Name+'.'+PropertyNames[PropIndex ] + '_EnS'), // =号前的名字
'', // 如果没有找到字符串时，返回的默认值
PropNewValue, //存放取得字符
255, //取得字符的允许最大长度
pchar(AppPath +ConfigFile) // 调用的文件名
);
if length(PropNewValue) <>0 then
SetStrProp(Comp, PropertyNames[PropIndex], PropNewValue);
end;
ReadDefaultLanguage(comp, PartName + '.' + Comp.Name, Language);
end;
end;
end;
if Language =Chinese then
WritePrivateProfileString('Languages','Languages','Chines', pchar(AppPath +ConfigFile))
else
WritePrivateProfileString('Languages','Languages','English', pchar(AppPath +ConfigFile));
freemem(PropNewValue);
end;
Function TGlobal.GetLocalIP(HostName:string='LocalHost'):string;
var
HostEnt: PHostEnt;
addr: pchar;
Buffer: array [0..63] of char;
GInitData: TWSADATA;
begin
try
WSAStartup(2, GInitData);
if HostName ='LocalHost' then
GetHostName(Buffer, SizeOf(Buffer))
else
Move(HostName[1],Buffer[0],length(hostname));
HostEnt := GetHostByName(buffer);
if HostEnt = nil then Exit;
addr := HostEnt^.h_addr_list^;
result := Format('%d.%d.%d.%d', [byte(addr [0]),
byte (addr [1]), byte (addr [2]), byte (addr [3])]);
finally
WSACleanup;
end;
end;
Function GetCPUIDX : TCPUID; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Resukt}
MOV EAX,1
DW $A20F {CPUID Command}
STOSD {CPUID[1]}
MOV EAX,EBX
STOSD {CPUID[2]}
MOV EAX,ECX
STOSD {CPUID[3]}
MOV EAX,EDX
STOSD {CPUID[4]}
POP EDI {Restore registers}
POP EBX
end;
Function GetCPUVendorX : TVendor; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Result (TVendor)}
MOV EAX,0
DW $A20F {CPUID Command}
MOV EAX,EBX
XCHG EBX,ECX {save ECX result}
MOV ECX,4
@1:
STOSB
SHR EAX,8
LOOP @1
MOV EAX,EDX
MOV ECX,4
@2:
STOSB
SHR EAX,8
LOOP @2
MOV EAX,EBX
MOV ECX,4
@3:
STOSB
SHR EAX,8
LOOP @3
POP EDI {Restore registers}
POP EBX
end;
Procedure TGlobal.GetCPUVendor(var CpuVerd : TVendor);//得到CPU的厂商信息
begin
CpuVerd:=GetCPUVendorX;
end;
Procedure TGlobal.GetCPUID(Var CPUID:TCPUID);//得到CPU的序列号。
begin
CPUID:=GetCPUIDX ;
end;
Function TGlobal.Getmac:MacAdd ;
var
ncb : TNCB;
s:string;
adapt : TASTAT;
lanaEnum : TLanaEnum;
i, m : integer;
begin
FillChar(ncb, SizeOf(TNCB), 0);
ncb.ncb_command := Char(NCBEnum);
ncb.ncb_buffer := PChar(@lanaEnum);
ncb.ncb_length := SizeOf(TLanaEnum);
s:=Netbios(@ncb);
for i := 0 to integer(lanaEnum.length)-1 do
begin
FillChar(ncb, SizeOf(TNCB), 0);
ncb.ncb_command := Char(NCBReset);
ncb.ncb_lana_num := lanaEnum.lana;
Netbios(@ncb);
Netbios(@ncb);
FillChar(ncb, SizeOf(TNCB), 0);
ncb.ncb_command := Chr(NCBAstat);
ncb.ncb_lana_num := lanaEnum.lana;
ncb.ncb_callname := '* ';
ncb.ncb_buffer := PChar(@adapt);
ncb.ncb_length := SizeOf(TASTAT);
m:=0;
if (Win32Platform = VER_PLATFORM_WIN32_NT) then
m:=1;
if m=1 then
begin
if Netbios(@ncb) = Chr(0) then
move(adapt.adapter.adapter_address[0],result[0],6);
end;
if m=0 then
if Netbios(@ncb) <> Chr(0) then
begin
fillchar(result[0],6,0);
move(adapt.adapter.adapter_address[0],result[0],6);
end;
end;
end;
Function TGlobal.SumAdd(Buffchar):Word; //计算累加和。
var I:integer;
begin
for i:=0 to length(buff)-1 do
Result:=Result+ord(buff[0]);
end;
constructor TGlobal.create(AOwnet:TComponent) ;
var i:integer;
begin
inherited ;
for i:=0 to ComponentCount -1 do
begin
if Components Is TDBGrid then
begin
Setlength(OldMouseWheel,high(OldMouseWheel)+1+1);
OldMouseWheel[high(OldMouseWheel)]:=TDBGrid(Components).WindowProc;
TDBGrid(Components).Tag:=high(OldMouseWheel);
TDBGrid(Components).WindowProc:= NewMouseWheel;
if Not Assigned(TDBGrid(Components).OnTitleClick) then
TDBGrid(Components).OnTitleClick:=DBGridTitleClick;
if Not Assigned(TDBGrid(Components).OnDrawColumnCell) then
TDBGrid(Components).OnDrawColumnCell :=Dbgrid_DrawColumnCell;
end;
end;
HintWindow:=TxyHintWindow.Create(self);
KeyPreview:=true;
OnKeyPress:=FormSlectNexe;
end;
destructor TGlobal.Destroy;
begin
inherited;
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.GetHardIDENTITY
作者: 王彦鹏
日期: 2005-11-19
参数: HardInfo: HardIDENTITY
返回值: integer
说明: 返回硬件标识
-------------------------------------------------------------------------------}
function TGlobal.GetHardIDENTITY(HardInfo: HardIDENTITY): integer;
var CpuID:tcpuid;
Mac:MacAdd;
begin
FillChar(HardInfo[0],24,0);
if sizeof(HardInfo)<>24 then
result:=-1
else
begin
GetCPUID(CpuID );
Mac:=Getmac;
move(cpuid[0],HardInfo[0],16);
move(mac[0],HardInfo[16],7);
result:=0;
end;
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.AppName
作者: 王彦鹏
日期: 2005-11-22
参数: 无
返回值: string
说明: 返回当前执行程序的文件名
-------------------------------------------------------------------------------}
function TGlobal.AppName: string;
begin
Result:=ExtractFileName(Application.ExeName);
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.AppPath
作者: 王彦鹏
日期: 2005-11-22
参数: 无
返回值: string
说明: 返回 当前的可执行文件的路径。带'/'。
-------------------------------------------------------------------------------}
function TGlobal.AppPath: string;
begin
Result:=ExtractFilePath(Application.ExeName );
if Copy(Result,length(Result),1)<>'/' then
Result:=Result+'/';
end;
procedure TGlobal.SetLanguage(Value: LanguageType);
begin
ReadDefaultLanguage(self,self.Name,Value );
case value of
Chinese:WriteIniFile('Languages','Languages','Chines');
English:WriteIniFile('Languages','Languages','English');
end;
// DefaultLanguage:=Value;
end;
function TGlobal.Version: string;
begin
result:=GetFileVerSion(GetModuleName(0));
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.GetIniStrValue
作者: 王彦鹏
日期: 2005-12-15
参数: MainKey, Key: PChar
返回值: string
说明: 返回Ini的键值。
-------------------------------------------------------------------------------}
function TGlobal.GetIniStrValue(MainKey, Key: PChar): string;
var SvalueChar;
begin
Svalue:=AllocMem(1024);
GetPrivateProfileString(
MainKey, // []中标题的名字
key, // =号前的名字
'', // 如果没有找到字符串时，返回的默认值
svalue, //存放取得字符
255, //取得字符的允许最大长度
pchar(AppPath +ConfigFile) // 调用的文件名
);
Result :=Svalue;
FreeMem(Svalue);
end;
procedure TGlobal.RunFile(const FName: string; Handle: THandle;
const Param: string);
begin
ShellExecute(Handle, nil, PChar(FName), PChar(Param), nil, SW_SHOWNORMAL);
end;
// 打开一个链接
procedure TGlobal.OpenUrl(const Url: string);
const
csPrefix = 'http://';
var
AUrl: string;
begin
if Pos(csPrefix, Url) < 0 then
AUrl := csPrefix + Url
else
AUrl := Url;
RunFile(AUrl);
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.GetLastErrStr
意义: 返回GetLastError的错误原因。
作者: 王彦鹏
日期: 2005-12-16 15:36:37
参数: LastErrID: Integer; var ErrStr: PChar
传出参数:
返回值: Integer
返回值类型:Integer (Type)
-------------------------------------------------------------------------------}
function TGlobal.GetLastErrStr(LastErrID: Integer;
var ErrStr: PChar): Integer;
begin
if ErrStr = nil then
result := -1
else
result := FormatMessage(
FORMAT_MESSAGE_ALLOCATE_BUFFER or
FORMAT_MESSAGE_FROM_SYSTEM or
FORMAT_MESSAGE_IGNORE_INSERTS,
nil, LastErrID, 0,@ErrStr , 0, nil);
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.GetLastErrStr
意义: 重载
作者: 王彦鹏
日期: 2005-12-16 15:44:22
参数: LastErrID: Integer
传出参数:
返回值: string
返回值类型:string (Type)
-------------------------------------------------------------------------------}
function TGlobal.GetLastErrStr(LastErrID: Integer): string;
var ErrCodechar;
begin
if GetLastErrStr(LastErrID,ErrCode )>0 then
result:=ErrCode
else
begin
if GetLastErrStr(GetLastError,ErrCode )>0 then
result:=ErrCode
else
result:='未指定的错误！';
end;
end;
procedure TGlobal.CMMouseEnter(var Msg: TMessage);
begin
if Assigned(FMouseEnter) and (TObject(Msg.lParam) <>nil) then
FMouseEnter(TObject(Msg.lParam));
end;
procedure TGlobal.CMMouseLeave(var Msg: TMessage);
var
AnObject : TObject;
begin
if Assigned(FMouseLeave) and (TObject(Msg.lParam) <>nil)then
FMouseLeave(TObject(Msg.lParam));
end;
{-------------------------------------------------------------------------------
过程名: FormatSqlValue
意义:
作者: 王彦鹏
日期: 2006-1-5 12:05:52
参数: const Value:string
传出参数:
返回值: string
返回值类型:string (Type)
-------------------------------------------------------------------------------}
function TGlobal.FormatSqlValue(const Value: string): string;
var i:integer;
Vs:string;
begin
vs:='';
for i:=1 to length(value) do
begin
vs:=vs+value;
if value='''' then
vs:=vs+'''';
end;
result:=vs;
end;
function TGlobal.DefaultLanguage: LanguageType;
var Languages:string;
begin
Languages:=GetIniStrValue('Languages','Languages');
// Languages:=ReadIniFile('Languages','Languages','Chines');
if Languages ='Chines' then
Result:=Chinese
else
Result:=English;
end;
function TGlobal.GetHostMac(const IPAddress: String): MacAdd;
var
DestIP: Integer;
pMacAddr: puLong;
AddrLen: Longint;
MacAddr: MacAdd ;
p: PByte;
s: String;
i: Integer;
IPStr: String;
begin
IPStr := IPAddress;
DestIP := iNet_Addr(PChar(IPStr));
pMacAddr := puLong(@MacAddr);
AddrLen := SizeOf(MacAddr);
if SendARP(DestIP, 0, pMacAddr, @AddrLen) = 0 then
begin
Result:=MacAddr ;
end;
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.GetLocalHostName
意义: 得到本机机器名
作者: 王彦鹏
日期: 2006-2-6 14:26:56
参数: 无
传出参数:
返回值: string
返回值类型:string (Type)
-------------------------------------------------------------------------------}
function TGlobal.GetLocalHostName: string;
var CompName:array[0..255] of char;
Len:Cardinal;
begin
fillchar(CompName[0],256,0);
GetComputerName(compName,len);
result:=CompName;
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.NewMouseWheel
意义: 鼠标滚动的消息拦截
作者: 王彦鹏
日期: 2006-2-17 13:52:55
参数: var Msg: TMessage
传出参数:
返回值: 无
返回值类型:
-------------------------------------------------------------------------------}
procedure TGlobal.NewMouseWheel(var Msg: TMessage);
var I:integer;
begin
if Msg.Msg = WM_MouseWheel then
begin
if Msg.wParam > 0 then
begin
for i:=0 to ComponentCount -1 do
if (Components Is TDBGrid)and((Components as TDBGrid).Focused ) then
begin
SendMessage(TDBGrid(Components).Handle,WM_VSCROLL,SB_LINEUP,0);
(Components as TDBGrid).Refresh;
end
else
OldMouseWheel[TDBGrid(Components).Tag ](msg);
end
else
begin
for i:=0 to ComponentCount -1 do
if (Components Is TDBGrid)and((Components as TDBGrid).Focused ) then
begin
SendMessage((Components as TDBGrid).Handle,WM_VSCROLL,SB_LINEDOWN,0);
(Components as TDBGrid).Refresh;
end
else
OldMouseWheel[TDBGrid(Components).Tag ](msg);
end;
end
else
begin
for i:=0 to high(OldMouseWheel) do
OldMouseWheel(msg);
end;
end;
procedure TGlobal.DBGridTitleClick(Column: TColumn);
begin
SortQuery(Column);
end;
procedure TGlobal.Dbgrid_DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
inherited;
if TDBGrid(Sender).DataSource.DataSet.RecNo mod 2 =1 then
begin
TDBGrid(Sender).Canvas.Brush.Color := clWindow ;
TDBGrid(Sender).DefaultDrawDataCell(Rect, Column.Field, State);
end
else
begin
TDBGrid(Sender).Canvas.Brush.Color := $00FEFAF5 ;
TDBGrid(Sender).DefaultDrawDataCell(Rect, Column.Field, State);
end;
if (Rect.Top = TStringGrid(TDBGrid(sender)).CellRect(TStringGrid(TDBGrid(sender)).col,
TStringGrid(TDBGrid(sender)).row).top) then
begin
TDBGrid(sender).Canvas.Brush.Color := $00FF8080;
TDBGrid(Sender).Canvas.Font.Color:= clWhite ;
TDBGrid(Sender).Canvas.Font.Style :=[fsBold ];
TDBGrid(sender).DefaultDrawDataCell(Rect, Column.Field, State);
end;
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.ChmHelp
作者: 王彦鹏
日期: 2005-11-20
参数: hwndcaller: Integer; lpHelpFile: string; wCommand: Integer; dwData: string
返回值: HWND
说明: 调用Chm格式的帮助文件。
-------------------------------------------------------------------------------}
function TGlobal.ChmHelp(lpHelpFile: string; wCommand: Integer; dwData: string): HWND;
begin
if not FileExists(lpHelpFile ) then
HintWindow.ShouHintW(self,'未找到帮助文件，请确定安装文件是否完整！',IDI_INFORMATION)
else
HtmlHelpA(Handle,lpHelpFile,wCommand,dwData);
end;
procedure TGlobal.FreeTreeViewData(TreeView: TTreeView);
var i:integer;
begin
for i:=0 to TreeView.Items.Count -1 do
begin
if Assigned(TreeView.Items.Data) then
FreeMem(TreeView.Items.Data);
end;
end;
procedure TGlobal.FreeNodeData(ParentNode: TTreeNode);
var i:integer;
begin
for i:=0 to ParentNode.Count -1 do
begin
if Assigned(ParentNode.Item.Data) then
FreeMem(ParentNode.Item.Data);
end;
FreeMem(ParentNode.Data);
end;
procedure TGlobal.ClearInputInfo;
const
PropertyNames: array[0..0] of PChar = ('Text');
var
Comp: TComponent;
CompIndex, PropIndex: Integer;
PropInfoPtr: PPropInfo;
PropNewValue: pchar;
begin
PropNewValue := AllocMem(1024);
with Self do
for CompIndex := 0 to ComponentCount - 1 do
begin
Comp := Components[CompIndex];
for PropIndex := Low(PropertyNames) to High(PropertyNames) do
begin
PropInfoPtr := GetPropInfo(Comp, PropertyNames[PropIndex]);
if PropInfoPtr = nil then continue;
if PropInfoPtr^.PropType^.Kind = tklString then
begin
fillchar(PropNewValue[0], 1024, 0);
SetStrProp(Comp, PropertyNames[PropIndex], '');
end;
end;
end;
end;
end.
我现在写程序都是这样写：
我写一个一类：TGlobal，这个类继承自Tform ，然后程序所有的类都继承于这个类。在这个类中写一个段代码。可以为每一个Dbgrid添加上鼠标滚动事件，
var
OldMouseWheel:array of TWndMethod;
procedure
Procedure NewMouseWheel(Var Msg :TMessage); virtual; //鼠标滚动
实现是这样的：在TGlobal的Create时为每一个Dbgrid重新赋值
for i:=0 to ComponentCount -1 do
begin
if Components Is TDBGrid then
begin
Setlength(OldMouseWheel,high(OldMouseWheel)+1+1);
OldMouseWheel[high(OldMouseWheel)]:=TDBGrid(Components).WindowProc;
TDBGrid(Components).Tag:=high(OldMouseWheel);
TDBGrid(Components).WindowProc:= NewMouseWheel;
if Not Assigned(TDBGrid(Components).OnTitleClick) then
TDBGrid(Components).OnTitleClick:=DBGridTitleClick;
if Not Assigned(TDBGrid(Components).OnDrawColumnCell) then
TDBGrid(Components).OnDrawColumnCell :=Dbgrid_DrawColumnCell;
end;
end;
每一个Dbgrid的消息实现是：
procedure TGlobal.NewMouseWheel(var Msg: TMessage);
var I:integer;
begin
if Msg.Msg = WM_MouseWheel then
begin
if Msg.wParam > 0 then
begin
for i:=0 to ComponentCount -1 do
if (Components Is TDBGrid)and((Components as TDBGrid).Focused ) then
begin
SendMessage(TDBGrid(Components).Handle,WM_VSCROLL,SB_LINEUP,0);
(Components as TDBGrid).Refresh;
end
else
OldMouseWheel[TDBGrid(Components).Tag ](msg);
end
else
begin
for i:=0 to ComponentCount -1 do
if (Components Is TDBGrid)and((Components as TDBGrid).Focused ) then
begin
SendMessage((Components as TDBGrid).Handle,WM_VSCROLL,SB_LINEDOWN,0);
(Components as TDBGrid).Refresh;
end
else
OldMouseWheel[TDBGrid(Components).Tag ](msg);
end;
end
else
begin
for i:=0 to high(OldMouseWheel) do //问题所在
OldMouseWheel(msg); //问题所在
end;
end;
在消息重发的时候，不知道向哪一个Dbgrid发。这样就导致Form只能支持一个Dbgrid，而不能支持多个Dbgrid，请问高后，如何实现能支持多个DBgrid？
付源码：
{*******************************************************}
{ }
{ 一个函数单元 }
{ }
{ 版权所有 (C) 2005 石家庄华园电脑科技有限公司 }
{ }
{ 创建者：王彦鹏 }
{ }
{ 创建日期:2005-8-29 }
{ 版本：1.00 }
{*******************************************************}
unit Global_Class;
interface
uses Windows, Classes, Forms, ExtCtrls, Graphics, StdCtrls,
Messages, Controls, DBGrids, DB, ADODB, registry, SysUtils, typinfo,
WinSock,nb30,shellapi,WHintWindow ,ComCtrls,Grids;
const
ConfigFile='language.ini';
type
PASTAT = ^TASTAT;
TASTAT = record
adapter : TAdapterStatus;
name_buf : TNameBuffer;
end;
type
LanguageType = (Chinese, English); ///语言
TCPUID = array[0..3] of Longint; //CPUID
TVendor = array [0..11] of char; //CPU版本
MacAdd = array [0..5] of byte; //网卡MAC地址
HardIDENTITY=array[0..23] of byte; //硬件标识,网卡和CpuID的合成。
type
TMouseEnter_Event = procedure(Sender: TObject) of object;
TMouseLeave_Event = procedure(Sender: TObject) of object;
DbgridWheel_Event= Procedure (Var Msg :TMessage) of object;
TGlobal=class(TForm )
private
//DefaultLanguage:LanguageType;
FMouseEnter:TMouseEnter_Event;
FMouseLeave:TMouseLeave_Event;
OldMouseWheel:array of TWndMethod;
procedure SetLanguage(Value:LanguageType);
function DefaultLanguage: LanguageType; //当前默认语言.
Procedure NewMouseWheel(Var Msg :TMessage); virtual; //鼠标滚动
function GetPYIndexChar(hzchar: string): Char; //返回一个字符（汉字）的第一个拼音。
protected
HintWindow:TxyHintWindow;
function ImgToBmp(Img: TImage): TBitmap; //把Image中的图像转换为Bmp.
procedure ObjectMouseDown(Sender: TWinControl; Button: TMouseButton;
Shift: TShiftState; X, Y: integer); //使一个控件可拖动。
function Pyin(str: string): string; //返回一个字符串的第一个拼音字符串。
procedure PaintBorder(Sender: TForm; col: TColor); //画边框。
procedure FormSlectNexe(Sender: TObject; var Key: Char); //回车选择下一控件
function Isnull(Sender: TComponent; HintInfo: string; CheckValue: byte =
0;Icon
char=IDI_INFORMATION): boolean; //检查一个输入控件的值是否为空。procedure SortQuery(Column: TColumn); //DBGrid排序.
procedure BrushBmp(Sender: TWinControl; BrushImg: TImage); //在指定的控件上画图。
function GetRegValue(RootKey:HKEY;Key, SubKey: string): Variant; //读注册指定的键值。
procedure SetRegValue(RootKey:HKEY;Key, SubKey, Value: string); //设置注册表指定的键为指定的值。
function GetCObjectS(Cbx: TComboBox): string;
function GetFileVerSion(FileName: string): string;
Function Version:string;
function WriteErrLog(LogText: string;FileName:string='Log.Txt'): integer;
procedure WriteDefaultLanguage(MainComp: TComponent; PartName: string);
procedure ReadDefaultLanguage(mainComp: TComponent; PartName: string;
Language: LanguageType);
function GetLocalIP(HostName:string='LocalHost'):string; //得到本机IP地址。
function GetLocalHostName:string; //得到本机机器名
procedure GetCPUVendor(var CpuVerd : TVendor); //得到CPU的厂商信息
procedure GetCPUID(Var CPUID:TCPUID); //得到CPU的序列号。
function Getmac:MacAdd ; //得到Mac地址。
Function GetHostMac(const IPAddress: String):MacAdd; //得到局域网上的主机MAC地址
function SumAdd(Buff
char):Word; //计算累加和，双字节累加和。Function GetHardIDENTITY(HardInfo:HardIDENTITY):integer;
Function AppName:string; // 当前程序名称
Function AppPath:string; //当前路径
property Language:LanguageType read DefaultLanguage write SetLanguage;
function GetIniStrValue(MainKey, Key: PChar): string;
procedure OpenUrl(const Url: string);
procedure RunFile(const FName: string; Handle: THandle=0;
const Param: string='');
procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER; //鼠标移入的消息
procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE; //鼠标移出的消息
function ReadIniConfig(const Ident:string; Default: string=''): string;virtual ;abstract;
function ReadIniFile(const Section,Ident:string;
Default:string=''):string;virtual;abstract; //读Ini文件
function WriteIniFile(const Section,Ident,Value:string):boolean;virtual;abstract; //写字符串到INI文件。
Function MsgBox(const Ident, Txt,Caption:string;Buton:Integer):integer;overload;virtual;abstract; //一个Messagebox的封装
Function MsgBox(const Txt,Caption:string;Buton:Integer):integer;overload; virtual;abstract; //一个Messagebox的封装
procedure DBGridTitleClick(Column: TColumn);virtual; //Dbgrid 的点击Title默认处理
procedure Dbgrid_DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState); virtual; //Dbgrid 的重画默认处理;
Function ChmHelp(lpHelpFile:string;wCommand:Longint; dwData:string):HWND;
procedure FreeTreeViewData(TreeView:TTreeView ); //释放TreeView的节点信息。
Procedure FreeNodeData(ParentNode:TTreeNode); //释放ParentNode下的节点信息
procedure ClearInputInfo; //清空本窗体所有的输入的框内容
public
constructor create(AOwnet:TComponent) ;
destructor Destroy;virtual ;
function GetLastErrStr(LastErrID: Integer; var ErrStr: PChar): Integer;overload; //返回最后一个错误原因
function GetLastErrStr(LastErrID: Integer): string;overload; //返回最后一个错误原因
Function FormatSqlValue(const Value:string):string; //格式化一个Sql语句
published
property OnMouseEnter:TMouseEnter_Event read FMouseEnter write FMouseEnter ;
property OnMouseLeave:TMouseLeave_Event read FMouseLeave write FMouseLeave;
end;
function SendARP(DestIP,SrcIP: DWORD; pMacAddr: puLong;
PhyAddrLen: puLong): DWORD; stdCall; external 'IPHLPAPI.DLL'
function HtmlHelpA (hwndcaller:Longint;lpHelpFile:string;wCommand:Longint;
dwData:string):HWND;STDCALL;EXTERNAL 'hhctrl.ocx' //调用Chm格式的帮助文件。
implementation
{-------------------------------------------------------------------------------
过程名: 把Image的图像转换为Bmp
功能：
作者: 王彦鹏
日期: 2005.08.29
参数: Img: TImage
传入参数：
传出参数：
返回值: TBitmap
-------------------------------------------------------------------------------}
Function TGlobal.ImgToBmp(Img: TImage): TBitmap;
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
if Img.Picture.Graphic = nil then
begin
Result := Bmp;
exit;
end;
Bmp.Width := Img.Picture.Graphic.Width;
Bmp.Height := Img.Picture.Graphic.Height;
Bmp.Canvas.Draw(0, 0, Img.Picture.Graphic);
Result := Bmp;
end;
{-------------------------------------------------------------------------------
过程名: GetPYIndexChar
功能： 返回一个字符（汉字）的第一个拼音。
作者: 王彦鹏
日期: 2005.08.29
参数: hzchar: string
传入参数：
传出参数：
返回值: Char
-------------------------------------------------------------------------------}
Function TGlobal.GetPYIndexChar(hzchar: string): Char;
begin
if hzchar = '' then
begin
Result := Char(32);
exit;
end;
case Word(hzchar[1]) shl 8 + Word(hzchar[2]) 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 := Char(32);
end;
end;
{-------------------------------------------------------------------------------
过程名: Pyin
功能： 返回一个字符串的第一个拼音字符串。
作者: 王彦鹏
日期: 2005.08.29
参数: str: string
传入参数：
传出参数：
返回值: string
-------------------------------------------------------------------------------}
Function TGlobal.Pyin(str: string): string;
var
i: integer;
PY: string;
s: string;
begin
s := '';
i := 1;
while i <= Length(str) do
begin
PY := Copy(str, i, 1);
if PY >= Chr(128) then
begin
Inc(i);
PY := PY + Copy(str, i, 1);
s := s + GetPYIndexChar(PY);
end
else
s := s + PY;
Inc(i);
end;
Result := s;
end;
{-------------------------------------------------------------------------------
过程名: PaintBorder
功能： 为一个可视的窗体画一个边框。
作者: 王彦鹏
日期: 2005.08.29
参数: Sender: TForm; col: TColor
传入参数：
传出参数：
返回值: 无
-------------------------------------------------------------------------------}
Procedure TGlobal.PaintBorder(Sender: TForm; col: TColor);
var
Dc: Hdc;
Pen: Hpen;
Oldpen: Hpen;
OldBrush: HBRUSH;
begin
Dc := GetWindowDC(Sender.Handle);
Pen := CreatePen(PS_SOLID, 2, col);
Oldpen := SelectObject(Dc, Pen);
OldBrush := SelectObject(Dc, GetStockObject(NULL_BRUSH));
Rectangle(Dc, 0, 0, Sender.Width, (Sender).Height);
SelectObject(Dc, OldBrush);
SelectObject(Dc, Oldpen);
DeleteObject(Pen);
ReleaseDC((Sender).Handle, Sender.Canvas.Handle);
Sender.Update;
end;
{-------------------------------------------------------------------------------
过程名: FormSlectNexe
功能： 回车选择下一个控件
作者: 王彦鹏
日期: 2005.08.29
参数: Sender: TWinControl; HintInfo: string; CheckValue: byte = 0
传入参数：
传出参数：
返回值: boolean
-------------------------------------------------------------------------------}
Procedure TGlobal.FormSlectNexe(Sender: TObject ; var Key: Char);
begin
if Key = #13 then
begin
Postmessage(TWinControl(Sender).Handle, WM_KEYDOWN, VK_TAB, 0);
Key := #0;
end;
end;
{-------------------------------------------------------------------------------
过程名: Isnull
功能： 检查一个可输入框是否为空
作者: 王彦鹏
日期: 2005.08.29
参数: Sender: TWinControl; HintInfo: string; CheckValue: byte = 0
传入参数： 如果CheckValue<>0 时检查是不是 0 ，如果输入框值为 0 也视为空。
传出参数：
返回值: boolean
-------------------------------------------------------------------------------}
Function TGlobal.Isnull(Sender: TComponent ; HintInfo: string; CheckValue: byte =
0;Icon
char=IDI_INFORMATION): boolean;const
PropertyNames: array[0..0] of PChar = ('Text');
var
PropIndex: Integer;
PropInfoPtr: PPropInfo;
PropOldValue: string;
begin
for PropIndex := Low(PropertyNames) to High(PropertyNames) do
begin
PropInfoPtr := GetPropInfo(Sender, PropertyNames[PropIndex]);
if PropInfoPtr = nil then continue;
if PropInfoPtr^.PropType^.Kind = tklString then
begin
PropOldValue := GetStrProp(Sender, PropInfoPtr);
if CheckValue =0 then
begin
if (PropOldValue ='') then
begin
//Application.MessageBox(pchar(HintInfo), '提示', 64);
if Not Assigned(HintWindow ) then
HintWindow:=TxyHintWindow.Create(self);
HintWindow.ShouHintW(TWinControl(Sender),HintInfo,Icon);
if Sender is TWinControl then
begin
if TWinControl(sender).CanFocus then
begin
TWinControl(sender).SetFocus;
Abort;
end
else
Abort;
end;
end;
end
else
if (PropOldValue ='') or (StrToInt(PropOldValue) =0) then
begin
Application.MessageBox(pchar(HintInfo), '提示', 64);
if Sender is TWinControl then
begin
if TWinControl(sender).CanFocus then
begin
TWinControl(sender).SetFocus;
Abort;
end
else
Abort;
end;
end;
end;
end;
result:=true;
end;
{-------------------------------------------------------------------------------
过程名: SortQuery
功能： 使一个控件可拖动。
作者: 王彦鹏
日期: 2005.08.29
参数: Column: TColumn
传入参数：
传出参数：
返回值: 无
-------------------------------------------------------------------------------}
Procedure TGlobal.ObjectMouseDown(Sender: TWinControl; Button: TMouseButton;
Shift: TShiftState; X, Y: integer);
begin
ReleaseCapture;
SendMessage(Sender.Handle, WM_SYSCOMMAND, $F012, 0);
end;
{-------------------------------------------------------------------------------
过程名: SortQuery
意义: 一个让DBGrid点击Title可以正反排序的过程。
作者: 王彦鹏
日期: 2005-11-1 15:34:28
参数: Column: TColumn
传出参数:
返回值: 无
返回值类型:
-------------------------------------------------------------------------------}
Procedure TGlobal.SortQuery(Column: TColumn);
var
SqlStr, myFieldName, TempStr: string;
OrderPos: integer;
SavedParams: TParameters;
const
//▽△
Descchar='▽';
AscChar='△';
procedure RestoryColunmCaption;
var i:integer;
S:string;
begin
for i:=0 to TDBGrid(Column.Grid).Columns.Count -1 do
begin
s:=TDBGrid(Column.Grid).Columns.Title.Caption;
delete(s,pos(Descchar,TDBGrid(Column.Grid).Columns.Title.Caption),length(Descchar));
TDBGrid(Column.Grid).Columns.Title.Caption:=s;
s:=TDBGrid(Column.Grid).Columns.Title.Caption;
delete(s,pos(AscChar,TDBGrid(Column.Grid).Columns.Title.Caption),length(AscChar));
TDBGrid(Column.Grid).Columns.Title.Caption:=s;
end;
end;
begin
RestoryColunmCaption;
if not(Assigned(Column.field)) then
exit;
if not (Column.Field.FieldKind in [fkData, fkLookup]) then
exit;
if Column.Field.FieldKind = fkData then
myFieldName := UpperCase(Column.Field.FieldName)
else
myFieldName := UpperCase(Column.Field.KeyFields);
while Pos(myFieldName, ';') <> 0 do
myFieldName := Copy(myFieldName, 1, Pos(myFieldName, ';') - 1)
+ ',' + Copy(myFieldName, Pos(myFieldName, ';') + 1, 100);
with TADOQuery(TDBGrid(Column.Grid).DataSource.DataSet) do
begin
SqlStr := UpperCase(sql.Text);
if ParamCount > 0 then
begin
SavedParams := TParameters.Create(nil, nil);
SavedParams.Assign(Parameters);
end;
OrderPos := Pos('ORDER', SqlStr);
if (OrderPos = 0) or
(Pos(myFieldName, Copy(SqlStr, OrderPos, 100)) = 0) then
begin
TempStr := ' Order By ' + myFieldName + ' Asc';
Column.Title.Caption:=Column.Title.Caption +ascchar;
end
else
if Pos('ASC', SqlStr) = 0 then
begin
TempStr := ' Order By ' + myFieldName + ' Asc';
Column.Title.Caption:=Column.Title.Caption +ascchar;
end
else
begin
TempStr := ' Order By ' + myFieldName + ' Desc';
Column.Title.Caption:=Column.Title.Caption +Descchar ;
end;
if OrderPos <> 0 then
SqlStr := Copy(SqlStr, 1, OrderPos - 1);
SqlStr := SqlStr + TempStr;
Active := false;
sql.Clear;
sql.Text := SqlStr;
if ParamCount > 0 then
begin
if SavedParams <> nil then
begin
Parameters.AssignValues(SavedParams);
SavedParams.Free;
end;
end;
open;
end;
end;
{-------------------------------------------------------------------------------
过程名: BrushBmp
意义: 在指定的控件上画图
作者: 王彦鹏
日期: 2005-11-1 15:35:47
参数: Sender: TWinControl; BrushImg: TImage
传出参数:
返回值: 无
返回值类型:
-------------------------------------------------------------------------------}
Procedure TGlobal.BrushBmp(Sender: TWinControl; BrushImg: TImage);
begin
if BrushImg <> nil then
Sender.Brush.bitmap := BrushImg.Picture.bitmap;
end;
{-------------------------------------------------------------------------------
过程名: GetRegValue
意义:
作者: 王彦鹏
日期: 2005-11-1 15:36:28
参数: Key, SubKey: string
传出参数:
返回值: Variant
返回值类型:Variant (Type)
-------------------------------------------------------------------------------}
Function TGlobal.GetRegValue(RootKey:HKEY;Key, SubKey: string): Variant;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
Reg.RootKey:=RootKey;
if Reg.OpenKey(Key, true) then
begin
Result := Reg.ReadString(SubKey);
end;
Reg.Free;
end;
{-------------------------------------------------------------------------------
过程名: GetCObjectS
意义:
作者: 王彦鹏
日期: 2005-11-1 15:36:42
参数: Cbx: TComboBox
传出参数:
返回值: string
返回值类型:string (Type)
-------------------------------------------------------------------------------}
Procedure TGlobal.SetRegValue(RootKey:HKEY;Key, SubKey, Value: string);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
Reg.RootKey:=RootKey;
if Reg.OpenKey(Key, true) then
begin
Reg.WriteString(SubKey, Value);
end;
Reg.Free;
end;
{-------------------------------------------------------------------------------
过程名: GetFileVerSion
意义:
作者: 王彦鹏
日期: 2005-11-1 15:37:02
参数: var V1, V2, V3, V4: dword; FileName: string
传出参数:
返回值: boolean
返回值类型:boolean (Type)
-------------------------------------------------------------------------------}
Function TGlobal.GetCObjectS(Cbx: TComboBox): string;
begin
case Cbx.ItemIndex of
-1: Result := '';
else
begin
if Cbx.Items.Objects[Cbx.ItemIndex] <> nil then
Result := inttostr(integer(Cbx.Items.Objects[Cbx.ItemIndex]))
else
Result := '0';
end;
end;
end;
{-------------------------------------------------------------------------------
过程名: GetFileVerSion
意义: 返回文件的版本号。
作者: 王彦鹏
日期: 2005-11-1 15:40:23
参数: FileName: string
传出参数:
返回值: string
返回值类型:string (Type)
-------------------------------------------------------------------------------}
Function TGlobal.GetFileVerSion(FileName: string): string;
var
VerInfoSize: dword;
VerInfo: Pointer;
VerValueSize: dword;
VerValue: PVSFixedFileInfo;
Dummy: dword;
V1, V2, V3, V4: dword;
begin
VerInfoSize := GetFileVersionInfoSize(pchar(FileName), Dummy);
GetMem(VerInfo, VerInfoSize);
GetFileVersionInfo(pchar(FileName), 0, VerInfoSize, VerInfo);
if VerInfo = nil then
begin
result:='1.0.0.0';
exit;
end;
VerQueryValue(VerInfo, '/', Pointer(VerValue), VerValueSize);
with VerValue^ do
begin
V1 := dwFileVersionMS shr 16;
V2 := dwFileVersionMS and $FFFF;
V3 := dwFileVersionLS shr 16;
V4 := dwFileVersionLS and $FFFF;
end;
FreeMem(VerInfo, VerInfoSize);
result := format('%d.%d.%d.%d', [v1,v2,v3, v4]);
end;
Function GetModuleName(Module: HMODULE): string;
var
ModName: array[0..MAX_PATH] of Char;
begin
SetString(Result, ModName, GetModuleFileName(Module, ModName, SizeOf(ModName)));
end;
{-------------------------------------------------------------------------------
过程名: WriteErrLog
意义: 写日志。文件名为Log.Txt
作者: 王彦鹏
日期: 2005-11-1 15:40:49
参数: LogText: string
传出参数:
返回值: integer
返回值类型:integer (Type)
-------------------------------------------------------------------------------}
Function TGlobal.WriteErrLog(LogText: string;FileName:string='Log.Txt'): integer;
var FileHandle: thandle;
FileSize: integer;
FileB: pchar;
begin
try
FileName := 'Log.Txt';
if ExtractFilePath(FileName) = '' then
begin
CreateDir(ExtractFilePath(GetModuleName(0)) + 'Log');
FileName := ExtractFilePath(GetModuleName(0)) + 'Log/' + FileName;
end;
if not FileExists(filename) then
begin
FileHandle := FileCreate(FileName);
CloseHandle(FileHandle);
end;
LogText := LogText + ' 时间：' + formatdatetime('yyyy-MM-dd hh:mm:ss', now);
LogText := LogText + #13 + #10;
GetMem(Fileb, 1024);
fillchar(Fileb[0], 1024, #0);
move(LogText[1], fileb[0], length(LogText));
FileHandle := FileOpen(filename, fmOpenWrite);
FileSize := FileSeek(FileHandle, 0, 2);
if FileSize > 2048 * 1000 then
begin
FileClose(FileHandle);
DeleteFile(FileName);
FileHandle := FileCreate(FileName);
end;
FileWrite(filehandle, fileb[0], length(LogText));
FileClose(FileHandle);
result := 0;
except
result := 1;
end;
end;
{-------------------------------------------------------------------------------
过程名: WriteResource
意义: 一个把本窗体上的所有控件的标题写入一个文件。
作者: 王彦鹏
日期: 2005-11-1 15:43:30
参数: 无
传出参数:
返回值: integer
返回值类型:integer (Type)
-------------------------------------------------------------------------------}
Procedure TGlobal.WriteDefaultLanguage(MainComp: TComponent; PartName: string);
const
PropertyNames: array[0..4] of PChar = ('Caption', 'Text', 'Hint', 'Title','Lines');
var
Comp: TComponent;
CompIndex, PropIndex: Integer;
PropInfoPtr: PPropInfo;
PropOldValue: string;
begin
with MainComp do
begin
for CompIndex := 0 to ComponentCount - 1 do
begin
Comp := Components[CompIndex];
for PropIndex := Low(PropertyNames) to High(PropertyNames) do
begin
PropInfoPtr := GetPropInfo(Comp, PropertyNames[PropIndex]);
if PropInfoPtr = nil then continue;
case PropInfoPtr^.PropType^.Kind of
tkLString :
begin
PropOldValue := GetStrProp(Comp, PropInfoPtr);
if (PropOldValue <> '') then
begin
//PropNewValue := 'test';
WritePrivateProfileString(pchar(PartName), pchar(Comp.Name+'.'+PropertyNames[PropIndex ] + '_CHS'), pchar(PropOldValue), pchar(AppPath +ConfigFile));
WritePrivateProfileString(pchar(PartName), pchar(Comp.Name+'.'+PropertyNames[PropIndex ] + '_EnS'), '', pchar(AppPath +ConfigFile));
//SetStrProp(Comp, PropertyNames[PropIndex], PropNewValue);
end;
end;
tkClass:
begin
end;
end;
WriteDefaultLanguage(comp, PartName + '.' + Comp.Name);
end;
end;
WritePrivateProfileString('Languages','Languages','Chines', pchar(AppPath +ConfigFile))
end;
end;
Procedure TGlobal.ReadDefaultLanguage(mainComp: TComponent; PartName: string; Language: LanguageType);
const
PropertyNames: array[0..3] of PChar = ('Caption', 'Text', 'Hint', 'Title');
var
Comp: TComponent;
CompIndex, PropIndex: Integer;
PropInfoPtr: PPropInfo;
PropNewValue: pchar;
begin
PropNewValue := AllocMem(1024);
with MainComp do
begin
for CompIndex := 0 to ComponentCount - 1 do
begin
Comp := Components[CompIndex];
for PropIndex := Low(PropertyNames) to High(PropertyNames) do
begin
PropInfoPtr := GetPropInfo(Comp, PropertyNames[PropIndex]);
if PropInfoPtr = nil then continue;
if PropInfoPtr^.PropType^.Kind = tklString then
begin
fillchar(PropNewValue[0], 1024, 0);
if Language = Chinese then
GetPrivateProfileString(
pchar(PartName), // []中标题的名字
pchar(Comp.Name+'.'+PropertyNames[PropIndex ] + '_CHS'), // =号前的名字
'', // 如果没有找到字符串时，返回的默认值
PropNewValue, //存放取得字符
255, //取得字符的允许最大长度
pchar(AppPath +ConfigFile) // 调用的文件名
)
else
GetPrivateProfileString(
pchar(PartName), // []中标题的名字
pchar(Comp.Name+'.'+PropertyNames[PropIndex ] + '_EnS'), // =号前的名字
'', // 如果没有找到字符串时，返回的默认值
PropNewValue, //存放取得字符
255, //取得字符的允许最大长度
pchar(AppPath +ConfigFile) // 调用的文件名
);
if length(PropNewValue) <>0 then
SetStrProp(Comp, PropertyNames[PropIndex], PropNewValue);
end;
ReadDefaultLanguage(comp, PartName + '.' + Comp.Name, Language);
end;
end;
end;
if Language =Chinese then
WritePrivateProfileString('Languages','Languages','Chines', pchar(AppPath +ConfigFile))
else
WritePrivateProfileString('Languages','Languages','English', pchar(AppPath +ConfigFile));
freemem(PropNewValue);
end;
Function TGlobal.GetLocalIP(HostName:string='LocalHost'):string;
var
HostEnt: PHostEnt;
addr: pchar;
Buffer: array [0..63] of char;
GInitData: TWSADATA;
begin
try
WSAStartup(2, GInitData);
if HostName ='LocalHost' then
GetHostName(Buffer, SizeOf(Buffer))
else
Move(HostName[1],Buffer[0],length(hostname));
HostEnt := GetHostByName(buffer);
if HostEnt = nil then Exit;
addr := HostEnt^.h_addr_list^;
result := Format('%d.%d.%d.%d', [byte(addr [0]),
byte (addr [1]), byte (addr [2]), byte (addr [3])]);
finally
WSACleanup;
end;
end;
Function GetCPUIDX : TCPUID; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Resukt}
MOV EAX,1
DW $A20F {CPUID Command}
STOSD {CPUID[1]}
MOV EAX,EBX
STOSD {CPUID[2]}
MOV EAX,ECX
STOSD {CPUID[3]}
MOV EAX,EDX
STOSD {CPUID[4]}
POP EDI {Restore registers}
POP EBX
end;
Function GetCPUVendorX : TVendor; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Result (TVendor)}
MOV EAX,0
DW $A20F {CPUID Command}
MOV EAX,EBX
XCHG EBX,ECX {save ECX result}
MOV ECX,4
@1:
STOSB
SHR EAX,8
LOOP @1
MOV EAX,EDX
MOV ECX,4
@2:
STOSB
SHR EAX,8
LOOP @2
MOV EAX,EBX
MOV ECX,4
@3:
STOSB
SHR EAX,8
LOOP @3
POP EDI {Restore registers}
POP EBX
end;
Procedure TGlobal.GetCPUVendor(var CpuVerd : TVendor);//得到CPU的厂商信息
begin
CpuVerd:=GetCPUVendorX;
end;
Procedure TGlobal.GetCPUID(Var CPUID:TCPUID);//得到CPU的序列号。
begin
CPUID:=GetCPUIDX ;
end;
Function TGlobal.Getmac:MacAdd ;
var
ncb : TNCB;
s:string;
adapt : TASTAT;
lanaEnum : TLanaEnum;
i, m : integer;
begin
FillChar(ncb, SizeOf(TNCB), 0);
ncb.ncb_command := Char(NCBEnum);
ncb.ncb_buffer := PChar(@lanaEnum);
ncb.ncb_length := SizeOf(TLanaEnum);
s:=Netbios(@ncb);
for i := 0 to integer(lanaEnum.length)-1 do
begin
FillChar(ncb, SizeOf(TNCB), 0);
ncb.ncb_command := Char(NCBReset);
ncb.ncb_lana_num := lanaEnum.lana;
Netbios(@ncb);
Netbios(@ncb);
FillChar(ncb, SizeOf(TNCB), 0);
ncb.ncb_command := Chr(NCBAstat);
ncb.ncb_lana_num := lanaEnum.lana;
ncb.ncb_callname := '* ';
ncb.ncb_buffer := PChar(@adapt);
ncb.ncb_length := SizeOf(TASTAT);
m:=0;
if (Win32Platform = VER_PLATFORM_WIN32_NT) then
m:=1;
if m=1 then
begin
if Netbios(@ncb) = Chr(0) then
move(adapt.adapter.adapter_address[0],result[0],6);
end;
if m=0 then
if Netbios(@ncb) <> Chr(0) then
begin
fillchar(result[0],6,0);
move(adapt.adapter.adapter_address[0],result[0],6);
end;
end;
end;
Function TGlobal.SumAdd(Buff
char):Word; //计算累加和。var I:integer;
begin
for i:=0 to length(buff)-1 do
Result:=Result+ord(buff[0]);
end;
constructor TGlobal.create(AOwnet:TComponent) ;
var i:integer;
begin
inherited ;
for i:=0 to ComponentCount -1 do
begin
if Components Is TDBGrid then
begin
Setlength(OldMouseWheel,high(OldMouseWheel)+1+1);
OldMouseWheel[high(OldMouseWheel)]:=TDBGrid(Components).WindowProc;
TDBGrid(Components).Tag:=high(OldMouseWheel);
TDBGrid(Components).WindowProc:= NewMouseWheel;
if Not Assigned(TDBGrid(Components).OnTitleClick) then
TDBGrid(Components).OnTitleClick:=DBGridTitleClick;
if Not Assigned(TDBGrid(Components).OnDrawColumnCell) then
TDBGrid(Components).OnDrawColumnCell :=Dbgrid_DrawColumnCell;
end;
end;
HintWindow:=TxyHintWindow.Create(self);
KeyPreview:=true;
OnKeyPress:=FormSlectNexe;
end;
destructor TGlobal.Destroy;
begin
inherited;
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.GetHardIDENTITY
作者: 王彦鹏
日期: 2005-11-19
参数: HardInfo: HardIDENTITY
返回值: integer
说明: 返回硬件标识
-------------------------------------------------------------------------------}
function TGlobal.GetHardIDENTITY(HardInfo: HardIDENTITY): integer;
var CpuID:tcpuid;
Mac:MacAdd;
begin
FillChar(HardInfo[0],24,0);
if sizeof(HardInfo)<>24 then
result:=-1
else
begin
GetCPUID(CpuID );
Mac:=Getmac;
move(cpuid[0],HardInfo[0],16);
move(mac[0],HardInfo[16],7);
result:=0;
end;
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.AppName
作者: 王彦鹏
日期: 2005-11-22
参数: 无
返回值: string
说明: 返回当前执行程序的文件名
-------------------------------------------------------------------------------}
function TGlobal.AppName: string;
begin
Result:=ExtractFileName(Application.ExeName);
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.AppPath
作者: 王彦鹏
日期: 2005-11-22
参数: 无
返回值: string
说明: 返回 当前的可执行文件的路径。带'/'。
-------------------------------------------------------------------------------}
function TGlobal.AppPath: string;
begin
Result:=ExtractFilePath(Application.ExeName );
if Copy(Result,length(Result),1)<>'/' then
Result:=Result+'/';
end;
procedure TGlobal.SetLanguage(Value: LanguageType);
begin
ReadDefaultLanguage(self,self.Name,Value );
case value of
Chinese:WriteIniFile('Languages','Languages','Chines');
English:WriteIniFile('Languages','Languages','English');
end;
// DefaultLanguage:=Value;
end;
function TGlobal.Version: string;
begin
result:=GetFileVerSion(GetModuleName(0));
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.GetIniStrValue
作者: 王彦鹏
日期: 2005-12-15
参数: MainKey, Key: PChar
返回值: string
说明: 返回Ini的键值。
-------------------------------------------------------------------------------}
function TGlobal.GetIniStrValue(MainKey, Key: PChar): string;
var Svalue
Char;begin
Svalue:=AllocMem(1024);
GetPrivateProfileString(
MainKey, // []中标题的名字
key, // =号前的名字
'', // 如果没有找到字符串时，返回的默认值
svalue, //存放取得字符
255, //取得字符的允许最大长度
pchar(AppPath +ConfigFile) // 调用的文件名
);
Result :=Svalue;
FreeMem(Svalue);
end;
procedure TGlobal.RunFile(const FName: string; Handle: THandle;
const Param: string);
begin
ShellExecute(Handle, nil, PChar(FName), PChar(Param), nil, SW_SHOWNORMAL);
end;
// 打开一个链接
procedure TGlobal.OpenUrl(const Url: string);
const
csPrefix = 'http://';
var
AUrl: string;
begin
if Pos(csPrefix, Url) < 0 then
AUrl := csPrefix + Url
else
AUrl := Url;
RunFile(AUrl);
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.GetLastErrStr
意义: 返回GetLastError的错误原因。
作者: 王彦鹏
日期: 2005-12-16 15:36:37
参数: LastErrID: Integer; var ErrStr: PChar
传出参数:
返回值: Integer
返回值类型:Integer (Type)
-------------------------------------------------------------------------------}
function TGlobal.GetLastErrStr(LastErrID: Integer;
var ErrStr: PChar): Integer;
begin
if ErrStr = nil then
result := -1
else
result := FormatMessage(
FORMAT_MESSAGE_ALLOCATE_BUFFER or
FORMAT_MESSAGE_FROM_SYSTEM or
FORMAT_MESSAGE_IGNORE_INSERTS,
nil, LastErrID, 0,@ErrStr , 0, nil);
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.GetLastErrStr
意义: 重载
作者: 王彦鹏
日期: 2005-12-16 15:44:22
参数: LastErrID: Integer
传出参数:
返回值: string
返回值类型:string (Type)
-------------------------------------------------------------------------------}
function TGlobal.GetLastErrStr(LastErrID: Integer): string;
var ErrCode
char;begin
if GetLastErrStr(LastErrID,ErrCode )>0 then
result:=ErrCode
else
begin
if GetLastErrStr(GetLastError,ErrCode )>0 then
result:=ErrCode
else
result:='未指定的错误！';
end;
end;
procedure TGlobal.CMMouseEnter(var Msg: TMessage);
begin
if Assigned(FMouseEnter) and (TObject(Msg.lParam) <>nil) then
FMouseEnter(TObject(Msg.lParam));
end;
procedure TGlobal.CMMouseLeave(var Msg: TMessage);
var
AnObject : TObject;
begin
if Assigned(FMouseLeave) and (TObject(Msg.lParam) <>nil)then
FMouseLeave(TObject(Msg.lParam));
end;
{-------------------------------------------------------------------------------
过程名: FormatSqlValue
意义:
作者: 王彦鹏
日期: 2006-1-5 12:05:52
参数: const Value:string
传出参数:
返回值: string
返回值类型:string (Type)
-------------------------------------------------------------------------------}
function TGlobal.FormatSqlValue(const Value: string): string;
var i:integer;
Vs:string;
begin
vs:='';
for i:=1 to length(value) do
begin
vs:=vs+value;
if value='''' then
vs:=vs+'''';
end;
result:=vs;
end;
function TGlobal.DefaultLanguage: LanguageType;
var Languages:string;
begin
Languages:=GetIniStrValue('Languages','Languages');
// Languages:=ReadIniFile('Languages','Languages','Chines');
if Languages ='Chines' then
Result:=Chinese
else
Result:=English;
end;
function TGlobal.GetHostMac(const IPAddress: String): MacAdd;
var
DestIP: Integer;
pMacAddr: puLong;
AddrLen: Longint;
MacAddr: MacAdd ;
p: PByte;
s: String;
i: Integer;
IPStr: String;
begin
IPStr := IPAddress;
DestIP := iNet_Addr(PChar(IPStr));
pMacAddr := puLong(@MacAddr);
AddrLen := SizeOf(MacAddr);
if SendARP(DestIP, 0, pMacAddr, @AddrLen) = 0 then
begin
Result:=MacAddr ;
end;
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.GetLocalHostName
意义: 得到本机机器名
作者: 王彦鹏
日期: 2006-2-6 14:26:56
参数: 无
传出参数:
返回值: string
返回值类型:string (Type)
-------------------------------------------------------------------------------}
function TGlobal.GetLocalHostName: string;
var CompName:array[0..255] of char;
Len:Cardinal;
begin
fillchar(CompName[0],256,0);
GetComputerName(compName,len);
result:=CompName;
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.NewMouseWheel
意义: 鼠标滚动的消息拦截
作者: 王彦鹏
日期: 2006-2-17 13:52:55
参数: var Msg: TMessage
传出参数:
返回值: 无
返回值类型:
-------------------------------------------------------------------------------}
procedure TGlobal.NewMouseWheel(var Msg: TMessage);
var I:integer;
begin
if Msg.Msg = WM_MouseWheel then
begin
if Msg.wParam > 0 then
begin
for i:=0 to ComponentCount -1 do
if (Components Is TDBGrid)and((Components as TDBGrid).Focused ) then
begin
SendMessage(TDBGrid(Components).Handle,WM_VSCROLL,SB_LINEUP,0);
(Components as TDBGrid).Refresh;
end
else
OldMouseWheel[TDBGrid(Components).Tag ](msg);
end
else
begin
for i:=0 to ComponentCount -1 do
if (Components Is TDBGrid)and((Components as TDBGrid).Focused ) then
begin
SendMessage((Components as TDBGrid).Handle,WM_VSCROLL,SB_LINEDOWN,0);
(Components as TDBGrid).Refresh;
end
else
OldMouseWheel[TDBGrid(Components).Tag ](msg);
end;
end
else
begin
for i:=0 to high(OldMouseWheel) do
OldMouseWheel(msg);
end;
end;
procedure TGlobal.DBGridTitleClick(Column: TColumn);
begin
SortQuery(Column);
end;
procedure TGlobal.Dbgrid_DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
inherited;
if TDBGrid(Sender).DataSource.DataSet.RecNo mod 2 =1 then
begin
TDBGrid(Sender).Canvas.Brush.Color := clWindow ;
TDBGrid(Sender).DefaultDrawDataCell(Rect, Column.Field, State);
end
else
begin
TDBGrid(Sender).Canvas.Brush.Color := $00FEFAF5 ;
TDBGrid(Sender).DefaultDrawDataCell(Rect, Column.Field, State);
end;
if (Rect.Top = TStringGrid(TDBGrid(sender)).CellRect(TStringGrid(TDBGrid(sender)).col,
TStringGrid(TDBGrid(sender)).row).top) then
begin
TDBGrid(sender).Canvas.Brush.Color := $00FF8080;
TDBGrid(Sender).Canvas.Font.Color:= clWhite ;
TDBGrid(Sender).Canvas.Font.Style :=[fsBold ];
TDBGrid(sender).DefaultDrawDataCell(Rect, Column.Field, State);
end;
end;
{-------------------------------------------------------------------------------
过程名: TGlobal.ChmHelp
作者: 王彦鹏
日期: 2005-11-20
参数: hwndcaller: Integer; lpHelpFile: string; wCommand: Integer; dwData: string
返回值: HWND
说明: 调用Chm格式的帮助文件。
-------------------------------------------------------------------------------}
function TGlobal.ChmHelp(lpHelpFile: string; wCommand: Integer; dwData: string): HWND;
begin
if not FileExists(lpHelpFile ) then
HintWindow.ShouHintW(self,'未找到帮助文件，请确定安装文件是否完整！',IDI_INFORMATION)
else
HtmlHelpA(Handle,lpHelpFile,wCommand,dwData);
end;
procedure TGlobal.FreeTreeViewData(TreeView: TTreeView);
var i:integer;
begin
for i:=0 to TreeView.Items.Count -1 do
begin
if Assigned(TreeView.Items.Data) then
FreeMem(TreeView.Items.Data);
end;
end;
procedure TGlobal.FreeNodeData(ParentNode: TTreeNode);
var i:integer;
begin
for i:=0 to ParentNode.Count -1 do
begin
if Assigned(ParentNode.Item.Data) then
FreeMem(ParentNode.Item.Data);
end;
FreeMem(ParentNode.Data);
end;
procedure TGlobal.ClearInputInfo;
const
PropertyNames: array[0..0] of PChar = ('Text');
var
Comp: TComponent;
CompIndex, PropIndex: Integer;
PropInfoPtr: PPropInfo;
PropNewValue: pchar;
begin
PropNewValue := AllocMem(1024);
with Self do
for CompIndex := 0 to ComponentCount - 1 do
begin
Comp := Components[CompIndex];
for PropIndex := Low(PropertyNames) to High(PropertyNames) do
begin
PropInfoPtr := GetPropInfo(Comp, PropertyNames[PropIndex]);
if PropInfoPtr = nil then continue;
if PropInfoPtr^.PropType^.Kind = tklString then
begin
fillchar(PropNewValue[0], 1024, 0);
SetStrProp(Comp, PropertyNames[PropIndex], '');
end;
end;
end;
end;
end.