リモートでキャプチャしたスクリーン画像をエクセルで修正

リモートでキャプチャしたスクリーン画像のリモートでの貼り付け

エクセルでドキュメント作成しているときに、リモート環境でキャプチャした画像を、ローカル環境で貼り付ける。
環境に依存するかもしれないが、画像が数ピクセル（3ピクセル）ずれてしまう。

貼り付け

拡大すると

エクセル上で修正して修正結果を横に張り付け

（実行する前に、エクセルの表示の拡大縮小をしたときには、画像サイズをリセット）

画像を選択して、Test_ClipImageLeftShitToClip()を実行。
OK? おや

ピクセルずれだけじゃないなぁ。どこだろ。

imageShift.bas

Option Explicit

Public Const CF_BITMAP = 2

Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As LongPtr
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Declare PtrSafe Function OpenClipboard Lib "user32" ( _
        ByVal hwnd As LongPtr) As Long

Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

Private Declare PtrSafe Function SetClipboardData Lib "user32" ( _
        ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr

Private Declare PtrSafe Function GetClipboardData Lib "user32" ( _
        ByVal wFormat As Long) As LongPtr

Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long

Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" ( _
        ByRef token As LongPtr, _
        ByRef inputBuf As GdiplusStartupInput, _
        Optional ByVal outputBuf As LongPtr = 0) As Long

Private Declare PtrSafe Sub GdiplusShutdown Lib "gdiplus" ( _
        ByVal token As LongPtr)

Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" ( _
        ByVal hbm As LongPtr, _
        ByVal hpal As LongPtr, _
        ByRef bitmap As LongPtr) As Long

Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" ( _
        ByVal image As LongPtr) As Long

Private Declare PtrSafe Function GdipGetImageHeight Lib "gdiplus" ( _
        ByVal image As LongPtr, _
        ByRef Height As Long) As Long

Private Declare PtrSafe Function GdipGetImageWidth Lib "gdiplus" ( _
        ByVal image As LongPtr, _
        ByRef Width As Long) As Long

Private Declare PtrSafe Function GdipCreateBitmapFromGraphics Lib "gdiplus" ( _
        ByVal Width As Long, _
        ByVal Height As Long, _
        ByVal Target As LongPtr, _
        ByRef bitmap As LongPtr) As Long

Private Declare PtrSafe Function GdipGetImageGraphicsContext Lib "gdiplus" ( _
        ByVal image As LongPtr, _
        ByRef graphics As LongPtr) As Long

Private Declare PtrSafe Function GdipDeleteGraphics Lib "gdiplus" ( _
        ByVal graphics As LongPtr) As Long

Private Declare PtrSafe Function GdipDrawImageRectI Lib "gdiplus" ( _
        ByVal graphics As LongPtr, _
        ByVal image As LongPtr, _
        ByVal x As Long, _
        ByVal y As Long, _
        ByVal Width As Long, _
        ByVal Height As Long) As Long

Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" ( _
        ByVal bitmap As LongPtr, _
        hbmReturn As LongPtr, _
        ByVal background As Long) As Long

''' テストコード
Sub Test_ClipImageLeftShitToClip()
    Dim errMsg As String
    Dim ret As Boolean
    Dim rngShape As Range

    On Error GoTo EH
    Set rngShape = Selection.TopLeftCell

    EmptyClipboard
    Selection.CopyPicture xlScreen, xlBitmap

    ' リモートデスクトップのコピーをローカルにペーストしたとき ずれ幅
    ret = ClipImageLeftShitToClip(3, errMsg)

    ' 修正した画像を張り付け
    ActiveSheet.Paste Destination:=rngShape.Offset(3, 3)

    Debug.Print ret, errMsg
    Exit Sub

EH:
    MsgBox "エラーです。たぶん画像が選択されていません。画像を選択してから実行してください。"
End Sub

' メインコード
Public Function ClipImageLeftShitToClip(ByVal shiftLeft As Long, ByRef errMsg As String) As Boolean
    ClipImageLeftShitToClip = False

    ' 初期化
    Dim startupInput  As GdiplusStartupInput
    Dim pGpToken  As LongPtr
    startupInput.GdiplusVersion = 1
    If GdiplusStartup(pGpToken, startupInput, ByVal 0&) <> 0 Then
        errMsg = "GdiplusStartup error."
        Exit Function
    End If

    ' クリップボードからビットマップハンドル作成
    Dim hBmp As LongPtr
    If OpenClipboard(0&) <> 0 Then
        If Application.ClipboardFormats(1) = xlClipboardFormatBitmap Then
            hBmp = GetClipboardData(CF_BITMAP)
        End If
        Call CloseClipboard
        If hBmp = 0 Then
            errMsg = "GetClipboardData error."
            GdiplusShutdown pGpToken
            Exit Function
        End If
    Else
        errMsg = "OpenClipboard error."
        GdiplusShutdown pGpToken
        Exit Function
    End If

    'BitmapハンドルからBitmapオブジェクト
    Dim pGPImageSrc   As LongPtr
    If GdipCreateBitmapFromHBITMAP(hBmp, 0&, pGPImageSrc) <> 0 Then
        errMsg = "GdipCreateBitmapFromHBITMAP error."
        GdiplusShutdown pGpToken
        Exit Function
    End If

    ' 画像サイズの取得
    Dim lngWidth  As Long
    Dim lngHeight As Long
    If GdipGetImageWidth(pGPImageSrc, lngWidth) <> 0 Then
        errMsg = "GdipGetImageWidth error."
        GoTo DISPOSE_GDIP
    End If

    ' 画像サイズの取得
    If GdipGetImageHeight(pGPImageSrc, lngHeight) <> 0 Then
        errMsg = "GdipGetImageHeight error."
        GoTo DISPOSE_GDIP
    End If

    ' 画像サイズのチェック
    Debug.Print lngWidth, lngHeight
    If lngWidth > 3200 Or lngHeight > 3200 Or shiftLeft > 3200 Then
        errMsg = "Picture size error. Width <= 3200 And Height <= 3200 And shiftR <= 3200"
        GoTo DISPOSE_GDIP
    End If

    ' 画像Graphics作成
    Dim pGpGraphics As LongPtr
    If GdipGetImageGraphicsContext(pGPImageSrc, pGpGraphics) <> 0 Then
        GoTo DISPOSE_GDIP
    End If

    ' 出力用Bitmap作成
    Dim pGPImageDst   As LongPtr
    If GdipCreateBitmapFromGraphics(lngWidth, lngHeight, pGpGraphics, pGPImageDst) <> 0 Then
        GoTo DISPOSE_GDIP
    End If
    GdipDeleteGraphics pGpGraphics
    pGpGraphics = 0

    ' 出力用Graphics作成
    Dim pGpGraphics2 As LongPtr
    If GdipGetImageGraphicsContext(pGPImageDst, pGpGraphics2) <> 0 Then
        GoTo DISPOSE_GDIP
    End If

    ' 出力用Graphicsに、画像をずらして描く
    If shiftLeft >= 0 Then
        GdipDrawImageRectI pGpGraphics2, pGPImageSrc, -shiftLeft, 0, lngWidth, lngHeight
        GdipDrawImageRectI pGpGraphics2, pGPImageSrc, lngWidth - shiftLeft, 0, lngWidth, lngHeight
    Else
        GdipDrawImageRectI pGpGraphics2, pGPImageSrc, -lngWidth - shiftLeft, 0, lngWidth, lngHeight
        GdipDrawImageRectI pGpGraphics2, pGPImageSrc, -shiftLeft, 0, lngWidth, lngHeight
    End If
    GdipDeleteGraphics pGpGraphics2
    pGpGraphics2 = 0

    ' 出力用ビットマップから、ビットマップハンドルを作成
    Dim hBmp2 As LongPtr
    If GdipCreateHBITMAPFromBitmap(pGPImageDst, hBmp2, 0) <> 0 Then
        errMsg = "SetClipboardData error."
        GoTo DISPOSE_GDIP
    End If

    '画像（ビットマップハンドル）をクリップボードにコピー
    If OpenClipboard(0) <> 0 Then
        EmptyClipboard
        If SetClipboardData(CF_BITMAP, hBmp2) = 0 Then
            errMsg = "SetClipboardData error."
            GoTo DISPOSE_GDIP
        End If
        CloseClipboard
    Else
        errMsg = "OpenClipboard error."
        GoTo DISPOSE_GDIP
    End If
    ClipImageLeftShitToClip = True

DISPOSE_GDIP: 'イメージの廃棄
    ' 2重に破棄しても、エラーになるだけなので大丈夫か？
    GdipDeleteGraphics pGpGraphics
    GdipDeleteGraphics pGpGraphics2
    GdipDisposeImage pGPImageDst
    GdipDisposeImage pGPImageSrc

SHUTDOWN_GDIP: 'GDI+終了
    GdiplusShutdown pGpToken
End Function