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

最新推荐文章于 2020-12-07 19:17:57 发布
华芸智森
最新推荐文章于 2020-12-07 19:17:57 发布
阅读量2k
点赞数
分类专栏： VB 文章标签：磁盘 vb string windows shell performance
本文链接：https://blog.csdn.net/MSTOP/article/details/3053437
版权
VB 专栏收录该内容
19 篇文章 0 订阅
订阅专栏
 
 
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
 
华芸智森
关注
0
点赞
踩
1

收藏

觉得还不错? 一键收藏
1
评论
VB中取各种系统路径名,格式化磁盘,建立快捷方式,鼠标的定位,移动

Option Explicit 系统操作(SmSysCls) Const SW_SHOW = 5Public Type SmPointAPI X As Long Y As LongEnd TypePrivate Declare Function EbExecuteLine Lib "vba6.
复制链接

扫一扫