VBA编写笔记：常用的对象和方法

友人a丶
VBA笔记
2021-08-12
1210热度
0评论

常用对象和方法

Application对象

1. Application.ScreenUpdating 属性

如果启用屏幕更新，则该属性值为 True。Boolean 类型，可读写。
关闭屏幕更新可加快宏的执行速度。这样将看不到宏的执行过程，但宏的执行速度加快了。
当宏结束运行后，请记住将 ScreenUpdating 属性设置回 True。

2. Application.FileDialog 属性

返回一个 FileDialog 对象，该对象表示文件对话框的实例

TypeName 函数

返回一个 String，提供有关变量的信息。

TypeName(varname)，必要的 varname 参数是一个 Variant，它包含用户定义类型变量之外的任何变量。

Application.Volatile 方法

用于将用户自定义函数标记为易失性函数，无论何时在工作表的任意单元格中进行计算时，易失性函数都必须重新进行计算。非易失性函数只在输入变量改变时才重新计算，若不用于计算工作表单元格的用户自定义函数中，则此方法无效。

记录

GetObject获取的表格对象是多应用模式。workbooks.open则是单应用，多应用存在跨应用调用问题。GetObject相当于存在了两个Application，而workbooks.open还是一个。
unprotect解除工作表保护，protect 保护工作表，同样适用于工作簿。
range对象的offset属性能整体偏移选择其它范围，并返回它的range对象。

VB中数组维度的问题

Ubound(array,dimenssion)，获取指定数组的指定维度的维数上限。
Lbound(array,dimenssion)，获取指定数组的指定维度的维数下限。

Application.DisplayAlerts函数

Application.DisplayAlerts = False，禁用OFFICE出错时的错误提示。

WorksheetFunction 对象

用作可从 Visual Basic 中调用的 Microsoft Excel 工作表函数的容器。

Set myRange = Worksheets("Sheet1").Range("A1:C10")
answer = Application.WorksheetFunction.Min(myRange)
MsgBox answer

VBA中常用的COM对象

scripting.dictionary，字典对象。
wscript.shell，激活指定窗口，发送按键指令，运行程序，弹出提醒框等等。
scripting.filesystemobject，文件系统的对象。
shell.application，操作窗口排列等等
Internet.application ，IE浏览器
VBScript.RegExp，正则对象
MSXML2.XmlHttp，用于HTTP获取数据（GET、POST）
WinHttp.WinHttpRequest.5.1，用于HTTP获取数据（GET、POST）

踩坑

模块中的变量需要用public标志，才能在表格对象中使用。

Application.CutCopyMode

Application.CutCopyMode = False，清除复制和剪切的状态

Application.onkey 和 sendKey

发送键盘按键信息，以及指定按键触发的时候执行指定的操作。

Application.onTime/onRepeat/onUndo/onKey

到达指定时间、撤销、重做、按下指定按键时触发执行指定的操作，可以递归调用自身，实现类似Timer的功能。

Excel 控制word的时候，要注意

录制的宏里的常量是word环境下的，在Excel里要适配一下。

表格插入控件

可插入的控件分为表单控件和activex控件。表单控件只能通过shapes对象去获取，activex对象可以直接操作。

Set a = ActiveDocument.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=2)
a.Delete

VB笔记

1.CommonDialog

CommonDialog1.ShowOpen打开对话框

参考：https://www.jb51.net/softjc/684049.html

2.表格按行数量拆分

Sub SplitTableIntoFiles()
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long
    Dim rowCounter As Long
    Dim rowCount As Long
    Dim fileCounter As Long
    
    Set ws = ThisWorkbook.ActiveSheet ' 替换为你要处理的工作表
    Set rng = ws.Range("A1") ' 替换为您要处理的表格的起始单元格
    
    ' 设置每个文件中的行数
    rowCount = 7000 ' 替换为你想要的行数
    
    lastRow = ws.Cells(ws.Rows.Count, rng.Column).End(xlUp).Row
    fileCounter = 1
    rowCounter = 0
    
    Do While rowCounter < lastRow
        ' 创建新的工作簿
        Workbooks.Add
        With ActiveSheet
            ' 复制指定行数的数据到新的工作簿
            ws.Rows(1).Resize(rowCount).Copy .Range("A1")
            ws.Rows(rng.Row + rowCounter).Resize(rowCount).Copy .Range("A2")
        End With
        
        ' 保存新的工作簿为文件
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "/" & fileCounter & ".xlsx" ' 替换为您要保存文件的路径和文件名
        
        ' 关闭当前工作簿
        ActiveWorkbook.Close SaveChanges:=False
        
        ' 更新行和文件计数器
        rowCounter = rowCounter + rowCount
        fileCounter = fileCounter + 1
    Loop
End Sub

3.特殊时间格式转换

Function ConvertDateFormat(inputDate As String) As String
    '将日期和时间分开
    Dim datePart As Date
    Dim timePart As Date
    
    datePart = DateValue(inputDate)
    timePart = TimeValue(inputDate)
    
    '格式化为所需的格式
    Dim outputDate As String
    outputDate = Format(datePart, "yyyy-mm-dd") & " " & Format(timePart, "hh:mm:ss")
    
    ConvertDateFormat = outputDate
End Function

4.删除指定目录下所有表的指定列

Sub DeleteColumns()

    Dim folderPath As String
    Dim fileExtension As String
    Dim arrHeaders As Variant
    Dim header As Variant
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lastColumn As Long
    Dim col As Long
    Dim cell As Range
    
    '设置要删除列的表头
    arrHeaders = Array("Transaction Date", "Invoice Date", "Tracking Number", "Express or Ground Tracking ID", "Net Charge Amount", "Net Amount", "跟踪号", "费用USD")
    
    '设置要处理的目录和文件扩展名
    folderPath = "C:UsersAdministratorDesktop捷仓不含手续费，UPS4%，FedEx6%" '修改为实际目录
    fileExtension = "*.xlsx" '修改为实际文件扩展名
    
    '循环处理目录下的所有符合条件的文件
    Dim fileName As String
    fileName = Dir(folderPath & fileExtension)
    Do While fileName <> ""
        
        '打开工作簿
        Set wb = Workbooks.Open(folderPath & fileName)
        
        '循环处理工作簿中的所有工作表
        For Each ws In wb.Worksheets
            
    
                
                '找到表头行后，循环处理所有表头单元格
                lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
                
                For col = lastColumn To 1 Step -1
                
                    If Not IsError(Application.Match(ws.Cells(1, col).Value, arrHeaders, 0)) Then
                        '表头在数组中存在，保留列
                    Else
                        '表头不在数组中，删除整列
                        ws.Columns(col).Delete
                    End If
                Next col
       
            
        Next ws
        
        '保存工作簿并关闭
        wb.Save
        wb.Close
        
        '处理下一个文件
        fileName = Dir()
        
    Loop
    
End Sub

5.列拆分成行

Sub SplitData()

    ' 定义变量
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim targetWorkbook As Workbook
    Dim sourceRow As Long
    Dim targetRow As Long
    Dim targetColumn As Long
    
    ' 设置源工作表和目标工作簿
    Set sourceSheet = ThisWorkbook.Worksheets(1)
    Set targetWorkbook = Workbooks.Add
    Set targetSheet = targetWorkbook.Worksheets(1)
    
    targetSheet.Cells(1, 1).Value = "公司"
    targetSheet.Cells(1, 2).Value = "手机号"
    
    ' 将 B 列设置为文本格式
    targetSheet.Range("B:B").NumberFormat = "@"
    
    ' 设置目标行和列
    targetRow = 2
    targetColumn = 2
    
    sourceRow = 2
    
    Application.ScreenUpdating = False
    
    ' 遍历每一行数据
   Do While sourceSheet.Range("a" & sourceRow).Value <> ""
        
        sourceColumn = 2
        
        Do While sourceSheet.Cells(sourceRow, sourceColumn).Value <> ""
        
            ' 将第一列数据复制到目标表格中
            targetSheet.Cells(targetRow, 1).Value = sourceSheet.Cells(sourceRow, 1).Value
            targetSheet.Cells(targetRow, 2).Value = sourceSheet.Cells(sourceRow, sourceColumn).Value
            sourceColumn = sourceColumn + 1
            targetRow = targetRow + 1
            
        Loop

        sourceRow = sourceRow + 1
        
    Loop
  
    Application.ScreenUpdating = True
    
    MsgBox "成功！"
    
End Sub

6.分列

Sub SplitAndWrite()
    Dim ws As Worksheet
    Dim cell As Range
    Dim data() As String
    Dim i As Integer
    Dim col As Long
    Dim row As Long
    
    ' 设置工作表
    Set ws = ActiveSheet
    
    col = 24
    row = 2
    
    Do While ws.Cells(row, col).Value <> ""
    
        'Debug.Print ws.Cells(row, col).Value
    
        ' 按换行符拆分数据
        data = Split(ws.Cells(row, col).Value, Chr(10))

        ' 逐行写入到指定单元格的右边
        For i = LBound(data) To UBound(data)
            ws.Cells(row, col + i + 1).Value = data(i)
        Next i
        
        
        row = row + 1
        ws.Cells(row, col).Select
    
    Loop
End Sub

7.破解工程密码

新建下列模块：

Option Explicit
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
        (Destination As Long, Source As Long, ByVal Length As Long)


Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, _
        ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
        
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
   
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _
        ByVal lpProcName As String) As Long
   
Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, _
        ByVal pTemplateName As Long, ByVal hWndParent As Long, _
        ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
        
Dim HookBytes(0 To 5) As Byte
Dim OriginBytes(0 To 5) As Byte
Dim pFunc As Long
Dim Flag As Boolean


Private Function GetPtr(ByVal Value As Long) As Long
    '获得函数的地址
    GetPtr = Value
End Function


Public Sub RecoverBytes()
    '若已经hook,则恢复原API开头的6字节,也就是恢复原来函数的功能
    If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6
End Sub


Public Function Hook() As Boolean
    Dim TmpBytes(0 To 5) As Byte
    Dim p As Long
    Dim OriginProtect As Long
   
    Hook = False
   
    'VBE6.dll调用DialogBoxParamA显示VB6INTL.dll资源中的第4070号对话框(就是输入密码的窗口)
    '若DialogBoxParamA返回值非0,则VBE会认为密码正确,所以我们要hook DialogBoxParamA函数
    pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")
   
    '标准api hook过程之一: 修改内存属性,使其可写
    If VirtualProtect(ByVal pFunc, 6, &H40, OriginProtect) <> 0 Then
        '标准api hook过程之二: 判断是否已经hook,看看API的第一个字节是否为&H68,
        '若是则说明已经Hook
        MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6
        If TmpBytes(0) <> &H68 Then
            '标准api hook过程之三: 保存原函数开头字节,这里是6个字节,以备后面恢复
            MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6
            '用AddressOf获取MyDialogBoxParam的地址
            '因为语法不允许写成p = AddressOf MyDialogBoxParam,这里我们写一个函数
            'GetPtr,作用仅仅是返回AddressOf MyDialogBoxParam的值,从而实现将
            'MyDialogBoxParam的地址付给p的目的
            p = GetPtr(AddressOf MyDialogBoxParam)
            
            '标准api hook过程之四: 组装API入口的新代码
            'HookBytes 组成如下汇编
            'push MyDialogBoxParam的地址
            'ret
            '作用是跳转到MyDialogBoxParam函数
            HookBytes(0) = &H68
            MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4
            HookBytes(5) = &HC3
            
            '标准api hook过程之五: 用HookBytes的内容改写API前6个字节
            MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6
            '设置hook成功标志
            Flag = True
            Hook = True
        End If
    End If
End Function

Private Function MyDialogBoxParam(ByVal hInstance As Long, _
        ByVal pTemplateName As Long, ByVal hWndParent As Long, _
        ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
    If pTemplateName = 4070 Then
        '有程序调用DialogBoxParamA装入4070号对话框,这里我们直接返回1,让
        'VBE以为密码正确了
        MyDialogBoxParam = 1
    Else
        '有程序调用DialogBoxParamA,但装入的不是4070号对话框,这里我们调用
        'RecoverBytes函数恢复原来函数的功能,在进行原来的函数
        RecoverBytes
        MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _
                           hWndParent, lpDialogFunc, dwInitParam)
        '原来的函数执行完毕,再次hook
        Hook
    End If
End Function

运行下列过程：

Sub 破解()
If Hook Then
MsgBox "破解成功"
End If
End Sub

Sub 恢复()
RecoverBytes
MsgBox "恢复成功"
End Sub