Picture Paste auf Userform

Axel · 1970-01-01T00:00:00+00:00

Guten Morgen liebe Helfer! Mal wieder an der Grenze meines Könnens: ich habe einen Tabellenbereich (inklusive Formatierung etc) als .bmp im Zwischenspeicher. Wenn ich jetzt im Eigenschaftenbereich einer Userform auf Picture klicke, kann ich diesen Zwischenspeicher pasten (ctrl+v), das .bmp wird prima in die Userform eingegliedert. Genau diesen Schritt möchte ich gerne als Befehl innerhalb eines Makros, d.h. ohne aufwändigen Export eines Bildes in eine Datei/Excel-Sheet mit anschließendem "Reimport" auf die Userform. Gibt's das? Danke für Hilfe! Gruß, Axel

Hallo Axel,
versuch es mal so:

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
    ByRef PicDesc As PIC_DESC, _
    ByRef RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, _
    ByRef IPic As IPictureDisp) As Long
Private Declare Function CopyImage Lib "user32.dll" ( _
    ByVal handle As Long, _
    ByVal un1 As Long, _
    ByVal n1 As Long, _
    ByVal n2 As Long, _
    ByVal un2 As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
    ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
    ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
    ByVal wFormat As Integer) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type PIC_DESC
    lngSize As Long
    lngType As Long
    lnghPic As Long
    lnghPal As Long
End Type

Private Const PICTYPE_BITMAP = 1
Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"

Private Function Paste_Picture() As IPictureDisp

    Dim lngReturn As Long, lngCopy As Long, lngPointer As Long

    If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
        lngReturn = OpenClipboard(FindWindow(GC_CLASSNAMEMSEXCEL, Application.Caption))
        If lngReturn > 0 Then
            lngPointer = GetClipboardData(CF_BITMAP)
            lngCopy = CopyImage(lngPointer, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Call CloseClipboard
            If lngPointer <> 0 Then Set Paste_Picture = Create_Picture(lngCopy, 0&, CF_BITMAP)
        End If
    End If

End Function

Private Function Create_Picture( _
        ByVal lnghPic As Long, _
        ByVal lnghPal As Long, _
        ByVal lngPicType As Long) As IPictureDisp

    Dim udtPicInfo As PIC_DESC, udtID_IDispatch As GUID
    Dim objPicture As IPictureDisp

    With udtID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With

    With udtPicInfo
        .lngSize = Len(udtPicInfo)
        .lngType = PICTYPE_BITMAP
        .lnghPic = lnghPic
        .lnghPal = lnghPal
    End With

    Call OleCreatePictureIndirect(udtPicInfo, udtID_IDispatch, 0&, objPicture)

    Set Create_Picture = objPicture

End Function

Public Sub Show_Range()

    Dim objPicture As IPictureDisp

    Call EmptyClipboard

    Tabelle1.Range("A1:C5").CopyPicture _
        Appearance:=xlScreen, Format:=xlBitmap

    Set objPicture = Paste_Picture

    If Not objPicture Is Nothing Then
        UserForm1.Picture = objPicture
    Else
        MsgBox "Error - Range can't show in Userform", vbCritical, "Error"
    End If

    UserForm1.Show

End Sub

Gruß
Nepumuk

Hallo Nepumuk,
ja, eine neue Mappe zeigt den gleichen Fehler wie beschrieben. Deinen Code habe ich in ein "normales" Modul eingefügt, eine Userform1 ist vorhanden.
Muss ich evtl noch irgendwelche References aktivieren?
Ich werde mir Dein Makro in jedem Fall mal genauer ansehen, da kann ich viel lernen.
Inzwischen habe ich es doch über einen Export erledigt (wollte ich vermeiden, weil bei Netzwerkrechnern die Belegung der FestplattenBuchstaben und der vorhandnen Ordner nie perfekt zuverlässig ist).
Danke Dir nochmals,
Axel
Sub zeichnung_auslesen()
vFilePath = "..."
Workbooks.Open Filename:=vFilePath
Sheets(1).Range("A1:I8").CopyPicture Appearance:=xlScreen, Format:=xlPicture
If ActiveWorkbook.Name = ZeichnungsNummer & ".xls" Then
ActiveWorkbook.Close savechanges:=False
End If
Sheets(1).Select
Charts.Add
ActiveChart.Paste
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.ScaleWidth 1.42, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.42, msoFalse, msoScaleFromTopLeft
ActiveChart.ChartArea.Select
ActiveChart.Location Where:=xlLocationAsObject, Name:= sheets(1).name
ActiveSheet.ChartObjects(1).Activate
ActiveSheet.Shapes(1).ScaleWidth 1.63, msoFalse, msoScaleFromBottomRight
ActiveSheet.Shapes(1).ScaleHeight 0.79, msoFalse, msoScaleFromTopLeft
Worksheets(1).ChartObjects(1).Chart.Export Filename:="C:\Temp\999.gif", FilterName:="gif"
ActiveWindow.Visible = False
Selection.Delete
ZeichnBl1.Show
End Sub

Private Sub Userform_Initialize()
Dateiname = "C:\Temp\999.gif"
ZeichnBl1.Image1.Picture = LoadPicture(Dateiname)
End Sub

Forumthread: Picture Paste auf Userform

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Infobox / Tutorial

Bilder in eine Userform mit VBA einfügen

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)