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

Option Explicit

'

'系统操作(SmSysCls)

'

Const SW_SHOW = 5

Public Type SmPointAPI

X As Long

Y As Long

End Type

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

Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long

Private Declare Function GetCursorPos Lib "user32" (lpPoint As SmPointAPI) As Long

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

'/----------------------------------------------------------------

Private Declare Function SHGetSpecialFolderLocation Lib "Shell32" (ByVal hwndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As Long

Private Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal Pidl As Long, ByVal szPath As String) As Long

'/---------------------------------------------------------------

'/非常危险，小心使用。

Private Declare Function GetSystemDirectory Lib "kernel32" Alias _

"GetSystemDirectoryA" (ByVal lpBuffer As String, _

ByVal nSize As Long) As Long

Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Declare Function ShellExecute Lib "shell32.dll" Alias _

"ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation _

As String, ByVal lpFile As String, ByVal lpParameters _

As String, ByVal lpDirectory As String, ByVal nShowCmd _

As Long) As Long

'/-------------------------------------------------------------

Private Const HKEY_CLASSES_ROOT =

Private Const HKEY_CURRENT_USER =

Private Const HKEY_LOCAL_MACHINE =

Private Const HKEY_USERS =

Private Const HKEY_PERFORMANCE_DATA =

Private Const HKEY_CURRENT_CONFIG =

Private Const HKEY_DYN_DATA =

Private Const REG_NONE = 0

Private Const REG_SZ = 1

Private Const REG_EXPAND_SZ = 2

Private Const REG_BINARY = 3

Private Const REG_DWORD = 4

Private Const REG_DWORD_BIG_ENDIAN = 5

Private Const REG_MULTI_SZ = 7

'

'取计算机名

'函数:Get_ComputerName

'参数:无

'返回值:String,计算机名称

'例子：

Public Function Get_ComputerName() As String

Dim strString As String

strString = String(255, Chr$(0))

GetComputerName strString, 255

strString = Left$(strString, InStr(1, strString, Chr$(0)) - 1)

Get_ComputerName = strString

End Function

'

'格式化磁盘(危险)

'函数:FormatDisk

'参数:DiskName 磁盘名称，WinHwnd调用本函数的窗口句柄．

'返回值:无

'说明：

Public Function FormatDisk(DiskName As String, Optional WinHwnd As Long = 0)

Dim sFor As String

Dim sTemp As String

sFor = String(255, " ")

GetWindowsDirectory sFor, 255

sTemp = Left$(sFor, InStr(sFor, Chr$(0)) - 1) + "/rundll32.exe" _

+ Chr(0)

ShellExecute WinHwnd, vbNullString, sTemp, _

"Shell32.dll,SHFormatDrive" + Chr$(0), DiskName + Chr$(0), _

SW_SHOW

End Function

'/

'/取WINDOWS路径

'/函数:GetWinPath

'/参数:

'/返回值:WINDOWS目录路径.

'/说明：

Private Function GetWinPath() As String

Dim strFolder As String

Dim lngResult As Long

strFolder = String(255, Chr$(0))

lngResult = GetWindowsDirectory(strFolder, 255)

If lngResult <> 0 Then

GetWinPath = Left$(strFolder, InStr(strFolder, Chr$(0)) - 1)

Else

GetWinPath = ""

End If

End Function

'/

'/取SYSTEM路径

'/函数:GetSystemPath

'/参数:

'/返回值:SYSTEM目录路径.

'/说明：

Private Function GetSystemPath() As String

Dim strFolder As String

Dim lngResult As Long

strFolder = String(255, Chr$(0))

lngResult = GetSystemDirectory(strFolder, 255)

If lngResult <> 0 Then

GetSystemPath = Left$(strFolder, InStr(strFolder, Chr$(0)) - 1)

Else

GetSystemPath = ""

End If

End Function

'/

'/取TEMP路径

'/函数:GetTmpPath

'/参数:

'/返回值:系统临时目录路径.

'/说明：

Private Function GetTmpPath() As String

Dim strFolder As String

Dim lngResult As Long

strFolder = String(255, Chr$(0))

lngResult = GetTempPath(255, strFolder)

If lngResult <> 0 Then

GetTmpPath = Left$(strFolder, InStr(strFolder, Chr$(0)) - 1)

Else

GetTmpPath = ""

End If

End Function

'

'取特殊文件夹.

'函数:GetFolder

'参数:FolderID SysFolder枚举变量．

'返回值:所取文件路径．

'例子：

Public Function GetFolder(FolderID As SmSysFolder) As String

Dim Pidl As Long, s As String

Dim id As Long

Dim ReturnVal As String

id = FolderID

If id > &H15& Then

Select Case id

Case Is = &H16

ReturnVal = GetWinPath

Case Is = &H17

ReturnVal = GetSystemPath

Case Is = &H18

ReturnVal = GetTmpPath

Case Else

ReturnVal = ""

End Select

Else

s = String(255, Chr$(0))

If SHGetSpecialFolderLocation(0, id, Pidl) <> 0 Then

ReturnVal = ""

GoTo EndFun

End If

If SHGetPathFromIDList(Pidl, s) = 0 Then

ReturnVal = ""

GoTo EndFun

End If

ReturnVal = Left$(s, InStr(s, Chr$(0)) - 1)

End If

EndFun:

GetFolder = ReturnVal

End Function

'

'取当前WINDOWS用户名

'函数:UserName

'参数:

'返回值:当前WINDOWS用户名．

'例子：

Public Function UserName() As String

Dim Cn As String

Dim Ls As Long

Dim res As Long

Cn = String$(255, Chr$(0))

Ls = 255

res = GetUserName(Cn, Ls)

If res <> 0 Then

UserName = Mid$(Cn, 1, InStr(Cn, Chr$(0)) - 1)

Else

UserName = ""

End If

End Function

'

'建立文件快捷方式.

'函数:CreateLink

'参数:

' FileFullName 对应的文件全称.

' IconLocation 图标路径

' LinkFolder 快捷方式的系统位置(枚举).

' UserLinkFolder 用户自定义快捷方式位置.

' LinkName 快捷方式名称.

' WorkingDirectory 工作目录.

' Hotkey 热键.

' WindowStyle 运行方式(枚举).

'返回值:无.

'例子：

'注:如果 UserLinkFolder 不为空.则 LinkFolder 无效,即:用户自定义位置优先.

Public Function CreateLink(FileFullName As String, _

Optional IconLocation As String = "", _

Optional LinkFolder As SmSysFolder = SmDeskTop, _

Optional UserLinkFolder As String = "", _

Optional LinkName As String = "", _

Optional WorkingDirectory As String = "", _

Optional Hotkey As String = "", _

Optional WindowStyle As SmWinStyle = SmNormalFocus)

Dim GetName As New SmFileCls

Dim WSH_shell As New IWshRuntimeLibrary.IWshShortcut_Class 'IWshRuntimeLibrary.WshShell

Dim UrlLink As New IWshRuntimeLibrary.IWshShortcut_Class 'IWshRuntimeLibrary.WshShortcut

Dim LinkPath As String

Dim CreateDir As New SmFileCls

On Error Resume Next

If Len(Trim$(WorkingDirectory)) = 0 Then

WorkingDirectory = GetName.FilePath(FileFullName)

End If

If Len(Trim$(LinkName)) = 0 Then

LinkName = GetName.Filename(FileFullName)

End If

If UCase$(Right$(LinkName, 3)) <> "LNK" Then

LinkName = LinkName & ".LNK"

End If

'/-----------------------------------------

If Len(Trim$(UserLinkFolder)) > 0 Then

LinkPath = UserLinkFolder

ElseIf IsNumeric(LinkFolder) Then

LinkPath = GetFolder(LinkFolder)

Else

Exit Function

End If

'/------------------------------------------

If Right$(LinkPath, 1) <> "/" Then LinkPath = LinkPath & "/"

If Len(Dir$(LinkPath, vbDirectory + vbHidden + vbReadOnly + vbSystem + vbAlias + vbNormal)) = 0 Then

If Not CreateDir.CreateDir(LinkPath) Then

Exit Function

End If

End If

LinkPath = LinkPath & LinkName

Set UrlLink = WSH_shell.CreateShortcut(LinkPath)

With UrlLink

.TargetPath = FileFullName

.IconLocation = IconLocation

.Hotkey = Hotkey

.WorkingDirectory = WorkingDirectory '起始位置

.WindowStyle = WindowStyle '开始样式

End With

UrlLink.Save '保存快捷方式

Set WSH_shell = Nothing

Set UrlLink = Nothing

Set GetName = Nothing

Set CreateDir = Nothing

End Function

'

'取当前鼠标的屏幕坐标值.

'函数:SmScrMouseXY

'参数:

'返回值:SmPointAPI结构体．

'例子：

Public Function SmScrMouseXY() As SmPointAPI

Dim hCursorWnd As Long, Point As SmPointAPI

Dim M_Scrxy As SmPointAPI

GetCursorPos Point

hCursorWnd = WindowFromPoint(Point.X, Point.Y)

M_Scrxy.X = Point.X * 15: M_Scrxy.Y = Point.Y * 15

End Function

'

'移动鼠标到屏幕的指定点.

'函数:SmScrMouseXY

'参数:MouseX,MouseY

'返回值:

'例子：

Public Sub SmMoveMouse(MouseX As Long, MouseY As Long)

SetCursorPos MouseX, MouseY

End Sub

'执行一段标准的VB代码.

'函数:ExecuteLine

'参数:sCode,fCheckOnly

'返回值:TRUE 成功执行.FALSE 执行失败.

'例子：ExecuteLine "Form2.show"

Public Function ExecuteLine(sCode As String, Optional fCheckOnly As Boolean) As Boolean

ExecuteLine = EbExecuteLine(StrPtr(sCode), 0&, 0&, Abs(fCheckOnly)) = 0

End Function