|
▼wen さん:
>・挿入する写真のサイズを「縦60mmに変更」、「横80mmに変更」もしくは「横は縦の縮小と同じ倍率に縮小」
>・挿入するセルの中央に配置
>
>以上のコードについて、
mm単位をポイント単位に変換する方法は調べていただくとして、
たとえばですが
よこサイズを 200ポイント、たてサイズを150 ポイント
> Const MyX = 200, MyY = 150 '(挿入後画像サイズ:単位ポイント)
にしたい、としますと、
こんな感じでしょうかね?
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim PicFile As Variant
Dim rX As Double, rY As Double
Dim Ratio As Double, L As Double, T As Double
Dim W As Double, H As Double
Const MyX = 200, MyY = 150 '(挿入後画像サイズ:単位ポイント)
'[ファイルを開く]ダイアログボックスを表示
PicFile = Application.GetOpenFilename( _
"画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp")
If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub
Application.ScreenUpdating = False
'画像を挿入
With ActiveSheet.Pictures.Insert(PicFile)
W = .Width
H = .Height
rX = MyX / W
rY = MyY / H
If rX > rY Then
Ratio = rY
Else
Ratio = rX
End If
.Width = W * Ratio
.Height = H * Ratio
'セルの中央(横方向/縦方向の中央)に配置
L = Target.Left ' + (MyX - .Width) / 2
T = Target.Top '+ (MyY - .Height) / 2
Dim is2010 As Boolean
is2010 = Val(Application.Version) > 13
If is2010 Then 'ver14 = XL2010
.CopyPicture 'クリップボードに画像コピー
.Delete 'いったん削除
Else
.Left = L
.Top = T
End If
End With
If is2010 Then
Target.Activate
ActiveSheet.Paste
With Selection
.Left = L
.Top = T
End With
End If
Application.ScreenUpdating = True
Cancel = True
End Sub
↑このばあい、セルのたて×よこ サイズは無関係になりますので、
> 'セルの中央(横方向/縦方向の中央)に配置
の部分の処理はありません。
|
|