|
あれあれ?(レス確認)・・・あ!
[#22653]で1行コピーし忘れてました。
申し訳ないです(i = PicCount + 1)
改めて全文を。
おわびではありませんが、「5」は冒頭の1つにしてみました。
Sub 取込()
'画像取込み
Const z1 As Single = 150 'サイズ指定
'↑ここで表示のサイズが変えられます。
Const ColChVal As Long = 5 '1列の画像数
'↑ここで縦に並べる数が変えられます。
Dim TopSetVal As Long
Dim LeftSetVal As Long
Dim PicCount As Long
Dim Stc As Variant
Dim Selnm As Variant
Dim x1 As Single
Dim y1 As Single
Dim xx As Single
Dim yy As Single
Dim i As Long
'ChDir "D:\Other
Selnm = Application.GetOpenFilename(Title:="Ctrl、矢印ドラッグで複数選択", _
MultiSelect:=True)
If Not IsArray(Selnm) Then MsgBox "キャンセルされました": Exit Sub
PicCount = ActiveSheet.Shapes.Count
TopSetVal = 30 + (PicCount Mod ColChVal) * (z1 + 10) '最上位の位置
LeftSetVal = Int(PicCount / ColChVal) * (z1 + 10) '左の位置
i = PicCount + 1
On Error Resume Next
With ActiveSheet 'Sheet指定
For Each Stc In Selnm
With .Shapes(.Pictures.Insert(Stc).Name)
If Err.Number = 0 Then
.Name = Dir(Stc, vbNormal) '名前付け
.LockAspectRatio = msoTrue '固定
x1 = .Width '横取得
y1 = .Height '縦取得
If x1 > y1 Then '縦横判定
xx = z1 '横形
yy = y1 * z1 / x1
Else
yy = z1 '縦形
xx = x1 * z1 / y1
End If
.Width = xx
.Height = yy
'------------------------------------------------ここから
'一旦切り取って、形式を指定して貼り付け
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Select
Selection.Cut
ActiveSheet.PasteSpecial Format:="図 (JPEG)", _
Link:=False, DisplayAsIcon:=False
Selection.Left = LeftSetVal '左位置指定
Selection.Top = TopSetVal '上位置指定
TopSetVal = TopSetVal + z1 + 10 '間隔指定
'ColChVal個目で列変え
If i Mod ColChVal = 0 Then
LeftSetVal = LeftSetVal + xx + 10
TopSetVal = 30
End If
i = i + 1
'------------------------------------------ここまでを追加
Else
Err.Clear 'ErrReset
End If
End With
Next
End With
End Sub
|
|