Fatal编程技术网
  • vba/
  • Vba 提前终止代码时使用退出代码清理

Vba 提前终止代码时使用退出代码清理

vba macros

Vba 提前终止代码时使用退出代码清理,vba,macros,Vba,Macros,我正在运行一个宏，在Excel中可能需要一些时间。有时我可能需要提前终止宏。因此，这会导致宏不执行其清理功能，例如：Application.screenUpdate=True，因为它在我使用的Do…Loop语句之前设置为False。这将导致明显的问题，我通常会在宏的最开始添加True语句，然后添加End，以解决问题 是否有任何方法可用于在代码中启用post terminateGoTo语句？我知道当我单击Esc时可能不是这样，但是一个类似于MsgBox但不会停止代码运行的持久框呢？我基本上可以将此

我正在运行一个宏，在Excel中可能需要一些时间。有时我可能需要提前终止宏。因此，这会导致宏不执行其清理功能，例如：
Application.screenUpdate=True
，因为它在我使用的
Do…Loop
语句之前设置为
False
。这将导致明显的问题，我通常会在宏的最开始添加
True
语句，然后添加
End
，以解决问题

是否有任何方法可用于在代码中启用post terminate
GoTo
语句？我知道当我单击
Esc
时可能不是这样，但是一个类似于
MsgBox
但不会停止代码运行的持久框呢？我基本上可以将此框用作“取消”按钮，并且此框可以在整个宏期间保持不动，而不会中断宏的操作。单击所述框中的取消按钮后，它将立即停止正常操作，并按照我的
GoTo
命令执行必要的清理任务

我强烈感觉这是不可能的，但我想我会问那些最了解VBA的人

Option Explicit

Dim ATC As AccuTermClasses.AccuTerm, A As Session, Sheet As Worksheet

Function RemoveSpaces(MyString As String) As String
    Do Until Right(MyString, 1) <> " "
        MyString = Left(MyString, Len(MyString) - 1)
    Loop
    RemoveSpaces = MyString
End Function

Sub CopyEntireFeeBoard()

    Set ATC = GetObject(, "AtWin32.AccuTerm")
    Set Sheet = Workbooks("2016 FEE BOARD.XLSM").ActiveSheet
    Set A = ATC.ActiveSession

    Dim xlRow As Long, aRow As Integer   'Excel's and AccuTerm's Row #s
    Dim Rate As Single, Name As String, Client As String, Desk As Byte
    xlRow = 2   'Starting row
    aRow = 3

    Application.Calculation = xlCalculationManual
    Do
        Rate = 0
        On Error Resume Next    'Incase Rate is blank
        Rate = A.GetText(47, aRow, 4, 1)
        On Error GoTo 0

        Client = RemoveSpaces(A.GetText(10, aRow, 7, 1))
        If Client = "100AAA" Then Client = ""
        Name = RemoveSpaces(A.GetText(26, aRow, 16, 1))
        Desk = A.GetText(56, aRow, 2, 1)

        Sheet.Cells(xlRow, 1).Value = A.GetText(0, aRow, 8, 1)      'Date
        Sheet.Cells(xlRow, 2).Value = Client                        'Client
        Sheet.Cells(xlRow, 3).Value = A.GetText(18, aRow, 7, 1)     'DNUM
        Sheet.Cells(xlRow, 4).Value = Name                          'Name
        Sheet.Cells(xlRow, 5).Value = A.GetText(43, aRow, 3, 1)     'TC
        If Rate <> 0 Then Sheet.Cells(xlRow, 6).Value = Rate        'Rate
        Sheet.Cells(xlRow, 7).Value = A.GetText(52, aRow, 3, 1)     'STS
        Sheet.Cells(xlRow, 8).Value = Desk                          'DESK
        Sheet.Cells(xlRow, 9).Value = A.GetText(59, aRow, 10, 1)    'AMOUNT
        xlRow = xlRow + 1
        aRow = aRow + 1

        ' Reached the end of host application's page.
        If aRow = 22 Then

            'Will go ahead and refresh Excel at this point
            Application.Calculation = xlCalculationAutomatic

            aRow = 3 'Reset AccuTerm's Starting Row
            A.Output Chr(13)    'Enter key

            ' Give time for the next screen to refresh
            Application.Wait Now + TimeValue("00:00:01")
            Application.Calculation = xlCalculationManual
        End If

    Loop Until A.GetText(26, aRow, 1, 1) = " "

    Application.Calculation = xlCalculationAutomatic

    Set ATC = Nothing
    Set Sheet = Nothing
    Set A = Nothing

End Sub

选项显式
将ATC设置为AccuTerm Classes.AccuTerm，设置为会话，设置为工作表
函数removespace（MyString作为String）作为String
直到正确为止（MyString，1）”
MyString=Left（MyString，Len（MyString）-1）
环
removespace=MyString
端函数
子CopyEntireFeeBoard（）
设置ATC=GetObject（，“AtWin32.AccuTerm”）
设置工作表=工作簿（“2016费用委员会.XLSM”）。活动工作表
设置A=ATC.ActiveSession
Dim xlRow尽可能长，大约为整数“Excel”和AccuTerm的行
Dim Rate为Single，Name为String，Client为String，Desk为Byte
xlRow=2'起始行
aRow=3
Application.Calculation=xlCalculationManual
做
比率=0
错误时继续下一步“如果速率为空
Rate=A.GetText（47，aRow，4，1）
错误转到0
Client=removespace（A.GetText（10，aRow，7，1））
如果Client=“100AAA”则Client=“”
Name=removespace（A.GetText（26，aRow，16，1））
桌面=A.GetText（56，aRow，2，1）
Sheet.Cells（xlRow，1）.Value=A.GetText（0，aRow，8，1）的日期
Sheet.Cells（xlRow，2）.Value=客户端的客户端
Sheet.Cells（xlRow，3）.Value=A.GetText（18，aRow，7，1）'DNUM
Sheet.Cells（xlRow，4）.Value=Name'Name
Sheet.Cells（xlRow，5）.Value=A.GetText（43，aRow，3，1）'TC
如果速率为0，则为表单元格（xlRow，6）。值=速率“速率”
Sheet.Cells（xlRow，7）.Value=A.GetText（52，aRow，3，1）'STS
表.单元格（xlRow，8）.值=书桌的书桌
Sheet.Cells（xlRow，9）.Value=A.GetText（59，aRow，10，1）数量
xlRow=xlRow+1
aRow=aRow+1
'已到达主机应用程序页面的末尾。
如果aRow=22，则
'将继续并在此时刷新Excel
Application.Calculation=xlCalculationAutomatic
aRow=3'重置AccuTerm的起始行
A.输出Chr（13）'Enter键
'给下一个屏幕刷新时间
应用程序。立即等待+时间值（“00:00:01”）
Application.Calculation=xlCalculationManual
如果结束
循环直到A.GetText（26，aRow，1，1）=“”
Application.Calculation=xlCalculationAutomatic
设置ATC=无
集合表=无
设置A=无
端接头
添加例如
UserForm
，其中一个按钮用于执行长时间运行的操作，另一个按钮用于提前终止。当您决定提前终止操作时，只需单击设置bool变量的cancel按钮，do循环将退出

用户表单代码 （添加两个名为CancelCommandButton和ExecuteCommandButton的命令按钮）

标准模块代码

我修改了您的代码，使其在按下结束键时退出
Do循环

此外，在退出循环后，通过一次操作将数据收集到数组中并写入工作表。这样，就不需要切换计算和屏幕更新

内置的VBA函数
RTrim
与
removespace
的功能相同，但效率更高

Private声明函数GetKeyState Lib“user32”（ByVal nVirtKey作为Long）作为Long
常数VK_END=&H23
将ATC调暗为AccuTermClasses.AccuTerm，作为会话
子CopyEntireFeeBoard（）
设置ATC=GetObject（，“AtWin32.AccuTerm”）
设置A=ATC.ActiveSession
Dim AllData，行数据（1到9）
尺寸xlRow为Long，x为Long'Excel's和AccuTerm's行
Dim Rate为Single，Name为String，Client为String，Desk为Byte
aRow=3
重拨所有数据（0）
做
ReDim保留所有数据（x）
比率=0
错误时继续下一步“如果速率为空
Rate=A.GetText（47，aRow，4，1）
错误转到0
Client=RTrim（A.GetText（10，aRow，7，1））
如果Client=“100AAA”则Client=“”
Name=removespace（A.GetText（26，aRow，16，1））
桌面=A.GetText（56，aRow，2，1）
RowData（1）.Value=A.GetText（0，aRow，8，1）'Date
RowData（2）.值=客户端的客户端
RowData（3）.Value=A.GetText（18，aRow，7，1）'DNUM
RowData（4）.Value=Name'Name
RowData（5）.Value=A.GetText（43，aRow，3，1）'TC
如果速率为0，则为RowData（6）。值=速率“速率”
RowData（7）.Value=A.GetText（52，aRow，3，1）'STS
RowData（8）.值=桌面的桌面
RowData（9）.Value=A.GetText（59，aRow，10，1）'AMOUNT
AllData（x）=行数据
aRow=aRo

Private Sub CancelCommandButton_Click()
    CancelRequest = True
End Sub

Private Sub ExecuteCommandButton_Click()
    Me.Repaint
    CancelRequest = False
    LongRunningTask
End Sub



Public CancelRequest As Boolean

Public Sub LongRunningTask() ' e.g. like CopyEntireFeeBoard()
    ' ...

    Dim result As Long
    Do
        result = result + 1

        ' ...

        ' At the and of the loop check the bool variable and exit if necessary
        DoEvents
        If CancelRequest Then
            ' Do some cleanup
            Exit Do
        End If
    Loop Until result = 100000000 ' A.GetText(26, aRow, 1, 1) = " "

    ' ...
End Sub



Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Long
Const VK_END = &H23

Dim ATC As AccuTermClasses.AccuTerm, A As Session

Sub CopyEntireFeeBoard()

    Set ATC = GetObject(, "AtWin32.AccuTerm")
    Set A = ATC.ActiveSession
    Dim AllData, RowData(1 To 9)

    Dim xlRow As Long, x As Long   'Excel's and AccuTerm's Row #s
    Dim Rate As Single, Name As String, Client As String, Desk As Byte
    aRow = 3
    ReDim AllData(0)

    Do
        ReDim Preserve AllData(x)

        Rate = 0
        On Error Resume Next    'Incase Rate is blank
        Rate = A.GetText(47, aRow, 4, 1)
        On Error GoTo 0

        Client = RTrim(A.GetText(10, aRow, 7, 1))
        If Client = "100AAA" Then Client = ""
        Name = RemoveSpaces(A.GetText(26, aRow, 16, 1))
        Desk = A.GetText(56, aRow, 2, 1)

        RowData(1).Value = A.GetText(0, aRow, 8, 1)       'Date
        RowData(2).Value = Client                        'Client
        RowData(3).Value = A.GetText(18, aRow, 7, 1)     'DNUM
        RowData(4).Value = Name                          'Name
        RowData(5).Value = A.GetText(43, aRow, 3, 1)     'TC
        If Rate <> 0 Then RowData(6).Value = Rate        'Rate
        RowData(7).Value = A.GetText(52, aRow, 3, 1)     'STS
        RowData(8).Value = Desk                          'DESK
        RowData(9).Value = A.GetText(59, aRow, 10, 1)    'AMOUNT

        AllData(x) = RowData
        aRow = aRow + 1

        ' Reached the end of host application's page.
        If aRow = 22 Then

            aRow = 3 'Reset AccuTerm's Starting Row
            A.Output Chr(13)    'Enter key

            ' Give time for the next screen to refresh
            Application.Wait Now + TimeValue("00:00:01")

        End If

        x = x + 1
    Loop Until A.GetText(26, aRow, 1, 1) = " " Or GetKeyState(VK_END)

    'Converts the Array of Arrays into a 2 Dimensional array
    AllData = Transpose(AllData)
    AllData = Transpose(AllData)

    With Workbooks("2016 FEE BOARD.XLSM")
        .Range("A1").Resize(UBound(data, 1) + 1, 9).Value = AllData
    End With

    Set ATC = Nothing
    Set Sheet = Nothing
    Set A = Nothing

End Sub