Grafik aus Excelsheet in Shapes speichern und Transparenz beibehalten

[Blaupunkt79]

Hallo Zusammen,

ich habe folgenden Code aus dem Netz, um eine Grafik (transparentes gif) aus einem Excelsheet in einem Shape zu speichern. Im Shape geht allerdings die Transparenz verloren, wie erhalte ich diese?

Code [Auswählen] Erweitern

Option Private Module

Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
    ByRef PicDesc As PICT_DESC, _
    ByRef RefIID As GUID, _
    ByVal fPictureOwnsHandle As LongPtr, _
    ByRef IPic As IPicture) As LongPtr
Private Declare PtrSafe Function CopyImage Lib "user32.dll" ( _
    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.dll" ( _
    ByVal wFormat As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
    ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" ( _
    ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" ( _
    ByVal lpsz As Any, _
    ByRef pCLSID As GUID) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe 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 PICT_DESC
    lSize As Long
    lType As Long
    hPic As LongPtr
    hPal As LongPtr
End Type

Private Const PICTYPE_BITMAP As Long = 1
Private Const CF_BITMAP As Long = 2
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_COPYRETURNORG As Long = &H4
Private Const GUID_IPICTUREDISP As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"

Private Function PastePicture(ByRef prlngptrCopy As LongPtr) As IPictureDisp

    Dim lngReturn As Long, lngptrPointer As LongPtr

    If IsClipboardFormatAvailable(CF_BITMAP) = 1 Then

        lngReturn = OpenClipboard(CLngPtr(Application.hwnd))

        If lngReturn > 0 Then

            lngptrPointer = GetClipboardData(CF_BITMAP)

            prlngptrCopy = CopyImage(lngptrPointer, _
                IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)

            Call CloseClipboard

            If lngptrPointer <> 0 Then Set PastePicture = _
                CreatePicture(prlngptrCopy, 0)

        End If
    End If
End Function

Private Function CreatePicture( _
    ByVal lngptrhPic As LongPtr, _
    ByVal lngptrhPal As LongPtr) As IPictureDisp

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

    Call CLSIDFromString(StrPtr( _
        GUID_IPICTUREDISP), udtID_IDispatch)

    With udtPicInfo
        .lSize = Len(udtPicInfo)
        .lType = PICTYPE_BITMAP
        .hPic = lngptrhPic
        .hPal = lngptrhPal
    End With

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

    Set CreatePicture = objPicture

    Set objPicture = Nothing

End Function


Public Sub ShowPicture()

    Dim objPicture As IPictureDisp
    Dim lngptrCopy As LongPtr

Set wb = ActiveWorkbook

    Call OpenClipboard(0&)
    Call EmptyClipboard
    Call CloseClipboard
   
    Do

        Call Tabelle110.Shapes("Grafik 2").CopyPicture( _
            Appearance:=xlScreen, Format:=xlBitmap)
           
         
        Set objPicture = PastePicture(lngptrCopy)
       
        If Not objPicture Is Nothing Then Exit Do
   
    Loop
   
    Set wb.Worksheets("Minus_final").Image3.Picture = objPicture

End Sub

Aufrufen tu ich die Routine wie folgt, im Anschluß habe ich noch versucht, alles auf Transparent zu setzen, macht nur keinen Unterschied:

Code [Auswählen] Erweitern

Call ShowPicture
 
Dim objShape As Shape

For Each objShape In wb.Worksheets("Minus_final").Shapes
With objShape
.Fill.Transparency = 1

End With
Next

Danke

Grüße

Mirko

[PhilS]

ich habe folgenden Code aus dem Netz, um eine Grafik (transparentes gif) aus einem Excelsheet in einem Shape zu speichern. Im Shape geht allerdings die Transparenz verloren, wie erhalte ich diese?

Eine Frage stellt sich mir da vorab: Bleibt die Transparenz erhalten, wenn du das Bild manuell über die Benutzeroberfläche einfügst.

[Blaupunkt79]

Ja meine gif's sind alle Transparent, auch in den Excelsheets sind diese Transparent, wenn ich beispielsweise einige Zellen mit einer Hintergrundfarbe befülle.