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

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

没有更多推荐了,返回首页

©️2019 CSDN 皮肤主题: 大白 设计师: CSDN官方博客

分享到微信朋友圈

×

扫一扫,手机浏览