[[20160301153848]]　『複数の画像を順番に貼付したい　VBA』（HaMi）　ページの最後に飛ぶ

『複数の画像を順番に貼付したい　VBA』（HaMi）

お世話になります。
リストがあり、そのリストと同じ名前の画像を指定のフォルダーから
貼り付けるというコードを作成しました。（下記参照ください)
しかしながら、Pictures.Insert()を使用するとリンクになってしまいます。
このコードをAddPictureに変更したいのですが、どう変えていいのかわかりません。
ご指導いただけないでしょうか？
以下、Pictures.Insertを使用したコードです。

Sub macro1()
Dim MF As String
Dim h As Range

'Image Address
MF = Range("B1") & "\"

'アクティブシートの既存のImage削除
ActiveSheet.Pictures.Delete

'Articleが入力されている行まで繰り返す　ForEachIn
For Each h In Range("C2:C" & Range("B1048576").End(xlUp).Row)

'Imageがファイルにある場合
If Dir(MF & h) <> "" Then
With ActiveSheet.Pictures.Insert(MF & h)

'列C「Filename」の右へ1列目にImageを入れる
.Top = h.Offset(0, 1).Top
.Left = h.Offset(0, 1).Left

'写真サイズの設定
.Width = h.Offset(0, 1).Width
.Height = h.Offset(0, 1).Height

End With

End If

End Sub

質問がわかりづらかったら、すみません。補足しますのでご指摘願います。
何卒よろしくお願いいたします。

＜使用 Excel：Excel2013、使用 OS：Windows2000 ＞

 【学校】の全文検索で　AddPicture を与えると、リンク貼り付けの解消のためPictures.InsertからAddPictureに変更する回答案のページがたくさん出てきますので
 それらをチェックしてみてください。

（β） 2016/03/01(火) 16:35

まず最初今から前提としてこのプログラムにはバグのようなものがあります

B1を空白
C列を空白にして実行するとCドライブ直下で実行されます。

普通にwindows7の時ただフォルダのパスに\を入れるとCドライプ直下になります。

またこの時C列を空白にすると
またDir(MF & h)はCドライブ直下にファイルがあるかどうかになりますので、通ります。
その状態で実行するとリンクされたイメージが表示されませんが空白の分複数作成されます。

まあB1を空白C列に途中に空白がある場合にには対応です
※個人的ですがwindows2000でexcel2013が動くんですね

（x） 2016/03/01(火) 16:48

（β）様、（x）様、ご回答ありがとうございます。
VBA超初心者のため、上記のコードにバグがあることもわかりませんでした。
他のAddpictureについての書き込みもみましたが、いまいち理解できず。。。でした。
元コードがだめなのでこれを元にしても動かないのでしょうか。
エラーは1004アプリケーション定義エラーとでます。（その前にインポートが中止されました）とでます。
※エクセルの表では、B列に画像の名前（未完成）C列にB列に補足をして画像の正しい名前が入る関数を入れています。
B1には画像のあるフォルダのアドレスです。

Sub macro1()
Dim MF As String
Dim h As Range
Dim myShape As Shape

'Image Address
MF = Range("B1") & "\"

'アクティブシートの既存のImage削除
ActiveSheet.Pictures.Delete

'Articleが入力されている行まで繰り返す　ForEachIn
For Each h In Range("C3:C" & Range("B1048576").End(xlUp).Row)

'Imageがファイルにある場合
If Dir(MF & h) <> "" Then
Set myShape = ActiveSheet.Shapes.AddPicture( _

    Filename:=MF, Linktofile:=False, _
    SavewithDocument:=True, _
           Left:=Selection.Left, _
          Top:=Selection.Top, _
          Width:=0, _
          Height:=0)

    myShape.ScaleHeight 1, msoTrue
    myShape.ScaleWidth 1, msoTrue

End If
Next
End Sub

どこをどのように直せば良いのか、ご教示くださると助かります。
画像がたくさんあります。どうか助けてください。
よろしくお願いします！
（HaMi） 2016/03/03(木) 10:37

 画像は D列に入れるんだと思いますが、何かご希望の位置等はありますか？

 ・元画像と縦横比率は同じにしたい
 ・D列のセルの中心に画像の中心をあわせたい
 ・できるだけセルの中に入る範囲で大きくしたい

 等々

（β） 2016/03/03(木) 11:06

（β）様ありがとうございます！！！

D列に挿入する形で考えています。
画像に関しては、

比率は元画像と同じ
セル内中心（左寄りでも大丈夫です）
セルの大きさに合わせて画像の大きさ変わる

この形で大丈夫です。
よろしくお願いいたします。
（HaMi） 2016/03/03(木) 11:47

 お試しください。

 Sub Sample()
    Dim MF As String
    Dim h As Range

    Application.ScreenUpdating = False

    'Image Address
    MF = Range("B1").Value & "\"
    'アクティブシートの既存のImage削除
    ActiveSheet.Pictures.Delete

    For Each h In Range("C2", Range("C" & Rows.Count).End(xlUp))
        If Dir(MF & h.Value) <> "" Then

            With ActiveSheet.Shapes.AddPicture(Filename:=MF & h.Value, LinkToFile:=False, _
                SaveWithDocument:=True, Left:=h.Offset(, 1).Left, Top:=h.Offset(, 1).Top, _
                Width:=-1, Height:=-1)    '★　とりあえず　縦横元サイズでセル左上隅に

                .LockAspectRatio = msoTrue '念のため縦横比率固定
                'セル内で最大限の大きさに
                .Width = h.Offset(, 1).Width
                If .Height > h.Offset(, 1).Height Then .Height = h.Offset(, 1).Height
                '中央へ配置
                .Left = h.Offset(, 1).Left + h.Offset(, 1).Width / 2 - .Width / 2
                .Top = h.Offset(, 1).Top + h.Offset(, 1).Height / 2 - .Height / 2
            End With

        End If
    Next

 End Sub

（β） 2016/03/03(木) 12:04

（β）様ありがとうございます！！！
動きました。
このコードをみて勉強させていただきます。

しかしながら、実行した後（画像は貼付できていますが）エラーメッセージがでます。
まず、「このファイルのインポート中にエラーが発生しました：C:\･･･（ファイルアドレス）」というメッセージがでて、その後、「400」というメッセージがでます。
これはどういうことでしょうか？

何度もすみませんが、教えてください。

よろしくお願いします。
（HaMi） 2016/03/03(木) 14:51

 お試しください。バクがあったら、教えてください。1年ぐらい前に自分用に作ったものです。
 http://ww10.puny.jp/uploader/download/1456984812.zip
 Excel画像貼付(ver1_02)@Shapes_AddPicture（ダウンロードパスワード：abc）
（マリオ） 2016/03/03(木) 15:06

（マリオ）様、ありがとうございます！
頂いたURLからDLしてみたのですが、私には高度過ぎて何がどうなっているのか
さっぱりわかりませんでした。
これを応用･･･どころか、使うことすらできなそうです。
すみません。

（HaMi） 2016/03/03(木) 15:51

 >>このファイルのインポート中にエラーが発生しました

 これを、そのまま検索語にしてググると、同じような報告ページがいくつかヒットしますね。
 xl2007 であれば、こと画像関係については、おそまつで、何が起こっても不思議ではないのですが
 そちらは xl2013 なんですよねぇ・・・（OS が win2000 というところが気になりますが）

 まぁ、ネットのページを１つ１つチェックして、そちらの環境や状況（含む画像のサイズ等）に合致するものがないか
 調べてください。

（β） 2016/03/03(木) 16:05

 Office2007の段階で、もうWINDOWS2000にはインストールできなかったような？
 Office2013は、XPでも駄目だったような？
（???） 2016/03/03(木) 16:20

 To マリオさん

 コード拝見。
 バグではないのですが、フォルダ選択のところ、ファイル選択画面だったので複数選択なのかなと。
 でも、選択できるのは１つだけで、結局は、選択されたファイルのフォルダからファイルを抽出しているのですね。

 コードコメントでも、

 '   フォルダを選択するダイアログボックスを表示

 となっていました。

 フォルダ選択ならフォルダ選択ダイアログを出してもいいのかも。

（β） 2016/03/03(木) 18:38

 To βさん
 見つかっちゃた(^^♪　ダイアログのところは、あまり気にしてません。
　
 写真が100枚とか多いときに、台紙コピーでタスクバーの表示がフリーズ。
 ★Application.StatusBar = "台紙コピー中です…　" & i + 1
 の表示がフリーズしたりします。フリーズしてても裏で動いていて、画像貼り付けの段階で、表示が復活します。

 あと、100回に1回ぐらい？、ごくたまに、画像貼り付け失敗します。100枚の内、1枚だけ失敗みたいな。
　複雑すぎて、自分でも見直すの苦労してます。
（マリオ） 2016/03/03(木) 23:44

皆さんがご指摘してくださっている、Windowsのﾊﾞｰｼﾞｮﾝですが
私のチェック間違いでした。
使用しているのはWindows７です。
すみませんでした。
（HaMi） 2016/03/04(金) 09:39

（β）様、（マリオ）様、ありがとうございました。
その後、いろいろ調べたりしましたが、できたようです。（新規でエクセルで再度コード書き換えしたところ、エラーが出なくなりました。。。なぜでしょう。）
これで、仕事が効率化できます。
ありがとうございました！もっと勉強します。
（HaMi） 2016/03/04(金) 11:23

コメント返信：

[ 一覧(最新更新順) ]

[[20160301153848]] 『複数の画像を順番に貼付したい VBA』（HaMi） ページの最後に飛ぶ

[[20160301153848]]　『複数の画像を順番に貼付したい　VBA』（HaMi）　ページの最後に飛ぶ