AW: SendKeys für Kopieren und einfügen
11.03.2023 14:38:40
Nepumuk
Hallo Dieter,
im Modul des UserForms:
Option Explicit
Private Declare PtrSafe Function GetWindowRect Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByRef lpRect As RECT) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Const GC_CLASSNAME_USERFORM = "ThunderDFrame"
Private Sub CommandButton1_Click()
Dim lngptrHwnd As LongPtr
Dim udtRectangularForm As RECT
lngptrHwnd = FindWindowA(GC_CLASSNAME_USERFORM, Caption)
Call GetWindowRect(lngptrHwnd, udtRectangularForm)
With udtRectangularForm
.Bottom = .Bottom - 5
.Left = .Left + 5
.Right = .Right - 5
.Top = .Top + 5
End With
Call CopyUserForm(udtRectangularForm)
End Sub
In einem Standardmodul:
Option Explicit
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32.dll" ( _
ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetSystemPaletteEntries Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal wStartIndex As Long, _
ByVal wNumEntries As Long, _
ByRef lpPaletteEntries As PALETTEENTRY) As Long
Private Declare PtrSafe Function CreatePalette Lib "gdi32.dll" ( _
ByRef lpLogPalette As LOGPALETTE) As LongPtr
Private Declare PtrSafe Function SelectPalette Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal hPalette As LongPtr, _
ByVal bForceBackground As Long) As LongPtr
Private Declare PtrSafe Function RealizePalette Lib "gdi32.dll" ( _
ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function BitBlt Lib "gdi32.dll" ( _
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.dll" ( _
ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" ( _
ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Long, _
ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" ( _
ByVal wFormat As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
Private Const HWND_DESKTOP As LongPtr = 0
Private Const RASTERCAPS As Long = 38&
Private Const RC_PALETTE As Long = &H100&
Private Const SIZEPALETTE As Long = 104&
Private Const SRCCOPY As Long = &HCC0020
Private Const CF_BITMAP As Long = 2&
Public Sub CopyUserForm(ByRef prudtRectangle As RECT)
Call OpenClipboard(0)
Call EmptyClipboard
Call SetClipboardData(CF_BITMAP, DC_To_Picture(prudtRectangle))
Call CloseClipboard
If IsClipboardFormatAvailable(CF_BITMAP) = 1 Then
Call ActiveSheet.Paste
Else
Call MsgBox("Kopieren des Userforms fehlgeschlagen.", vbCritical, "Kopierfehler")
End If
End Sub
Private Function DC_To_Picture( _
ByRef prudtRect As RECT) As LongPtr
Dim lngLeftSrc As Long, lngTopSrc As Long, lngWidthSrc As Long, lngHeightSrc As Long
Dim lngptrhDCMemory As LongPtr, lngptrhBmp As LongPtr, lngptrhDCScr As LongPtr
Dim lngptrhPal As LongPtr, lngptrhPalPrev As LongPtr, lngptrhBmpPrev As LongPtr
Dim lngRasterCapsScrn As Long
Dim lngHasPaletteScrn As Long, lngPaletteSizeScrn As Long
Dim udtLogPal As LOGPALETTE
lngLeftSrc = prudtRect.Left
lngTopSrc = prudtRect.Top
lngWidthSrc = prudtRect.Right - prudtRect.Left
lngHeightSrc = prudtRect.Bottom - prudtRect.Top
lngptrhDCScr = GetDC(HWND_DESKTOP)
lngptrhDCMemory = CreateCompatibleDC(lngptrhDCScr)
lngptrhBmp = CreateCompatibleBitmap(lngptrhDCScr, lngWidthSrc, lngHeightSrc)
lngptrhBmpPrev = SelectObject(lngptrhDCMemory, lngptrhBmp)
lngRasterCapsScrn = GetDeviceCaps(lngptrhDCScr, RASTERCAPS)
lngHasPaletteScrn = lngRasterCapsScrn And RC_PALETTE
lngPaletteSizeScrn = GetDeviceCaps(lngptrhDCScr, SIZEPALETTE)
If lngHasPaletteScrn And (lngPaletteSizeScrn = &H100&) Then
udtLogPal.palVersion = &H300&
udtLogPal.palNumEntries = &H100&
Call GetSystemPaletteEntries(lngptrhDCScr, 0&, _
&H100&, udtLogPal.palPalEntry(0&))
lngptrhPal = CreatePalette(udtLogPal)
lngptrhPalPrev = SelectPalette(lngptrhDCMemory, lngptrhPal, 0&)
Call RealizePalette(lngptrhDCMemory)
End If
Call BitBlt(lngptrhDCMemory, 0&, 0&, lngWidthSrc, lngHeightSrc, _
lngptrhDCScr, lngLeftSrc, lngTopSrc, SRCCOPY)
lngptrhBmp = SelectObject(lngptrhDCMemory, lngptrhBmpPrev)
If lngHasPaletteScrn And (lngPaletteSizeScrn = 256&) Then _
lngptrhPal = SelectPalette(lngptrhDCMemory, lngptrhPalPrev, 0&)
Call DeleteDC(lngptrhDCMemory)
DC_To_Picture = lngptrhBmp
End Function
Gruß
Nepumuk