画像ファイルサイズアップ防止 VBA

Question

前提・実現したいこと

大事なところが抜けていた為、追記させていただきます。△1部分

excel VBAでセルの大きさに合わせて、画像をリサイズ挿入したいです。
＜手順＞
①所定セルをダブルクリック(添付画像：B4)
②予め指定したフォルダのダイアログボックスが開く
③画像を選択し開く
④セルの大きさに収まった大きさで画像が貼り付けられる。
△1.貼付画像の保管先が変更されると、”リンク先されたイメージを表示できません。”となる為、
貼付画像の保管先が変更されても影響されないようにしたいと考えております。
△1

発生している問題・エラーメッセージ

セルに合わせて画像が貼り付けられるのですが、excelファイルサイズが画像ファイルサイズの倍以上のファイルサイズになってしまう為、ファイルサイズアップを防ぎたいです。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim myPic
Dim myRange As Range 
Dim rX As Double, rY As Double

Dim myPath As String
myPath = "C:\画像"

With CreateObject("WScript.Shell")
    .CurrentDirectory = myPath
End With


myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
If VarType(myPic) = vbBoolean Then Exit Sub

Set myRange = Target 


Application.ScreenUpdating = False
With ActiveSheet.Pictures.Insert(myPic)


  rX = myRange.Width / .Width
  rY = myRange.Height / .Height
  If rX > rY Then
    .Height = .Height * rY
  Else
    .Width = .Width * rX
  End If
  
  .Left = .Left + (myRange.Width - .Width) / 2  
　.Top = .Top + (myRange.Height - .Height) / 2 

  .CopyPicture    
  .Delete        
End With

ActiveSheet.Paste   

Application.ScreenUpdating = True
Cancel = True
End Sub

Comments

[meg_]

マクロは完成しているのですね。質問タイトルが紛らわしいので修正してください。

[jabe]

アドバイスありがとうございます。タイトル名を変更しました。
画像貼り付け時にファイルサイズが大きくなるのを防止したいのですが、やり方が分からないのでご教示していただけるとありがたいです。

Answer 1

”リンク先されたイメージを表示できません。”

AddPictureを使いましょう

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim myPic
    Dim myRange As Range
    Dim rX As Double, rY As Double
    Dim myShape As Shape
    
    Dim myPath As String
    myPath = "C:\画像"
    
    With CreateObject("WScript.Shell")
        .CurrentDirectory = myPath
    End With
    
    myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
    If VarType(myPic) = vbBoolean Then Exit Sub
    
    Set myRange = Target
    
'    ' セルのサイズに合わせるだけならこちらでだけでOK
'    Set myShape = ActiveSheet.Shapes.AddPicture( _
'          Filename:=myPic, _
'          LinkToFile:=True, _
'          SaveWithDocument:=True, _
'          Left:=myRange.Left, _
'          Top:=myRange.Top, _
'          Width:=myRange.Width, _
'          Height:=myRange.Height)
    
    ' 画像の比率は残したままセルに合わせるならこちら
    Set myShape = ActiveSheet.Shapes.AddPicture( _
          Filename:=myPic, _
          LinkToFile:=True, _
          SaveWithDocument:=True, _
          Left:=myRange.Left, _
          Top:=myRange.Top, _
          Width:=0, _
          Height:=0)
    
    With myShape
        .ScaleHeight 1, msoTrue
        .ScaleWidth 1, msoTrue
        .LockAspectRatio = True
        rX = myRange.Width / .Width
        rY = myRange.Height / .Height
        If rX > rY Then
            .Height = .Height * rY
        Else
            .Width = .Width * rX
        End If
    End With

    Set myShape = Nothing

End Sub

Comments

[jabe]

コードありがとうございます。
狙い通りに動作しました。助かりました。

AddPictureメソッド初めて知りました。これを機に勉強していきます。

Answer 2

.Topまでで画像への処理が終わっているので下記は不要です。
コメントアウトしています。

'  .CopyPicture    
'  .Delete        
End With

'ActiveSheet.Paste   

Pasteすることによって該当セルの左上を起点に貼り付けられているので、
.Leftと.Topで位置指定していたのが無意味になっています。
上記のようにすることによってファイルサイズは小さいですし、位置も真ん中になります。

Comments

[jabe]

説明ありがとうございます。

大事なところが抜けていましたので追加させてください。
元々の方法の場合、貼付画像の保管先が変更されると、”リンク先されたイメージを表示できません。”となる為、貼付画像の保管先が変更されても影響されないようにしたいと考えております。

Answer 3

  .CopyPicture    
  .Delete        

ActiveSheet.Paste   

ファイルサイズが大きくなるのはここのコピー＆ペーストで
元の画像ファイル情報が無くなるからです。

画像オブジェクトのサイズ変更は
.Width
.Height
の値を直接変更する事で可能ですので、そのように修正してみて下さい。

Comments

[jabe]

回答ありがとうございます。
画像オブジェクトサイズ変更は理解しました。

ファイルサイズアップ要因はそのような理由なんですね。
こちらを解消するにはどのようなコードにすればよいのでしょうか？

[kuma_kuma_]

いやもうすでに
If rX > rY Then
.Height = .Height * rY
Else
.Width = .Width * rX
End If
でされているでしょ？

.CopyPicture
.Delete
ActiveSheet.Paste
この処理が特別な意味があれば別ですが、要らないですよね？
という事です。

[jabe]

大事なところが抜けていましたので追加させてください。
元々の方法の場合、貼付画像の保管先が変更されると、”リンク先されたイメージを表示できません。”となる為、貼付画像の保管先が変更されても影響されないようにしたいと考えております。