条件付き書式の取得

'--------------------------------------------------
'プロシージャの概要:
'処理名:importExcel条件付き書式
'概要:Excelブックの条件付き書式（数式タイプ）を取得し、t数式テーブルに格納する
'--------------------------------------------------
Public Sub importExcel条件付き書式()
    Dim db As Database
    Dim rs As Recordset
    Dim xlApp As Excel.Application
    Dim wb As Excel.Workbook
    Dim ws As Excel.Worksheet
    Dim rngFormatCondition As Range
    Dim objFormatCondition As Object
    Dim lngRuleNumber As Long
    Dim lngConditionIndex As Long
    Dim strSQL As String
    Dim blnSheetProtected As Boolean
    Dim strProtectPassword As String
    
    '定数宣言
    Const C_EXCEL_FILE_PATH As String = "C:\temp\target.xlsx"  'Excelファイルパス（適宜変更）
    Const C_TABLE_NAME As String = "t数式"
    Const C_PASSWORD_BLANK As String = ""
    Const C_PROTECT_ERROR_MESSAGE As String = "シート保護のため解析不可"
    
    'データベースオブジェクト取得
    Set db = CurrentDb
    
    '既存データ削除
    strSQL = "DELETE FROM " & C_TABLE_NAME
    db.Execute strSQL
    
    'Excelアプリケーション起動
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
    xlApp.DisplayAlerts = False
    
    'Excelブック開く
    Set wb = xlApp.Workbooks.Open(C_EXCEL_FILE_PATH)
    
    'レコードセット開く
    strSQL = "SELECT * FROM " & C_TABLE_NAME
    Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
    
    'シート単位で処理
    For Each ws In wb.Worksheets
        With ws
            'シート保護状態確認
            blnSheetProtected = False
            If .ProtectContents Then
                blnSheetProtected = True
                'パスワード空白で保護解除試行
                On Error Resume Next
                .Unprotect C_PASSWORD_BLANK
                If Err.Number <> 0 Then
                    'パスワード解除失敗時の処理
                    Err.Clear
                    On Error GoTo 0
                    
                    'エラーレコード追加
                    rs.AddNew
                    rs!ブック名 = wb.Name
                    rs!シート名 = .Name
                    rs!セル番地 = "N/A"
                    rs!ルール番号 = 0
                    rs!条件タイプ = 0
                    rs!数式 = C_PROTECT_ERROR_MESSAGE
                    rs!Formula2 = Null
                    rs!優先順位 = 0
                    rs!停止条件 = False
                    rs.Update
                    
                    '次のシートへ
                    GoTo NextSheet
                End If
                On Error GoTo 0
            End If
            
            '条件付き書式の取得処理
            On Error Resume Next
            For lngConditionIndex = 1 To .Cells.FormatConditions.Count
                Set objFormatCondition = .Cells.FormatConditions(lngConditionIndex)
                
                '数式タイプ（xlExpression=2）のみ処理
                If objFormatCondition.Type = 2 Then  'xlExpression
                    lngRuleNumber = lngRuleNumber + 1
                    
                    'レコード追加
                    rs.AddNew
                    rs!ブック名 = wb.Name
                    rs!シート名 = .Name
                    
                    '適用範囲取得
                    rs!セル番地 = objFormatCondition.AppliesTo.Address(False, False)
                    
                    rs!ルール番号 = lngRuleNumber
                    rs!条件タイプ = objFormatCondition.Type
                    
                    '数式取得（Formula1）
                    If Err.Number = 0 Then
                        rs!数式 = objFormatCondition.Formula1
                    Else
                        rs!数式 = Null
                        Err.Clear
                    End If
                    
                    'Formula2取得（存在する場合）
                    On Error Resume Next
                    rs!Formula2 = objFormatCondition.Formula2
                    If Err.Number <> 0 Then
                        rs!Formula2 = Null
                        Err.Clear
                    End If
                    
                    '優先順位取得
                    On Error Resume Next
                    rs!優先順位 = objFormatCondition.Priority
                    If Err.Number <> 0 Then
                        rs!優先順位 = lngRuleNumber
                        Err.Clear
                    End If
                    
                    '停止条件取得
                    On Error Resume Next
                    rs!停止条件 = objFormatCondition.StopIfTrue
                    If Err.Number <> 0 Then
                        rs!停止条件 = False
                        Err.Clear
                    End If
                    
                    rs.Update
                End If
            Next lngConditionIndex
            On Error GoTo 0
            
            'ルール番号リセット
            lngRuleNumber = 0
            
            'シート保護を元に戻す
            If blnSheetProtected Then
                .Protect C_PASSWORD_BLANK
            End If
            
NextSheet:
        End With
    Next ws
    
    'オブジェクト解放
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    
    'Excelブック閉じる
    wb.Close SaveChanges:=False
    Set wb = Nothing
    
    'Excel終了
    xlApp.Quit
    Set xlApp = Nothing
    
    MsgBox "条件付き書式の取得が完了しました。", vbInformation
    
End Sub