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