Excel VBA質問箱 IV

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

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


4712 / 76732 ←次へ | 前へ→

【77636】VBA 画像圧縮
質問  SEWING11  - 15/11/14(土) 22:45 -

引用なし
パスワード
   お世話になります。
OKweb様へも質問しましたが回答がつかないので・・・

エクセル2010を使用しています。写真帳を作成しダブルクリックすれば写真が挿入されるようVBAにて作成しましたが、写真の解像度が高いので挿入するたびに画像が圧縮するようにVBAを組みたいのですが、どなたかご教示ください。
具体的には一同挿入した画像を一度コピーし、再度貼り付ける・・・という動作かなと考えているのですが、マクロの記憶では記録されず・・・困っております。

現在の写真帳の構文は
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


'挿入のセルを指定

If Application.Intersect(Target, Range("d6,d23,d40")) Is Nothing Then Exit Sub
Cancel = True
Application.ScreenUpdating = False


End If


'写真挿入

Next
myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
If myPic = False Then
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 '最背面へ移動

End With
Application.ScreenUpdating = True
Cancel = True

End Sub

上記に.CUT などを書き足せばよいのか・・・
→エラーばかりで動かなったので。。
 こちらに質問することにしました。
どうぞ、よろしくお願いします。
0 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 お礼[未読]

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