仕事で写真報告書を作っています。 3枚毎に貼りたいのですがどのようにすればよろしいでしょうか。
仕事で写真報告書を作っています。 3枚毎に貼りたいのですがどのようにすればよろしいでしょうか。 Option Explicit '図をリンク オブジェクトではなく図として挿入する 'Pictures.Insert メソッドではなく、Shapes.Add メソッドを使用 Sub 複数の画像を挿入2() Dim strFilter As String Dim Filenames As Variant Dim objShape As Shape Dim i As Integer ' 「ファイルを開く」ダイアログでファイル名を取得 strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png" Filenames = Application.GetOpenFilename( _ FileFilter:=strFilter, _ Title:="図の挿入(複数選択可）", _ MultiSelect:=True) If Not IsArray(Filenames) Then Exit Sub ' ファイル名をソート Call BubbleSort_Str(Filenames, True, vbTextCompare) ' 貼り付け開始セルを選択 Range("A1").Select ' マクロ実行中の画面描写を停止 Application.ScreenUpdating = False ' 順番に画像を挿入 For i = LBound(Filenames) To UBound(Filenames) Set objShape = ActiveSheet.Shapes.AddPicture( _ Filenames(i), False, True, Selection.Left, Selection.Top, 247#, 327#) '------------------------------------------------------------- ' 画像の各種プロパティ変更 '------------------------------------------------------------- With objShape.Width = Selection.Width * 0.95.Height = Selection.Height * 0.95.Left = Selection.Left + Selection.Width / 2 - .Width / 2.Top = Selection.Top + Selection.Height / 2 - .Height / 2 .Placement = xlMove ' 移動するがサイズ変更しない End With ' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル] ActiveCell.Offset(5).Select Set objShape = Nothing Next i ' 終了 Application.ScreenUpdating = True MsgBox UBound(Filenames) & "枚の画像を挿入しました", vbInformation End Sub ' バブルソート（文字列） 'ORIGINAL Private Sub BubbleSort_Str( _ ByRef Source As Variant, _ Optional ByVal SortAsc As Boolean = True, _ Optional ByVal Compare As VbCompareMethod = vbTextCompare) If Not IsArray(Source) Then Exit Sub Dim i As Long, j As Long Dim vntTmp As Variant For i = LBound(Source) To UBound(Source) - 1 For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1 If StrComp(Source(IIf(SortAsc, j, j + 1)), _ Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then vntTmp = Source(j) Source(j) = Source(j + 1) Source(j + 1) = vntTmp End If Next j Next i End Sub
B3からスタートして、下に3枚貼り そのあとK3へ移り下に３枚貼る作業を行いたいです。 現状B3（セル結合されている部分）のところで ダブルクリックすると写真選択できて サイズまで統一されるようになっております。 会社支給の報告書なので極力このフォーマットは使用したいです。 よろしくお願いいたします。
Visual Basic | Excel・64閲覧
ベストアンサー
＞そのあとK3へ移り下に３枚貼る 更にその後はどうしたいのでしょうか、一応そのまま横に続ける ということで、 画像貼り付け用の下記クラスモジュールを使用したコード例です。 （このクラスモジュールを使うと画像貼付は基本的に 画像のフルパスと貼り付先のセル又はセル範囲、を指定 するだけです。その他、隙間を空ける設定等も出来ます。） ＜＜＜ cLoadPicture クラスモジュールの設定方法 ＞＞＞ http://hp.vector.co.jp/authors/VA033788/kowaza.html#0223 上記リンク先にある、 ===== cLoadPicture クラスモジュール ===== の下、 Option Explicit 以下のコードを「クラスモジュール」にコピペして下さい。 クラスモジュールの挿入は、[挿入]-[クラスモジュール]メニューです。 そして、そのクラスモジュールの名前（オブジェクト名）を 「Class1」から「cLoadPicture」と変更して下さい。 ＜＜＜ 設定方法 ここまで ＞＞＞ 上記設定が完了しているとして、以下のコードを標準モジュールに コピペして下さい。 Sub 写真貼付() Dim cLP As cLoadPicture Dim R As Long, C As Long Dim i As Long Dim Fpaths As Variant Fpaths = Application.GetOpenFilename("写真(*.jpg),*.jpg", MultiSelect:=True) If Not IsArray(Fpaths) Then Exit Sub Fpaths = Csort(Fpaths) Set cLP = New cLoadPicture For i = 1 To UBound(Fpaths) R = ((i - 1) Mod 3) * 19 + 3 C = ((i - 1) \ 3) * 9 + 2 With cLP Set .LoadPointCell = Worksheets("写真報告台紙").Cells(R, C) .PictureFullPath = Fpaths(i) .LoadPicture End With Next End Sub Private Function Csort(ByVal Ary As Variant) As Variant '昇順並べ替え、引数は１次元配列のみ可 Dim L As Long Dim U As Long Dim i As Long Dim gap As Long Dim Temp As Variant Dim F As Boolean L = LBound(Ary) U = UBound(Ary) gap = U - L F = True Do While gap > 1 Or F = True gap = Int(gap / 1.3) If gap = 9 Or gap = 10 Then gap = 11 ElseIf gap < 1 Then gap = 1 End If F = False For i = L To U - gap If Ary(i) > Ary(i + gap) Then Temp = Ary(i) Ary(i) = Ary(i + gap) Ary(i + gap) = Temp F = True End If Next Loop Csort = Ary End Function 基本的に提示されている元コードは無視していますが、 元コードにファイル名をソートする部分があったので ソートは入れておきました。 もし、ソートは不要でダイアログで選択した順番 で処理するということでしたら、メインプロシージャ Sub 写真貼付() の中ほどの Fpaths = Csort(Fpaths) この行は不要です。 それと、ソート関数の、 Private Function Csort(ByVal Ary As Variant) As Variant 以下も不要です。
1人がナイス！しています
ありがとうございます。 クラスモジュールの設定の仕方ですが いまいちわからないのですが 再度ご教示頂けますでしょうか？
質問者からのお礼コメント
ありがとうございました。 ほんとに助かりました。、
お礼日時：2020/11/25 7:52
