Zwischenablage Bild als Bitmap speichern
31.08.2005 12:36:15
Reinhard
Hallo Ralf,
danke für den Code.
Zumindest als bmp kann man wohl die Zwischenablage speichern, deshalb aus Archivgründen den Betreff geändert, siehe:
http://die-schwimmers.de/vba074.htm
Nachfolgend der Code, sind API-Funktionen und ist sehr lang.
Gruß
Reinhard
'Mein Code ermöglicht es, ein Bitmap aus der Zwischenablage als Datei mit den Farbtiefen '4 Bit, 8 Bit und 16 Bit abzuspeichern.
'Zum Erstellen einer Bildschirmkopie und Testen folgenden Code
'5 Buttons auf ein Tabellenblatt
Option Explicit
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_MENU = &H12
Private Const VK_SNAPSHOT = &H2C
Private Declare Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function GetVersionEx Lib _
"kernel32" Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
'Bildschirmkopie, wenn mode=0. Fensterkopie, wenn mode=1
Public Sub CopyToClip(mode As Integer)
Dim lngParam As Long
If mode <> 0 Then
keybd_event VK_MENU, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
Else
If IsWindows9X() Then lngParam = 1
keybd_event VK_SNAPSHOT, lngParam, 0, 0
keybd_event VK_SNAPSHOT, lngParam, KEYEVENTF_KEYUP, 0
End If
End Sub
Private Function IsWindows9X()
Dim osinfo As OSVERSIONINFO
With osinfo
.dwOSVersionInfoSize = Len(osinfo)
GetVersionEx osinfo
If .dwPlatformId = 1 Then _
IsWindows9X = True
End With
End Function
Private Sub cmbClipSave_16_Click()
ClipboardToPicture 16
End Sub
Private Sub cmbClipSave_4_Click()
ClipboardToPicture 4
End Sub
Private Sub cmbClipSave_8_Click()
ClipboardToPicture 8
End Sub
Private Sub cmbSCR_Copy_Click()
CopyToClip 0
End Sub
Private Sub cmbWindow_Copy_Click()
CopyToClip 1
End Sub
'Hier beginnt der eigentliche Code
Option Explicit
Private 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
Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private 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
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Type BITMAPINFO_4
bmiHeader As BITMAPINFOHEADER
bmiColors(15) As RGBQUAD
End Type
Private Type BITMAPINFO_8
bmiHeader As BITMAPINFOHEADER
bmiColors(255) 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 GetDIBits_4 _
Lib "gdi32" Alias "GetDIBits" ( _
ByVal aHDC As Long, _
ByVal hBitmap As Long, _
ByVal nStartScan As Long, _
ByVal nNumScans As Long, _
lpBits As Any, _
lpBI As BITMAPINFO_4, _
ByVal wUsage As Long _
) As Long
Private Declare Function GetDIBits_8 _
Lib "gdi32" Alias "GetDIBits" ( _
ByVal aHDC As Long, _
ByVal hBitmap As Long, _
ByVal nStartScan As Long, _
ByVal nNumScans As Long, _
lpBits As Any, _
lpBI As BITMAPINFO_8, _
ByVal wUsage As Long _
) As Long
Private Declare Function GetDC _
Lib "user32" ( _
ByVal hwnd As Long _
) As Long
Private Declare Function ReleaseDC _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hdc As Long _
) As Long
Private Declare Function CloseClipboard _
Lib "user32" () As Long
Private Declare Function OpenClipboard _
Lib "user32" ( _
ByVal hwnd As Long _
) As Long
Private Declare Function GetClipboardData _
Lib "user32" ( _
ByVal wFormat As Long _
) As Long
Private Declare Function IsClipboardFormatAvailable _
Lib "user32" ( _
ByVal wFormat As Long _
) As Long
Private Declare Function SelectObject _
Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal hObject As Long _
) As Long
Private Declare Function CreateCompatibleDC _
Lib "gdi32" ( _
ByVal hdc As Long _
) As Long
Private Declare Function DeleteDC _
Lib "gdi32" ( _
ByVal hdc 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 Const BI_RGB = 0&
Private Const CF_BITMAP = 2
Public Sub ClipboardToPicture(Optional Quality_4_8_16 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 txtReturn As String, Ret As Long
Dim myFileHeader As BITMAPFILEHEADER
Dim myBMInfo_4 As BITMAPINFO_4
Dim myBMInfo_8 As BITMAPINFO_8
Dim myBMInfo As BITMAPINFO
Dim FF As Long, Länge As Long
Dim Faktor As Double
Select Case Quality_4_8_16
Case 4
Faktor = 0.5
Case 8
Faktor = 1
Case 16
Faktor = 2
Case Else
Quality_4_8_16 = 8
End Select
On Error GoTo fehlerbehandlung
OpenClipboard 0&
If IsClipboardFormatAvailable(CF_BITMAP) Then
'Speicherpfad holen
txtReturn = Application.GetSaveAsFilename( _
"Clip.bmp", _
"Bitmapdateien (*.bmp),*.bmp" _
, , _
"Als Bitmap speichern" _
)
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)
Select Case Quality_4_8_16
Case 4
With myBMInfo_4.bmiHeader
.biBitCount = 4
.biSize = 40
.biWidth = BMP.bmWidth
.biHeight = BMP.bmHeight
.biPlanes = 1
.biCompression = BI_RGB
.biSizeImage = Buffergröße
End With
Case 8
With myBMInfo_8.bmiHeader
.biBitCount = 8
.biSize = 40
.biWidth = BMP.bmWidth
.biHeight = BMP.bmHeight
.biPlanes = 1
.biCompression = BI_RGB
.biSizeImage = Buffergröße
End With
Case 16
With myBMInfo.bmiHeader
.biBitCount = 16
.biSize = 40
.biWidth = BMP.bmWidth
.biHeight = BMP.bmHeight
.biPlanes = 1
.biCompression = BI_RGB
.biSizeImage = Buffergröße
End With
End Select
'Daten auslesen
Select Case Quality_4_8_16
Case 4 '4 Bit Farbtiefe
Ret = GetDIBits_4(dummyDC, hBitmap, 0&, _
BMP.bmHeight, Buffer(0), myBMInfo_4, 0&)
Länge = Len(myBMInfo_4)
Case 8 '8 Bit Farbtiefe
Ret = GetDIBits_8(dummyDC, hBitmap, 0&, _
BMP.bmHeight, Buffer(0), myBMInfo_8, 0&)
Länge = Len(myBMInfo_8)
Case 16 '16 Bit Farbtiefe
Ret = GetDIBits(dummyDC, hBitmap, 0&, _
BMP.bmHeight, Buffer(0), myBMInfo, 0&)
Länge = Len(myBMInfo)
End Select
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
Select Case Quality_4_8_16
Case 4
Put FF, , myBMInfo_4
Case 8
Put FF, , myBMInfo_8
Case 16
Put FF, , myBMInfo
End Select
Put FF, , Buffer
Close
Exit Sub
fehlerbehandlung:
CloseClipboard
DeleteDC dummyDC
End Sub