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

常用对象和方法 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打开对话框

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