VB中取各种系统路径名,格式化磁盘,建立快捷方式,鼠标的定位,移动

 

2. Option Explicit
4. '
5. '系统操作(SmSysCls)
6. '
8. Const SW_SHOW = 5
10. Public Type SmPointAPI
11.         X As Long
12.         Y As Long
13. End Type
15. Private Declare Function EbExecuteLine Lib "vba6.dll" (ByVal pStringToExec As Long, ByVal Unknownn1 As Long, ByVal Unknownn2 As Long, ByVal fCheckOnly As Long) As Long
16. Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
17. Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
18. Private Declare Function GetCursorPos Lib "user32" (lpPoint As SmPointAPI) As Long
20. Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
21. Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
22. Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
23. '/----------------------------------------------------------------
24. Private Declare Function SHGetSpecialFolderLocation Lib "Shell32" (ByVal hwndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As Long
25. Private Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal Pidl As Long, ByVal szPath As String) As Long
26. '/---------------------------------------------------------------
27. '/非常危险，小心使用。
28. Private Declare Function GetSystemDirectory Lib "kernel32" Alias _
29.         "GetSystemDirectoryA" (ByVal lpBuffer As String, _
30.         ByVal nSize As Long) As Long
31. Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
32. Private Declare Function ShellExecute Lib "shell32.dll" Alias _
33.         "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation _
34.         As String, ByVal lpFile As String, ByVal lpParameters _
35.         As String, ByVal lpDirectory As String, ByVal nShowCmd _
36.         As Long) As Long
38. '/-------------------------------------------------------------
39. Private Const HKEY_CLASSES_ROOT = 
40. Private Const HKEY_CURRENT_USER = 
41. Private Const HKEY_LOCAL_MACHINE = 
42. Private Const HKEY_USERS = 
43. Private Const HKEY_PERFORMANCE_DATA = 
44. Private Const HKEY_CURRENT_CONFIG = 
45. Private Const HKEY_DYN_DATA = 
47. Private Const REG_NONE = 0
48. Private Const REG_SZ = 1
49. Private Const REG_EXPAND_SZ = 2
50. Private Const REG_BINARY = 3
51. Private Const REG_DWORD = 4
52. Private Const REG_DWORD_BIG_ENDIAN = 5
53. Private Const REG_MULTI_SZ = 7
55. '
56. '取计算机名
57. '函数:Get_ComputerName
58. '参数:无
59. '返回值:String,计算机名称
60. '例子：
61. Public Function Get_ComputerName() As String
62.     Dim strString As String
63.     strString = String(255, Chr$(0))
64.     GetComputerName strString, 255
65.     strString = Left$(strString, InStr(1, strString, Chr$(0)) - 1)
66.     Get_ComputerName = strString
67. End Function
69. '
70. '格式化磁盘(危险)
71. '函数:FormatDisk
72. '参数:DiskName 磁盘名称，WinHwnd调用本函数的窗口句柄．
73. '返回值:无
74. '说明：
75. Public Function FormatDisk(DiskName As String, Optional WinHwnd As Long = 0)
76.     Dim sFor As String
77.     Dim sTemp As String
78.     
79.     sFor = String(255, " ")
80.     GetWindowsDirectory sFor, 255
81.     sTemp = Left$(sFor, InStr(sFor, Chr$(0)) - 1) + "/rundll32.exe" _
82.             + Chr(0)
83.     ShellExecute WinHwnd, vbNullString, sTemp, _
84.             "Shell32.dll,SHFormatDrive" + Chr$(0), DiskName + Chr$(0), _
85.              SW_SHOW
86. End Function
88. '/
89. '/取WINDOWS路径
90. '/函数:GetWinPath
91. '/参数:
92. '/返回值:WINDOWS目录路径.
93. '/说明：
94. Private Function GetWinPath() As String
95.     Dim strFolder As String
96.     Dim lngResult As Long
97.     strFolder = String(255, Chr$(0))
98.     lngResult = GetWindowsDirectory(strFolder, 255)
99.     If lngResult <> 0 Then
100.         GetWinPath = Left$(strFolder, InStr(strFolder, Chr$(0)) - 1)
101.     Else
102.         GetWinPath = ""
103.     End If
104. End Function
106. '/
107. '/取SYSTEM路径
108. '/函数:GetSystemPath
109. '/参数:
110. '/返回值:SYSTEM目录路径.
111. '/说明：
112. Private Function GetSystemPath() As String
113.     Dim strFolder As String
114.     Dim lngResult As Long
115.     strFolder = String(255, Chr$(0))
116.     lngResult = GetSystemDirectory(strFolder, 255)
117.     If lngResult <> 0 Then
118.         GetSystemPath = Left$(strFolder, InStr(strFolder, Chr$(0)) - 1)
119.     Else
120.         GetSystemPath = ""
121.     End If
122. End Function
124. '/
125. '/取TEMP路径
126. '/函数:GetTmpPath
127. '/参数:
128. '/返回值:系统临时目录路径.
129. '/说明：
130. Private Function GetTmpPath() As String
131.     Dim strFolder As String
132.     Dim lngResult As Long
133.     strFolder = String(255, Chr$(0))
134.     lngResult = GetTempPath(255, strFolder)
135.     If lngResult <> 0 Then
136.         GetTmpPath = Left$(strFolder, InStr(strFolder, Chr$(0)) - 1)
137.     Else
138.         GetTmpPath = ""
139.     End If
140. End Function
142. '
143. '取特殊文件夹.
144. '函数:GetFolder
145. '参数:FolderID SysFolder枚举变量．
146. '返回值:所取文件路径．
147. '例子：
148. Public Function GetFolder(FolderID As SmSysFolder) As String
149.     Dim Pidl As Long, s As String
150.     Dim id As Long
151.     Dim ReturnVal As String
152.     id = FolderID
154.     If id > &H15& Then
155.        Select Case id
156.               Case Is = &H16
157.                    ReturnVal = GetWinPath
158.               Case Is = &H17
159.                    ReturnVal = GetSystemPath
160.               Case Is = &H18
161.                    ReturnVal = GetTmpPath
162.               Case Else
163.                    ReturnVal = ""
164.        End Select
165.     Else
166.         s = String(255, Chr$(0))
167.         If SHGetSpecialFolderLocation(0, id, Pidl) <> 0 Then
168.            ReturnVal = ""
169.            GoTo EndFun
170.         End If
171.         If SHGetPathFromIDList(Pidl, s) = 0 Then
172.            ReturnVal = ""
173.            GoTo EndFun
174.         End If
175.         ReturnVal = Left$(s, InStr(s, Chr$(0)) - 1)
176.     End If
177. EndFun:
178.     GetFolder = ReturnVal
179. End Function
181. '
182. '取当前WINDOWS用户名
183. '函数:UserName
184. '参数:
185. '返回值:当前WINDOWS用户名．
186. '例子：
187. Public Function UserName() As String
188.     Dim Cn As String
189.     Dim Ls As Long
190.     Dim res As Long
192.     Cn = String$(255, Chr$(0))
193.     Ls = 255
194.     res = GetUserName(Cn, Ls)
195.     If res <> 0 Then
196.         UserName = Mid$(Cn, 1, InStr(Cn, Chr$(0)) - 1)
197.     Else
198.         UserName = ""
199.     End If
200. End Function
202. '
203. '建立文件快捷方式.
204. '函数:CreateLink
205. '参数:
206. '       FileFullName       对应的文件全称.
207. '       IconLocation       图标路径
208. '       LinkFolder         快捷方式的系统位置(枚举).
209. '       UserLinkFolder     用户自定义快捷方式位置.
210. '       LinkName           快捷方式名称.
211. '       WorkingDirectory   工作目录.
212. '       Hotkey             热键.
213. '       WindowStyle        运行方式(枚举).
214. '返回值:无.
215. '例子：
216. '注:如果 UserLinkFolder 不为空.则 LinkFolder 无效,即:用户自定义位置优先.
217. Public Function CreateLink(FileFullName As String, _
218.                            Optional IconLocation As String = "", _
219.                            Optional LinkFolder As SmSysFolder = SmDeskTop, _
220.                            Optional UserLinkFolder As String = "", _
221.                            Optional LinkName As String = "", _
222.                            Optional WorkingDirectory As String = "", _
223.                            Optional Hotkey As String = "", _
224.                            Optional WindowStyle As SmWinStyle = SmNormalFocus)
226.     Dim GetName As New SmFileCls
227.     Dim WSH_shell As New IWshRuntimeLibrary.IWshShortcut_Class 'IWshRuntimeLibrary.WshShell
228.     Dim UrlLink As New IWshRuntimeLibrary.IWshShortcut_Class 'IWshRuntimeLibrary.WshShortcut
229.     Dim LinkPath As String
230.     Dim CreateDir As New SmFileCls
232.     On Error Resume Next
233.     
234.     If Len(Trim$(WorkingDirectory)) = 0 Then
235.        WorkingDirectory = GetName.FilePath(FileFullName)
236.     End If
237.     If Len(Trim$(LinkName)) = 0 Then
238.        LinkName = GetName.Filename(FileFullName)
239.     End If
240.     If UCase$(Right$(LinkName, 3)) <> "LNK" Then
241.        LinkName = LinkName & ".LNK"
242.     End If
243.     '/-----------------------------------------
244.     If Len(Trim$(UserLinkFolder)) > 0 Then
245.        LinkPath = UserLinkFolder
246.     ElseIf IsNumeric(LinkFolder) Then
247.        LinkPath = GetFolder(LinkFolder)
248.     Else
249.        Exit Function
250.     End If
251.     '/------------------------------------------
252.     If Right$(LinkPath, 1) <> "/" Then LinkPath = LinkPath & "/"
253.     If Len(Dir$(LinkPath, vbDirectory + vbHidden + vbReadOnly + vbSystem + vbAlias + vbNormal)) = 0 Then
254.        If Not CreateDir.CreateDir(LinkPath) Then
255.           Exit Function
256.        End If
257.     End If
258.     LinkPath = LinkPath & LinkName
259.     Set UrlLink = WSH_shell.CreateShortcut(LinkPath)
260.     With UrlLink
261.          .TargetPath = FileFullName
262.          .IconLocation = IconLocation
263.          .Hotkey = Hotkey
264.          .WorkingDirectory = WorkingDirectory   '起始位置
265.          .WindowStyle = WindowStyle             '开始样式
266.     End With
267.     UrlLink.Save '保存快捷方式
268.     Set WSH_shell = Nothing
269.     Set UrlLink = Nothing
270.     Set GetName = Nothing
271.     Set CreateDir = Nothing
272. End Function
274. '
275. '取当前鼠标的屏幕坐标值.
276. '函数:SmScrMouseXY
277. '参数:
278. '返回值:SmPointAPI结构体．
279. '例子：
280. Public Function SmScrMouseXY() As SmPointAPI
281.       Dim hCursorWnd As Long, Point As SmPointAPI
282.       Dim M_Scrxy As SmPointAPI
283.       GetCursorPos Point
284.       hCursorWnd = WindowFromPoint(Point.X, Point.Y)
285.       M_Scrxy.X = Point.X * 15: M_Scrxy.Y = Point.Y * 15
286. End Function
288. '
289. '移动鼠标到屏幕的指定点.
290. '函数:SmScrMouseXY
291. '参数:MouseX,MouseY
292. '返回值:
293. '例子：
294. Public Sub SmMoveMouse(MouseX As Long, MouseY As Long)
295.        SetCursorPos MouseX, MouseY
296. End Sub
298. '执行一段标准的VB代码.
299. '函数:ExecuteLine
300. '参数:sCode,fCheckOnly
301. '返回值:TRUE 成功执行.FALSE 执行失败.
302. '例子：ExecuteLine "Form2.show"
303. Public Function ExecuteLine(sCode As String, Optional fCheckOnly As Boolean) As Boolean
304.     ExecuteLine = EbExecuteLine(StrPtr(sCode), 0&, 0&, Abs(fCheckOnly)) = 0
305. End Function