Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


4704 / 76732 ←次へ | 前へ→

【77644】Re:VBA 画像圧縮
回答  ウッシ  - 15/11/17(火) 8:43 -

引用なし
パスワード
   こんにちは

セルに貼り付けた画像のサイズにして良ければ、

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
  Dim myF As Variant
  Dim mySp As Object
  Dim myAD1 As String
  Dim myAD2 As String
  Dim myHH As Double
  Dim myWW As Double
  Dim myHH2 As Double
  Dim myWW2 As Double
  Dim myPic As Variant
  Dim myRange As Range
  Dim rX As Single
  Dim rY As Single
  Dim cht As Chart
  
  '挿入のセルを指定
  
  If Application.Intersect(Target, Range("D6,D23,D40")) Is Nothing Then Exit Sub
  Cancel = True
  Application.ScreenUpdating = False
  
  '写真挿入
  myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
  If myPic = False Then
    Application.ScreenUpdating = True
    MsgBox "画像を選択してください"
    Exit Sub
  End If
  
  Set myRange = Target 'このセル範囲に収まるように画像を縮小する
  Application.ScreenUpdating = False
  With ActiveSheet.Shapes.AddPicture(myPic, False, True, myRange.Left, myRange.Top, myRange.Width, myRange.Height)
    
    rX = 0.85
    rY = 1
    
    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 '写真を縦方向に中央に配置
    .ZOrder msoSendToBack '最背面へ移動
    
    Kill myPic
        
  End With
  
  myRange.Select
  myRange.CopyPicture appearance:=xlScreen, Format:=xlPicture
  '画像貼り付け用の埋め込みグラフを作成
  Set cht = ActiveSheet.ChartObjects.Add(0, 0, myRange.Width + 1, myRange.Height + 1).Chart
  '埋め込みグラフに貼り付ける
  cht.Paste
  'JPEG形式で保存
  cht.Export Filename:=myPic, filtername:="JPG"
  '埋め込みグラフを削除
  cht.Parent.Delete
  
  Application.ScreenUpdating = True
  Cancel = True

End Sub

とかでどうでしょうか?

元画像を削除しますのでテスト環境で試して下さい。

2 hits

【77636】VBA 画像圧縮 SEWING11 15/11/14(土) 22:45 質問[未読]
【77637】Re:VBA 画像圧縮 β 15/11/15(日) 6:10 発言[未読]
【77638】Re:VBA 画像圧縮 SEWING11 15/11/15(日) 16:02 お礼[未読]
【77639】Re:VBA 画像圧縮 β 15/11/15(日) 17:17 発言[未読]
【77640】Re:VBA 画像圧縮 マナ 15/11/15(日) 21:11 発言[未読]
【77641】Re:VBA 画像圧縮 SEWING11 15/11/15(日) 21:38 お礼[未読]
【77644】Re:VBA 画像圧縮 ウッシ 15/11/17(火) 8:43 回答[未読]
【77646】Re:VBA 画像圧縮 SEWING11 15/11/18(水) 0:15 お礼[未読]
【77647】Re:VBA 画像圧縮 ウッシ 15/11/18(水) 8:39 回答[未読]
【77648】Re:VBA 画像圧縮 β 15/11/18(水) 8:49 発言[未読]
【77649】Re:VBA 画像圧縮 SEWING11 15/11/18(水) 9:42 お礼[未読]
【77653】Re:VBA 画像圧縮 SEWING11 15/11/18(水) 12:44 お礼[未読]
【77654】Re:VBA 画像圧縮 ウッシ 15/11/18(水) 14:05 回答[未読]
【77659】Re:VBA 画像圧縮 SEWING11 15/11/18(水) 18:14 お礼[未読]

4704 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free