Applicationのまとめ（一部）

先日から、処理速度に影響する画面更新などを一時停止する
クラスモジュールを作成している。
infoment.hatenablog.com
今日は、そのまとめ。

先日来、どちらにするか悩んでいたのが、↓ の 「Call Init」の個所。

初期化と同時に、自動で初期設定している。しかし、もしこれを使用する方が
居たとして、本人が知らないうちに設定が切り替わって良いものか？一方で、
基本的に自分が使うだけだから、コードは一行でも減らして短くしたい。

２～３日考えて出した、今回の結論がこちら。
「本人が知らないところで初期設定が適用されるのはＮＧ」

きっと時間が経ったら、作った本人も忘れるに違いないから。

ということで、これまでのまとめをこちらに記載する。

◆ソースコード（クリックで展開）◆

Option Explicit

Dim BackupDisplayAlerts As Boolean
Dim TempDisplayAlerts As Boolean

Dim BackupScreenUpdating As Boolean
Dim TempScreenUpdating As Boolean

Dim BackupEnableEvents As Boolean
Dim TempEnableEvents As Boolean

Dim BackupCalculation As XlCalculation
Dim TempCalculation As XlCalculation

Dim RecoverSetting As Boolean

Dim App As Application

Public Enum DeleteType
    sdDelete
    sdRemain
End Enum

Private Sub Class_Initialize()
    Set App = Application
    
        ' インスタンス作成時点の設定を退避。
        BackupScreenUpdating = App.ScreenUpdating
        BackupDisplayAlerts = App.DisplayAlerts
        BackupEnableEvents = App.EnableEvents
        BackupCalculation = App.Calculation

End Sub

Public Sub init(Optional screen_updating As Boolean = False, _
                Optional display_alerts As Boolean = False, _
                Optional enable_events As Boolean = False, _
                Optional calculation_ As XlCalculation = xlAutomatic, _
                Optional recover_setting As Boolean = True)
                
    ' 画面更新に関する設定。
    App.ScreenUpdating = screen_updating
    
    ' 警告表示に関する設定。
    App.DisplayAlerts = display_alerts
    
    ' ワークシートイベントの停止に関する設定。
    App.EnableEvents = enable_events
    
    ' 計算方法に関する設定。
    ' 計算を止めると意図しない結果になる場合もあるため、
    ' 初期値は自動計算としている。
    App.Calculation = calculation_
    
    ' ここで変えた設定を、最後に元に戻すかの設定。
    RecoverSetting = recover_setting
    
End Sub

Public Function SheetDeleteWithoutAlerts(ByVal target_sheet As Variant) As Boolean
    
    On Error GoTo er:
    
    ' 現在の設定を退避。
    TempDisplayAlerts = PresentDisplayAlerts
    
    ' 警告表示を一時停止。
    App.DisplayAlerts = False
    
    Select Case TypeName(target_sheet)
        
        ' シート位置、シート名で指定された場合。
        Case "Integer", "Long", "String"
            Sheets(target_sheet).Delete
        
        ' シートオブジェクトで指定された場合。
        Case "Worksheet"
            target_sheet.Delete
            
        ' それ以外の場合は処理しない。
        Case Else
            GoTo er:
            
    End Select
    
    ' 削除成功。
    SheetDeleteWithoutAlerts = True
    App.DisplayAlerts = TempDisplayAlerts
    
    Exit Function
    
    ' 削除失敗。
er:
    App.DisplayAlerts = True
    
End Function

' 指定したシートを残す、または削除。
Public Function SpecifiedSheetDelete(specified_sheet_name As String, _
                            Optional LookAt As XlLookAt = xlWhole, _
                            Optional delete_type As DeleteType = DeleteType.sdDelete) As Boolean
                            
    Dim Ws As Worksheet
    
        On Error GoTo er:
    
        ' 部分一致の場合。
        If LookAt = xlPart Then
            specified_sheet_name = "*" & specified_sheet_name & "*"
        End If
        
        ' 各シート名を評価して選択削除。
        For Each Ws In Worksheets
        
            ' シート数が１の時点でループを抜ける。
            ' ※シート数１で削除しようとするとエラーになるため。
            If Worksheets.Count = 1 Then GoTo er:
            
            ' 指定文字を含む場合に削除（完全一致を含む）。
            If delete_type = sdDelete Then
                If Ws.Name Like specified_sheet_name Then
                    If Not SheetDeleteWithoutAlerts(Ws) Then GoTo er:
                End If
            
            ' 指定文字を含まない場合に削除（完全一致を含む）。
            Else
                If Not Ws.Name Like specified_sheet_name Then
                    If Not SheetDeleteWithoutAlerts(Ws) Then GoTo er:
                End If
            End If
        Next
        
        On Error GoTo 0
        
        SpecifiedSheetDelete = True
        Exit Function
        
er:

        On Error GoTo 0
        
        SpecifiedSheetDelete = False
        
End Function

' 指定したパターンとマッチする名前のシートを残す、または削除。
Public Function RegExpSheetDelete(specified_pattern As String, _
                         Optional delete_type As DeleteType = DeleteType.sdDelete) As Boolean
                            
    Dim myReg As Object
    Set myReg = CreateObject("VBScript.RegExp")
    
        ' 正規表現のパターン設定。
        myReg.Pattern = specified_pattern
    Dim Ws As Worksheet
    
        On Error GoTo er:
        
        ' 各シート名を評価して選択削除。
        For Each Ws In Worksheets
        
            ' シート数が１の時点でループを抜ける。
            ' ※シート数１で削除しようとするとエラーになるため。
            If Worksheets.Count = 1 Then GoTo er:
            
            ' 指定パターンに一致する場合に削除。
            If delete_type = sdDelete Then
                If myReg.Test(Ws.Name) Then
                    If Not SheetDeleteWithoutAlerts(Ws) Then GoTo er:
                End If
            
            ' 指定パターンに一致しない場合に削除。
            Else
                If Not myReg.Test(Ws.Name) Then
                    If Not SheetDeleteWithoutAlerts(Ws) Then GoTo er:
                End If
            End If
        Next
        
        On Error GoTo 0
        
        RegExpSheetDelete = True
        Exit Function
        
er:

        On Error GoTo 0
        
        RegExpSheetDelete = False
        
End Function

' 現在の警告表示設定。
Private Property Get PresentDisplayAlerts() As Boolean
    PresentDisplayAlerts = App.DisplayAlerts
End Property

Private Sub Class_Terminate()

    ' 設定の復元。
    If RecoverSetting Then
        App.ScreenUpdating = BackupScreenUpdating
        App.DisplayAlerts = BackupDisplayAlerts
        App.EnableEvents = BackupEnableEvents
        App.Calculation = BackupCalculation
    End If
    
    ' ついでにステータスバーをリセット。
    App.StatusBar = False
    
End Sub

使い方サンプル。
1. 画面の更新処理を一時停止。

Sub Sample_1()

    Dim ApC As VBAProject.AppControl
    Set ApC = New VBAProject.AppControl
        ApC.init screen_updating:=False

End Sub

2. Sheet1を削除（削除時の警告を出さない）。

Sub Sample_2()

    Dim ApC As VBAProject.AppControl
    Set ApC = New VBAProject.AppControl
        ApC.SheetDeleteWithoutAlerts Sheet1

End Sub

3. 指定ブック内にある、シート名が数字６ケタのシートだけ削除。

Sub Sample_3()

    Dim ApC As VBAProject.AppControl
    Set ApC = New VBAProject.AppControl
        ApC.RegExpSheetDelete "^\d{6}$"

End Sub

今後、このクラスについて改修した結果は、全てこちらに集約することにしよう。

ということで、今回のシリーズはこれでおしまいです。

参考まで。