クリップボード経由で拡張メタファイル画像をEXCELなどに貼り付けた時､縦横比が変わってしまわない方法？

Question

下記のコードのように､PICTUREBOX､（170,135)の大きさのPicture1に､150W×100Hの片対数グラフを書いたものをクリップボード経由でEXCEL2002にコピーすると（152.4,179.9）の大きさに､WORD2002は（150.81,178.06）になってしまいます。同一寸法でペーストするには､どうすればよいのでしょうか？

VB6.0（SP6)でWINDOWS2000Pro（SP4)です。

 

VB上での描画や､プリンターへの印刷では､正しい寸法です。

なお､ソースを下記に記載いたします。（標準モジュールは省いています）

 

（追伸）

ディスプレーの解像度が800×600や1024×768の場合はうまくいくようです。

メタファイルで解像度に依存するとは思ってもいませんでした。

今のところ､どうしたらよいか見当もつきません。

' *******      対数グラフ描画[メタファイル]                      08.05.16    *********

 

Option Explicit

' クリップボードへコピー
Private Sub Command3_Click()
   
    Clipboard.Clear
    Clipboard.SetData Picture1.Picture
   
End Sub

' 終了ボタン
Private Sub Command4_Click()
    Unload Me       ' ﾌｫｰﾑをｱﾝﾛｰﾄﾞします。
    End             ' ｱﾌﾟﾘｹｰｼｮﾝを終了します。
End Sub

' フォームロード時グラフ描画
Private Sub Form_Load()
   
    Cls        ' フォーム描画クリア
       
    Set Picture1.Picture = CreateMeta(Picture1, 0, 0, 170, 135)      ' 対数グラフを描画
   
End Sub

Private Function CreateMeta(Target As Object, OrgLeft&, OrgTop&, Width&, Height&, _
                            Optional ScaleMode As ScaleModeConstants _
                            = vbMillimeters) As Picture
    'メタファイルピクチャの作成
    'input  Target          参照のオブジェクト
    '       Width/Height    メタファイルのサイズ
    'output (関数)          メタファイルピクチャ
   
    Dim hdc&, hEMF&
    Dim MyRect As RECT
    Dim MyPic As Picture
    Dim hDCRef&
    Dim hPen&, hOldPen&
    Dim PenW As Integer
   
    '-----メタファイルの作成
       
    With MyRect
        .Left = OrgLeft * 100
        .Top = OrgTop * 100
        .Right = (OrgLeft + Width) * 100
        .Bottom = (OrgTop + Height) * 100
    End With
   
    hDCRef = Target.hdc
    hdc = CreateEnhMetaFile(hDCRef, vbNullString, MyRect, vbNullString)
   
    PenW = 20
       
    '座標系の設定
    SetMapMode hdc, MM_HIMETRIC  'MM_ANISOTROPIC MM_LOMETRIC    'HIMETRIC
       
    '実際に描く
    Call LogDraw(hdc, Width, Height)
       
    ' 最下線再描画
    hPen = CreatePen(vbSolid, PenW, RGB(0, 0, 0))
    hOldPen = SelectObject(hdc, hPen)
    MoveToEx hdc, (50 * Log10(20) - 58) * 100, -(2 * 52.5) * 100, ByVal 0&
    LineTo hdc, (50 * Log10(20000) - 58) * 100, -(2 * 52.5) * 100
    DeleteObject SelectObject(hdc, hOldPen)
       
    hEMF = CloseEnhMetaFile(hdc)
   
    '---ピクチャオブジェクトに変換
    Set MyPic = CreatePictureFromHandle(hEMF)
    Set CreateMeta = MyPic

End Function

' 対数グラフの描画

Private Sub LogDraw(hdc&, Width&, Height&)
    Dim j, K   As Integer
    Dim i   As Integer
    Dim X, h As Double
    Dim hPen&, hOldPen&, hBrush&, hOldBrush&
    Dim PenW As Integer
   
    ScaleMode = 6
    Picture1.Width = Width
    Picture1.Height = Height
   
    PenW = 20
   
    SetBkMode hdc, TRANSPARENT
   
    '背景を白で塗りつぶす
    hPen = GetStockObject(NULL_PEN)
    hBrush = GetStockObject(WHITE_BRUSH)
    hOldPen = SelectObject(hdc, hPen)
    hOldBrush = SelectObject(hdc, hBrush)
    Rectangle hdc, 0, 0, Width * 100, -Height * 100
    DeleteObject SelectObject(hdc, hOldPen)
    DeleteObject SelectObject(hdc, hOldBrush)
   
    For i = 0 To 50 Step 1
        h = i + 2.5
        If (i Mod 10) = 0 Then
            hPen = CreatePen(vbSolid, PenW, RGB(0, 0, 0))
            hOldPen = SelectObject(hdc, hPen)
            MoveToEx hdc, (50 * Log10(20) - 58) * 100, -(2 * h) * 100, ByVal 0&
            LineTo hdc, (50 * Log10(20000) - 58) * 100, -(2 * h) * 100
            DeleteObject SelectObject(hdc, hOldPen)
        ElseIf (i Mod 5) = 0 Then
            hPen = CreatePen(vbSolid, PenW, &H777777)
            hOldPen = SelectObject(hdc, hPen)
            MoveToEx hdc, (50 * Log10(20) - 58) * 100, -(2 * h) * 100, ByVal 0&
            LineTo hdc, (50 * Log10(20000) - 58) * 100, -(2 * h) * 100
            DeleteObject SelectObject(hdc, hOldPen)
        Else
            hPen = CreatePen(vbSolid, PenW, &HBBBBBB)
            hOldPen = SelectObject(hdc, hPen)
            MoveToEx hdc, (50 * Log10(20) - 58) * 100, -(2 * h) * 100, ByVal 0&
            LineTo hdc, (50 * Log10(20000) - 58) * 100, -(2 * h) * 100
            DeleteObject SelectObject(hdc, hOldPen)
        End If
    Next i
   
    For j = 0 To 2
        K = 10 ^ j
        For i = 2 To 10
            X = (50 * Log10(K * i) - 8) * 100
            Select Case i
                Case 2
                    hPen = CreatePen(vbSolid, PenW, RGB(0, 0, 0))
                    hOldPen = SelectObject(hdc, hPen)
                    MoveToEx hdc, X, -5 * 100, ByVal 0&
                    LineTo hdc, X, -105 * 100
                    DeleteObject SelectObject(hdc, hOldPen)
                Case 5
                    hPen = CreatePen(vbSolid, PenW, &H777777)
                    hOldPen = SelectObject(hdc, hPen)
                    MoveToEx hdc, X, -5 * 100, ByVal 0&
                    LineTo hdc, X, -105 * 100
                    DeleteObject SelectObject(hdc, hOldPen)
                Case 10
                    hPen = CreatePen(vbSolid, PenW, &H777777)
                    hOldPen = SelectObject(hdc, hPen)
                    MoveToEx hdc, X, -5 * 100, ByVal 0&
                    LineTo hdc, X, -105 * 100
                    DeleteObject SelectObject(hdc, hOldPen)
                Case Else
                    hPen = CreatePen(vbSolid, PenW, &HBBBBBB)
                    hOldPen = SelectObject(hdc, hPen)
                    MoveToEx hdc, X, -5 * 100, ByVal 0&
                    LineTo hdc, X, -105 * 100
                    DeleteObject SelectObject(hdc, hOldPen)
            End Select
        Next i
    Next j
   
    hPen = CreatePen(vbSolid, PenW, RGB(0, 0, 0))
    hOldPen = SelectObject(hdc, hPen)
    MoveToEx hdc, (50 * Log10(20000) - 58) * 100, -5 * 100, ByVal 0&
    LineTo hdc, (50 * Log10(20000) - 58) * 100, -105 * 100
    DeleteObject SelectObject(hdc, hOldPen)

End Sub

Static Function Log10(X)
   Log10 = Log(X) / Log(10#)
End Function