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

  • 質問

  • 下記のコードのように、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

    2008年5月16日 2:59