■ワークシート上のPictureの倍率を取得する（後編

さて、と。
勘違いの前編は捨て記事扱いでいいですけど、その Sub test2 を2007で実行するとエラーです。
>With Selection.Duplicate.ShapeRange
がイケてません。

Pictureに対して
With Selection.Duplicate
　　MsgBox .Name
End With
や
Dim pic As Picture
Set pic = Selection.Duplicate
ってやると2003は通りますが2007はダメです。
Duplicateが失敗しているわけではなく、複製はできています。
複製と同時にObjectとして扱えないような感じです。

しつこくチェックしてみると
Dim x
With ActiveSheet
　　With .Pictures
　　　　Set x = .Item(.Count).Duplicate 'A
　　　　MsgBox TypeName(x)
　　End With
　　With .Shapes
　　　　Set x = .Item(.Count).Duplicate 'B
　　　　MsgBox TypeName(x)
　　End With
End With
Set x = Nothing

2003では
A　Picture
B　Shape

2007では
A　エラー
B　Shape

何の事はない、Shapeに対してDuplicateすれば良いだけだったり？
つまり
>With Selection.Duplicate.ShapeRange
With Selection.ShapeRange.Duplicate

Sub test3() 'Pictureを選択して実行
　　Dim x As Single
　　Dim y As Single

　　If TypeName(Selection) = "Picture" Then
　　　　With Selection.ShapeRange.Duplicate
　　　　　　With .PictureFormat
　　　　　　　　.CropTop = 0#
　　　　　　　　.CropLeft = 0#
　　　　　　　　.CropRight = 0#
　　　　　　　　.CropBottom = 0#
　　　　　　End With
　　　　　　x = .Width
　　　　　　y = .Height
　　　　　　.LockAspectRatio = msoFalse
　　　　　　.ScaleWidth 1, msoTrue
　　　　　　.ScaleHeight 1, msoTrue
　　　　　　x = x / .Width
　　　　　　y = y / .Height
　　　　　　.Delete
　　　　End With
　　　　MsgBox "x:= " & x & vbLf & "y:= " & y
　　End If
End Sub

以上、余談でした（ぇ


で、本題ですが :D
一見上手くいきそうな Sub test も2007ではイケてません。
上辺、左辺をトリミングした画像を Top = 0 , Left = 0 の位置で実行すると
>.CropTop = 0#
>.CropLeft = 0#
この時、画面外にハミ出す（？）為か、トリミング解除後のWidthとHeightが正しく取得できないようです。

（Excel2007：Sub test 実行前）


（Excel2007：Sub test 実行後）


一応、2007では http://oshiete.goo.ne.jp/qa/6074786.html の回答コードで、トリミングの場合でも取得できてます。
でもトリミング画像に対するScaleWidth｜Heightメソッドの挙動が、2007から変わってたようです。
なので2003の場合は対応できていませんでした。
トリミング画像に対して

With Selection.ShapeRange
　　.ScaleWidth 1, msoTrue
　　.ScaleHeight 1, msoTrue
End With

ScaleWidth｜Heightメソッドを実行した場合、
2003ではトリミング後のWidth,Heightを元サイズのWidth,Heightに戻します。
2007では元サイズのWidth,Heightからトリミング値を考慮した値になります。

（2003,2007比較）


結論としては、バージョンによる分岐処理が必要...という事になるのでしょうか。

Option Explicit
'---------------------------------------------------------------------
Sub try() 'Pictureを選択して実行
　　Dim ret

　　If TypeName(Selection) = "Picture" Then
　　　　ret = fGetPicScale(Selection)
　　　　If IsArray(ret) Then
　　　　　　MsgBox "x:= " & ret(0) & vbLf & "y:= " & ret(1)
　　　　End If
　　End If
End Sub
'---------------------------------------------------------------------
Function fGetPicScale(ByRef pic As Picture)
　　Dim x　As Single
　　Dim y　As Single
　　Dim T　As Single
　　Dim L　As Single
　　Dim W　As Single
　　Dim H　As Single
　　Dim LC As Long

　　On Error GoTo errExit
　　With pic.ShapeRange
　　　　T = .Top
　　　　L = .Left
　　　　W = .Width
　　　　H = .Height
　　　　LC = .LockAspectRatio
　　　　'画像位置によっては元サイズに戻しきれない場合の対策
　　　　.Top = 0
　　　　.Left = 0
　　　　.LockAspectRatio = msoFalse
　　　　.ScaleWidth 1, msoTrue, msoScaleFromTopLeft
　　　　.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
　　　　'Ver2003以前のみトリミング値を考慮する
　　　　If CLng(Application.Version) < 12 Then
　　　　　　With .PictureFormat
　　　　　　　　x = .CropLeft + .CropRight
　　　　　　　　y = .CropTop + .CropBottom
　　　　　　End With
　　　　End If
　　　　x = W / (.Width - x)
　　　　y = H / (.Height - y)
　　　　.Top = T
　　　　.Left = L
　　　　.Width = W
　　　　.Height = H
　　　　.LockAspectRatio = LC
　　End With
　　fGetPicScale = Array(x, y)
errExit:
End Function