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