CopyPicture Methode Kopiert nur Weiß
14.01.2019 08:17:50
Christian
ich bin mal wieder auf eure Hilfe angewiesen. Ich habe ein VBA Skript welches aus einem Tabellenblatt eine kleine Tabelle kopiert, diese als .bmp speichert und dann in einem anderem Tabellenblatt diese .bmp Datei in die Fußzeile setzt.
Dies hat alles Funktioniert, nur habe ich mittlerweile einige zusätzliche Funktionen implementiert und nun werden nur noch weiße Zellen kopiert. Ich vermute es hat was mit der CopyPicture Methode zu tun, da die Range Angabe korrekt ist. Ich habe das gesamte Modul als Code angehangen.
Da ich mir VBA in den letzten 3 Wochen übers Internet beigebracht habe, sind meine Kenntnisse in VBA begrenzt.
Mit freundlichem Gruß
Christian K
Option Explicit
' *** Clipboard als 24-Bit Bitmap speichern ***
Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Declare
Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, _
ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, _
lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare
Function IsClipboardFormatAvailable Lib "user32" ( _
ByVal wFormat As Long) As Long
Private Declare
Function GetObject Lib "gdi32" Alias "GetObjectA" ( _
ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare
Function GetActiveWindow Lib "user32" () As Long
Private Declare
Function GetDesktopWindow Lib "user32" () As Long
Private Declare
Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare
Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare
Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare
Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare
Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare
Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare
Function EmptyClipboard Lib "user32" () As Long
Private Declare
Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare
Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare
Function CloseClipboard Lib "user32" () As Long
Private Declare
Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare
Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare
Function GetFocus Lib "user32" _
() As Long
Private Const BI_RGB = 0&
Private Const CF_BITMAP = 2
Dim fz As Worksheet
Sub fußzeile_exp_und_anpassen_und_PDF()
Application.ScreenUpdating = False
'Sheet "Fußzeile" einblenden
Sheets("Serialnr. List").Select
Sheets("Fußzeile").Visible = True
'Fußzeilen aus Tabelle exportieren
Sheets("Fußzeile").Select
Range("A12:M15").CopyPicture xlScreen, xlBitmap
Call ClipboardToPicture(32)
'Fußzeile anpassen
Sheets("Serialnr. List").Select
ActiveSheet.PageSetup.LeftFooterPicture.Filename = _
ThisWorkbook.Path & "\fußzeile.bmp"
'Arbeitsmappe als PDF exportieren
Sheets(Array("Cover Sheet", "Serialnr. List")).Select
Sheets("Cover Sheet").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\Seriennummerliste_mit_Deckblatt.pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
'Sheet "Fußzeile" ausblenden
Sheets("Fußzeile").Select
ActiveWindow.SelectedSheets.Visible = False
Application.ScreenUpdating = True
End Sub
Sub ClipboardToPicture(Optional Quality As Long)
Dim hBitmap As Long, hOldBitmap As Long
Dim dummyDC As Long, BMP As BITMAP
Dim Buffergröße As Long, Buffer() As Byte
Dim Ret As Long, Faktor As Double
Dim myFileHeader As BITMAPFILEHEADER
Dim myBMInfo As BITMAPINFO
Dim FF As Long, Länge As Long
Dim txtReturn As String
'Faktor = 4 '24-Bit Bitmap
Faktor = 8 '32-Bit Bitmap
On Error GoTo fehlerbehandlung
OpenClipboard 0&
If IsClipboardFormatAvailable(CF_BITMAP) Then
'Speicherpfad holen
txtReturn = ThisWorkbook.Path & "\fußzeile.bmp" '*oder wo dein Bild hin soll*
If (LCase(txtReturn) = "false") Or (LCase(txtReturn) = "falsch") Then
'Abbrechen
GoTo fehlerbehandlung
End If
'Im Clipboard ist eine Bitmap
'Einen zum Screen kompatiblen Devicekontext erzeugen
dummyDC = CreateCompatibleDC(0)
If dummyDC Then
'Zugriffsnummer auf Bitmap im Clip holen
hBitmap = GetClipboardData(CF_BITMAP)
If (hBitmap) Then
'Die Struktur BMP mit Infos füllen
GetObject hBitmap, Len(BMP), BMP
'Doppelwortgrenze beim Berechnen
'der Größe des Puffers beachten
Buffergröße = ((BMP.bmWidth * Faktor + 3) And &HFFFFFFFC) * BMP.bmHeight
ReDim Buffer(Buffergröße - 1)
'Die Bitmap in den erzeugten DC stellen
hOldBitmap = SelectObject(dummyDC, hBitmap)
With myBMInfo.bmiHeader
.biBitCount = 24
.biSize = 40
.biWidth = BMP.bmWidth
.biHeight = BMP.bmHeight
.biPlanes = 1
.biCompression = BI_RGB
.biSizeImage = Buffergröße
End With
'Daten auslesen
Ret = GetDIBits(dummyDC, hBitmap, 0&, _
BMP.bmHeight, Buffer(0), myBMInfo, 0&)
Länge = Len(myBMInfo)
With myFileHeader
.bfType = &H4D42 ' "BM"
.bfSize = Buffergröße + Len(myFileHeader) + Länge
.bfOffBits = Len(myFileHeader) + Länge
End With
'Erzeugten DC löschen
DeleteDC dummyDC
'Clipboard schließen
CloseClipboard
End If
End If
Else
MsgBox "Keine Bitmap im Clipboard", vbCritical, "Fehler"
GoTo fehlerbehandlung
End If
'Als BMP speichern
FF = FreeFile
If Dir(txtReturn) "" Then Kill txtReturn
Open txtReturn For Binary As FF
Put FF, , myFileHeader
Put FF, , myBMInfo
Put FF, , Buffer
Close
Exit Sub
fehlerbehandlung:
CloseClipboard
DeleteDC dummyDC
End Sub