Snipping-Tool aus Excel steuern mit VBA
28.08.2023 23:19:44
volti
Hallo Peter,
für die Steuerung des Snippingtools per VBA habe ich gerade keine Lösung oder finde sie gerade nicht.
Falls auch niemand anderes hier helfen kann, nachfolgend mal ein Lösungsansatz, mit dem man Bildschirmausschnitte in die Zwischenablage kopieren kann.
Die Sub CopyScreen kopiert den Bereich mit den angegebenen Koordinaten in die Zwischenablage.
Falls diese Koordinaten einmal händisch ermittelt wurden, ist das Problem damit schon gelöst, auch innerhalb von Excel kann ein fester Bereich schon angegeben werden. Bei Verschiebung von Excel werden diese automatisch umgerechnet.
Die Angabe eines Range sollte auch funktionieren.
Um einen Bereich mittels Mausclick festlegen zu können, bedarf es noch einer entsprechenden Programmierung. Da würde ich noch eine gewisse Zeit für benötigen, wenn gewünscht.
Ansonsten, teste es einfach mal aus.....
Option Explicit
' Einen Bildausschnitt vom Desktop in die Zwischenablage kopieren
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
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 SelectObject Lib "gdi32" ( _
ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, _
ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As LongPtr, ByVal xSrc As Long, _
ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
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 EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" ( _
ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function ClientToScreen Lib "user32" ( _
ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Const SRCCOPY = &HCC0020
Sub CopyScreen(Left As Long, Top As Long, Width As Long, Height As Long)
' Sub kopiert einen Bildschirmausschnitt in die Zwischenablage, KHV 2012
Dim srcDC As LongPtr, trgDC As LongPtr, hBMP As LongPtr, hwnd As LongPtr, Farbe As Long
srcDC = GetDC(GetDesktopWindow())
trgDC = CreateCompatibleDC(srcDC) ' Device Context erstellen
hBMP = CreateCompatibleBitmap(srcDC, Width, Height) ' Bildausschnitt zuordnen
SelectObject trgDC, hBMP ' Bild auswählen
BitBlt trgDC, 0, 0, Width, Height, srcDC, Left, Top, SRCCOPY ' Pixel kopieren
OpenClipboard 0&: EmptyClipboard ' Zwischenablage öffnen
SetClipboardData 2, hBMP: CloseClipboard ' Bild rein und Zwischenablage schließen
DeleteDC trgDC: ReleaseDC hBMP, srcDC ' Device Context schließen
End Sub
' ################ Aufrufmöglichkeiten #################
Sub KopiereBildausschittAbsolut()
' Angabe von Direktkoordinaten absolut
CopyScreen 100, 100, 800, 800
End Sub
Sub KopiereBildausschittExcel()
' Angabe von Direktkoordinaten im Excelfenster
' Koordinaten werden von Excel auf den Bildschirm umgerechnet
Dim PT As POINTAPI
PT.x = 10: PT.y = 10
ClientToScreen Application.hwnd, PT
SetForegroundWindow Application.hwnd
CopyScreen PT.x, PT.y, 800, 800
End Sub
Sub KopiereBildausschittMousePos()
' Angabe von der Koordinaten per Mausposition
' Koordinaten werden von Excel auf den Bildschirm umgerechnet
Dim PT As POINTAPI
GetCursorPos PT
ClientToScreen Application.hwnd, PT
SetForegroundWindow Application.hwnd
CopyScreen PT.x, PT.y, 800, 800
End Sub
Sub KopiereBildausschittBereich()
' Angabe von der Koordinaten per Mausposition
' Koordinaten werden von Excel auf den Bildschirm umgerechnet
Dim PT1 As POINTAPI, PT2 As POINTAPI
With ActiveWindow
PT1.x = .PointsToScreenPixelsX(Range("B11").Left)
PT1.y = .PointsToScreenPixelsY(Range("B11").Top)
PT2.x = .PointsToScreenPixelsX(Range("G88").Left) - PT1.x
PT2.y = .PointsToScreenPixelsY(Range("G88").Top) - PT1.y
End With
SetForegroundWindow Application.hwnd
CopyScreen PT1.x, PT1.y, PT2.x, PT2.y
End Sub
Gruß
Karl-Heinz