Zurück zur Homepage

Aus dem Clipboard frisch auf den Tisch in die Datei

Sie haben eine Bildschirmkopie in die Zwischenablage mit der Druck - Taste geschoben, und wollen dieses Bild jetzt speichern?
Dann können Sie ein Bildbearbeitungsprogramm öffnen, das Bild aus der Zwischenablage einfügen und es dann speichern. Das geht aber auch ohne ein Zusatzprogramm.
Mein Code ermöglicht es, ein Bitmap aus der Zwischenablage als Datei mit den Farbtiefen 4 Bit, 8 Bit und 16 Bit abzuspeichern.

Beispielmappe bmp.zip 30 KB)
 

'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