'----------------------------------------------
' メイン処理:ファイルダイアログでExcelファイルを選択し、
' 未オープンなら開いて、すべてのシェイプの配置設定を変更する
'----------------------------------------------
Sub SetShapesFreeFloatingWithFileDialog()
Dim fdOpen As FileDialog
Dim strFilePath As String
Dim wbSelected As Workbook
Set fdOpen = Application.FileDialog(msoFileDialogFilePicker)
With fdOpen
.Title = "対象のExcelファイルを選択してください"
.Filters.Clear
.Filters.Add "Excelファイル", "*.xls;*.xlsx;*.xlsm;*.xlsb"
.AllowMultiSelect = False
If .Show = -1 Then
strFilePath = .SelectedItems(1)
Else
MsgBox "ファイルが選択されませんでした。処理を中止します。", vbInformation
Exit Sub
End If
End With
If IsWorkbookOpen(strFilePath) Then
MsgBox "選択したブックはすでに開かれています。" & vbCrLf & _
"すべての処理を中止します。", vbCritical
Exit Sub
End If
Set wbSelected = Workbooks.Open(strFilePath)
SetAllShapesFreeFloatingInWorkbook wbSelected
MsgBox "すべてのシェイプの設定が完了しました。" & vbCrLf & _
"ファイルを保存して閉じてください。", vbInformation
End Sub
'----------------------------------------------
' 関数:指定ファイルパスのブックがすでに開かれているか判定
'----------------------------------------------
Function IsWorkbookOpen(ByVal strFullPath As String) As Boolean
Dim wb As Workbook
IsWorkbookOpen = False
For Each wb In Application.Workbooks
If StrComp(wb.FullName, strFullPath, vbTextCompare) = 0 Then
IsWorkbookOpen = True
Exit For
End If
Next wb
End Function
'----------------------------------------------
' サブルーチン:指定したブック内の全シート・全シェイプを処理
'----------------------------------------------
Sub SetAllShapesFreeFloatingInWorkbook(ByVal wbTarget As Workbook)
Dim wsCurrent As Worksheet
Dim lngWsIdx As Long
For lngWsIdx = 1 To wbTarget.Worksheets.Count
Set wsCurrent = wbTarget.Worksheets(lngWsIdx)
SetShapesPlacementRecursive wsCurrent.Shapes
Next lngWsIdx
End Sub
'----------------------------------------------
' サブルーチン:ShapesまたはGroupShapesコレクション内の
' すべてのシェイプ・グループ内も再帰的に処理
'----------------------------------------------
Sub SetShapesPlacementRecursive(ByVal objShapes As Object)
Dim shpItem As Shape
Dim lngIdx As Long
For lngIdx = 1 To objShapes.Count
Set shpItem = objShapes(lngIdx)
' セルに合わせて移動やサイズ変更をしない設定
shpItem.Placement = xlFreeFloating
' グループ化シェイプの場合はグループ内も再帰的に処理
If shpItem.Type = msoGroup Then
SetShapesPlacementRecursive shpItem.GroupItems
End If
Next lngIdx
End Sub