学习VBAVBA常用功能方法（一）

一下提供一些VBA经常用的函数调用：

Private Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As Long
Private Declare Function RegCloseKey Lib "ADVAPI32.DLL" (ByVal hKey As Long) As Long
Private Declare Function RegSetValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByVal dwType As Long, ByVal sValue As String, ByVal dwSize As Long) As Long
Private Declare Function RegCreateKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As Long
Private Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByRef lValueType As Long, ByVal sValue As String, ByRef lResultLen As Long) As Long

Function GetRegistry(Key, Path, ByVal ValueName As String)
    Dim hKey As Long
    Dim lValueType As Long
    Dim sResult As String
    Dim lResultLen As Long
    Dim ResultLen As Long
    Dim x, TheKey As Long

    TheKey = -99
    Select Case UCase(Key)
        Case "HKEY_CLASSES_ROOT": TheKey = &H80000000
        Case "HKEY_CURRENT_USER": TheKey = &H80000001
        Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002
        Case "HKEY_USERS": TheKey = &H80000003
        Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004
        Case "HKEY_DYN_DATA": TheKey = &H80000005
    End Select
    
    If TheKey = -99 Then
        GetRegistry = "Not Found"
        Exit Function
    End If

    If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then _
        x = RegCreateKeyA(TheKey, Path, hKey)
    
    sResult = Space(100)
    lResultLen = 100
    
    x = RegQueryValueExA(hKey, ValueName, 0, lValueType, _
    sResult, lResultLen)
        
    Select Case x
        Case 0: GetRegistry = Left(sResult, lResultLen - 1)
        Case Else: GetRegistry = "Not Found"
    End Select
    
    RegCloseKey hKey
End Function

Function WriteRegistry(ByVal Key As String, _
    ByVal Path As String, ByVal entry As String, _
    ByVal value As String)
    
    Dim hKey As Long
    Dim lValueType As Long
    Dim sResult As String
    Dim lResultLen As Long
   
    TheKey = -99
    Select Case UCase(Key)
        Case "HKEY_CLASSES_ROOT": TheKey = &H80000000
        Case "HKEY_CURRENT_USER": TheKey = &H80000001
        Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002
        Case "HKEY_USERS": TheKey = &H80000003
        Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004
        Case "HKEY_DYN_DATA": TheKey = &H80000005
    End Select
    
    If TheKey = -99 Then
        WriteRegistry = False
        Exit Function
    End If

    If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then
        x = RegCreateKeyA(TheKey, Path, hKey)
    End If

    x = RegSetValueExA(hKey, entry, 0, 1, value, Len(value) + 1)
    If x = 0 Then WriteRegistry = True Else WriteRegistry = False
End Function

 '取得文件夹里文档的数目
 Sub tutorial_5_1()
    Dim dirStr As String
    Dim FileCount As Long
    dirStr = "c:\"
    With New IWshRuntimeLibrary.FileSystemObject
        FileCount = .GetFolder(dirStr).Files.Count
    End With
    MsgBox FileCount, vbInformation
End Sub

 '取得文件夹子目录数目
 Sub tutorial_5_2()
    Dim dirStr As String
    Dim FileCount As Long
    dirStr = "c:\"
    With New IWshRuntimeLibrary.FileSystemObject
        FileCount = .GetFolder(dirStr).SubFolders.Count
    End With
    MsgBox FileCount, vbInformation
End Sub

'取得磁盘可用容量
Sub tutorial_5_3()
    Dim myDrive As IWshRuntimeLibrary.Drive
    Dim i As Long
    Dim myValue() As Variant
    Const fletter As Long = 1
    Const ffreespace As Long = 2
    With New IWshRuntimeLibrary.FileSystemObject
        ReDim myValue(1 To .Drives.Count, fletter To ffreespace) As Variant
        For Each myDrive In .Drives
            i = i + 1
            With myDrive
                myValue(i, fletter) = .DriveLetter
                If .IsReady Then myValue(i, ffreespace) = .FreeSpace
            End With
        Next
    End With
    For i = 1 To UBound(myValue, 1)
    
    MsgBox myValue(i, fletter) & " : " & Format(myValue(i, ffreespace), "#,##0")
    Next i
End Sub

'取得系统文件夹
Sub tutorial_5_4()
    Dim mypath As String
    With New IWshRuntimeLibrary.FileSystemObject
        mypath = .GetSpecialFolder(SystemFolder)
    End With
    MsgBox mypath, vbInformation
End Sub

'取得桌面路径
Sub tutorial_5_5()
    Dim mypath As String
    With New IWshRuntimeLibrary.WshShell
        mypath = .SpecialFolders("Desktop")
    End With
    MsgBox mypath, vbInformation
End Sub

'取得电脑名称
Sub tutorial_5_6()
    Dim myStr As String
    With New IWshRuntimeLibrary.WshNetwork
        myStr = .ComputerName
    End With
    MsgBox myStr, vbInformation
End Sub

'使用者名称
Sub tutorial_5_7()
    Dim myStr As String
    With New IWshRuntimeLibrary.WshNetwork
        myStr = .UserName
    End With
    MsgBox myStr, vbInformation
End Sub

'复制档案
Sub tutorial_5_8()
    FileCopy "C:\temp.csv", "C:\temp.xls"
End Sub

'重命名档案
Sub tutorial_5_9()
    Name "C:\temp.xls" As "C:\temp2.xls"
End Sub

'复制资料夹
Sub tutorial_5_10()
    Dim fso As Object
    Dim FromPath As String
    Dim ToPath As String
    FromPath = "C:\swsetup"
    ToPath = "C:\swsetup2"
    Set fso = CreateObject("scripting.filesystemobject")
    fso.CopyFolder Source:=FromPath, Destination:=ToPath
End Sub

'重命名资料夹
Sub tutorial_5_11()
    Dim fso As Object
    Dim FromPath As String
    Dim ToPath As String
    FromPath = "C:\swsetup"
    ToPath = "C:\swsetup1"
    Set fso = CreateObject("scripting.filesystemobject")
    If fso.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If
    If fso.FolderExists(ToPath) = True Then
        MsgBox ToPath & " exist, not possible to move to a existing folder"
        Exit Sub
    End If
    fso.MoveFolder Source:=FromPath, Destination:=ToPath
End Sub

'删除档案
Sub tutorial_5_12()
    On Error Resume Next
    Kill "C:\swsetup\SP31858A\*.*"
    On Error GoTo 0
End Sub

'删除指定类型档案
Sub tutorial_5_13()
    On Error Resume Next
    Kill "C:\swsetup\SP31858A\*.xl*"
    On Error GoTo 0
End Sub

'暂存资料夹
Sub tutorial_5_14()
    MsgBox Environ("Temp")
End Sub

'列出已开启的项目
Sub tutorial_5_15()
    Dim WD, task, N As Long
    Set WD = CreateObject("Word.Application")
    For Each task In WD.Tasks
        If task.Visible = True Then
            N = N + 1
            Cells(N, 1) = task.Name
        End If
    Next
    WD.Quit
    Set WD = Nothing
End Sub

'讲ie关闭
Sub tutorial_5_16()
    Dim WD
    Set WD = CreateObject("Word.Application")
    If WD.Tasks.Exists("Internet Explorer") Then
        WD.Tasks("Internet Explorer").Close
    End If
    WD.Quit
    Set WD = Nothing
End Sub

'播放音乐
Sub tutorial_5_17()
    FullFileName = "C:\Windows\media\ringin.wav"
    ActiveWorkbook.FollowHyperlink Address:=FullFileName
End Sub

'判断工资表是否已经存在
Function tutorial_5_18(sname) As Boolean
    Dim x As Object
    On Error Resume Next
    Set x = ActiveWorkbook.Sheets(sname)
    If Err = 0 Then SheetExists = True _
        Else SheetExists = False
End Function

'判断workbook是否已经开启
Function tutorial_5_19(wbname) As Boolean
    Dim x As Workbook
    On Error Resume Next
    Set x = Workbooks(wbname)
    If Err = 0 Then WorkbookIsOpen = True _
        Else WorkbookIsOpen = False
End Function

'到Gmail
Sub tutorial_5_20()
    With CreateObject("InternetExplorer.Application")
        .Visible = True
        .navigate "http://www.gmail.com"
        Do Until .readyState = 4
            DoEvents
        Loop
        .document.Forms(0).all("email").value = "id"
        .document.Forms(0).all("passwd").value = "password"
        .document.Forms(0).all("signIn").Click
    End With
End Sub

'到QQ
Sub tutorial_5_21()
    With CreateObject("InternetExplorer.Application")
        .Visible = True
        .navigate "http://www.huaxiafax.com/"
        Do Until .readyState = 4
            DoEvents
        Loop
        .document.Forms(0).all("usernameshow").value = "id"
        .document.Forms(0).all("pwshow").value = "password"
    End With
End Sub

'状态栏
Sub tutorial_5_22()
    Application.StatusBar = "信息写在这"
End Sub

'压缩ZIP
Sub tutorial_5_23()
    Dim ShellApp As Object
    Dim FileNameZip As Variant
    Dim FileNames As Variant
    Dim i As Long, FileCount As Long

    FileNames = Application.GetOpenFilename(FileFilter:="All Files (*.*),*.*", FilterIndex:=1, Title:="Select the files to ZIP", MultiSelect:=True)

    If Not IsArray(FileNames) Then Exit Sub

    FileCount = UBound(FileNames)
    FileNameZip = Application.DefaultFilePath & "\compressed.zip"

    Open FileNameZip For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1

    Set ShellApp = CreateObject("Shell.Application")
    For i = LBound(FileNames) To UBound(FileNames)
        ShellApp.Namespace(FileNameZip).CopyHere FileNames(i)
    Next i

    On Error Resume Next
    Do Until ShellApp.Namespace(FileNameZip).items.Count = FileCount
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop

    If MsgBox(FileCount & " files were zipped to:" & vbNewLine & FileNameZip & vbNewLine & vbNewLine & "View the zip file?", vbQuestion + vbYesNo) = vbYes Then
        Shell "Explorer.exe /e," & FileNameZip, vbNormalFocus
    End If
End Sub

'解压Unzip
Sub tutorial_5_24()
    Dim ShellApp As Object
    Dim TargetFile
    Dim ZipFolder

    TargetFile = Application.GetOpenFilename(FileFilter:="Zip Files (*.zip), *.zip")
    If TargetFile = False Then Exit Sub

    ZipFolder = Application.DefaultFilePath & "\Unzipped\"

    On Error Resume Next
    RmDir ZipFolder
    MkDir ZipFolder
    On Error GoTo 0

    Set ShellApp = CreateObject("Shell.Application")
    ShellApp.Namespace(ZipFolder).CopyHere _
       ShellApp.Namespace(TargetFile).items

    If MsgBox("The files was unzipped to:" & vbNewLine & ZipFolder & vbNewLine & vbNewLine & "View the folder?", vbQuestion + vbYesNo) = vbYes Then
        Shell "Explorer.exe /e," & ZipFolder, vbNormalFocus
    End If
End Sub

'更新注册UpdateReg
Sub tutorial_5_25()
    RootKey = "hkey_current_user"
    Path = "software\Compal\VBA\ABO_FAI"
    RegEntry = "FilePath"
    RegVal = "U:\E-Bidding Project\"

    Call WriteRegistry(RootKey, Path, RegEntry, RegVal)
End Sub

'获取注册GetReg
Sub tutorial_5_26()
    RootKey = "hkey_current_user"
    Path = "software\Compal\VBA\ABO_FAI"
    RegEntry = "FilePath"
    MsgBox GetRegistry(RootKey, Path, RegEntry), vbInformation, Path & "\RegEntry"
End Sub

'连接网络（局域网）磁盘
Sub tutorial_5_27()
    Dim myWshNw As WshNetwork
    Set myWshNw = CreateObject("Wscript.Network")
    myWshNw.MapNetworkDrive "H:", "\\10.128.2.19\Download"
End Sub

'中断网络磁盘
Sub tutorial_5_28()
    Dim myWshNw As WshNetwork
    Set myWshNw = CreateObject("Wscript.Network")
    myWshNw.RemoveNetworkDrive "H:"
End Sub

'Mail选择的区块
Sub tutorial_5_29()
    Dim Rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set Rng = Nothing
    On Error Resume Next
    Set Rng = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "shengming_lee@compal.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(Rng)
        .Send
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Function RangetoHTML(Rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    Rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    TempWB.Close savechanges:=False
 
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

'发送Mail,不跳出提示
Sub tutorial_5_30()
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    strbody = "Hi there" & vbNewLine & vbNewLine & _
              "This is line 1" & vbNewLine & _
              "This is line 2" & vbNewLine & _
              "This is line 3" & vbNewLine & _
              "This is line 4"
        iConf.Load -1
        Set Flds = iConf.Fields
        With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "webmail.compal.com"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With

    With iMsg
        Set .Configuration = iConf
        .To = "shengming_lee@compal.com"
        .CC = ""
        .BCC = ""
        .From = """Shengming"" <shengming_lee@compal.com>"
        .Subject = "Important message"
        .TextBody = strbody
        .Send
    End With
End Sub

'特定栏位找资料，并移除该栏位
Sub tutorial_5_31()
    Dim FindString As String
    Dim Rng As Range
    FindString = InputBox("Enter a Search value")
    If Trim(FindString) <> "" Then
        With Sheets("Sheet2").Range("A:A")
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
End Sub

'回传数组范围
Sub tutorial_5_32()
    t = Test
    MsgBox UBound(t, 1)
    MsgBox UBound(t, 2)
End Sub
Function Test() As Variant
    Dim CallerRows As Long
    Dim CallerCols As Long
    Dim CallerAddr As String
    Dim Result() As Long
    Dim N As Long
    Dim RowNdx As Long
    Dim ColNdx As Long
        
    With Application.ActiveSheet
        CallerRows = .UsedRange.Rows.Count
        CallerCols = .UsedRange.Columns.Count
    End With
    ReDim Result(1 To CallerRows, 1 To CallerCols)
    For RowNdx = 1 To CallerRows
        For ColNdx = 1 To CallerCols
            N = N + 1
            Result(RowNdx, ColNdx) = N
        Next ColNdx
     Next RowNdx
     Test = Result
End Function

我们使用一些功能的时候也要增加一些程序集vba增加程序集步骤：

1.

2.

outlook：

outlook代码：

Set File_Search = Excel.Application.filesearch
    rPath = "d:\aa"
查找文件夹aa下文件excel数量，
    With File_Search
        .NewSearch
        .fileName = "*.xls"
        .LookIn = rPath
        .SearchSubFolders = True
        .Execute msoSortByFileName, msoSortOrderAscending
        If .Execute > 0 Then
           filecount = .FoundFiles.count
        Else
           filecount = 0
        End If
    End With
    查找文件夹aa下文件csv数量，
        With File_Search
        .NewSearch
        .fileName = "*.csv"
        .LookIn = rPath
        .SearchSubFolders = True
        .Execute msoSortByFileName, msoSortOrderAscending
        If .Execute > 0 Then
           csvcount = .FoundFiles.count
        Else
           csvcount = 0
        End If
    End With
    
    doYN = MsgBox("Please confirm you didn't select extra files about ESL,APCC." & vbCrLf & " Especially of ESL return files! ", vbYesNo, "Save file to this path ?")
    If doYN = vbYes Then
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists("d:\GDS_HUB_Report_Used_by_Rita") Then
        'Set f = fso.getFOLDER("d:\GDS_HUB_Report_Used_by_Rita") '判斷文件是否存在
          'fso.DeleteFolder ("d:\GDS_HUB_Report_Used_by_Rita")
          'If fso.getFOLDER("d:\GDS_HUB_Report_Used_by_Rita") Then
          If filecount > 0 Or csvcount > 0 Then
          删除所有文件
Kill "D:\GDS_HUB_Report_Used_by_Rita\*.*"
          End If
          'End If
           'f.Delete
        'MkDir "D:\GDS_HUB_Report_Used_by_Rita"
         'Shell "del d:\GDS_HUB_Report_Used_by_Rita\*.*", 1
    Else
            MkDir "D:\GDS_HUB_Report_Used_by_Rita"
    End If