[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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 >
現状のマクロで、既に画像の貼り付けは実現できてますよね?
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 '1段の写真の数 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
ちょっと勉強不足なのを実感しましたので頑張ります。
(ikon) 2015/08/31(月) 11:51
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.