Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Home Premium : Excel 2013)
Pictureを挿入するマクロについて
投稿日時: 18/09/20 10:54:32
投稿者: スケソウダラ

いつもお世話になっております。
どなたかご教授ねがいます。
 
下記のように画像を選択挿入するマクロを作りました。
XPの時は問題なかったのですが、7になってから、
元の画像をゴミ箱にいれると、エクセル上の画像が消えてしまい。
「リンクされたイメージを表示できません」と表示されます。
 
なんででしょうか?
どなたか教えて下さい。
 
Public strFileName As Variant
 
Sub 一括挿入()
 
Dim FileCount As Integer
Dim FileToOpen As Variant
Dim TempFile As Variant
Dim PicRowCnt As Integer
Dim PicColumnCnt As Integer
Dim SetRowCnt As Integer
Dim ZuSpaceRow, ZuSpaceColumn As Integer
Dim i, j As Integer
     
    
'図の縦方向貼り付け数がない場合はエラー表示して終了
If ActiveSheet.Cells(11, 7) = "" Then
        ErrMsg1
        Exit Sub
Else
        SetRowCnt = ActiveSheet.Cells(11, 7).Value + 1
End If
 
'図の大きさがない場合はエラー表示して終了
If ActiveSheet.Cells(14, 7) = "" Then
        ErrMsg2
        Exit Sub
Else
        ZuHI = ActiveSheet.Cells(14, 7).Value
End If
 
OokisaHI = ZuHI * 28.345
ZuSpaceRow = OokisaHI / 13.5 + 2
ZuSpaceColumn = ZuSpaceRow / 3 + 1
 
'図の大きさの大きさ確認
If ActiveSheet.Cells(14, 7) > 10 Then
        ErrMsg3
        Exit Sub
End If
 
'挿入するファイルの種類の選択(jpg,gif,bmpのみ)
FileToOpen = Application.GetOpenFilename("画像ファイル (*.jpg;*.gif;*.bmp), *.jpg;*.gif;*.bmp", _
Title:="挿入ファイル選択", MultiSelect:=True)
     
'キャンセル時エラー表示
If IsArray(FileToOpen) = False Then
    EndMsg
    Exit Sub
End If
     
'選択されたファイル数をカウント
FileCount = UBound(FileToOpen, 1)
     
'ファイル名の並び替え(昇順)及び記憶
For i = 1 To FileCount
    For j = i To FileCount
        If FileToOpen(j) < FileToOpen(i) Then
            TempFile = FileToOpen(i)
            FileToOpen(i) = FileToOpen(j)
            FileToOpen(j) = TempFile
        End If
    Next j
Next i
    
'エクセルの新規作成(データ貼り付け用BOOK新規作成)
Workbooks.Add
Do Until Sheets.Count = 1
    Application.DisplayAlerts = False
    Sheets("Sheet" & Sheets.Count).Delete
    Application.DisplayAlerts = True
Loop
 
ActiveSheet.Name = "画像挿入"
ActiveWindow.Zoom = 100 'ズームサイズ
'ActiveWindow.DisplayGridlines = False '白塗りの設定の有無
     
Application.ScreenUpdating = False
     
'データの貼り付け
PicRowCnt = 1
PicColumnCnt = 1
For i = 1 To FileCount
    'ファイル名称の挿入
    strFileName = FileToOpen(i)
    ActiveSheet.Cells(3 + ZuSpaceRow * (PicRowCnt - 1), 1 + _
                        ZuSpaceColumn * (PicColumnCnt - 1)) = strNameOnly
    '画像の挿入
    ActiveSheet.Cells(4 + ZuSpaceRow * (PicRowCnt - 1), 1 + _
                        ZuSpaceColumn * (PicColumnCnt - 1)).Select
                         
    PicRowCnt = PicRowCnt + 1
    'サイズ変更
    ActiveSheet.Pictures.Insert(FileToOpen(i)).Select
    ActiveSheet.Shapes("Picture " & i).Select
        With Selection.ShapeRange
            '.LockAspectRatio = msoFalse '図の縦横比の固定の有無
            .Height = OokisaHI
        End With
         
    '指定数並べたら次の列へ
    If PicRowCnt = SetRowCnt Then
        PicRowCnt = 1
        PicColumnCnt = PicColumnCnt + 1
    End If
Next i
     
 
Application.ScreenUpdating = True
ActiveSheet.Cells(1, 1).Select
     
End Sub
 
'--------キャンセル時--------
Function EndMsg()
           
Dim Msg, Style, Title, Response
 
    Msg = "キャンセルが選択されました" & Chr(13) & "処理を中止します"
    Style = vbDefaultButton2
    Title = "終了メッセージ"
         
    ' メッセージを表示します。
    Response = MsgBox(Msg, Style, Title)
 
    Application.ScreenUpdating = True
    
End Function
 
'--------エラーメッセージ1--------
Function ErrMsg1()
           
Dim Msg, Style, Title, Response
 
    Msg = "挿入する画像の縦方向数が入力されていません。" & _
        Chr(13) & "縦方向数を入力して再度実行して下さい。"
    Style = vbDefaultButton2
    Title = "入力エラー"
 
    ' メッセージを表示
    Response = MsgBox(Msg, Style, Title)
 
    Application.ScreenUpdating = True
    
End Function
 
'--------エラーメッセージ2--------
Function ErrMsg2()
           
Dim Msg, Style, Title, Response
 
    Msg = "挿入する画像のサイズ(高さ)入力されていません。" & _
        Chr(13) & "サイズを入力して再度実行して下さい。"
    Style = vbDefaultButton2
    Title = "入力エラー"
 
    ' メッセージを表示
    Response = MsgBox(Msg, Style, Title)
 
    Application.ScreenUpdating = True
    
End Function
 
'--------エラーメッセージ3--------
Function ErrMsg3()
           
Dim Msg, Style, Title, Response
 
    Msg = "やりすぎでしょ〜 (´〜`)ξ 10cm以下にして下さい。"
         
    Style = vbDefaultButton2
    Title = "入力エラー"
 
    ' メッセージを表示
    Response = MsgBox(Msg, Style, Title)
 
    Application.ScreenUpdating = True
    
End Function
 
'--------フルパスからファイル名の取得--------
Function strNameOnly() As Variant
 
Dim m, n As Integer
 
    'iにstrfileNameの文字数を代入
    For m = Len(strFileName) To 1 Step -1
        n = n + 1
    'strfileName内の何文字目に\があるか検索
     If Mid(strFileName, m, 1) = "\" Then
        Exit For
     End If
    Next
    'strfileNameのファイル名を取得
    strNameOnly = Right(strFileName, n - 1)
 
End Function
 

回答
投稿日時: 18/09/20 13:15:23
投稿者: WinArrow
投稿者のウェブサイトに移動

>元の画像をゴミ箱にいれると、エクセル上の画像が消えてしまい。
> 「リンクされたイメージを表示できません」と表示されます。
 
きわめて、当たり前のことです。
 
> XPの時は問題なかったのですが、
 
おそらく、リンクの更新をしなかったのでしょう。
 

回答
投稿日時: 18/09/20 13:39:05
投稿者: sk

引用:
XPの時は問題なかったのですが、7になってから、
元の画像をゴミ箱にいれると、エクセル上の画像が消えてしまい。
リンクされたイメージを表示できません」と表示されます。

引用:
ActiveSheet.Pictures.Insert(FileToOpen(i)).Select

Pictures オブジェクトの Insert メソッドによって挿入されるのが
埋め込み画像とリンク画像のどちらであるかは、Excel のバージョンに
よって異なります。
 
Pictures オブジェクトの Insert メソッドではなく、
Shapes オブジェクトの AddPicture メソッドを使用して
明示的に埋め込み画像を追加するようにして下さい。
 
引用:
なんででしょうか?

Windows XP 環境にインストールされていた Excel の
バージョンが 2003 以前だったからでしょう。

回答
投稿日時: 18/09/20 14:10:01
投稿者: なと

この質問はとても頻繁に見かけますね。
回答はskさんの仰る通りですが、追加でヒントを。
 
「Pictures.Insert リンクされたイメージを表示できません」
でグーグル検索すると驚くほどたくさんのサンプルが出てきます。

回答
投稿日時: 18/09/20 15:50:26
投稿者: WinArrow
投稿者のウェブサイトに移動

WinArrow さんの引用:
>元の画像をゴミ箱にいれると、エクセル上の画像が消えてしまい。
> 「リンクされたイメージを表示できません」と表示されます。
 
きわめて、当たり前のことです。
 
> XPの時は問題なかったのですが、
 
おそらく、リンクの更新をしなかったのでしょう。
 

 
私のレス、適切ではなかったと思います。
skさんのレスにもありますように
Pictures.Insertは、Excel2007までと、Excel2010以降は仕様が変わっているようです。
また、このPicuresオブジェクトはExcel97以降、隠しオブジェクトなっていて、HELPでは参照できません。
 
>リンク
は、ファイルパス情報だけをExcelファイルに記録しています。
画像取り込みと比較すると、ファイル容量がすくなくなります。
記録したファイルパスにそのファイルがなくなって(削除や移動)しまうと、画像が表示できなくなります。
Excelファイルを他のPCに複写するときには、画像ファイルも一緒に渡し、画像ファイルを複写先のPCに同じ名前のフォルダを作成して格納する必要があります。
 
 

回答
投稿日時: 18/09/23 07:29:38
投稿者: simple

遅ればせながら。
こちらのサイトの"即効テクニック"に、
この関係(Pictues.Insertの挙動の変化およびそれへの対応)の記事があります。
「画像ファイルを挿入する」
http://www.moug.net/tech/exvba/0120020.html
参考にしてください。

投稿日時: 18/09/28 09:24:47
投稿者: スケソウダラ

WinArrow様
sk 様
なと 様
simple 様
 
ご回答ありがとうございます。
Set myShape = ActiveSheet.Shapes.AddPicture( _
          Filename:=strFileName, _
          LinkToFile:=False, _
          SaveWithDocument:=True, _
          Left:=Selection.Left, _
          Top:=Selection.Top, _
          Width:=0, _
          Height:=0)
 
で出来ました。
 
感謝です。
 
下記、疑問が残りました。
マクロの記憶で画像の挿入した場合、
Sub Macro1()
    ActiveSheet.Pictures.Insert( _
        "C:\Users\1821\Desktop\新しいフォルダー (2)\Resized\IMG_0501.jpg").Select
    Range("P3").Select
End Sub
となったのですが、この操作で挿入された元画像をゴミ箱にいれても、
エクセル上の画像が消えることはありません。
 
なんででしょうか?Excelの仕様でしょうか?
すみませんが教えて下さい。
 
  
 
 

回答
投稿日時: 18/09/28 09:43:01
投稿者: sk

引用:
マクロの記憶で画像の挿入した場合、
Sub Macro1()
    ActiveSheet.Pictures.Insert( _
        "C:\Users\1821\Desktop\新しいフォルダー (2)\Resized\IMG_0501.jpg").Select
    Range("P3").Select
End Sub
となったのですが、この操作で挿入された元画像をゴミ箱にいれても、
エクセル上の画像が消えることはありません。

Excel 2007 以前の環境下でそのマクロを実行したことによって、
既に埋め込み済みである画像に関してはそうでしょう。
 
Excel 2010 以前の環境下で同じマクロを実行して
新しい画像を挿入しようとした場合は、埋め込み画像ではなく
リンク画像として配置されることになり、もしリンク先の
画像を参照することが出来なくなれば、当然その画像は
表示されないはず。

回答
投稿日時: 18/09/29 21:52:12
投稿者: なと

なるほど。
 
最新バージョンのExcelでマクロの記録を行ってみましたが、生成されるコードはActiveSheet.Pictures.Insertになるのですね。
 
予想でしか無いですが、MicrosoftはExcelのGUI操作とマクロの記録のプログラムは変更せず、Insertメソッドの仕様だけを変更したんでしょう。
となると、仕様として受け入れるしかないと思います。
 
何も知らない初心者がこのマクロをそのまま利用するとリンク挿入になってしまうと・・。
 
最近はマクロの記録を使わないので知りませんでしたが、ようやく長年の謎が解けました。

回答
投稿日時: 18/09/30 13:43:27
投稿者: だるま
投稿者のウェブサイトに移動

こんにちは ^d^
 
コードの問題は解決して、マクロ記録とリンク貼り付けの関係についても
納得できるような回答が付いており、もう私の出番は無さそうです。
 
で、今更ですが画像貼り付けを簡単にするためのクラスがありますので、
参考までにご紹介させていただきます。
 
LoadPictureクラス ― 画像を指定セル(結合セル、セル範囲可)に読み込むクラス
http://hp.vector.co.jp/authors/VA033788/kowaza.html#0223
 
 
あと、こんなフリーソフトもありますのでこちらもご参考まで。
 
 
画像貼付Express
http://www.vector.co.jp/soft/winnt/business/se513830.html
 
実用的な機能に絞り【簡単操作】を実現した、ワークシート画像貼付ソフトです。
 
 
 
画像貼付名人
http://www.vector.co.jp/soft/winnt/business/se509888.html
 
複数画像の貼り付けと調整が簡単に出来ます。

投稿日時: 18/10/03 12:47:21
投稿者: スケソウダラ

なと 様
だるま 様
 
ご回答ありがとうございます。
マクロのコードは深くわからないものですから、マクロの記憶を
あてにしています。
 
稚拙なコードですが、私なりに満足いくものができたので、解決済みにさせていただきます。
 
皆さま、ありがとうございました。