| |
▼kanabun さん：
改訂版、ありがとうございます！！2010でうまく行きました！
イメージしていた通りの作業が、可能になりました。大変勉強になりました。
続けての質問で恐縮なのですが、写真のサイズを指定するコードの書き方がわかれば、ご教授いただけませんでしょうか？
改定版の、「'画像を挿入」「'セルの中央（横方向/縦方向の中央）に配置」のぶ宇文について、
・挿入する写真のサイズを「縦60mmに変更」、「横80mmに変更」もしくは「横は縦の縮小と同じ倍率に縮小」
・挿入するセルの中央に配置
以上のコードについて、可能であればご教授ください。
よろしくお願いいたします。
>▼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
|
|
wen
- 13/2/18(月) 18:16 -
