ここから本文です

エクセル2013 マクロで写真画像挿入 エクセル2013で、マクロで写真画像を挿入す...

miu********さん

2017/4/515:05:57

エクセル2013 マクロで写真画像挿入

エクセル2013で、マクロで写真画像を挿入することを行いたく、以下のマクロを参考にしました。

以下のマクロでは、ファイルダイアログで、複数のファイルも選択できるのですが、
0.5行ずつあけながら、写真ファイルを挿入していくと、1ページ目は、3枚の写真が貼り付けられますが、2ページ目、3ページ目と行くと、1ページ目と同じようなファイルの挿入位置にはならず、写真画像の
途中で、改ページされてしまいます。

1ページにつき、3枚の写真をどのページも貼り付けるようにするには、どうしたらいいのでしょうか?

貼り付ける写真のデータは、150枚ほどです。

-----------------------------------------------------------------------------------
Sub ボタン5_Click()
'PastePicturesマクロ
Dim filenames As Variant, filename As Variant
Dim fd As FileDialog
Dim shp As shape

filenames = Application.GetOpenFilename( _
FileFilter:="画像ファイル,*.png;*.jpg", _
MultiSelect:=True)



If IsArray(filenames) Then
For Each filename In filenames
'画像間を0.5行空ける
PastePicture CStr(filename), 0.5
Next filename
End If

End Sub

Sub PastePicture(filename As String, offset As Integer)
Dim picture As shape
Dim shp As shape

Set picture = ActiveSheet.Shapes.AddPicture( _
filename:=filename, _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=Selection.Left, Top:=Selection.Top, _
Width:=0, Height:=0)

picture.ScaleHeight 0.6!, msoTrue
picture.ScaleWidth 0.6!, msoTrue


MoveDown picture.Height, offset



End Sub

Sub MoveDown(pt As Double, offset As Integer)
Dim moved As Double

moved = 0
Do While moved <= pt
'ActiveCell.heightはポイント単位
moved = moved + ActiveCell.Height
ActiveCell.offset(1, 0).Activate
Loop
ActiveCell.offset(offset, 0).Activate
End Sub
-----------------------------------------------------------------------------------------------------

閲覧数:
1,034
回答数:
1
お礼:
100枚

違反報告

ベストアンサーに選ばれた回答

ina********さん

2017/4/610:33:21

画像貼り付け用の下記クラスモジュールを使用したコードです。


<<< cLoadPicture クラスモジュールの設定方法 >>>

http://hp.vector.co.jp/authors/VA033788/kowaza.html#0223

上記リンク先にある、

===== cLoadPicture クラスモジュール ===== の下、
Option Explicit 以下のコードを「クラスモジュール」にコピペして下さい。

クラスモジュールの挿入は、[挿入]-[クラスモジュール]メニューです。

そして、そのクラスモジュールの名前(オブジェクト名)を
「Class1」から「cLoadPicture」と変更して下さい。

<<< 設定方法 ここまで >>>


上記設定が完了しているとして、以下のコードを標準モジュールに
コピペして下さい。


Sub Sample2()
Dim cLP As cLoadPicture
Dim Pic As Shape
Dim Fs As Variant
Dim F As Variant
Dim R As Range
Dim C As Long

'画像ファイル選択
Fs = Application.GetOpenFilename("画像(*.jpg;*.jpeg),*.jpg;*.jpeg", MultiSelect:=True)
If VarType(Fs) = vbBoolean Then Exit Sub

'画像貼り付け用クラス
Set cLP = New cLoadPicture
'画像貼り付け位置
Set R = Range("A1")

For Each F In Fs
C = C + 1

Set cLP.LoadPointCell = R.Resize(18, 5) '貼り付け位置
cLP.PictureFullPath = F '画像フルパス
cLP.SetCenter = False '中央揃え(なし)
cLP.LoadPicture '画像貼り付け実行

'貼り付けた画像
Set Pic = cLP.Picture

' '★画像の大きさ調整
' Pic.ScaleHeight 0.6, msoTrue
' Pic.ScaleWidth 0.6, msoTrue

'次の貼り付け位置
Set R = Intersect(R.EntireColumn, Pic.BottomRightCell.EntireRow)
Set R = R.Offset(1)

'3枚貼り付けたら改ページを挿入
If C Mod 3 = 0 Then
R.Worksheet.HPageBreaks.Add R
End If
Next

Set cLP = Nothing
End Sub



今回使用している「画像貼り付け用クラス」では、貼り付け先のセル範囲
を指定すればその範囲に合うように画像の大きさを自動調整する機能が
ありますので、とりあえず貼り付け先のセル範囲を18行5列としています。

Set cLP.LoadPointCell = R.Resize(18, 5) '貼り付け位置

もし、元コードのように、貼り付けた画像の大きさを元の画像の大きさ
の60%にしたければ、

' '★画像の大きさ調整
' Pic.ScaleHeight 0.6, msoTrue
' Pic.ScaleWidth 0.6, msoTrue

ここのリマーク(')を外して、コードを有効にしてください。


因みに、(今回の様な改ページの挿入という機能はありませんが)
こんなフリーソフトもあります、ご参考まで。


画像貼付Express
http://www.vector.co.jp/soft/winnt/business/se513830.html

実用的な機能に絞り【簡単操作】を実現した、ワークシート画像貼付ソフトです。



画像貼付名人
http://www.vector.co.jp/soft/winnt/business/se509888.html

複数画像の貼り付けと調整が簡単に出来ます。

  • 質問者

    miu********さん

    2017/4/613:25:40

    こんなに早く、アドバイスいただき有難うございました。期待通りの結果ができ、大変うれしく思います。有難うございます。あと、ファイル名をファイルの下に記載するにはどうしたらいいでしょうか?アドバイスいただけたらうれしいです。宜しくお願いします。

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる