Excel (VBA)

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

 
(指定なし : Excel 2013)
Excelへの画像挿入について
投稿日時: 23/12/21 21:47:53
投稿者: soonrail

下記のExcel VBAについてご教示いただけますでしょうか。
画像取込はできるのですが、リンク貼り付けとなり元の画像を削除すると
Excel上には画像が表示されなくなります。
元の画像を削除してもExcel上の画像は表示されるように修正したいのですが、
ご教示願いますでしょうか。
 
 
' 指定したフォルダにある画像ファイルを読み込み、EXCELシートに貼り付ける。
' 2023/9/27 21画像以降は2列にする
'
Sub EggFunc_pasteDirImage()
 
     ' 変数定義
     Dim fileName As String
     Dim targetCol As Integer
     Dim targetRow As Integer
     Dim targetCell As Range
     Dim shell, myPath
     Dim pos As Integer
     Dim extention As String
     Dim isImage As Boolean
 
     Dim vRootFolder As String
     Dim currentFolderPath As String
 
     Dim tagetcells As Integer
 
     Dim mergedWidth As Double
     Dim mergedHeight As Double
      
     Dim targetCell1 As Range
     Dim mergeArea As Range
     Dim mergedRowCount As Long
 
     Dim imageCount As Long
  
     Dim targetCell2 As Range
     Dim mergeArea2 As Range
     Dim mergedColumnCount2 As Long
      
     Dim tagetcells2 As Integer
     Dim targetRow1 As Integer
   
 
     ' 選択セルを取得
     targetRow = Range("z11") '貼り付け開始行
     targetRow1 = Range("z11") '貼り付け開始行固定
     targetCol = Range("z12") '貼り付け開始列
     'tagetcells = Range("d3") '結合セル数
      
     '行方向結合セル数を取得
     Set targetCell1 = Cells(targetRow, targetCol)
     'Set targetCell1 = Range("B5")
     Set mergeArea = targetCell1.mergeArea
     
     mergedRowCount = mergeArea.Rows.Count
     tagetcells = mergedRowCount '結合セル数
      
 
  
     ' 列方向結合セル数を取得
     Set targetCell2 = Cells(targetRow, targetCol)
     Set mergeArea2 = targetCell2.mergeArea
 
     mergedColumnCount2 = mergeArea2.Columns.Count
     tagetcells2 = mergedColumnCount2 ' 結合セル数
 
         
     ' targetCol = ActiveCell.Column
     ' targetRow = ActiveCell.Row
     ' Range("B2").Select
   
   
   
     ' フォルダ選択画面を表示
     Set shell = CreateObject("Shell.Application")
      
     Set myPath = shell.BrowseForFolder(0, "フォルダを選んでください", &H1 + &H10, ThisWorkbook.Path)
      
     Set shell = Nothing
 
 
    'マクロの画面上の動きを見せなくする
     Application.ScreenUpdating = False
 
      
     ' フォルダを選択したら...
     If Not myPath Is Nothing Then
          
         fileName = Dir(myPath.Items.Item.Path + "\")
          
         Do While fileName <> ""
                          
             ' ファイル拡張子の判別
            isImage = True
             pos = InStrRev(fileName, ".")
             If pos > 0 Then
                 Select Case LCase(Mid(fileName, pos + 1))
                     Case "jpeg"
                     Case "jpg"
                     Case "gif"
                     Case "png"
                     Case Else
                         isImage = False
                 End Select
             Else
                 isImage = False
             End If
              
             ' 拡張子が画像であれば
            If isImage = True Then
                  
                 ' 貼り付け先を選択
                Cells(targetRow, targetCol).Select
                Set targetCell = ActiveCell
                  
                 ' 画像読込み
                ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName).Select
                'ActiveSheet.Pictures.Insert (myPath.Items.Item.Path + "\" + fileName)
                ActiveSheet.Shapes(1).LockAspectRatio = msoFalse
                  
                  
            ' 画像が結合されたセルより大きい場合のサイズ調整
             
                mergedWidth = targetCell.mergeArea.Width
                mergedHeight = targetCell.mergeArea.Height
             
             
                If Selection.Width > mergedWidth Or Selection.Height > mergedHeight Then
                    If Selection.Width / mergedWidth > Selection.Height / mergedHeight Then
                        Selection.Height = Selection.Height * (mergedWidth / Selection.Width)
                        Selection.Width = mergedWidth
                    Else
                        Selection.Width = Selection.Width * (mergedHeight / Selection.Height)
                        Selection.Height = mergedHeight
                    End If
                End If
                  
                
                ' 画像カウンターをインクリメント
                imageCount = imageCount + 1
             
                ' 20枚ごとに列を移動
                If imageCount Mod 20 = 0 Then
                    targetCol = targetCol + tagetcells2 + 1 ' 貼り付け開始列+5
                    targetRow = targetRow1 ' 貼り付け開始行に戻す
                Else
                    ' 20枚以外の場合、行を進める
                    targetRow = targetRow + tagetcells
                End If
                  
                  
                  
             End If
              
             fileName = Dir()
          
         Loop
          
         MsgBox "画像の読込みが終了しました"
      
     Range("U1").Select
      
     End If
 
 
     '止めていた画面の動きを元に戻す
     Application.ScreenUpdating = True
 
 
 End Sub
 

回答
投稿日時: 23/12/21 23:18:10
投稿者: simple

即効テクニックの以下の記事を参考にしてください。
https://www.moug.net/tech/exvba/0120020.html
●注意2● の箇所です。
 
繰り返すと、
 ' 画像読込み

   ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName).Select
のところを
    With ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName)
        .CopyPicture    'クリップボードにコピー
        .Delete         '画像をいったん削除
    End With
    ActiveSheet.Paste   '画像を貼り付け
に変更するとよいでしょう。画像(Pictureオブジェクト)が選択状態になります。
 
■具体的には、
【この部分】を
 
   ' 貼り付け先を選択
    Cells(targetRow, targetCol).Select
    Set targetCell = ActiveCell

    ' 画像読込み
    ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName).Select
    ActiveSheet.Shapes(1).LockAspectRatio = msoFalse

    ' 画像が結合されたセルより大きい場合のサイズ調整
    mergedWidth = targetCell.mergeArea.Width
    mergedHeight = targetCell.mergeArea.Height

    If Selection.Width > mergedWidth Or Selection.Height > mergedHeight Then
        If Selection.Width / mergedWidth > Selection.Height / mergedHeight Then
            Selection.Height = Selection.Height * (mergedWidth / Selection.Width)
            Selection.Width = mergedWidth
        Else
            Selection.Width = Selection.Width * (mergedHeight / Selection.Height)
            Selection.Height = mergedHeight
        End If
    End If
【このコード】に置き換えて下さい。
 
   Dim myFilePath  As String
    Dim targetCell  As Range
    Dim shp         As Shape
    Dim mergedWidth As Double, mergedHeight As Double
    
    Set targetCell = Selection
    
    myFilePath = "画像のフルパス"
    With ActiveSheet.Pictures.Insert(fileName:=myFilePath)
        .CopyPicture    'クリップボードにコピー
        .Delete         '画像をいったん削除
    End With
    ActiveSheet.Paste   '画像を貼り付け
    Set shp = Selection.ShapeRange(1)
    shp.LockAspectRatio = msoFalse
    
    ' 画像が結合されたセルより大きい場合のサイズ調整
    mergedWidth = targetCell.mergeArea.Width
    mergedHeight = targetCell.mergeArea.Height

    If shp.Width > mergedWidth Or shp.Height > mergedHeight Then
        If shp.Width / mergedWidth > shp.Height / mergedHeight Then
            shp.Height = shp.Height * (mergedWidth / shp.Width)
            shp.Width = mergedWidth
        Else
            shp.Width = shp.Width * (mergedHeight / shp.Height)
            shp.Height = mergedHeight
        End If
    End If

このほか、Shapes.AddPictureを使う方法もあるようです。

回答
投稿日時: 23/12/22 07:02:15
投稿者: simple

補足です。
 
Pictures.Insertすると挿入された画像(Picture)と関連付けられたShapeオブジェクトの
縦横比.LockAspectRatioはmsoTrueが設定されているので、
単に、以下のように書けます。

     画像が結合されたセルより大きい場合のサイズ調整
    mergedWidth = targetCell.mergeArea.Width
    mergedHeight = targetCell.mergeArea.Height

    If shp.Width > mergedWidth Or shp.Height > mergedHeight Then
        If shp.Width / mergedWidth > shp.Height / mergedHeight Then
            shp.Width = mergedWidth
        Else
            shp.Height = mergedHeight
        End If
    End If
-------------------------------------------------------------
【もうひとつの方法 : Shapes.AddPictureを利用 】
Shapes.AddPictureを利用する場合は、以下のように書けます。
.Shapes.AddPictureの使い方については、下記を参照ください。
https://engi.cocolog-nifty.com/sirenai/2019/04/post-bb08.html
 
Width:=-1, Height:= -1として .Shapes.AddPictureを使う方法は、
いかにもトリッキーなTipsで少し気が差しますが、使えることは使えます。
 
Sub test2()
    Dim myFilePath As String
    Dim targetCell As Range
    Dim shp As Shape
    Dim mergedWidth As Double, mergedHeight As Double
    
    Set targetCell = Selection
    
    myFilePath = "画像のパス"      ' ■(修正ください)
    Set shp = ActiveSheet.Shapes.AddPicture(myFilePath, False, msoTrue, _
                                            targetCell.Left, targetCell.Top, -1, -1)
    shp.Width = targetCell.Width

    ' 画像が結合されたセルより大きい場合のサイズ調整
    mergedWidth = targetCell.mergeArea.Width
    mergedHeight = targetCell.mergeArea.Height

    If shp.Width > mergedWidth Or shp.Height > mergedHeight Then
        If shp.Width / mergedWidth > shp.Height / mergedHeight Then
            shp.Width = mergedWidth
        Else
            shp.Height = mergedHeight
        End If
    End If
    'Width:=-1, Height:= -1として .Shapes.AddPictureしたときは、自動的に
    '.LockAspectRatioが msoTrueになるので、上記のようなコードで問題ないことに注意。
End Sub

投稿日時: 23/12/22 07:25:25
投稿者: soonrail

simpleさま
ご教示ありがとうございます。
 
画像挿入については下記のコード変更で解消しました。
 
    With ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName)
        .CopyPicture 'クリップボードにコピー
        .Delete '画像をいったん削除
    End With
    ActiveSheet.Paste '画像を貼り付け
 
他のご教示の部分は今後修正したいと思います。
ありがとうございました。

投稿日時: 23/12/22 08:53:02
投稿者: soonrail

simpleさま
ご教示ありがとうございます。
解決しました。