[[20230222201735]]　『プリントスクリーンを貼り付けてトリミング』（はさみ男）　ページの最後に飛ぶ

『プリントスクリーンを貼り付けてトリミング』（はさみ男）

こんにちわ。教えていただきたいことがあります。

1.Ctrl＋PrtScボタンで画面全体をスクリーンショット
2.エクセルに貼り付け
2.手動でサイズをトリミング

をしております。
1は従来通りマクロでは無くても良いのですが

2と3を同時にやる事はマクロで可能でしょうか？

3ついては毎回サイズが微妙に異なるのでせめて

(スクリーンショット済)
エクセルに貼り付け→全画面の左半分にトリム(右側を消す)
など方法はありますでしょうか

方法、またはそれに似た事が出来るようでしたらよろしくお願いします。

＜使用 Excel：Microsoft365、使用 OS：Windows11 ＞

 マクロの記録を試してみてください
 画像サイズが一定でない場合、何を基準にしているかが数値として
 取得できれば可能だと思いますが、色の境目などを基準とする場合は
 標準のマクロ操作では無理だと思います。
（稲葉） 2023/02/22(水) 20:52:41

 そもそも画面の左半分しかコピーしない。(という力技... まぁ、お遊びのひとつです。^^;)

    Option Explicit
    Type RECT
       Left As Long
       Top As Long
       Right As Long
       Bottom As Long
    End Type
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" ( _
        ByVal hdcDest As LongPtr, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hDCSrc As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, _
        ByVal dwRop As Long) As Long
    Private Const SRCCOPY As Long = &HCC0020
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function EmptyClipboard 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 CloseClipboard Lib "user32" () As Long
    Private Const CF_BITMAP As Long = 2

    Function CopyImageby_hWnd(ByVal TargethWnd As Long, Xpos As Long, Ypos As Long, Hsize As Long, Wsize As Long) As Long
        Dim hDC As Long, hMDC As Long, hBMP As Long
        Dim hPrevBMP As Long, BitCopiedFlg As Boolean
        hDC = GetWindowDC(TargethWnd)
        If hDC = 0 Then Exit Function
        hMDC = CreateCompatibleDC(hDC)
        If hMDC = 0 Then Exit Function
        hBMP = CreateCompatibleBitmap(hDC, Wsize, Hsize)
        If hBMP Then
            hPrevBMP = SelectObject(hMDC, hBMP)
            If hPrevBMP Then
                BitCopiedFlg = CBool(BitBlt(hMDC, 0, 0, Wsize, Hsize, hDC, Xpos, Ypos, SRCCOPY))
            End If
            Call SelectObject(hMDC, hPrevBMP)
        End If
        Call DeleteDC(hMDC)
        Call ReleaseDC(TargethWnd, hDC)
        If Not BitCopiedFlg Then
            Call DeleteObject(hBMP)
        Else
            If OpenClipboard(0) Then
                Call EmptyClipboard
                If SetClipboardData(CF_BITMAP, hBMP) Then
                    CopyImageby_hWnd = hBMP
                    Call DeleteObject(hBMP)
                    hBMP = 0
                End If
                Call CloseClipboard
            End If
        End If
    End Function
    Sub test()
        Dim aRect As RECT
        Call GetWindowRect(GetDesktopWindow, aRect)
        With aRect
            Call CopyImageby_hWnd(0&, .Left, .Top, .Bottom - .Top, (.Right - .Left) \ 2)
        End With
        ActiveSheet.Paste
    End Sub

（白茶） 2023/02/22(水) 23:45:51

みなさんありがとうございます。

決まったサイズでトリミングして貼り付ける事が出来るようになりました。

このトリミングしたと同時に
図のトリミング部分を削除、というのをマクロでは不可能ですか？
記録を取ってもネットで検索してもなかなか出て来ません。

アドバイス頂けないでしょうか

（はさみ男） 2023/02/23(木) 20:28:00

コメント返信：

[ 一覧(最新更新順) ]

[[20230222201735]] 『プリントスクリーンを貼り付けてトリミング』（はさみ男） ページの最後に飛ぶ

[[20230222201735]]　『プリントスクリーンを貼り付けてトリミング』（はさみ男）　ページの最後に飛ぶ