[[20150831074248]]　『VBAで画像をまとめて読み込み、隙間なく配置し（＝x（ikon）　ページの最後に飛ぶ

『VBAで画像をまとめて読み込み、隙間なく配置し（＊完成画像参照）ファイル名を画像直下に置きたいです』（ikon）

以下の様な名簿を作りたいのですが
サンプル：http://xup.cc/xup9vogflue
ものを作りたいのですが、このソースでは実行結果のようになってそこから
実行結果：http://xup.cc/xup0nziinjl

実行→ファイル名に空白を置換→画像を1.96にリサイズ→一つ一つ所定位置に配置→
名前を画像下にコピペという手順を踏みます。これらをVBAで行いたいのですが・・・
アドバイスをお願いいたします。

/ソース

Option Explicit
Sub InsertPictures()

    Dim fName As Variant
    Dim i As Long
    Dim Pict As Picture

    fName = Application.GetOpenFilename("JPGファイル, *.jpg", MultiSelect:=True)
    If IsArray(fName) Then
        Application.ScreenUpdating = False
        '配列に格納されたファイル名をソート
        BubbleSort fName, True
        For i = 1 To UBound(fName)
            Set Pict = ActiveSheet.Pictures.Insert(fName(i))
            With Pict
                .TopLeftCell = ActiveCell
                .ShapeRange.LockAspectRatio = msoTrue
                'どちらかをコメントアウト
                .ShapeRange.Height = ActiveCell.Height 'セルの高さリサイズ
                '.ShapeRange.Width = ActiveCell.Width 'セルの幅にリサイズ
                ActiveCell.Offset(0, 1) = fName(i) 'ファイル名書込み
            End With
            ActiveCell.Offset(4, 0).Activate
            Application.StatusBar = "処理中：" & i & "/" & UBound(fName) & "枚目"
        Next i
    End If
    With Application
        .StatusBar = False
        .ScreenUpdating = True
    End With
    Set Pict = Nothing
    MsgBox i & "枚の画像を挿入しました", vbInformation

End Sub

'値の入替え
Public Sub Swap(ByRef Dat1 As Variant, ByRef Dat2 As Variant)

    Dim varBuf As Variant
    varBuf = Dat1
    Dat1 = Dat2
    Dat2 = varBuf

End Sub

'配列のバブルソート
Public Sub BubbleSort(ByRef aryDat As Variant, _

    Optional ByVal SortAsc As Boolean = True)

    Dim i As Long
    Dim j As Long
    For i = LBound(aryDat) To UBound(aryDat) - 1
        For j = LBound(aryDat) To LBound(aryDat) + UBound(aryDat) - i - 1
            If aryDat(IIf(SortAsc, j, j + 1)) > aryDat(IIf(SortAsc, j + 1, j)) Then
                Call Swap(aryDat(j), aryDat(j + 1))
            End If
        Next j
    Next i

End Sub

＜使用 Excel：Excel2010、使用 OS：Windows 10 ＞

用心のため、外部URLはあまり踏みたくないので、ソースだけ見て書きます。

現状のマクロで、既に画像の貼り付けは実現できてますよね？
ActiveCell.Offset(4, 0).Activate の1文で、次は4行下、と指定しているので、
このあたりを変えるだけで実現できるのではないでしょうか？

あと、iのループを抜けた後にiを枚数として表示していますが、これだと必ず1枚多く表示されますよ。
（???） 2015/08/31(月) 10:46

 >>画像を1.96にリサイズ

 この意味がよくわかりません。
 また、実際の配置も適当に設定。
 「隙間なく」であれば Adjust を　0 にすればよろしいかと。
 配置要件や大きさについては先頭の

    Const pW As Double = 72
    Const pH As Double = 72
    Const lH As Double = 18
    Const cntH As Long = 12
    Const adjust As Double = 5

 ここを調整してください。

 Sub Test()
    Const pW As Double = 72     '写真の幅
    Const pH As Double = 72     '写真の高さ
    Const lH As Double = 18     '名前欄の高さ
    Const cntH As Long = 12     '１段の写真の数
    Const adjust As Double = 5  '写真と写真の間の隙間

    Dim fName As Variant
    Dim f As Variant
    Dim x As Long
    Dim y As Long
    Dim al As Object
    Dim myL As Double
    Dim myT As Double
    Dim nm As Variant

    ActiveSheet.Labels.Delete
    ActiveSheet.Pictures.Delete
    ActiveSheet.UsedRange.ClearContents
    Set al = CreateObject("System.Collections.ArrayList")

    fName = Application.GetOpenFilename("JPGファイル, *.jpg", MultiSelect:=True)
    If IsArray(fName) Then
        '昇順並び替え
        For Each f In fName
            al.Add f
        Next
        al.Sort
        fName = al.toarray
        y = 1
        For Each f In fName
            x = x + 1
            If x > cntH Then
                x = 1
                y = y + 1
            End If
            '画像の貼り付け
            myL = (pW + adjust) * (x - 1)
            myT = (pH + lH + adjust) * (y - 1)
            With ActiveSheet.Shapes.AddPicture( _
                    Filename:=f, _
                    LinkToFile:=False, _
                    SaveWithDocument:=True, _
                    Left:=Selection.Left, _
                    Top:=Selection.Top, _
                    Width:=0, _
                    Height:=0)
                '一旦、元のサイズに戻す
                .ScaleHeight 1, msoTrue
                .ScaleWidth 1, msoTrue
                'サイズ、位置調整
                .Left = myL
                .Top = myT
                .Width = pW
                .Height = pH
            End With
            '名前用ラベル
            nm = Split(f, "\")
            nm = nm(UBound(nm))
            nm = Split(nm, ".")(0)
            With ActiveSheet.Labels.Add(myL, myT + pH, pW, lH)
                .Caption = nm
            End With

        Next

    End If

 End Sub

（β） 2015/08/31(月) 10:55

ありがとうございました。
画像の位置決め、の問題でした・・ただ、このソースだともとの画像が縮小するので
1.96＊1.96が１００％だったのですが25％にリサイズされていましたので１００％にする手順を踏んでいました。

ちょっと勉強不足なのを実感しましたので頑張ります。
（ikon） 2015/08/31(月) 11:51

コメント返信：

[ 一覧(最新更新順) ]

[[20150831074248]] 『VBAで画像をまとめて読み込み、隙間なく配置し（＝x（ikon） ページの最後に飛ぶ

[[20150831074248]]　『VBAで画像をまとめて読み込み、隙間なく配置し（＝x（ikon）　ページの最後に飛ぶ