オブジェクト取得

Option Explicit
Option Base 1

'--------------------------------------------------
'プロシージャの概要:
'処理名:getExcelShapeInfo
'概要:Excelブック内の全シートの図形・シェイプ情報を取得してテーブルに追加
'db:カレントのDatabase
'xlApp:Excelアプリケーションオブジェクト
'wb:解析対象のExcelワークブック
'--------------------------------------------------
Public Sub getExcelShapeInfo(db As DAO.Database, xlApp As Excel.Application, wb As Excel.Workbook)
    Dim ws As Excel.Worksheet
    Dim shp As Excel.Shape
    Dim rsShape As DAO.Recordset
    Dim strSheetName As String
    Dim strCellAddr As String
    Dim strObjName As String
    Dim strObjType As String
    Dim strCaption As String
    Dim strOnAction As String
    Dim intSheetIdx As Integer
    Dim intShpIdx As Integer
    Dim intGrpIdx As Integer
    Dim binIsGrp As Boolean
    Dim binWasProt As Boolean
    Dim binUnprotOk As Boolean
    Dim cltGrpShps As Collection
    
    On Error GoTo ErrorHandler
    
    ' グループ化されたシェイプを格納するコレクションを初期化
    Set cltGrpShps = New Collection
    
    ' 全シート(VeryHiddenも含む)をループ処理
    For intSheetIdx = 1 To wb.Worksheets.Count
        Set ws = wb.Worksheets(intSheetIdx)
        strSheetName = ws.Name
        binWasProt = False
        binUnprotOk = True
        
        ' シートの保護状態を確認
        If ws.ProtectContents Then
            binWasProt = True
            ' 保護解除を試行
            On Error GoTo UnprotectFailed
            ws.Unprotect ""
            On Error GoTo ErrorHandler
        End If
        
        ' シート内の全図形をループ処理
        For intShpIdx = 1 To ws.Shapes.Count
            ' ステータスバーに進捗を表示
            Application.SysCmd acSysCmdSetStatus, "(" & strSheetName & ")のオブジェクト情報取得中・・・" & intShpIdx & "/" & ws.Shapes.Count
            
            Set shp = ws.Shapes(intShpIdx)
            
            ' グループ化されているかを判定
            binIsGrp = (shp.Type = 6) ' msoGroup
            
            If binIsGrp Then
                ' グループ化されている場合は解除して個別に処理
                Call processGroupedShape(ws, shp, rsShape, strSheetName, cltGrpShps)
            Else
                ' 通常のシェイプを処理
                Call processSingleShape(ws, shp, rsShape, strSheetName)
            End If
        Next intShpIdx
        
        ' グループ化を復元
        Call restoreGroupedShapes(ws, cltGrpShps)
        
        ' シート保護を復元
        If binWasProt And binUnprotOk Then
            ws.Protect ""
        End If
        
        ' コレクションをクリア
        Set cltGrpShps = New Collection
        
        GoTo NextSheet
        
UnprotectFailed:
        ' 保護解除に失敗した場合
        binUnprotOk = False
        rsShape.AddNew
        rsShape!シート名 = strSheetName & "(保護解除不可)"
        rsShape!セル番地 = ""
        rsShape!オブジェクト名 = ""
        rsShape!オブジェクトタイプ = ""
        rsShape!キャプション = ""
        rsShape!OnAction = ""
        rsShape.Update
        On Error GoTo ErrorHandler
        
NextSheet:
    Next intSheetIdx
    
    ' ステータスバーをクリア
    Application.SysCmd acSysCmdClearStatus
    
    ' レコードセットをクローズ
    rsShape.Close
    Set rsShape = Nothing
    
    Exit Sub
    
ErrorHandler:
    ' エラー時はレコードにエラー情報を追加
    If Not rsShape Is Nothing Then
        On Error Resume Next
        rsShape.AddNew
        rsShape!シート名 = strSheetName
        rsShape!セル番地 = ""
        rsShape!オブジェクト名 = "エラーにより取得不可"
        rsShape!オブジェクトタイプ = ""
        rsShape!キャプション = ""
        rsShape!OnAction = ""
        rsShape.Update
        rsShape.Close
        Set rsShape = Nothing
        On Error GoTo 0
    End If
    Resume Next
End Sub

'--------------------------------------------------
'プロシージャの概要:
'処理名:processSingleShape
'概要:単一のシェイプ情報を取得してレコードセットに追加
'ws:対象ワークシート
'shp:対象シェイプ
'rsShape:追加先のレコードセット
'objRs:追加先のレコードセット
'strSheetName:シート名
'--------------------------------------------------
Private Sub processSingleShape(ws As Excel.Worksheet, shp As Excel.Shape, rsShape As DAO.Recordset, strSheetName As String)
    Dim strCellAddr As String
    Dim strObjName As String
    Dim strObjType As String
    Dim strCaption As String
    Dim strOnAction As String
    
    On Error GoTo ErrorHandler
    
    ' 基本情報を取得
    strObjName = shp.Name
    strObjType = getShapeTypeName(shp.Type)
    
    ' セル番地を取得(左上角の位置)
    strCellAddr = ws.Cells(shp.TopLeftCell.Row, shp.TopLeftCell.Column).Address(False, False)
    
    ' キャプション(表示文字)を取得
    strCaption = getShapeCaption(shp)
    
    ' OnActionを取得
    strOnAction = getShapeOnAction(shp)
    
    ' レコードセットに追加
    rsShape.AddNew
    rsShape!シート名 = strSheetName
    rsShape!セル番地 = strCellAddr
    rsShape!オブジェクト名 = strObjName
    rsShape!オブジェクトタイプ = strObjType
    rsShape!キャプション = strCaption
    rsShape!OnAction = strOnAction
    rsShape.Update
    
    Exit Sub
    
ErrorHandler:
    ' エラー時はエラー情報を追加
    rsShape.AddNew
    rsShape!シート名 = strSheetName
    rsShape!セル番地 = ""
    rsShape!オブジェクト名 = "エラーにより取得不可"
    rsShape!オブジェクトタイプ = ""
    rsShape!キャプション = ""
    rsShape!OnAction = ""
    rsShape.Update
End Sub

'--------------------------------------------------
'プロシージャの概要:
'処理名:processGroupedShape
'概要:グループ化されたシェイプを解除して個別に処理
'ws:対象ワークシート
'grpShape:グループ化されたシェイプ
'rsShape:追加先のレコードセット
'objRs:追加先のレコードセット
'strSheetName:シート名
'cltGroupedShapes:グループ情報を保存するコレクション
'--------------------------------------------------
Private Sub processGroupedShape(ws As Excel.Worksheet, grpShape As Excel.Shape, rsShape As DAO.Recordset, strSheetName As String, cltGrpShps As Collection)
    Dim shp As Excel.Shape
    Dim arrStrShpNames As Variant
    Dim intShpIdx As Integer
    Dim strGrpName As String
    
    On Error GoTo ErrorHandler
    
    ' グループ名を保存
    strGrpName = grpShape.Name
    
    ' グループ内のシェイプ名を取得
    ReDim arrStrShpNames(1 To grpShape.GroupItems.Count)
    For intShpIdx = 1 To grpShape.GroupItems.Count
        arrStrShpNames(intShpIdx) = grpShape.GroupItems(intShpIdx).Name
    Next intShpIdx
    
    ' グループ化を解除
    grpShape.Ungroup
    
    ' 解除されたシェイプを個別に処理
    For intShpIdx = 1 To UBound(arrStrShpNames)
        Set shp = ws.Shapes(arrStrShpNames(intShpIdx))
        Call processSingleShape(ws, shp, rsShape, strSheetName)
    Next intShpIdx
    
    ' グループ情報をコレクションに保存
    cltGrpShps.Add Array(strGrpName, arrStrShpNames)
    
    Exit Sub
    
ErrorHandler:
    ' エラー時はエラー情報を追加
    rsShape.AddNew
    rsShape!シート名 = strSheetName
    rsShape!セル番地 = ""
    rsShape!オブジェクト名 = "エラーにより取得不可"
    rsShape!オブジェクトタイプ = ""
    rsShape!キャプション = ""
    rsShape!OnAction = ""
    rsShape.Update
End Sub

'--------------------------------------------------
'プロシージャの概要:
'処理名:restoreGroupedShapes
'概要:解除されたグループ化を復元
'ws:対象ワークシート
'cltGroupedShapes:グループ情報を保存するコレクション
'--------------------------------------------------
Private Sub restoreGroupedShapes(ws As Excel.Worksheet, cltGrpShps As Collection)
    Dim varGrpInfo As Variant
    Dim arrStrShpNames As Variant
    Dim strGrpName As String
    Dim rngShps As Excel.ShapeRange
    Dim intGrpIdx As Integer
    
    On Error Resume Next
    
    ' 保存されたグループ情報を使用してグループ化を復元
    For intGrpIdx = 1 To cltGrpShps.Count
        varGrpInfo = cltGrpShps(intGrpIdx)
        strGrpName = varGrpInfo(0)
        arrStrShpNames = varGrpInfo(1)
        
        ' シェイプ範囲を作成
        Set rngShps = ws.Shapes.Range(arrStrShpNames)
        
        ' グループ化を復元
        rngShps.Group.Name = strGrpName
    Next intGrpIdx
End Sub

'--------------------------------------------------
'プロシージャの概要:
'処理名:getShapeTypeName
'概要:シェイプタイプから文字列を取得
'intShapeType:シェイプタイプの数値
'[戻り値]:シェイプタイプの文字列
'--------------------------------------------------
Private Function getShapeTypeName(intShpType As Integer) As String
    Select Case intShpType
        Case 1: getShapeTypeName = "オートシェイプ"        ' msoAutoShape
        Case 2: getShapeTypeName = "コメント"              ' msoCallout
        Case 3: getShapeTypeName = "フリーフォーム"        ' msoFreeform
        Case 6: getShapeTypeName = "グループ"              ' msoGroup
        Case 7: getShapeTypeName = "埋め込みOLEオブジェクト" ' msoEmbeddedOLEObject
        Case 8: getShapeTypeName = "フォームコントロール"   ' msoFormControl
        Case 9: getShapeTypeName = "線"                   ' msoLine
        Case 10: getShapeTypeName = "リンクOLEオブジェクト" ' msoLinkedOLEObject
        Case 11: getShapeTypeName = "リンク画像"           ' msoLinkedPicture
        Case 12: getShapeTypeName = "OLEコントロールオブジェクト" ' msoOLEControlObject
        Case 13: getShapeTypeName = "画像"                ' msoPicture
        Case 14: getShapeTypeName = "プレースホルダー"     ' msoPlaceholder
        Case 17: getShapeTypeName = "テキストボックス"     ' msoTextBox
        Case 16: getShapeTypeName = "メディア"             ' msoMedia
        Case 15: getShapeTypeName = "テキスト効果"         ' msoTextEffect
        Case 24: getShapeTypeName = "スマートアート"       ' msoSmartArt
        Case 19: getShapeTypeName = "テーブル"             ' msoTable
        Case 20: getShapeTypeName = "キャンバス"           ' msoCanvas
        Case 3: getShapeTypeName = "図表"                 ' msoChart
        Case Else: getShapeTypeName = "不明なタイプ"
    End Select
End Function

'--------------------------------------------------
'プロシージャの概要:
'処理名:getShapeCaption
'概要:シェイプからキャプション(表示文字)を取得
'shp:対象シェイプ
'[戻り値]:キャプション文字列
'--------------------------------------------------
Private Function getShapeCaption(shp As Excel.Shape) As String
    Dim strCaption As String
    
    On Error GoTo TryAlternative
    
    ' TextFrame2.TextRange.Textを優先して取得
    If shp.HasTextFrame Then
        If shp.TextFrame2.HasText Then
            strCaption = shp.TextFrame2.TextRange.Text
            GoTo ExitFunction
        End If
    End If
    
TryAlternative:
    On Error GoTo TryCaption
    
    ' TextFrame.Characters.Textを試行
    If shp.HasTextFrame Then
        strCaption = shp.TextFrame.Characters.Text
        GoTo ExitFunction
    End If
    
TryCaption:
    On Error GoTo TryText
    
    ' Captionプロパティを試行
    strCaption = shp.Caption
    GoTo ExitFunction
    
TryText:
    On Error GoTo NoText
    
    ' Textプロパティを試行
    strCaption = shp.Text
    GoTo ExitFunction
    
NoText:
    ' テキストが取得できない場合
    strCaption = "テキストなし"
    
ExitFunction:
    getShapeCaption = strCaption
End Function

'--------------------------------------------------
'プロシージャの概要:
'処理名:getShapeOnAction
'概要:シェイプからOnActionプロパティを取得
'objShape:対象シェイプ
'[戻り値]:OnAction文字列
'--------------------------------------------------
Private Function getShapeOnAction(shp As Excel.Shape) As String
    Dim strOnAction As String
    
    On Error GoTo NoOnAction
    
    strOnAction = shp.OnAction
    GoTo ExitFunction
    
NoOnAction:
    strOnAction = ""
    
ExitFunction:
    getShapeOnAction = strOnAction
End Function