常用api模块

作者:admin 日期:2008-06-17

字体大小: 小中大

Option Explicit
'*****************************************************************
'*              通用模块，建立于2005年11月10日                   *
'*                                                               *
'*                                                   wstar        *
'*****************************************************************

'打开、另存文件对话框
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Type OPENFILENAME
     lStructSize As Long
     hwndOwner As Long
     hInstance As Long
     lpstrFilter As String
     lpstrCustomFilter As String
     nMaxCustFilter As Long
     nFilterIndex As Long
     lpstrFile As String
     nMaxFile As Long
     lpstrFileTitle As String
     nMaxFileTitle As Long
     lpstrInitialDir As String
     lpstrTitle As String
     flags As Long
     nFileOffset As Integer
     nFileExtension As Integer
     lpstrDefExt As String
     lCustData As Long
     lpfnHook As Long
     lpTemplateName As String
End Type

'打开目录对话框
Public Declare Function SHGetPathFromIDList Lib "Shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHBrowseForFolder Lib "Shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
   hOwner           As Long
   pidlRoot         As Long
   pszDisplayName   As String
   lpszTitle        As String
   ulFlags          As Long
   lpfn             As Long
   lParam           As Long
   iImage           As Long
End Type
Public Const BIF_RETURNONLYFSDIRS = &H1
Public pidl As Long

'读取INI文件
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

'移动、复制、删除目录
Declare Function SHFileOperation Lib "Shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Type SHFILEOPSTRUCT
hwnd As Long '窗口句柄
wFunc As Long '执行的操作
pFrom As String '原地点
pTo As String '目标地点
fFlags As Long '操作执行方式
fAnyOperationsAborted As Long '错误代码返回
hNameMappings As Long
lpszProgressTitle As String
End Type
Public Const FO_MOVE As Long = &H1
Public Const FO_COPY As Long = &H2
Public Const FO_Delete As Long = &H3
Public Const FO_RENAME As Long = &H4
Public Const FOF_MULTIDESTFILES As Long = &H1
Public Const FOF_CONFIRMMOUSE As Long = &H2
Public Const FOF_SILENT As Long = &H4
Public Const FOF_RENAMEONCOLLISION As Long = &H8
Public Const FOF_NOCONFIRMATION As Long = &H10
Public Const FOF_WANTMAPPINGHANDLE As Long = &H20
Public Const FOF_CreatePROGRESSDLG As Long = &H0
Public Const FOF_ALLOWUNDO As Long = &H40
Public Const FOF_FILESONLY As Long = &H80
Public Const FOF_SIMPLEPROGRESS As Long = &H100
Public Const FOF_NOCONFIRMMKDIR As Long = &H200

'读写注册表
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002

Function wReadIni(wAppName As String, wKeyName As String, wIniFilePath As String) As String
   Dim RetStr As String
   RetStr = String(255, Chr(0))
   wReadIni = Left(RetStr, GetPrivateProfileString(wAppName, ByVal wKeyName, "", RetStr, Len(RetStr), wIniFilePath))
End Function

Function wWriteIni(wAppName As String, wKeyName As String, wText As String, wIniFilePath As String) As Long
   wWriteIni = WritePrivateProfileString(wAppName, wKeyName, wText, wIniFilePath)
End Function

Function wCutFolder(wSource As String, wDestination As String, wHwnd As Long) As Long
    Dim DelFileOp As SHFILEOPSTRUCT

    With DelFileOp
        .hwnd = wHwnd

        .wFunc = FO_MOVE '(这三行代码完成移动)
        .pFrom = wSource & vbNullChar & vbNullChar
        .pTo = wDestination

        .fFlags = FOF_NOCONFIRMATION
    End With
    wCutFolder = SHFileOperation(DelFileOp)
End Function

Function wCopyFolder(wSource As String, wDestination As String, wHwnd As Long) As Long
    Dim DelFileOp As SHFILEOPSTRUCT

    With DelFileOp
        .hwnd = wHwnd

        .wFunc = FO_COPY '(这三行代码完成拷贝)
        .pFrom = wSource & vbNullChar & vbNullChar
        .pTo = wDestination

        .fFlags = FOF_NOCONFIRMATION
    End With
    wCopyFolder = SHFileOperation(DelFileOp)
End Function
Function wDelFolder(wFoldPath As String, wHwnd As Long) As Long
    Dim DelFileOp As SHFILEOPSTRUCT

    With DelFileOp
        .hwnd = wHwnd

        .wFunc = FO_Delete '(这两行代码完成删除)
        .pFrom = wFoldPath & vbNullChar & vbNullChar

        .fFlags = FOF_NOCONFIRMATION
    End With
    wDelFolder = SHFileOperation(DelFileOp)
End Function

Function wSelectFolder(wCaption As String, wHwnd As Long) As String
    Dim bi As BROWSEINFO
    Dim r As Long
    Dim pidl As Long
    Dim path As String
    Dim pos As Integer
    '句柄
    bi.hOwner = wHwnd
    '展开根目录
    bi.pidlRoot = 0&
    '列表框标题
    bi.lpszTitle = wCaption
    '规定只能选择文件夹，其他无效
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    '调用API函数显示列表框
    pidl = SHBrowseForFolder(bi)
    '利用API函数获取返回的路径
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal pidl&, ByVal path)
    If r Then
          pos = InStr(path, Chr$(0))
          wSelectFolder = Left(path, pos - 1)
    Else
          wSelectFolder = ""
    End If
End Function

Function wOpenFile(wCaption As String, wFilter As String, wHwnd As Long) As String
    Dim ofn As OPENFILENAME
    Dim rtn As String

    ofn.lStructSize = Len(ofn)
    ofn.hwndOwner = wHwnd
    ofn.hInstance = App.hInstance
    ofn.lpstrFilter = wFilter
    '"文本文件 (*.TXT)" + Chr$(0) + "*.TXT" + Chr$(0) + "所有文件 (*.*)" + Chr$(0) + "*.*" + Chr$(0)
    ofn.lpstrFile = Space(254)
    ofn.nMaxFile = 255
    ofn.lpstrFileTitle = Space(254)
    ofn.nMaxFileTitle = 255
    ofn.lpstrInitialDir = App.path
    ofn.lpstrTitle = wCaption
    ofn.flags = 6148

    rtn = GetOpenFileName(ofn)

    If rtn >= 1 Then
        wOpenFile = ofn.lpstrFile
    Else
        wOpenFile = ""
    End If
End Function

Function wSaveFile(wCaption As String, wFilter As String, wHwnd As Long) As String
    Dim i As Integer
    Dim ofn As OPENFILENAME
    Dim filename As String
    ofn.lStructSize = Len(ofn)
    ofn.hwndOwner = wHwnd
    ofn.hInstance = App.hInstance
    ofn.lpstrFile = Space(254)
    ofn.nMaxFile = 255
    ofn.lpstrFileTitle = Space(254)
    ofn.nMaxFileTitle = 255
    ofn.lpstrInitialDir = App.path
    ofn.flags = 6148
    '过虑对话框文件类型
    ofn.lpstrFilter = wFilter
    '"文本文件 (*.TXT)" + Chr$(0) + "*.TXT" + Chr$(0) + "所有文件 (*.*)" + Chr$(0) + "*.*" + Chr$(0)

    '对话框标题栏文字
    ofn.lpstrTitle = wCaption
    i = GetSaveFileName(ofn) '显示保存文件对话框
    If i >= 1 Then '取得对话中用户选择输入的文件名及路径
        filename = ofn.lpstrFile
        wSaveFile = Left(filename, InStr(filename, Chr(0)) - 1)
    End If
End Function

Function wReadReg(wMainKey As Long, wKeySubPath As String, wSubKey As String) As Variant '参数顺序为：根键，子路径主键，键名
    Dim rqveValue, apiFunHandle, apiFunData, apiFunType As Long
    Dim srqvStr As String
    If RegOpenKeyEx(wMainKey, wKeySubPath, 0&, &H20019, apiFunHandle) <> 0& Then Exit Function

    rqveValue = RegQueryValueEx(apiFunHandle, wSubKey, 0&, apiFunType, ByVal srqvStr, apiFunData)
    srqvStr = Space(apiFunData)
    rqveValue = RegQueryValueEx(apiFunHandle, wSubKey, 0&, apiFunType, ByVal srqvStr, apiFunData)

    If RegCloseKey(apiFunHandle) <> 0& Then apiFunType = -1&
    wReadReg = srqvStr
End Function

Function wWriteReg(wMainKey As Long, wKeySubPath As String, ParamArray SKnKV()) As Boolean '参数顺序为：根键、子路径主键、要建立的键名,键值列表，（可以一次调用本函数来建立多个同路径的键名，但键值只能为字符串，一只调用最多是16383个），如果写入正确，则函数返回true
    Dim KeyLong As Long
    Dim Revalue As Long
    Dim Keyvalue As String
    Dim Sk() As String, Kv() As String
    Dim SkKvNum As Integer
    Dim i As Integer, Scl As Integer
    SkKvNum = (UBound(SKnKV) + 1) / 2
    ReDim Sk(SkKvNum)
    ReDim Kv(SkKvNum)
    For i = 1 To SkKvNum
        Sk(i) = SKnKV(Scl)
        Scl = Scl + 1
        Kv(i) = SKnKV(Scl)
        Scl = Scl + 1
    Next
    Revalue = RegCreateKey(wMainKey, wKeySubPath, KeyLong)
    For i = 1 To SkKvNum
        Revalue = RegSetValueEx(KeyLong, Sk(i), 0&, 1, ByVal Kv(i), Len(Kv(i)) + 1)
    Next
    wWriteReg = True
    If Err <> 0 Then
        Err = 0
        wWriteReg = False
    End If
End Function

Function wProgress(wPictureBox As Control, ByVal wPercent)
    Dim Num As String
    Dim BarString As String
    If Not wPictureBox.AutoRedraw Then
        wPictureBox.AutoRedraw = -1
    End If
    wPictureBox.Cls
    wPictureBox.ScaleWidth = 100
    wPictureBox.DrawMode = 10
    Num = BarString & Format$(wPercent, "###") + "%"
    wPictureBox.CurrentX = 50 - wPictureBox.TextWidth(Num) / 2
    wPictureBox.CurrentY = (wPictureBox.ScaleHeight - wPictureBox.TextHeight(Num)) / 2
    wPictureBox.Print Num
    wPictureBox.Line (0, 0)-(wPercent, wPictureBox.ScaleHeight), RGB(22, 17, 238), BF
    wPictureBox.Refresh
End Function

'引用自http://topic.csdn.net/u/20080529/00/573e70c3-e6c5-43be-86da-8654e8fb841b.html
感谢wstar