Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

4706 / 76732

←次へ　｜　前へ→


	【77642】EXCEL VBAでの写真一括貼り付けについての質問

daizuko

- 15/11/16(月) 17:27 -


	引用なし

	パスワード

はじめまして。
どなたか分かる方がいましたらお答えいただければ幸いです。

EXCEL VBAにて複数の写真を一括貼り付けできるマクロを組みました。
しかし、私がつくったものは全てリンク貼り付けとなってしまいます。
仕事上、送受信やファイル名変更がたびたびあり、そのたびにリンクが切れてしまい大変不便です。
どのように変更すればリンク貼り付けではなくなるでしょうか。

また、こちらは出来ればでいいのですが、写真を貼り付けた際、写真のファイル名をセルに表示することは可能でしょうか。

よろしくお願いいたします。

Sub 複数の画像を挿入()
　
　　Dim strFilter As String
　　Dim Filenames As Variant
　　Dim PIC　　　 As Picture
　　
　　' 「ファイルを開く」ダイアログでファイル名を取得
　　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)
　　
　　' 貼り付け開始セルを選択
　　Set Rng = Application.InputBox( _
　　　　Prompt:="貼り付け開始セルを入力してください", _
　　　　Title:="セル選択ダイアログ", _
　　　　Type:=8)
　　　　
　　　　Rng.Select
　　
　　' マクロ実行中の画面描写を停止
　　Application.ScreenUpdating = False
　　
　　L = InputBox("画像の間隔を入力してください")
　　N = InputBox("画像の高さを入力してください(行の高さ)")
　　
　　
　　' 順番に画像を挿入
　　For i = LBound(Filenames) To UBound(Filenames)
　　　　Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))
　　　
　　　　'-------------------------------------------------------------
　　　　' 画像の各種プロパティ変更
　　　　'-------------------------------------------------------------
　　　　With PIC
　　　　　　.Top = ActiveCell.Top　　　　' 位置：アクティブセルの上側に重ねる
　　　　　　.Left = ActiveCell.Left　　　' 位置：アクティブセルの左側に重ねる
　　　　　　.Placement = xlMove　　　　　' 移動するがサイズ変更しない
　　　　　　.PrintObject = True　　　　　' 印刷する
　　　　End With
　　　　With PIC.ShapeRange
　　　　　　.LockAspectRatio = msoTrue　 ' 縦横比維持
　　　　　　.Height = N
　　　　End With

　　　　ActiveCell.Offset(L).Select
　　
　　　　Set PIC = Nothing
　　Next i
　
　　' 終了
　　Application.ScreenUpdating = True
　　MsgBox i & "枚の画像を挿入しました", vbInformation

End Sub

' バブルソート（文字列）
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

2 hits

▼

【77642】EXCEL VBAでの写真一括貼り付けについての質問 daizuko 15/11/16(月) 17:27