【ExcelVBA】図の縮小貼付時のトラブル

ExcelVBAで「ActiveSheet.PasteSpecial Format:="図 (jpeg)"」という記述を使った際、
ある一定の行までは正常に図が貼り付けられるのですが、ある一定の行以降は図が
正常に張り付かない（つぶれた図になってしまう）現象に悩まされています。

※正確には行数ではなく、選択したセルのselection.topの値が２８０００を超えた
　あたりからおかしくなります（１行の高さが高いほど、低い行数から現象が発生します）

もし何かしらの解決策を頂ければと思い、質問させて頂きました。
宜しくお願い致します。



マクロ自体は「セルを選択して実行し、図を選択すると、縦横の比率を計算してセル内に
貼り付けてくれる」という機能に、「ファイルサイズを縮小する為、貼り付けた図を一度
切り取りして、ペーストする」という作業を行っております。

Sub Paste_Picture()

Dim CELL_WIDTH As Long
Dim CELL_HEIGHT As Long
Dim CELL_TOP As Long
Dim CELL_LEFT As Long
Dim CELL_PERCENTAGE As Single
Dim PHOTO_WIDTH As Long
Dim PHOTO_HEIGHT As Long
Dim PHOTO_TOP As Long
Dim PHOTO_LEFT As Long
Dim PHOTO_PERCENTAGE As Single
Dim PHOTO_FILE_NAME As String
Dim myPHOTO As Object

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

PHOTO_FILE_NAME = Application.GetOpenFilename _
(Filefilter:="画像 ファイル(*.BMP;*.JPG;*.TIF), *.BMP;*.JPG;*.TIF")

If PHOTO_FILE_NAME = "False" Then
Exit Sub
End If

ActiveSheet.Select

CELL_WIDTH = Selection.Width
CELL_HEIGHT = Selection.Height
CELL_TOP = Selection.Top
CELL_LEFT = Selection.Left
CELL_PERCENTAGE = CELL_HEIGHT / CELL_WIDTH

Set myPHOTO = ActiveSheet.Pictures.Insert(PHOTO_FILE_NAME)

PHOTO_WIDTH = myPHOTO.Width
PHOTO_HEIGHT = myPHOTO.Height
PHOTO_TOP = myPHOTO.Top
PHOTO_LEFT = myPHOTO.Left
PHOTO_PERCENTAGE = PHOTO_HEIGHT / PHOTO_WIDTH

If CELL_PERCENTAGE > PHOTO_PERCENTAGE Then

myPHOTO.Width = CELL_WIDTH * 0.95
myPHOTO.Height = CELL_WIDTH * PHOTO_PERCENTAGE * 0.95
myPHOTO.Cut
ActiveSheet.PasteSpecial Format:="図 (jpeg)" 　　　　　　　←ここで図がおかしくなります。
Selection.Top = CELL_TOP + _
(CELL_HEIGHT - (CELL_WIDTH * PHOTO_PERCENTAGE * 0.95)) / 2
Selection.Left = CELL_LEFT + (CELL_WIDTH * 0.025)


Else
（中略）
End If

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Set myPHOTO = Nothing

End Sub

No.2 ベストアンサー 回答者： end-u 回答日時： 2011/10/25 23:27

ぁっ。

失礼..
：
>CELL_PERCENTAGE = CELL_HEIGHT / CELL_WIDTH
>Range("A1").Activate　　'■
>
>Set myPHOTO = ActiveSheet.Pictures.Insert(PHOTO_FILE_NAME)
：

Range("A1").Activate　この１行だけで良かったのでした。

この回答へのお礼

回答ありがとうございます。

お教え頂いた記述を追記して実行すると正常に動きました！

a1を参照してselection.xxxの値を変更する事で正常に貼付
できるとは考えつきませんでした。。

本当にありがとうございました！

お礼日時：2011/10/26 08:49

No.1 回答者： end-u 回答日時： 2011/10/25 23:22

>※正確には行数ではなく、選択したセルのselection.topの値が２８０００を超えた

>　あたりからおかしくなります（１行の高さが高いほど、低い行数から現象が発生します）
簡易対応としては、Cut&Paste処理時の位置をA1セル付近でやれば良いです。
：
Dim r As Range　　'■追加

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

PHOTO_FILE_NAME = Application.GetOpenFilename _
　　　　　　　　　(Filefilter:="画像 ファイル(*.BMP;*.JPG;*.TIF), *.BMP;*.JPG;*.TIF")

If PHOTO_FILE_NAME = "False" Then
　　Exit Sub
End If

ActiveSheet.Select
Set r = Selection　　'■
CELL_WIDTH = r.Width　　'□変更
CELL_HEIGHT = r.Height　　'□
CELL_TOP = r.Top　　'□
CELL_LEFT = r.Left　　'□
CELL_PERCENTAGE = CELL_HEIGHT / CELL_WIDTH
Range("A1").Activate　　'■

Set myPHOTO = ActiveSheet.Pictures.Insert(PHOTO_FILE_NAME)
：

こんな感じ。
他には、Pictures.Insertメソッドではなく
AddPictureメソッドを使って、位置を指定して画像挿入する方法でも良いかもしれません。
（その際はScaleWidth｜ScaleHeightで元サイズにする必要があります）