| |
お世話になります。
OKweb様へも質問しましたが回答がつかないので・・・
エクセル２０１０を使用しています。写真帳を作成しダブルクリックすれば写真が挿入されるよう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 などを書き足せばよいのか・・・
→エラーばかりで動かなったので。。
こちらに質問することにしました。
どうぞ、よろしくお願いします。
|
|
SEWING11
- 15/11/14(土) 22:45 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
≪
