Thema Datum  Von Nutzer Rating
Antwort
22.11.2021 02:59:24 DerLarry
NotSolved
22.11.2021 04:17:51 Gast25562
NotSolved
22.11.2021 11:58:54 DerLarry
NotSolved
23.11.2021 13:55:07 Gast25562
NotSolved
Rot Ungültiges Bild
22.11.2021 08:13:25 volti
NotSolved
22.11.2021 12:09:10 DerLarry
NotSolved
22.11.2021 19:07:43 xlKing
NotSolved
24.11.2021 13:23:33 DerLarry
Solved

Ansicht des Beitrags:
Von:
volti
Datum:
22.11.2021 08:13:25
Views:
496
Rating: Antwort:
  Ja
Thema:
Ungültiges Bild

Hallo Larry,

habe zwar keine Antwort auf Deine Frage aber vielleicht eine Alternative.

Warum das Bild exportieren und nicht direkt in das Image kopieren.

Teste mal folgendes Beispiel nach Anpassungen...

Option Explicit

Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
        ByRef PicDesc As PIC_DESC, ByRef RefIID As GUID, _
        ByVal fPictureOwnsHandle As LongPtr, ByRef IPic As IPictureDisp) As Long
Private Declare PtrSafe Function CopyImage Lib "user32" ( _
        ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, _
        ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" ( _
        ByVal wFormat As Long) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _
        ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "user32" ( _
        ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32" ( _
        ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" _
        Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
  
Private Type PIC_DESC
    lSize As Long
    lType As Long
    hPic  As LongPtr
    hPal  As LongPtr
End Type
Dim hPic  As LongPtr

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

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

Sub Paste_Picture_ByName(sSuch As String)
' Fügt ein Bild aus einer Pic-Sammlung über die Zwischenablage
' in ein Userform-Control ein
  Dim oPict As IPictureDisp, oShape As Shape
  Dim tPicInfo As PIC_DESC, tID_IDispatch As GUID

' Bild suchen und in die Zwischenablage kopieren
  With ThisWorkbook.Sheets("Tabelle2")              ' Blatt ggf. <<<anpassen>>>
      For Each oShape In .Shapes
          If oShape.Name Like sSuch & "*" Then
             oShape.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
             DoEvents: Exit For
          End If
      Next oShape
  End With

' Bild aus Zwischenablage in das Image einfügen
  If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
     If OpenClipboard(0&) <> 0 Then
        hPic = CopyImage(GetClipboardData(CF_BITMAP), _
        IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
        CloseClipboard
        If hPic <> 0 Then
           With tID_IDispatch
               .Data1 = &H20400
               .Data4(0) = &HC0
               .Data4(7) = &H46
           End With

           With tPicInfo
               .lSize = Len(tPicInfo)
               .lType = PICTYPE_BITMAP
               .hPic = hPic
               .hPal = 0
           End With

           OleCreatePictureIndirect tPicInfo, tID_IDispatch, 0&, oPict

           If Not oPict Is Nothing Then
' ######### Hier die Userform und Image-Angaben anpassen ########
              UserForm1.Image3.Picture = oPict
           Else
              MsgBox "Das Bild kann nicht angezeigt werden", vbCritical, "Bild einfügen"
           End If

        End If
     End If
  End If
End Sub


'Aufrufbeispiel für Sternzeichenpicture
Sub test()
  Paste_Picture_ByName "Löwe"
  UserForm1.Show
End Sub

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
22.11.2021 02:59:24 DerLarry
NotSolved
22.11.2021 04:17:51 Gast25562
NotSolved
22.11.2021 11:58:54 DerLarry
NotSolved
23.11.2021 13:55:07 Gast25562
NotSolved
Rot Ungültiges Bild
22.11.2021 08:13:25 volti
NotSolved
22.11.2021 12:09:10 DerLarry
NotSolved
22.11.2021 19:07:43 xlKing
NotSolved
24.11.2021 13:23:33 DerLarry
Solved