引用:
さっそくネット検索で探して近いものを試してみましたが、どうしてもエラーがでてしまい先に進めませんでした。
当方はMacなので、それが原因のような気がしています。
実際のコードが判りませんし、macのテスト環境も無いので、何とも言えません。
mac の場合の参考記事
https://the-forme.net/note/spreadsheet/macvbapicture/
https://oshiete.goo.ne.jp/qa/10721136.html
2019では安定しないとの記載もありますが
実際の所は判りません。
Windowsで 当方が使用しているコードを提示しますが、
macではどうなるか判りません。
コードを使用するにあたっては、理解した上で使用してください。
不具合があれば対応しますが、質問者さんの用途に合わせた改造はご自分で行ってください。
Sub TEST()
'ダイアログにて選択した写真を
' A2 セルを起点として
'2行おき、0列おき 列方向に 1枚 挿入し
'当該セルの大きさいっぱいになる様 アスペクト比を変えずにセルセンターに配置
'(当該セルが 連結セルであれば、連結されたセルいっぱいに配置)
Call AddPictures(2, 0, 1)
End Sub
Sub AddPictures(Optional rowOff As Integer = 9, Optional clmOff As Integer = 0, Optional clmCnt As Integer = 1)
'引数
'rowOff : 次の行 までの 行間
'clmOff : 次の列 までの 列間
'clmCnt : 列方向に並べる 数
Dim wst As Worksheet
Dim rng As Range
Dim fName As Variant
Dim i As Long
Dim shp As Shape
Dim img_Rotation As Single
'アクティブシートがワークシート以外(グラフ等)なら 中止
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
'ファイル選択
fName = Application.GetOpenFilename("JPGファイル, *.jpg", MultiSelect:=True)
'ファイルが選択されなければ中止
If IsArray(fName) = False Then Exit Sub
Set wst = ActiveSheet
wst.Range("A2").Select
Application.ScreenUpdating = False
For i = LBound(fName) To UBound(fName)
'配置するRangeを取得(結合セルなら結合範囲)
If clmOff = 0 Then
Set rng = wst.Range("A2").Offset((i - 1) * rowOff, 0).MergeArea
Else
Set rng = wst.Range("A2").Offset(Int((i - 1) / clmCnt) * rowOff, ((i - 1) Mod clmCnt) * clmOff).MergeArea
End If
Set shp = wst.Shapes.AddPicture( _
Filename:=fName(i), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=rng.Left, Top:=rng.Top, Width:=-1, Height:=-1)
ImageAdjustRange rng, shp
Application.StatusBar = "処理中：" & i & "/" & UBound(fName) & "枚目"
Next i
With Application
.StatusBar = False
.ScreenUpdating = True
End With
Set shp = Nothing
Set rng = Nothing
Set wst = Nothing
MsgBox i - 1 & "枚の画像を挿入しました", vbInformation
End Sub
Sub ImageAdjustRange(rng As Range, shp As Shape)
' 配置したセルに収まり、センター揃いになる様配置
Dim sngBackup As Single
Dim img_Rotation As Single
With shp
.LockAspectRatio = msoTrue
If .Rotation = 90 Or .Rotation = 270 Then
If .Width / rng.Height < .Height / rng.Width Then
.Height = rng.Width
Else
.Width = rng.Height
End If
Else
If .Height / rng.Height < .Width / rng.Width Then
.Width = rng.Width
Else
.Height = rng.Height
End If
End If
sngBackup = .Width
img_Rotation = .Rotation
.Rotation = 0#
.Top = rng.Top
.Left = rng.Left
.LockAspectRatio = msoFalse
.Width = .Height
.Rotation = img_Rotation
.Width = sngBackup
.LockAspectRatio = msoTrue
'Range の センター位置にくる様、画像位置を修正
If img_Rotation = 90 Or img_Rotation = 270 Then
If .Top > 0 And rng.Top + (rng.Height - .Width) / 2 + Abs(.Width - .Height) / 2 >= 0 Then
.Top = rng.Top + (rng.Height - .Width) / 2 + Abs(.Width - .Height) / 2
End If
If rng.Left + (rng.Width - .Height) / 2 - Abs(.Width - .Height) / 2 >= 0 Then
.Left = rng.Left + (rng.Width - .Height) / 2 - Abs(.Width - .Height) / 2
End If
Else
.Top = rng.Top + (rng.Height - .Height) / 2
.Left = rng.Left + (rng.Width - .Width) / 2
End If
End With
End Sub
