Delphi编程地一些小程序

1、用Enter键代替Tab键 
在实际的程序开发中我们经常有这样的要求，用户不喜欢用Tab键，他希望用Enter键来代替。我们应该什么做呢？ 
首先：设定Form的KeyPreview属性为True。 
其次：把Form上的所有Button的Default属性设为False。 
最后：在Form的onKeyPress事件中添加如下代码： 
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); begin 
　if Key = #13 then 
　begin 
　　Key := #0; 
　　Perform(Wm_NextDlgCtl,0,0); 
　end; 
end; 
-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:10:38 
-- 
2、命令行参数的使用 
命令行参数的使用 
Delphi提供了访问命令行参数的方便的方式，那就是使用ParamStr和ParamCount函数。其中ParamStr(0)返回的是当前程序名，如C:TESTMYPROG.EXE，ParamStr(1)返回第一个参数，以此类推；ParamCount则是参数个数。示例如下: 
　　var 
　　I: Word; 
　　Y: Integer; 
　　begin 
　　 Y := 10; 
　　 forI := 1 to ParamCount do 
begin 
　　 Canvas.TextOut(5, Y, ParamStr(I)); 
　　 Y := Y ＋ Canvas.TextHeight(ParamStr(I)) ＋ 5; 
　　 end; 
　　end; 

-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:10:48 
-- 
3、如何分行提示 
Delphi中大部分控件都有一个实用的Hint属性，即浮动条提示。但有时提示较长，是否可以使得浮动提示条分行显示呢？其实，Hint是一个字符串（string），因而Delphi显示该字符串时会自动解释其中的回车控制符，所以只要加上回车控制符就可以了。依此原理，我们还能做出别具一格的垂直提示条。请先在form1中布置一个label，然后看示例代码： 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
label1.Hint :=\'垂\'+#13+\'直\'+#13+\'提\' +#13+\'示\'; 
end; 

-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:10:58 
-- 
4、如何取得一个文件的文件类型呀 
//要引用Shellapi单元 
function MrsGetFileType(const strFilename: string): string; 
var 
FileInf TSHFileInfo; 
begin 
FillChar(FileInfo, SizeOf(FileInfo), #0); 
SHGetFileInfo(PChar(strFilename), 0, FileInfo, SizeOf(FileInfo), SHGFI_TYPENAME); 
Result := FileInfo.szTypeName; 
end; 
-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:11:08 
-- 
5、取得当前操作平台 
//定义在Type部分 
TOSVersion = (osUnknown, os95, os95OSR2, os98, os98SE, osNT3, osNT4, os2K, osME,osXP); 
{ *获得操作系统} 
function GetOS :String; 
var 
OS :TOSVersionInfo; 
OSVersion:TOSVersion; 
begin 
ZeroMemory(@OS,SizeOf(OS)); 
OS.dwOSVersionInfoSize:=SizeOf(OS); 
GetVersionEx(OS); 
OSVersion:=osUnknown; 
if OS.dwPlatformId=VER_PLATFORM_WIN32_NT then 
begin 
case OS.dwMajorVersion of 
3: OSVersion:=osNT3; 
4: OSVersion:=osNT4; 
5: begin 
if OS.dwMinorVersion>=1 then 
OSVersion:=osXP 
else 
OSVersion:=os2K; 
end; 
end; 
end 
else 
begin 
if (OS.dwMajorVersion=4) and (OS.dwMinorVersion=0) then 
begin 
OSVersion:=os95; 
if (Trim(OS.szCSDVersion)=\'B\') then 
OSVersion:=os95OSR2; 
end 
else 
if (OS.dwMajorVersion=4) and (OS.dwMinorVersion=10) then 
begin 
OSVersion:=os98; 
if (Trim(OS.szCSDVersion)=\'A\') then 
OSVersion:=os98SE; 
end 
else 
if (OS.dwMajorVersion=4) and (OS.dwMinorVersion=90) then 
OSVersion:=osME; 
end; 
if OSVersion=osNT3 
then Result:=\'Window NT3\'; 
if OSVersion=OSNT4 
then Result:=\'Window NT4\'; 
if OSVersion=os2K 
then Result:=\'Winodw 2000\'; 
if OSVersion=osXp 
then Result:=\'Winodw Xp\'; 
if OSVersion=os95 
then Result:=\'Window 95\'; 
if OSVersion=os95OSR2 
then Result:=\'Window 97\'; 
if OSVersion=os98 
then Result:=\'Winodw 98\'; 
if OSVersion=os98SE 
then Result:=\'Winodw 98SE\'; 
if OSVersion=osME 
then Result:=\'Winodw ME\'; 
end; 

-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:11:17 
-- 
6、ListView 排序的实现 
ListView 排序 

怎样实现单击一下按升序,再单击一下按降序。 
function CustomSortProc(Item1, Item2: TListItem; ColumnIndex: integer): integer; stdcall; 
begin 
if ColumnIndex = 0 then 
Result := CompareText(Item1.Caption,Item2.Caption) 
else 
Result := CompareText(Item1.SubItems[ColumnIndex-1],Item2.SubItems[ColumnIndex-1]) 
end; 
procedure TFrmSrvrMain.ListView1ColumnClick(Sender: TObject; 
Column: TListColumn); 
begin 
ListView1.CustomSort(@CustomSortProc,Column.Index); 
end; 

-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:11:26 
-- 
7、获取本机的IP地址 
{* 获取本机的IP地址} 
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; 
-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:11:36 
-- 
8、获取本机的计算机名称 
{* 获取本机的计算机名称} 
function TNet.GetLocalName: string; 
var 
CNameBuffer : PChar; 
fl_loaded : Boolean; 
CLen : ^DWord; 
begin 
GetMem(CNameBuffer,255); 
New(CLen); 
CLen^:= 255; 
fl_loaded := GetComputerName(CNameBuffer,CLen^); 
if fl_loaded then 
GetLocalName := StrPas(CNameBuffer) 
else 
GetLocalName := \'未知\'; 
FreeMem(CNameBuffer,255); 
Dispose(CLen); 
end; 

-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:11:45 
-- 
9、让程序只运行一个实例Windows 下一个典型的特征就是多任务，我们可以同时打开多个窗口进行操作，也可以同时运行程序的多个实例，比如可以打开许多个资源管理器进行文件的移动复制操作。但有时出于某种考虑（比如安全性），我们要做出一些限制，让程序只能够运行一个实例。在Delphi编程中，笔者总结出了以下几种方法： 
　　一、 查找窗口法 
　　这是最为简单的一种方法。在程序运行前用FindWindow函数查找具有相同窗口类名和标题的窗口，如果找到了，就说明已经存在一个实例。在项目源文件的初始化部分添加以下代码： 
　　Program OneApp 
　　Uses 
　　Forms,Windows;（这里介绍的几种方法均需在项目源文件中添加Windows单元，以后不再重复了） 
　　Var Hwnd:Thandle; 
　　Begin 
　　 Hwnd:=FindWindow(‘TForm1’，‘SingleApp’); 
　　 If Hwnd=0 then 
　　 Begin 
　　 Application.Initialize; 
　　 Application.CreateForm(Tform1, Form1); 
　　 Application.Run; 
　　 End; 
　　End; 
　　FindWindow()函数带两个参数，FindWindow的第一个参数是类名，第二个参数是窗口标题,其中的一个参数可以忽略，但笔者强烈建议将两个参数都用上，免得凑巧别的程序也在使用相同的类名，就得不到正确的结果了。另外，如果是在Delphi IDE窗口中运行该程序，将一次都不能运行，因为已经存在相同类名和标题的窗口：设计时的窗体。 
　　二、使用互斥对象 
　　如果觉得查找窗口的方法效率不太高的话，可以使用创建互斥对象的方法。尽管互斥对象通常用于同步连接，但用在这个地方也是非常方便的。仅用了4句代码就轻松搞定。 
　　VAR Mutex:THandle; 
　　begin 
　　 Mutex:=CreateMutex(NIL,True,‘SingleApp’); 
　　 IF GetLastError<>ERROR_ALREADY_EXISTS THEN//如果不存在另一实例 
　　 BEGIN 
　　 Application.CreateHandle; 
　　 Application.CreateForm (TExpNoteForm, ExpNoteForm); 
　　 Application.Run; 
　　 END; 
　　 ReleaseMutex(Mutex); 
　　end. 
　　三、全局原子法 
　　我们也可以利用向系统添加全局原子的方法，来防止多个程序实例的运行。全局原子由Windows 系统负责维持，它能保证其中的每个原子都是唯一的，管理其引用计数，并且当该全局原子的引用计数为0时，从内存中清除。我们用GlobalAddAtom 函数向全局原子添加一个255个字节以内的字符串，用GlobalFindAtom来检查是否已经存在该全局原子，最后在程序结束时用GlobalDeleteAtom函数删除添加的全局原子。示例如下： 
　　Uses Windows 
　　const iAtom=‘SingleApp’; 
　　begin 
　　 if GlobalFindAtom(iAtom)=0 then 
　　 begin 
　　 GlobalAddAtom(iAtom); 
　　 Application.Initialize; 
　　 Application.CreateForm(TForm1,Form1); 
　　 Application.Run; 
　　 GlobalDeleteAtom(GlobalFindAtom(iAtom)); 
　　 end 
　　 else 
　　 MessageBox(0,‘You can not run a second copy of this App’,‘’,mb_OK); 
　　end. 
　　利用全局原子的引用计数规则，我们还可以判断当前共运行了该程序的多少个实例： 
　　var i:Integer; 
　　begin 
　　 I:=0; 
　　while GlobalFindAtom(iAtom)<>0 do 
　　 begin 
　　 GlobalDeleteAtom(GlobalFindAtom(iAtom)); 
　　 i:=i＋1; 
　　 end; 
　　 ShowMessage(IntToStr(I)); 
　　end; 
　　以上几种方法在笔者的Delphi 5.0，中文Windows2000下通过。 
-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:11:57 
-- 
10、计算字符串中中文的字数 
function TotalChineseCount(ans: AnsiString): Integer; 
var 
wis: WideString; 
begin 
wis := WideString( ans ); 
Result := Length( ans ) - Length( wis ); 
end; 
-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:12:12 
-- 
11、Virtual key codes 
Virtual Key Code Corresponding key 
VK_LBUTTON Left mouse button 
VK_RBUTTON Right mouse button 
VK_CANCEL Control+Break 
VK_MBUTTON Middle mouse button 
VK_BACK Backspace key 
VK_TAB Tab key 
VK_CLEAR Clear key 
VK_RETURN Enter key 
VK_SHIFT Shift key 
VK_CONTROL Ctrl key 
VK_MENU Alt key 
VK_PAUSE Pause key 
VK_CAPITAL Caps Lock key 
VK_KANA Used with IME 
VK_HANGUL Used with IME 
VK_JUNJA Used with IME 
VK_FINAL Used with IME 
VK_HANJA Used with IME 
VK_KANJI Used with IME 
VK_CONVERT Used with IME 
VK_NONCONVERT Used with IME 
VK_ACCEPT Used with IME 
VK_MODECHANGE Used with IME 
VK_ESCAPE Esc key 
VK_SPACE Space bar 
VK_PRIOR Page Up key 
VK_NEXT Page Down key 
VK_END End key 
VK_HOME Home key 
VK_LEFT Left Arrow key 
VK_UP Up Arrow key 
VK_RIGHT Right Arrow key 
VK_DOWN Down Arrow key 
VK_SELECT Select key 
VK_PRINT Print key (keyboard-specific) 
VK_EXECUTE Execute key 
VK_SNAPSHOT Print Screen key 
VK_INSERT Insert key 
VK_DELETE Delete key 
VK_HELP Help key 
VK_LWIN Left Windows key (Microsoft keyboard) 
VK_RWIN Right Windows key (Microsoft keyboard) 
VK_APPS Applications key (Microsoft keyboard) 
VK_NUMPAD0 0 key (numeric keypad) 
VK_NUMPAD1 1 key (numeric keypad) 
VK_NUMPAD2 2 key (numeric keypad) 
VK_NUMPAD3 3 key (numeric keypad) 
VK_NUMPAD4 4 key (numeric keypad) 
VK_NUMPAD5 5 key (numeric keypad) 
VK_NUMPAD6 6 key (numeric keypad) 
VK_NUMPAD7 7 key (numeric keypad) 
VK_NUMPAD8 8 key (numeric keypad) 
VK_NUMPAD9 9 key (numeric keypad) 
VK_MULTIPLY Multiply key (numeric keypad) 
VK_ADD Add key (numeric keypad) 
VK_SEPARATOR Separator key (numeric keypad) 
VK_SUBTRACT Subtract key (numeric keypad) 
VK_DECIMAL Decimal key (numeric keypad) 
VK_DIVIDE Divide key (numeric keypad) 
VK_F1 F1 key 
VK_F2 F2 key 
VK_F3 F3 key 
VK_F4 F4 key 
VK_F5 F5 key 
VK_F6 F6 key 
VK_F7 F7 key 
VK_F8 F8 key 
VK_F9 F9 key 
VK_F10 F10 key 
VK_F11 F11 key 
VK_F12 F12 key 
VK_F13 F13 key 
VK_F14 F14 key 
VK_F15 F15 key 
VK_F16 F16 key 
VK_F17 F17 key 
VK_F18 F18 key 
VK_F19 F19 key 
VK_F20 F20 key 
VK_F21 F21 key 
VK_F22 F22 key 
VK_F23 F23 key 
VK_F24 F24 key 
VK_NUMLOCK Num Lock key 
VK_SCROLL Scroll Lock key 
VK_LSHIFT Left Shift key (only used with GetAsyncKeyState and GetKeyState) 
VK_RSHIFT Right Shift key(only used with GetAsyncKeyState and GetKeyState) 
VK_LCONTROL Left Ctrl key(only used with GetAsyncKeyState and GetKeyState) 
VK_RCONTROL Right Ctrl key(only used with GetAsyncKeyState and GetKeyState) 
VK_LMENU Left Alt key(only used with GetAsyncKeyState and GetKeyState) 
VK_RMENU Right Alt key(only used with GetAsyncKeyState and GetKeyState) 
VK_PROCESSKEY Process key 
VK_ATTN Attn key 
VK_CRSEL CrSel key 
VK_EXSEL ExSel key 
VK_EREOF Erase EOF key 
VK_PLAY Play key 
VK_ZOOM Zoom key 
VK_NONAME Reserved for future use 
VK_PA1 PA1 key 
VK_OEM_CLEAR Clear key 
-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:12:21 
-- 
12、DELPHI中的快捷方式一览(完全正式版) 
1.SHIFT+鼠标左键先选中任一控件,按键后可选中窗体(选中控件后按Esc效果一样) 
2.Shift+F8调试时弹出CPU窗口。 
3.Shift+F10 等于鼠标右键（Windows快捷键）。 
4.Shitf+箭头选择 
5.shift +F12快速查找窗体并打开 
6.F7 （步进式调试同时追踪进入子过程） 
7.F8 （步进式调试不进入子过程） 
8.F9运行 
9.F12 切换EDITOR,FORM 
10.Alt+F4 关闭所有编辑框中打开的源程序文件，但不关闭项目 
11.ALT+鼠标左键可以块选代码，用来删除对齐的重复代码非常有用 
12.Ctrl+F9编译 
13.Ctrl+shift+N(n=1,2,3,4......)定义书签 
14.Ctrl+n(n=1,2,3,4......)跳到书签n 
15.CTRL +SHIFT+N在书签N处，再按一次 取消书签 
16.Ctrl+PageUp将光标移至本屏的第一行，屏幕不滚动 
17.Ctrl+PageDown将光标移至本屏的最后一行，屏幕不滚动 
18.Ctrl+↓向下滚动屏幕，光标跟随滚动不出本屏 
19.Ctrl+↑向上滚动屏幕，光标跟随滚动不出本屏 
20.Ctrl+Home将光标移至文件头 
21.Ctrl+End 将光标移至文件尾 
22.Ctrl+B Buffer List窗口 
23.Ctrl+I 同Tab键 
24.CTRL+J (弹出Delphi语句提示窗口，选择所需语句将自动完成一条语句)代码模板 
25.Ctrl+M 同Enter键。 
26.Ctrl+N 同Enter键，但光标位置保持不变 
27.Ctrl+T 删除光标右边的一个单词 
28.Ctrl+Y 删除光标所在行 
29.CTRL+C 复制 
30.CTRL+V 粘贴 
31.CTRL+X 剪切 
32.CTRL+Z 还原(Undo) 
33.CTRL+S 保存 
34.Ctrl+F 查找 
35.Ctrl+L 继续查找 
36.Ctrl+r 替换 
37.CTRL+ENTER 定位到单元文件 
38.Ctrl+F3弹出Call Stack窗口 
39.Ctrl+F4等于File菜单中的Close项 
40.Ctrl+Backspace 后退删除一个词,直到遇到一个分割符 
41.Ctrl+鼠标转轮加速滚屏 
42.Ctrl+O+U 切换选择块的大小写(注意松开O后再按U,Ctrl保持按下) 
43.Ctrl+K+O 切换选择块为小写(注意松开K后再按O,Ctrl保持按下) 
44.Ctrl+K+N 切换选择块为大写(注意松开K后再按N,Ctrl保持按下) 
45.Ctrl+Shift+G 插入GUID 
46.Ctrl+Shift+T 在光标行加入To-Do注释 
47.Ctrl+Shift+Y 删除光标之后至本行末尾之间的文本 
48.CTRL+SHIFT+C 编写申明或者补上函数，绝好!!! 
49.CTRL+SHIFT+E 显示EXPLORER 
50.Ctrl+Tab 在Inspector中切换Properties页和Events页 
51.CTRL+SHIFT+U 代码整块左移2个空格位置 
52.CTRL+SHIFT+I 代码整块右移2个空格位置 
53.CTRL+SHIFT+↑在过程、函数、事件内部, 可跳跃到相应的过程、函数、事 
件的定义（在interface和implementation之间来回切换） 
54.CTRL+SHIFT+↓在过程、函数、事件的定义处， 可跳跃到具体过程、函数、事件内部(同上) 
55.Tab在object inspector窗口按tab键将光标移动到属性名区，然后键入属性名的开头 
字母可快速定位到该属性 
56.Ctrl+Alt 按着Ctrl+Alt之后，可用鼠标选择一个矩形块中的代码， 
并可比它进行复制，粘贴 
57.Shift+↓、↑、→、← 以1像素单位更改所选控件大小 
58.Ctrl+↓、↑、→、←以1像素单位更改所选控件位置 
59.Ctrl+E 快速选择（呵呵，试试吧，很好玩的） 
-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:12:35 
-- 
13、DbGrid控件的标题栏弹出菜单 
procedure TFrmOrderPost.DbgOrderPostMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 
var 
CurPost:TPoint; 
begin 
GetCursorPos(CurPost);//获得鼠标当前坐标 
if (y<=17) and (x<=vCurRect.Right) then 
begin 
if button=mbright then 
begin 
PmTitle.Popup(CurPost.x,CurPost.y); 
end; 
end; 
end; 
//vCurRect该变量在DbGrid的DrawColumnCell事件中获得 
{procedure TFrmOrderPost.DbgOrderPostDrawColumnCell(Sender: TObject;const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); 
begin 
vCurRect:=Rect;//vCurRect在实现部分定义 
end;} 
-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:12:44 
-- 
14.模拟按按下键盘键(如输入法中的软键盘) 
//模拟在Edit组件中按下字母a键 
PostMessage(Edit1.Handle,WM_KEYDOWN,65,0); 
//模拟在窗体Form1中按下Tab键 
PostMessage(Form1.Handle,WM_KEYDOWN,VK_TAB,0); 
-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:12:56 
-- 
15.屏蔽系统功能键，如Ctrl+Alt+Del、Ctrl+Esc 
var tempint:integer; 
begin 
SystemParametersinfo(SPI_SCREENSAVERRUNNING,1,@tempint,0);//屏蔽 
SystemParametersinfo(SPI_SCREENSAVERRUNNING,0,@tempint,0);//取消屏蔽 
-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:13:07 
-- 
网络函数 
来自：在富翁 
作者：daojianrumeng 
unit netFunc; 
interface 
uses 
SysUtils 
,Windows 
,dialogs 
,winsock 
,Classes 
,ComObj 
,WinInet 
,Variants; 
//错误信息常量 
const 
C_Err_GetLocalIp = \'获取本地ip失败\'; 
C_Err_GetNameByIpAddr= \'获取主机名失败\'; 
C_Err_GetSQLServerList = \'获取SQLServer服务器失败\'; 
C_Err_GetUserResource= \'获取共享资失败\'; 
C_Err_GetGroupList = \'获取所有工作组失败\'; 
C_Err_GetGroupUsers= \'获取工作组中所有计算机失败\'; 
C_Err_GetNetList = \'获取所有网络类型失败\'; 
C_Err_CheckNet = \'网络不通\'; 
C_Err_CheckAttachNet = \'未登入网络\'; 
C_Err_InternetConnected =\'没有上网\'; 
C_Txt_CheckNetSuccess= \'网络畅通\'; 
C_Txt_CheckAttachNetSuccess = \'已登入网络\'; 
C_Txt_InternetConnected =\'上网了\'; 

//得到本机的局域网Ip地址 
Function GetLocalIp(var LocalIp:string): Boolean; 
//通过Ip返回机器名 
Function GetNameByIPAddr(IPAddr: string; var MacName: string): Boolean ; 
//获取网络中SQLServer列表 
Function GetSQLServerList(var List: Tstringlist): Boolean; 
//获取网络中的所有网络类型 
Function GetNetList(var List: Tstringlist): Boolean; 
//获取网络中的工作组 
Function GetGroupList(var List: TStringList): Boolean; 
//获取工作组中所有计算机 
Function GetUsers(GroupName: string; var List: TStringList): Boolean; 
//获取网络中的资源 
Function GetUserResource(IpAddr: string; var List: TStringList): Boolean; 
//映射网络驱动器 
Function NetAddConnection(NetPath: Pchar; PassWord: Pchar;LocalPath: Pchar): Boolean; 
//检测网络状态 
Function CheckNet(IpAddr:string): Boolean; 
//检测机器是否登入网络 
Function CheckMacAttachNet: Boolean; 
//判断Ip协议有没有安装 这个函数有问题 
Function IsIPInstalled : boolean; 
//检测机器是否上网 
Function InternetConnected: Boolean; 
//关闭网络连接 
function NetCloseAll:boolean; 
implementation 
{================================================================= 
功能: 检测机器是否登入网络 
参数: 无 
返回值: 成功:True失败:False 
备 注: 
版 本: 
1.02002/10/03 09:55:00 
=================================================================} 
Function CheckMacAttachNet: Boolean; 
begin 
Result := False; 
if GetSystemMetrics(SM_NETWORK) <> 0 then 
Result := True; 
end; 
{================================================================= 
功能: 返回本机的局域网Ip地址 
参数: 无 
返回值: 成功:True, 并填充LocalIp 失败:False 
备 注: 
版 本: 
1.02002/10/02 21:05:00 
=================================================================} 
function GetLocalIP(var LocalIp: string): Boolean; 
var 
HostEnt: PHostEnt; 
Ip: string; 
addr: pchar; 
Buffer: array [0..63] of char; 
GInitData: TWSADATA; 
begin 
Result := False; 
try 
WSAStartup(2, GInitData); 
GetHostName(Buffer, SizeOf(Buffer)); 
HostEnt := GetHostByName(buffer); 
if HostEnt = nil then Exit; 
addr := HostEnt^.h_addr_list^; 
ip := Format(\'%d.%d.%d.%d\', [byte(addr [0]), 
byte (addr [1]), byte (addr [2]), byte (addr [3])]); 
LocalIp := Ip; 
Result := True; 
finally 
WSACleanup; 
end; 
end; 
{================================================================= 
功能: 通过Ip返回机器名 
参数: 
IpAddr: 想要得到名字的Ip 
返回值: 成功:机器名 失败:\'\' 
备 注: 
inet_addr function converts a string containing an Internet 
Protocol dotted address into an in_addr. 
版 本: 
1.02002/10/02 22:09:00 
=================================================================} 
function GetNameByIPAddr(IPAddr : String;var MacName:String): Boolean; 
var 
SockAddrIn: TSockAddrIn; 
HostEnt: PHostEnt; 
WSAData: TWSAData; 
begin 
Result := False; 
if IpAddr = \'\' then exit; 
try 
WSAStartup(2, WSAData); 
SockAddrIn.sin_addr.s_addr := inet_addr(PChar(IPAddr)); 
HostEnt := gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET); 
if HostEnt <> nil then 
MacName := StrPas(Hostent^.h_name); 
Result := True; 
finally 
WSACleanup; 
end; 
end; 
{================================================================= 
功能: 返回网络中SQLServer列表 
参数: 
List: 需要填充的List 
返回值: 成功:True,并填充List失败 False 
备 注: 
版 本: 
1.02002/10/02 22:44:00 
=================================================================} 
Function GetSQLServerList(var List: Tstringlist): boolean; 
var 
i: integer; 
sRetvalue: String; 
SQLServer: Variant; 
ServerList: Variant; 
begin 
Result := False; 
List.Clear; 
try 
SQLServer := CreateOleObject(\'SQLDMO.Application\'); 
ServerList := SQLServer.ListAvailableSQLServers; 
for i := 1 to Serverlist.Count do 
list.Add (Serverlist.item(i)); 
Result := True; 
Finally 
SQLServer := NULL; 
ServerList := NULL; 
end; 
end; 
{================================================================= 
功能: 判断Ip协议有没有安装 
参数: 无 
返回值: 成功:True 失败: False; 
备 注: 该函数还有问题 
版 本: 
1.02002/10/02 21:05:00 
=================================================================} 
Function IsIPInstalled : boolean; 
var 
WSData: TWSAData; 
ProtoEnt: PProtoEnt; 
begin 
Result := True; 
try 
if WSAStartup(2,WSData) = 0 then 
begin 
ProtoEnt := GetProtoByName(\'IP\'); 
if ProtoEnt = nil then 
Result := False 
end; 
finally 
WSACleanup; 
end; 
end; 

{================================================================= 
功能: 返回网络中的共享资源 
参数: 
IpAddr: 机器Ip 
List: 需要填充的List 
返回值: 成功:True,并填充List 失败: False; 
备 注: 
WNetOpenEnum function starts an enumeration of network 
resources or existing connections. 
WNetEnumResource function continues a network-resource 
enumeration started by the WNetOpenEnum function. 
版 本: 
1.02002/10/03 07:30:00 
=================================================================} 

-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:13:19 
-- 
Function GetUserResource(IpAddr: string; var List: TStringList): Boolean; 
type 
TNetResourceArray = ^TNetResource;//网络类型的数组 
Var 
i: Integer; 
Buf: Pointer; 
Temp: TNetResourceArray; 
lphEnum: THandle; 
NetResource: TNetResource; 
Count,BufSize,Res: DWord; 
Begin 
Result := False; 
List.Clear; 
if copy(Ipaddr,0,2) <> \'\\\\\' then 
IpAddr := \'\\\\\'+IpAddr; //填充Ip地址信息 
FillChar(NetResource, SizeOf(NetResource), 0);//初始化网络层次信息 
NetResource.lpRemoteName := @IpAddr[1];//指定计算机名称 
//获取指定计算机的网络资源句柄 
Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 
RESOURCEUSAGE_CONNECTABLE, @NetResource,lphEnum); 
if Res <> NO_ERROR then exit;//执行失败 
while True do//列举指定工作组的网络资源 
begin 
Count := $FFFFFFFF;//不限资源数目 
BufSize := 8192;//缓冲区大小设置为8K 
GetMem(Buf, BufSize);//申请内存，用于获取工作组信息 
//获取指定计算机的网络资源名称 
Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize); 
if Res = ERROR_NO_MORE_ITEMS then break;//资源列举完毕 
if (Res <> NO_ERROR) then Exit;//执行失败 
Temp := TNetResourceArray(Buf); 
for i := 0 to Count - 1 do 
begin 
//获取指定计算机中的共享资源名称，+2表示删除"\\\\"， 
//如\\\\192.168.0.1 => 192.168.0.1 
List.Add(Temp^.lpRemoteName + 2); 
Inc(Temp); 
end; 
end; 
Res := WNetCloseEnum(lphEnum);//关闭一次列举 
if Res <> NO_ERROR then exit;//执行失败 
Result := True; 
FreeMem(Buf); 
End; 
{================================================================= 
功能: 返回网络中的工作组 
参数: 
List: 需要填充的List 
返回值: 成功:True,并填充List 失败: False; 
备注: 
版本: 
1.02002/10/03 08:00:00 
=================================================================} 
Function GetGroupList( var List : TStringList ) : Boolean; 
type 
TNetResourceArray = ^TNetResource;//网络类型的数组 
Var 
NetResource: TNetResource; 
Buf: Pointer; 
Count,BufSize,Res: DWORD; 
lphEnum: THandle; 
p: TNetResourceArray; 
i,j: SmallInt; 
NetworkTypeList: TList; 
Begin 
Result := False; 
NetworkTypeList := TList.Create; 
List.Clear; 
//获取整个网络中的文件资源的句柄，lphEnum为返回名柄 
Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK, 
RESOURCEUSAGE_CONTAINER, Nil,lphEnum); 
if Res <> NO_ERROR then exit;//Raise Exception(Res);//执行失败 
//获取整个网络中的网络类型信息 
Count := $FFFFFFFF;//不限资源数目 
BufSize := 8192;//缓冲区大小设置为8K 
GetMem(Buf, BufSize);//申请内存，用于获取工作组信息 
Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize); 
//资源列举完毕//执行失败 
if ( Res = ERROR_NO_MORE_ITEMS ) or (Res <> NO_ERROR ) then Exit; 
P := TNetResourceArray(Buf); 
for i := 0 to Count - 1 do//记录各个网络类型的信息 
begin 
NetworkTypeList.Add(p); 
Inc(P); 
end; 
Res := WNetCloseEnum(lphEnum);//关闭一次列举 
if Res <> NO_ERROR then exit; 
for j := 0 to NetworkTypeList.Count-1 do //列出各个网络类型中的所有工作组名称 
begin//列出一个网络类型中的所有工作组名称 
NetResource := TNetResource(NetworkTypeList.Items[J]^);//网络类型信息 
//获取某个网络类型的文件资源的句柄，NetResource为网络类型信息，lphEnum为返回名柄 
Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, 
RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum); 
if Res <> NO_ERROR then break;//执行失败 
while true do//列举一个网络类型的所有工作组的信息 
begin 
Count := $FFFFFFFF;//不限资源数目 
BufSize := 8192;//缓冲区大小设置为8K 
GetMem(Buf, BufSize);//申请内存，用于获取工作组信息 
//获取一个网络类型的文件资源信息， 
Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize); 
//资源列举完毕 //执行失败 
if ( Res = ERROR_NO_MORE_ITEMS ) or (Res <> NO_ERROR)then break; 
P := TNetResourceArray(Buf); 
for i := 0 to Count - 1 do//列举各个工作组的信息 
begin 
List.Add( StrPAS( P^.lpRemoteName ));//取得一个工作组的名称 
Inc(P); 
end; 
end; 
Res := WNetCloseEnum(lphEnum);//关闭一次列举 
if Res <> NO_ERROR then break;//执行失败 
end; 
Result := True; 
FreeMem(Buf); 
NetworkTypeList.Destroy; 
End; 
{================================================================= 
功能: 列举工作组中所有的计算机 
参数: 
List: 需要填充的List 
返回值: 成功:True,并填充List 失败: False; 
备注: 
版本: 
1.02002/10/03 08:00:00 
=================================================================} 
Function GetUsers(GroupName: string; var List: TStringList): Boolean; 
type 
TNetResourceArray = ^TNetResource;//网络类型的数组 
Var 
i: Integer; 
Buf: Pointer; 
Temp: TNetResourceArray; 
lphEnum: THandle; 
NetResource: TNetResource; 
Count,BufSize,Res: DWord; 
begin 
Result := False; 
List.Clear; 
FillChar(NetResource, SizeOf(NetResource), 0);//初始化网络层次信息 
NetResource.lpRemoteName := @GroupName[1];//指定工作组名称 
NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;//类型为服务器（工作组） 
NetResource.dwUsage := RESOURCEUSAGE_CONTAINER; 
NetResource.dwScope := RESOURCETYPE_DISK;//列举文件资源信息 
//获取指定工作组的网络资源句柄 
Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK, 
RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum); 
if Res <> NO_ERROR then Exit; //执行失败 
while True do//列举指定工作组的网络资源 
begin 
Count := $FFFFFFFF;//不限资源数目 
BufSize := 8192;//缓冲区大小设置为8K 
GetMem(Buf, BufSize);//申请内存，用于获取工作组信息 
//获取计算机名称 
Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize); 
if Res = ERROR_NO_MORE_ITEMS then break;//资源列举完毕 
if (Res <> NO_ERROR) then Exit;//执行失败 
Temp := TNetResourceArray(Buf); 
for i := 0 to Count - 1 do//列举工作组的计算机名称 
begin 
//获取工作组的计算机名称，+2表示删除"\\\\"，如\\\\wangfajun=>wangfajun 
List.Add(Temp^.lpRemoteName + 2); 
inc(Temp); 
end; 
end; 
Res := WNetCloseEnum(lphEnum);//关闭一次列举 
if Res <> NO_ERROR then exit;//执行失败 
Result := True; 
FreeMem(Buf); 
end; 
{================================================================= 
功能: 列举所有网络类型 
参数: 
List: 需要填充的List 
返回值: 成功:True,并填充List 失败: False; 
备 注: 
版 本: 
1.02002/10/03 08:54:00 
=================================================================} 
Function GetNetList(var List: Tstringlist): Boolean; 
type 
TNetResourceArray = ^TNetResource;//网络类型的数组 
Var 
p: TNetResourceArray; 
Buf: Pointer; 
i: SmallInt; 
lphEnum: THandle; 
NetResource: TNetResource; 
Count,BufSize,Res: DWORD; 
begin 
Result := False; 
List.Clear; 
Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK, 
RESOURCEUSAGE_CONTAINER, Nil,lphEnum); 
if Res <> NO_ERROR then exit;//执行失败 
Count := $FFFFFFFF;//不限资源数目 
BufSize := 8192;//缓冲区大小设置为8K 
GetMem(Buf, BufSize);//申请内存，用于获取工作组信息 
Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);//获取网络类型信息 
//资源列举完毕//执行失败 
if ( Res = ERROR_NO_MORE_ITEMS ) or (Res <> NO_ERROR ) then Exit; 
P := TNetResourceArray(Buf); 
for i := 0 to Count - 1 do//记录各个网络类型的信息 
begin 
List.Add(p^.lpRemoteName); 
Inc(P); 
end; 
Res := WNetCloseEnum(lphEnum); //关闭一次列举 
if Res <> NO_ERROR then exit; //执行失败 
Result := True; 
FreeMem(Buf);//释放内存 
end; 
{================================================================= 
功能: 映射网络驱动器 
参数: 
NetPath: 想要映射的网络路径 
Password: 访问密码 
Localpath 本地路径 
返回值: 成功:True失败: False; 
备 注: 
版 本: 
1.02002/10/03 09:24:00 
=================================================================} 
Function NetAddConnection(NetPath: Pchar; PassWord: Pchar 
;LocalPath: Pchar): Boolean; 
var 
Res: Dword; 
begin 
Result := False; 
Res := WNetAddConnection(NetPath,Password,LocalPath); 
if Res <> No_Error then exit; 
Result := True; 
end; 
{================================================================= 

-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:13:31 
-- 
功能:检测网络状态 
参数: 
IpAddr: 被测试网络上主机的IP地址或名称，建议使用Ip 
返回值: 成功:True失败: False; 
备 注: 
版 本: 
1.02002/10/03 09:40:00 
=================================================================} 
Function CheckNet(IpAddr: string): Boolean; 
type 
PIPOptionInformation = ^TIPOptionInformation; 
TIPOptionInformation = packed record 
TTL: Byte;// Time To Live (used for traceroute) 
TOS: Byte;// Type Of Service (usually 0) 
Flags: Byte;// IP header flags (usually 0) 
OptionsSize: Byte;// Size of options data (usually 0, max 40) 
OptionsData: PChar; // Options data buffer 
end; 
PIcmpEchoReply = ^TIcmpEchoReply; 
TIcmpEchoReply = packed record 
Address: DWord;// replying address 
Status:DWord;// IP status value (see below) 
RTT: DWord;// Round Trip Time in milliseconds 
DataSize:Word; // reply data size 
Reserved:Word; 
Data:Pointer;// pointer to reply data buffer 
Options: TIPOptionInformation; // reply options 
end; 
TIcmpCreateFile = function: THandle; stdcall; 
TIcmpCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall; 
TIcmpSendEcho = function( 
IcmpHandle:THandle; 
DestinationAddress:DWord; 
RequestData: Pointer; 
RequestSize: Word; 
RequestOptions:PIPOptionInformation; 
ReplyBuffer: Pointer; 
ReplySize: DWord; 
Timeout: DWord 
): DWord; stdcall; 
const 
Size = 32; 
TimeOut = 1000; 
var 
wsadata: TWSAData; 
Address: DWord; // Address of host to contact 
HostName, HostIP: String; // Name and dotted IP of host to contact 
Phe: PHostEnt;// HostEntry buffer for name lookup 
BufferSize, nPkts: Integer; 
pReqData, pData: Pointer; 
pIPE: PIcmpEchoReply; // ICMP Echo reply buffer 
IPOpt: TIPOptionInformation;// IP Options for packet to send 
const 
IcmpDLL = \'icmp.dll\'; 
var 
hICMPlib: HModule; 
IcmpCreateFile : TIcmpCreateFile; 
IcmpCloseHandle: TIcmpCloseHandle; 
IcmpSendEchTIcmpSendEcho; 
hICMP: THandle; // Handle for the ICMP Calls 
begin 
// initialise winsock 
Result:=True; 
if WSAStartup(2,wsadata) <> 0 then begin 
Result:=False; 
halt; 
end; 
// register the icmp.dll stuff 
hICMPlib := loadlibrary(icmpDLL); 
if hICMPlib <> null then begin 
@ICMPCreateFile := GetProcAddress(hICMPlib, \'IcmpCreateFile\'); 
@IcmpCloseHandle:= GetProcAddress(hICMPlib, \'IcmpCloseHandle\'); 
@IcmpSendEch= GetProcAddress(hICMPlib, \'IcmpSendEcho\'); 
if (@ICMPCreateFile = Nil) or (@IcmpCloseHandle = Nil) or (@IcmpSendEcho = Nil) then begin 
Result:=False; 
halt; 
end; 
hICMP := IcmpCreateFile; 
if hICMP = INVALID_HANDLE_value then begin 
Result:=False; 
halt; 
end; 
end else begin 
Result:=False; 
halt; 
end; 
// ------------------------------------------------------------ 
Address := inet_addr(PChar(IpAddr)); 
if (Address = INADDR_NONE) then begin 
Phe := GetHostByName(PChar(IpAddr)); 
if Phe = Nil then Result:=False 
else begin 
Address := longint(plongint(Phe^.h_addr_list^)^); 
HostName := Phe^.h_name; 
HostIP := StrPas(inet_ntoa(TInAddr(Address))); 
end; 
end 
else begin 
Phe := GetHostByAddr(@Address, 4, PF_INET); 
if Phe = Nil then Result:=False; 
end; 
if Address = INADDR_NONE then 
begin 
Result:=False; 
end; 
// Get some data buffer space and put something in the packet to send 
BufferSize := SizeOf(TICMPEchoReply) + Size; 
GetMem(pReqData, Size); 
GetMem(pData, Size); 
GetMem(pIPE, BufferSize); 
FillChar(pReqData^, Size, $AA); 
pIPE^.Data := pData; 
// Finally Send the packet 
FillChar(IPOpt, SizeOf(IPOpt), 0); 
IPOpt.TTL := 64; 
NPkts := IcmpSendEcho(hICMP, Address, pReqData, Size, 
@IPOpt, pIPE, BufferSize, TimeOut); 
if NPkts = 0 then Result:=False; 
// Free those buffers 
FreeMem(pIPE); FreeMem(pData); FreeMem(pReqData); 
// -------------------------------------------------------------- 
IcmpCloseHandle(hICMP); 
FreeLibrary(hICMPlib); 
// free winsock 
if WSACleanup <> 0 then Result:=False; 
end; 

{================================================================= 
功能:检测计算机是否上网 
参数:无 
返回值:成功:True失败: False; 
备 注: uses Wininet 
版 本: 
1.02002/10/07 13:33:00 
=================================================================} 
function InternetConnected: Boolean; 
const 
// local system uses a modem to connect to the Internet. 
INTERNET_CONNECTION_MODEM= 1; 
// local system uses a local area network to connect to the Internet. 
INTERNET_CONNECTION_LAN= 2; 
// local system uses a proxy server to connect to the Internet. 
INTERNET_CONNECTION_PROXY= 4; 
// local system\'s modem is busy with a non-Internet connection. 
INTERNET_CONNECTION_MODEM_BUSY = 8; 
var 
dwConnectionTypes : DWORD; 
begin 
dwConnectionTypes := INTERNET_CONNECTION_MODEM+ INTERNET_CONNECTION_LAN 
+ INTERNET_CONNECTION_PROXY; 
Result := InternetGetConnectedState(@dwConnectionTypes, 0); 
end; 

//关闭网络连接 
function NetCloseAll:boolean; 
const 
NETBUFF_SIZE=$208; 
type 
NET_API_STATUS=DWORD; 
LPByte=PByte; 
var 
dwNetRet:DWORD; 
i :integer; 
dwEntries :DWORD; 
dwTotalEntries:DWORD; 
szClient:LPWSTR; 
dwUserName:DWORD; 
Buff:array[0..NETBUFF_SIZE-1]of byte; 
Adword:array[0..NETBUFF_SIZE div 4-1] of dword; 
NetSessionEnum:function ( ServerName:LPSTR; 
Reserved:DWORD; 
Buf:LPByte; 
BufLen:DWORD; 
ConnectionCount:LPDWORD; 
ConnectionToltalCount:LPDWORD ):NET_API_STATUS; 
stdcall; 
NetSessionDel:function( ServerName:LPWSTR; 
UncClientName: LPWSTR ; 
UserName: dword):NET_API_STATUS; 
stdcall; 
LibHandle : THandle; 
begin 
Result:=false; 
try 
{ 加载 DLL } 
LibHandle := LoadLibrary(\'svrapi.dll\'); 
try 
{ 如果加载失败，LibHandle = 0.} 
if LibHandle = 0 then 
raise Exception.Create(\'不能加载SVRAPI.DLL\'); 
{ DLL 加载成功，取得到 DLL 输出函数的连接然后调用 } 
@NetSessionEnum := GetProcAddress(LibHandle, \'NetSessionEnum\'); 
@NetSessionDel := GetProcAddress(LibHandle, \'NetSessionDel\'); 
if (@NetSessionEnum = nil)or(@NetSessionDel=nil) then 
RaiseLastWin32Error { 连接函数失败 } 
else 
begin 
dwNetRet := NetSessionEnum( nil,$32, @Buff, 
NETBUFF_SIZE, @dwEntries, 
@dwTotalEntries ); 
if dwNetRet = 0 then 
begin 
Result := true; 
for i:=0 to dwTotalEntries-1 do 
begin 
Move(Buff,Adword,NETBUFF_SIZE); 
szClient:=LPWSTR(Adword[0]); 
dwUserName := Adword[2]; 
dwNetRet := NetSessionDel( nil,szClient,dwUserName); 
if( dwNetRet <> 0 ) then 
begin 
Result := false; 
break; 
end; 
Move(Buff[26],Buff[0],NETBUFF_SIZE-(i+1)*26); 
end 
end 
else 
Result := false; 
end; 
finally 
FreeLibrary(LibHandle); // Unload the DLL. 
end; 
except 
end; 
end; 
end. 

-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:13:48 
-- 
17、产生GUID 
Uses ComObj, ActiveX, Windows; 
function GetGUID:string; 
var 
Id: TGUID; 
begin 
if CoCreateGuid(Id) = S_OK then 
Result := GUIDToString(id); 
end; 

-------------------------------------------------------------------------------- 

--作者：kgdyga 
--发布时间：2005-2-25 13:14:00 
-- 
18、在ListBox移动鼠标时选择项目 
procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, 
Y: Integer); 
var 
i: integer; 
begin 
i := y div listbox1.ItemHeight; 
if (listbox1.TopIndex + i) < listbox1.items.count then 
begin 
listbox1.ItemIndex := listbox1.TopIndex + i; 
caption := listbox1.Items[listbox1.ItemIndex]; 
end; 
end;