CopyPicture Methode Kopiert nur Weiß

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