| |
▼wen さん：すみません。
Excel2010 上で動かしてみておっしゃってることが呑み込めました。
>ただ、貼り込まれた写真がどうもサイズがうまくいきません。
>'画像を挿入
> With ActiveSheet.Pictures.Insert(PicFile)
> rX = Target.Width / .Width
> rY = Target.Height / .Height
> If rX > rY Then
> ratio = rY
> Else
> ratio = rX
> End If
> .Width = .Width * ratio
> .Height = .Height * ratio
>
>の部分をどのように書き換えたらいいのかわかりません。
ステップ実行（トレース）していきますと、
（たとえば ratio が 0.5 だったとします）
こちらの【2003】 では
> .Width = .Width * ratio
を実行すると、横方向だけ 1/2 に縮小され、一時的に ひしゃげた
図になります。
そして
> .Height = .Height * ratio
を実行して、高さも 1/2に縮小され、元の縦横比が維持された図に
縮小されます。
ところが【２０１０】では、そうならないんですね！
> .Width = .Width * ratio
を実行すると、Widthはもちろん高さも 1/2 に縮小されます。
そして
> .Height = .Height * ratio
を実行すると、1/2に縮小された図が 【さらに 1/2】に縮小され、
とてつもなく小さな図になってしまいました！！
おそらく、この不具合をおっしゃってたのだろうと解せました。
改訂版です
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim PicFile As Variant
Dim rX#, rY#, Ratio# ' (ratioX, ratioY, ratio)
Dim L#, T#, W#, H# '(Left, Top, Width, Height)
'［ファイルを開く］ダイアログボックスを表示
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 = Target.Width / W
rY = Target.Height / H
If rX > rY Then
Ratio = rY
Else
Ratio = rX
End If
.Width = W * Ratio
.Height = H * Ratio
'セルの中央（横方向/縦方向の中央）に配置
L = Target.Left + (Target.Width - .Width) / 2
T = Target.Top + (Target.Height - .Height) / 2
Dim is2010 As Boolean
is2010 = Val(Application.Version) > 13
is2010 = True
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
