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
VB中取各種系統路徑名,格式化磁盤,建立快捷方式,鼠標的定位,移動

VB中取各種系統路徑名,格式化磁盤,建立快捷方式,鼠標的定位,移動

sqlserver2005的KPI展示控件開發詳解

VB中對數據庫的各種操作.

Analysis Services MDX 中的重要概念

SQLSERVER2000 用過程來模擬MDX分析報表的效果(2)

Mac下配置sublime實現LaTeX

https://yachay.unat.edu.pe/blog/index.php?comment_area=format_blog&comment_component=blog&comment_co

linux以太網驅動總結
