Die Community zu .NET und Classic VB.
Menü

Tipp-Upload: VB 5/6 0456: Alle von Windows unterstütze Bildformate in ein Bitmap oder JPEG konvertieren oder in eine PictureBox laden.

 von 

Über den Tipp  

Dieser Vorschlag soll VB 5/6 Tipp 0805 ersetzen.

Dieser Tippvorschlag wird übernommen.

Der Vorschlag ist in den folgenden Kategorien zu finden:

  • Grafik

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
Interfaces, ITranscodeImage, IStream, IShellItem, IPropertyStore

Der Vorschlag wurde erstellt am: 11.12.2018 10:03.
Die letzte Aktualisierung erfolgte am 11.12.2018 10:14.

Zurück zur Übersicht

Beschreibung  

Dieses Beispiel zeigt, unter Verwendung diverser Interfaces, wie eine von Windows unterstützte Bilddatei in ein Bitmap oder JPEG konvertiert werden kann. Die Bilddatei kann so auch in einer Picturebox angezeigt werden. Gleichzeitig zeigt dieses Beispiel wie einfach es ist diverse Interfaces von Windows in Visual Basic Classic ohne eine TypeLib (TLB) zu verwenden.

Schwierigkeitsgrad

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

CLSIDFromString, CoCreateInstance, CoTaskMemFree, CreateStreamOnHGlobal, DispCallFunc, IIDFromString, OleLoadPicture, PSGetPropertyKeyFromName, RtlMoveMemory, SHCreateItemFromParsingName, SHCreateStreamOnFileEx, SHGetPropertyStoreFromParsingName, lstrlenW

Download:

Download des Beispielprojektes [399,81 KB]

' Dieser Source stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.

' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
' Ansonsten viel Spaß und Erfolg mit diesem Source!

' ------------- Anfang Projektdatei Project1.vbp -------------

' --------- Anfang Formular "Form1" alias Form1.frm  ---------

' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Bildfeld-Steuerelement "Picture1"

Option Explicit

Private Sub Command1_Click()

    Dim sPicPath As String
    Dim sPicFile As String

    ' Pfad zur Bilddatei.
    sPicPath = App.Path

    ' Bilddatei.
    ' Es kann jedes von Windows unterstützte Bildformat verwendet werden.
    ' sPicFile = "Desert.wdp" ' zB. Windows Media Foto
    sPicFile = "Desert.png"

    ' Backslash anfügen wenn nicht vorhanden
    If Right$(sPicPath, 1) <> "\" Then sPicPath = sPicPath & "\"

    ' Bild in die PictureBox laden.
    Picture1.Picture = TranscodeImageToPicture(sPicPath & sPicFile)

    ' Ist ein Picture-Handle vorhanden?
    If Picture1.Picture.Handle <> 0 Then

        MsgBox sPicFile & " wurde erfolgreich in die PictureBox geladen.", vbInformation Or _
            vbOKOnly, "Bild in die PictureBox laden"

    End If

    ' Bild in ein Bitmap konvertieren.
    If TranscodeImageToDisc(sPicPath & sPicFile, TI_BITMAP) = True Then

        MsgBox sPicFile & " wurde erfolgreich in eine Bitmap konvertiert.", vbInformation Or _
            vbOKOnly, "Konvertierung nach BMP"

    End If

    ' Bild in ein JPEG konvertieren.
    If TranscodeImageToDisc(sPicPath & sPicFile, TI_JPEG) = True Then

        MsgBox sPicFile & " wurde erfolgreich in eine JPEG konvertiert.", vbInformation Or _
            vbOKOnly, "Konvertierung nach JPEG"

    End If

End Sub

' ---------- Ende Formular "Form1" alias Form1.frm  ----------

' --- Anfang Klasse "clsIShellItem" alias clsIShellItem.cls  ---

' Autor: F. Schüler (frank@activevb.de)
' Datum: 11/2017

' IUnknown interface
' https://docs.microsoft.com/en-us/windows/desktop/api/unknwn/nn-unknwn-iunknown

' IShellItem interface
' https://docs.microsoft.com/en-us/windows/desktop/api/shobjidl_core/nn-shobjidl_core-ishellitem

Option Explicit

' ----==== Const ====----
Private Const ERR_BASE As Long = 40670
Private Const CLSID_ShellItem As String = "{9ac9fbe1-e0a2-4ad6-b4ee-e212013ea917}"
Private Const IID_IShellItem As String = "{43826d1e-e718-42ee-bc55-a1e261c37bfe}"

' Die Positionen der einzelnen vtbOffets ergeben sich aus dem entsprechende Header
' zum Interface. Siehe dazu zB. -> typedef struct IShellItemVtbl. In der Funktion
' oleInvoke wird dann der Offset * 4 genommen um dann per DispCallFunc die richtige
' Funktion im Interface aufzurufen.
' Interface Pointer + (Offset * 4) = Pointer zur Funktion
Private Enum E_vtbOffsets

    ' /*** IUnknown methods ***/     ' Offset
    vtb_QueryInterface              ' 0
    vtb_AddRef                      ' 1
    vtb_Release                     ' 2

    ' /*** IShellItem methods ***/
    vtb_BindToHandler               ' 3
    vtb_GetParent                   ' 4
    vtb_GetDisplayName              ' 5
    vtb_GetAttributes               ' 6
    vtb_Compare                     ' 7
End Enum

' Beschreibung des IShellItem-Interfaces aus der Headerdatei ShObjIdl_core.h
'
' EXTERN_C const IID IID_IShellItem;
'
' #if defined(__cplusplus) && !defined(CINTERFACE)
'
'    MIDL_INTERFACE ("43826d1e-e718-42ee-bc55-a1e261c37bfe")
' IShellItem:      Public IUnknown
'    {
'    public:
'        virtual HRESULT STDMETHODCALLTYPE BindToHandler(
'            /* [unique][in] */ __RPC__in_opt IBindCtx *pbc,
'            /* [in] */ __RPC__in REFGUID bhid,
'            /* [in] */ __RPC__in REFIID riid,
'            /* [iid_is][out] */ __RPC__deref_out_opt void **ppv) = 0;
'
'        virtual HRESULT STDMETHODCALLTYPE GetParent(
'            /* [out] */ __RPC__deref_out_opt IShellItem **ppsi) = 0;
'
'        virtual HRESULT STDMETHODCALLTYPE GetDisplayName(
'            /* [in] */ SIGDN sigdnName,
'            /* [annotation][string][out] */
'            _Outptr_result_nullonfailure_  LPWSTR *ppszName) = 0;
'
'        virtual HRESULT STDMETHODCALLTYPE GetAttributes(
'            /* [in] */ SFGAOF sfgaoMask,
'            /* [out] */ __RPC__out SFGAOF *psfgaoAttribs) = 0;
'
'        virtual HRESULT STDMETHODCALLTYPE Compare(
'            /* [in] */ __RPC__in_opt IShellItem *psi,
'            /* [in] */ SICHINTF hint,
'            /* [out] */ __RPC__out int *piOrder) = 0;
'
'    };
'
'
' #else   /* C style interface */
'
'    typedef struct IShellItemVtbl
'    {
'        BEGIN_INTERFACE
'
'        HRESULT ( STDMETHODCALLTYPE *QueryInterface )(
'            __RPC__in IShellItem * This,
'            /* [in] */ __RPC__in REFIID riid,
'            /* [annotation][iid_is][out] */
'            _COM_Outptr_  void **ppvObject);
'
'        ULONG ( STDMETHODCALLTYPE *AddRef )(
'            __RPC__in IShellItem * This);
'
'        ULONG ( STDMETHODCALLTYPE *Release )(
'            __RPC__in IShellItem * This);
'
'        HRESULT ( STDMETHODCALLTYPE *BindToHandler )(
'            __RPC__in IShellItem * This,
'            /* [unique][in] */ __RPC__in_opt IBindCtx *pbc,
'            /* [in] */ __RPC__in REFGUID bhid,
'            /* [in] */ __RPC__in REFIID riid,
'            /* [iid_is][out] */ __RPC__deref_out_opt void **ppv);
'
'        HRESULT ( STDMETHODCALLTYPE *GetParent )(
'            __RPC__in IShellItem * This,
'            /* [out] */ __RPC__deref_out_opt IShellItem **ppsi);
'
'        HRESULT ( STDMETHODCALLTYPE *GetDisplayName )(
'            __RPC__in IShellItem * This,
'            /* [in] */ SIGDN sigdnName,
'            /* [annotation][string][out] */
'            _Outptr_result_nullonfailure_  LPWSTR *ppszName);
'
'        HRESULT ( STDMETHODCALLTYPE *GetAttributes )(
'            __RPC__in IShellItem * This,
'            /* [in] */ SFGAOF sfgaoMask,
'            /* [out] */ __RPC__out SFGAOF *psfgaoAttribs);
'
'        HRESULT ( STDMETHODCALLTYPE *Compare )(
'            __RPC__in IShellItem * This,
'            /* [in] */ __RPC__in_opt IShellItem *psi,
'            /* [in] */ SICHINTF hint,
'            /* [out] */ __RPC__out int *piOrder);
'
'        END_INTERFACE
'    } IShellItemVtbl;
'
'    Interface IShellItem
'    {
'        CONST_VTBL struct IShellItemVtbl *lpVtbl;
'    };

' ----==== Variablen ====----
Private m_initialized As Boolean
Private m_Interface As Interface_Data

Public Function BindToHandler(ByVal pbc As Long, ByVal rbhid As Long, ByVal riid _
    As Long) As Long

    Dim lRet As Long
    Dim ppvOut As Long
    Dim pppvOut As Long

    pppvOut = VarPtr(ppvOut)

    If x_OleInvoke(vtb_BindToHandler, pbc, rbhid, riid, pppvOut) Then

        lRet = ppvOut

    End If

    BindToHandler = lRet

End Function

Public Function GetParent() As Long

    Dim lRet As Long
    Dim ppsi As Long
    Dim pppsi As Long

    pppsi = VarPtr(ppsi)

    If x_OleInvoke(vtb_GetParent, pppsi) Then

        lRet = ppsi

    End If

    GetParent = lRet

End Function

Public Function GetDisplayName(ByVal sigdnName As SIGDN) As String

    Dim sRet As String
    Dim pszName As Long
    Dim ppszName As Long

    ppszName = VarPtr(pszName)

    If x_OleInvoke(vtb_GetDisplayName, sigdnName, ppszName) Then

        sRet = GetStringFromPointer(pszName)

    End If

    GetDisplayName = sRet

End Function

Public Function GetAttributes(ByVal sfgaoMask As Long) As Long

    Dim lRet As Long
    Dim psfgaoAttribs As Long
    Dim ppsfgaoAttribs As Long

    ppsfgaoAttribs = VarPtr(psfgaoAttribs)

    If x_OleInvoke(vtb_GetAttributes, sfgaoMask, ppsfgaoAttribs) Then

        lRet = psfgaoAttribs

    End If

    GetAttributes = lRet

End Function

Public Function Compare(ByVal psi As Long, ByVal hint As SICHINTF) As Long

    Dim lRet As Long
    Dim piOrder As Long
    Dim ppiOrder As Long

    ppiOrder = VarPtr(piOrder)

    If x_OleInvoke(vtb_Compare, psi, hint, ppiOrder) Then

        lRet = piOrder

    End If

    Compare = lRet

End Function

' ----==== Helper Func ====----
Public Sub Initialize(ByVal pInterface As Long)

    m_Interface.owner = ObjPtr(Me)  ' Objekt-Pointer dieser Klasse
    m_Interface.RaiseErrors = False ' Bei Fehler keine Unterbrechung
    m_Interface.ifc = pInterface    ' Interface-Pointer
    m_initialized = True            ' ist Initialisiert?

    ' Falls kein Pointer auf ein Interface übergeben wird, kann das Interface
    ' aus der CLSID und IID erstellt werden. Typischerweise dann in der
    ' Sub Class_Initialize. Siehe Klasse clsITranscodeImage. Wird hier aber
    ' nicht benötigt da der Pointer von einer externen Funktion kommt.

End Sub

Private Sub Class_Terminate()

    ' Ruft die Funktion Release des Interfaces auf
    Call ReleaseInterface(m_Interface)

End Sub

' Ändert die Einstellung wenn ein Fehler beim Ausführen einer
' Interface-Funktion auftritt.
Public Sub RaiseError(Optional ByVal Raise As Boolean = False)

    ' True = Fehler beim Aufrufen von Interface-Funktionen
    ' Unterbricht die weitere Codeausführung wenn kein On Error
    ' Statement vorhanden ist. Praktisch beim testen.

    ' False = kein Unterbrechen bei einem Fehler. Die entsprechenden
    ' Interface-Funktionen liefern dann bei einem Fehler
    ' x_OleInvoke = False zurück.
    m_Interface.RaiseErrors = Raise

End Sub

' Aufrufen der Interface-Funktion
Private Function x_OleInvoke(ByVal vtb As E_vtbOffsets, ParamArray var()) As Boolean

    Dim ret As Long

    ' ist kein Interface-Pointer vorhanden, also nicht initialisiert
    If Not m_initialized Then

        ' Fehler auslösen
        Call InterfaceError(m_Interface, ecd_OleInvoke)

    Else

        ' Interface-Funktion aufrufen. Siehe modInterface -> oleInvoke
        x_OleInvoke = oleInvoke(m_Interface, vtb, ret, True, var)

    End If

End Function

' wird bei einem Fehler aus der modInterface aufgerufen
Public Sub x_RaiseError()

    With m_Interface

        ' Fehler auslösen
        If .ecd Then Err.Raise ERR_BASE + .ecd, App.EXEName & ".clsIShellItem", .etx

        .ecd = 0    ' Fehlernummer löschen
        .etx = ""   ' Fehlertext löschen

    End With

End Sub

' --- Ende Klasse "clsIShellItem" alias clsIShellItem.cls  ---

' --- Anfang Klasse "clsITranscodeImage" alias clsITranscodeImage.cls  ---

' Autor: F. Schüler (frank@activevb.de)
' Datum: 09/2018

' IUnknown interface
' https://docs.microsoft.com/en-us/windows/desktop/api/unknwn/nn-unknwn-iunknown

' ITranscodeImage interface
' https://docs.microsoft.com/en-us/windows/desktop/api/imagetranscode/nn-imagetranscode-itransc
' odeimage
'

Option Explicit

' ----==== Const ====----
Private Const ERR_BASE As Long = 40670
Private Const CLSID_TranscodeImage As String = "{17B75166-928F-417d-9685-64AA135565C1}"
Private Const IID_ITranscodeImage As String = "{BAE86DDD-DC11-421c-B7AB-CC55D1D65C44}"

Private Enum E_vtbOffsets

    ' /*** IUnknown methods ***/
    vtb_QueryInterface
    vtb_AddRef
    vtb_Release

    ' /*** ITranscodeImage methods ***/
    vtb_TranscodeImage
End Enum

' ----==== Variablen ====----
Private m_initialized As Boolean
Private m_Interface As Interface_Data

Public Function TranscodeImage(ByVal pShellItem As Long, ByVal uiMaxWidth As Long, _
    ByVal uiMaxHeight As Long, ByVal flags As TI_FLAGS, ByVal pvImage As Long, _
    ByRef puiWidth As Long, ByRef puiHeight As Long) As Boolean

    Dim bRet As Boolean
    Dim ppuiWidth As Long
    Dim ppuiHeight As Long

    bRet = False
    ppuiWidth = VarPtr(puiWidth)
    ppuiHeight = VarPtr(puiHeight)

    If x_OleInvoke(vtb_TranscodeImage, pShellItem, uiMaxWidth, uiMaxHeight, flags, pvImage, _
        ppuiWidth, ppuiHeight) Then

        bRet = True

    End If

    TranscodeImage = bRet

End Function

' ----==== Helper Func ====----
Private Sub Class_Initialize()

    m_Interface.owner = ObjPtr(Me)
    m_Interface.RaiseErrors = False

    ' Interface wird aus CLSID und IID erstellt
    m_initialized = InitInterface(m_Interface, CLSID_TranscodeImage, IID_ITranscodeImage)

End Sub

Private Sub Class_Terminate()

    Call ReleaseInterface(m_Interface)

End Sub

Public Sub RaiseError(Optional ByVal Raise As Boolean = False)

    m_Interface.RaiseErrors = Raise

End Sub

Private Function x_OleInvoke(ByVal vtb As E_vtbOffsets, ParamArray var()) As Boolean

    Dim ret As Long

    If Not m_initialized Then

        Call InterfaceError(m_Interface, ecd_OleInvoke)

    Else

        x_OleInvoke = oleInvoke(m_Interface, vtb, ret, True, var)

    End If

End Function

Public Sub x_RaiseError()

    With m_Interface

        If .ecd Then Err.Raise ERR_BASE + .ecd, App.EXEName & ".clsITranscodeImage", .etx

        .ecd = 0
        .etx = ""

    End With

End Sub

' --- Ende Klasse "clsITranscodeImage" alias clsITranscodeImage.cls  ---

' ---- Anfang Modul "modInterface" alias modInterface.bas ----

' Universal Module für alle Interface-Klassen
' Ursprünglich glaub von Udo Schmidt (ActiveVB)

Option Explicit

' ----==== Const ====----
Private Const S_OK As Long = &H0
Private Const CLSCTX_INPROC As Long = &H1
Private Const CC_STDCALL As Long = &H4
Private Const IID_Release As Long = &H8

' ----==== Interface Error Code ====----
Public Enum Interface_errCodes
    ecd_None                    ' no error
    ecd_InvalidCall             ' invalid function call
    ecd_OleConvert              ' could not convert classid
    ecd_InitInterface           ' could not convert interface id
    ecd_OleInvoke               ' could not invoke interface function
End Enum

' ----==== Holds the Interface Data ====----
Public Type Interface_Data
    ifc As Long                 ' Interface-Pointer
    ecd As Interface_errCodes   ' Fehlercode
    etx As String               ' Fehlertext
    owner As Long               ' Pointer zur Klasse
    RaiseErrors As Boolean      ' Fehler auslösen?
End Type

' ----==== Kernel32 API-Deklarationen ====----
Private Declare Function lstrlenW Lib "kernel32" ( _
                         ByVal lpString As Long) As Long

Private Declare Sub RtlMoveMemory Lib "kernel32" ( _
                    ByRef hpvDest As Any, _
                    ByRef hpvSource As Any, _
                    ByVal cbCopy As Long)

' ----==== Ole32 API-Deklarationen ====----
Private Declare Sub CoTaskMemFree Lib "ole32" ( _
                    ByVal hMem As Long)

Private Declare Function CLSIDFromString Lib "ole32" ( _
                         ByVal lpszProgID As Long, _
                         ByRef pCLSID As Any) As Long

Private Declare Function CoCreateInstance Lib "ole32" ( _
                         ByRef rclsid As Any, _
                         ByVal pUnkOuter As Long, _
                         ByVal dwClsContext As Long, _
                         ByRef riid As Any, _
                         ByRef ppv As Long) As Long

' ----==== OleAut32 API-Deklarationen ====----
Private Declare Sub DispCallFunc Lib "OleAut32" ( _
                    ByVal ppv As Long, _
                    ByVal oVft As Long, _
                    ByVal cc As Long, _
                    ByVal rtTYP As VbVarType, _
                    ByVal paCNT As Long, _
                    ByRef paTypes As Any, _
                    ByRef paValues As Any, _
                    ByRef fuReturn As Variant)

' ----==== Variablen ====----
Private ole_typ(10) As Integer
Private ole_ptr(10) As Long

' ----==== Pointer to String ====----
Public Function GetStringFromPointer(ByVal lpStrPointer As Long) As String

    Dim lLen As Long
    Dim bBuffer() As Byte

    ' Länge des Strings im Speicher
    lLen = lstrlenW(lpStrPointer) * 2 - 1

    ' Länge > 0
    If lLen > 0 Then

        ' Puffer dimensionieren
        ReDim bBuffer(lLen)

        ' String vom Pointer in den Puffer kopieren
        Call RtlMoveMemory(bBuffer(0), ByVal lpStrPointer, lLen)

        ' String im Speicher freigeben
        Call CoTaskMemFree(lpStrPointer)

        ' String zurück geben
        GetStringFromPointer = bBuffer

    End If

End Function

' ----==== Init Interface ====----
Public Function InitInterface(ByRef Interface As Interface_Data, ByVal cid As _
    String, ByVal IID As String) As Boolean

    ' Erstellen eines Interfaces aus IID und CLSID

    Dim car() As Byte
    Dim iar() As Byte

    ' Falls die CLSID nicht konvertiert werden konnte
    If Not oleConvert(cid, car()) Then

        ' Fehler auslösen
        Call InterfaceError(Interface, ecd_OleConvert)

        ' Falls die IID nicht konvertiert werden konnte
    ElseIf Not oleConvert(IID, iar()) Then

        ' Fehler auslösen
        Call InterfaceError(Interface, ecd_OleConvert)

        ' Falls das Interface nicht aus CLSID und IID erstellt werden konnte
    ElseIf CoCreateInstance(car(0), 0&, CLSCTX_INPROC, iar(0), Interface.ifc) <> S_OK Then

        ' Fehler auslösen
        Call InterfaceError(Interface, ecd_InitInterface)

    Else

        ' Erstellung des Interfaces war erfolgreich
        InitInterface = True

    End If

End Function

' ----==== Release Interface ====----
Public Function ReleaseInterface(ByRef Interface As Interface_Data)

    Dim lRet As Long

    ' ist ein Pointer auf ein Interface vorhanden
    If Interface.ifc Then

        ' Funktion Release des Interfaces aufrufen
        Call DispCallFunc(Interface.ifc, IID_Release, CC_STDCALL, vbLong, 0&, 0&, 0&, lRet)

    End If

End Function

' ----==== Interface Error ====----
Public Function InterfaceError(ByRef Interface As Interface_Data, Optional ByVal _
    ecd As Interface_errCodes = -1) As Boolean

    Dim dmy As Object
    Dim obj As Object

    With Interface

        ' ist eine Fehlernummer vorhanden
        If ecd Then .ecd = ecd ' Fehlernummer speichern

        ' Felertext nach Fehlernummer speichern
        Select Case .ecd

        Case Is < 0:                .etx = "": .ecd = ecd_None
        Case ecd_InvalidCall:       .etx = "invalid function call"
        Case ecd_OleConvert:        .etx = "could not convert classid"
        Case ecd_InitInterface:     .etx = "could not convert interface id"
        Case ecd_OleInvoke:         .etx = "could not invoke ifc function"

        End Select

        If .ecd = ecd_None Then ' nur wenn Fehler ecd_None

        ElseIf Not .RaiseErrors Then ' Nur wenn RaiseErros = False

        ElseIf .owner Then ' ist ein Pointer zu einer Klasse vorhanden

            ' Objekt vom Pointer
            Call RtlMoveMemory(dmy, .owner, 4)

            ' Objekt speichern
            Set obj = dmy

            ' Objekt löschen
            Call RtlMoveMemory(dmy, 0&, 4)

            ' Sub x_RaiseError in der entsprechenden Klasse aufrufen
            obj.x_RaiseError

        End If

    End With

End Function

' ----==== IID/CLSID to ByteArray ====----
Private Function oleConvert(ByVal cid As String, ByRef bar() As Byte) As Boolean

    ReDim bar(15)
    oleConvert = (CLSIDFromString(StrPtr(cid), bar(0)) = S_OK)

End Function

' ----==== Call Interface Function ====----
Public Function oleInvoke(ByRef Interface As Interface_Data, ByVal cmd As Long, _
    ByRef ret As Variant, ByVal chk As Boolean, ParamArray arr()) As Boolean

    Dim lpc As Long
    Dim var As Variant

    ' wenn kein Interface-Pointer vorhanden ist
    If Interface.ifc = 0 Then

        ' Fehler auslösen
        Call InterfaceError(Interface, ecd_InvalidCall)

    Else

        ' nur wenn zum Aufruf der Interface-Funktion auch
        ' Parameter vorhanden sind.
        If UBound(arr) >= 0 Then

            ' ParamArray nach Variant
            var = arr

            ' ist der Variant ein Array, dann das erste Element daraus
            If IsArray(var) Then var = var(0)

            ' alle Parameter durchlaufen
            For lpc = 0 To UBound(var)

                ole_typ(lpc) = VarType(var(lpc))    ' Typ des Parameter
                ole_ptr(lpc) = VarPtr(var(lpc))     ' Pointer auf den Parameter

            Next

        End If

        ' Funktion des Interfaces aufrufen
        Call DispCallFunc(Interface.ifc, cmd * 4, CC_STDCALL, VarType(ret), lpc, ole_typ(0), _
            ole_ptr(0), ret)

        oleInvoke = True

        If Not chk Then ' wenn chk = False

        ElseIf VarType(ret) <> vbLong Then ' wenn ret <> vbLong ist

        ElseIf ret <> S_OK Then ' wenn ret <> S_OK ist

            ' Fehler auslösen
            Call InterfaceError(Interface, ecd_OleInvoke)

            ' zurück geben das der Aufruf fehlgeschlagen ist
            oleInvoke = False

        End If

    End If

End Function

' ----- Ende Modul "modInterface" alias modInterface.bas -----

' --- Anfang Modul "modITranscodeImage" alias modITranscodeImage.bas ---

' Autor: F. Schüler (frank@activevb.de)
' Datum: 09/2018

Option Explicit

' ----==== Const ====----
Private Const S_OK As Long = &H0
Private Const VT_UI4 As Long = &H13
Private Const GPS_DEFAULT As Long = &H0
Private Const ImageWidth As String = "System.Image.HorizontalSize"
Private Const ImageHeight As String = "System.Image.VerticalSize"
Private Const IID_IPicture As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Const IID_IShellItem As String = "{43826d1e-e718-42ee-bc55-a1e261c37bfe}"
Private Const IID_IPropertyStore As String = "{886D8EEB-8CF2-4446-8D02-CDBA1DBDCF99}"

' ----==== Enums ====----
Public Enum TI_FLAGS
    TI_BITMAP = &H1
    TI_JPEG = &H2
End Enum

Public Enum SICHINTF
    SICHINT_DISPLAY = &H0
    SICHINT_ALLFIELDS = &H80000000
    SICHINT_CANONICAL = &H10000000
    SICHINT_TEST_FILESYSPATH_IF_NOT_EQUAL = &H20000000
End Enum

Public Enum SIGDN
    SIGDN_NORMALDISPLAY = &H0
    SIGDN_PARENTRELATIVEPARSING = &H80018001
    SIGDN_DESKTOPABSOLUTEPARSING = &H80028000
    SIGDN_PARENTRELATIVEEDITING = &H80031001
    SIGDN_DESKTOPABSOLUTEEDITING = &H8004C000
    SIGDN_FILESYSPATH = &H80058000
    SIGDN_URL = &H80068000
    SIGDN_PARENTRELATIVEFORADDRESSBAR = &H8007C001
    SIGDN_PARENTRELATIVE = &H80080001
    SIGDN_PARENTRELATIVEFORUI = &H80094001
End Enum

Public Enum STGTY
    STGTY_STORAGE = &H1
    STGTY_STREAM = &H2
    STGTY_LOCKBYTES = &H3
    STGTY_PROPERTY = &H4
End Enum

Public Enum STGM
    STGM_FAILIFTHERE = &H0
    STGM_DIRECT = &H0
    STGM_READ = &H0
    STGM_WRITE = &H1
    STGM_READWRITE = &H2
    STGM_SHARE_EXCLUSIVE = &H10
    STGM_SHARE_DENY_WRITE = &H20
    STGM_SHARE_DENY_READ = &H30
    STGM_SHARE_DENY_NONE = &H40
    STGM_CREATE = &H1000
    STGM_TRANSACTED = &H10000
    STGM_CONVERT = &H20000
    STGM_PRIORITY = &H40000
    STGM_NOSCRATCH = &H100000
    STGM_NOSNAPSHOT = &H200000
    STGM_DIRECT_SWMR = &H400000
    STGM_SIMPLE = &H8000000
    STGM_DELETEONRELEASE = &H4000000
End Enum

Public Enum STGC
    STGC_DEFAULT = &H0
    STGC_OVERWRITE = &H1
    STGC_ONLYIFCURRENT = &H2
    STGC_DANGEROUSLYCOMMITMERELYTODISKCACHE = &H4
    STGC_CONSOLIDATE = &H8
End Enum

Public Enum STATFLAG
    STATFLAG_DEFAULT = &H0
    STATFLAG_NONAME = &H1
    STATFLAG_NOOPEN = &H2
End Enum

Public Enum STREAM_SEEK
    STREAM_SEEK_SET = &H0
    STREAM_SEEK_CUR = &H1
    STREAM_SEEK_END = &H2
End Enum

Public Enum LOCKTYPE
    LOCK_WRITE = &H1
    LOCK_EXCLUSIVE = &H2
    LOCK_ONLYONCE = &H4
End Enum

' ----==== Types ====----
Private Type SIZE
    cx As Long
    cy As Long
End Type

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

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

Public Type PROPERTYKEY
    fmtid As GUID
    pid As Long
End Type

Public Type PROPVARIANT
    vt As Integer
    wReserved1 As Integer
    wReserved2 As Integer
    wReserved3 As Integer
    vData As Long
    PadBytes As Long
End Type

Public Type STATSTG
    atime As Currency
    cbSize As Currency
    clsid As GUID
    ctime As Currency
    grfLocksSupported As LOCKTYPE
    grfMode As STGM
    grfStateBits As Long
    mtime As Currency
    pwcsName As Long
    reserved As Long
    eType As STGTY
End Type

' ----==== Ole32 API-Deklarationen ====----
Private Declare Function IIDFromString Lib "ole32.dll" ( _
                         ByVal lpsz As Long, _
                         ByRef lpIID As IID) As Long

Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" ( _
                         ByVal hGlobal As Long, _
                         ByVal fDeleteOnRelease As Long, _
                         ByRef ppstm As Any) As Long

' ----==== Oleaut32 API-Deklarationen ====----
Private Declare Function OleLoadPicture Lib "oleaut32.dll" ( _
                         ByVal lpstream As Long, _
                         ByVal lSize As Long, _
                         ByVal fRunmode As Long, _
                         ByRef riid As IID, _
                         ByRef lplpvObj As Any) As Long

' ----==== Shell32 API-Deklarationen ====----
Private Declare Function SHCreateItemFromParsingName Lib "shell32.dll" ( _
                         ByVal pszPath As Long, _
                         ByVal pbc As Long, _
                         ByRef riid As IID, _
                         ByRef pUnk As Long) As Long

Private Declare Function SHGetPropertyStoreFromParsingName Lib "shell32.dll" ( _
                         ByVal pszPath As Long, _
                         ByVal pbc As Long, _
                         ByVal flags As Long, _
                         ByRef riid As IID, _
                         ByRef ppv As Long) As Long

' ----==== Shlwapi API-Deklarationen ====----
Private Declare Function SHCreateStreamOnFileEx Lib "shlwapi.dll" ( _
                         ByVal pszFile As Long, _
                         ByVal grfMode As STGM, _
                         ByVal dwAttributes As Long, _
                         ByVal fCreate As Long, _
                         ByVal pstmTemplate As Long, _
                         ByRef ppstm As Long) As Long

' ----==== Propsys API-Deklarationen ====----
Private Declare Function PSGetPropertyKeyFromName Lib "propsys.dll" ( _
                         ByVal pszName As Long, _
                         ByRef propkey As PROPERTYKEY) As Long

' ----==== Konvertiert ein Bild und speichert es auf die Festplatte ====----
Public Function TranscodeImageToDisc(ByVal ImageFile As String, Optional ByVal _
    ConvertTo As TI_FLAGS = TI_BITMAP) As Boolean

    Dim bRet As Boolean
    Dim lWidth As Long
    Dim lHeight As Long
    Dim tIID As IID
    Dim tSize As SIZE
    Dim sOutImageFile As String
    Dim pImageFile As Long
    Dim psOutImageFile As Long
    Dim pIStream As Long
    Dim pIShellItem As Long
    Dim pIID_IShellItem As Long
    Dim IStream As clsIStream
    Dim IShellItem As clsIShellItem
    Dim ITranscodeImage As clsITranscodeImage

    bRet = False

    ' existiert die Datei
    If FileExists(ImageFile) = True Then

        ' Dimensionen des Bildes vom IPropertyStore ermitteln
        ' Hier kann auch eine andere Größe angegeben werden. Das Bild wird
        ' dann entsprechend proportional skaliert.
        tSize = GetImageDimension(ImageFile)

        ' IID_IShellItem -> Type IID
        pIID_IShellItem = StrPtr(IID_IShellItem)

        If IIDFromString(pIID_IShellItem, tIID) = S_OK Then

            ' ein IShellItem-Interface von Datei erstellen
            pImageFile = StrPtr(ImageFile)

            If SHCreateItemFromParsingName(pImageFile, 0&, tIID, pIShellItem) = S_OK Then

                ' Klasse für IShellItem initialisieren
                Set IShellItem = New clsIShellItem

                Call IShellItem.Initialize(pIShellItem)

                ' zu Bitmap konvertieren
                If ConvertTo = TI_BITMAP Then

                    ' Dateiname für die Ausgabe erstellen
                    sOutImageFile = Replace$(ImageFile, GetFileExtension(ImageFile), "bmp")

                Else ' zu JPEG konvertieren

                    ' Dateiname für die Ausgabe erstellen
                    sOutImageFile = Replace$(ImageFile, GetFileExtension(ImageFile), "jpg")

                End If

                ' FileStream für die Ausgabedatei erstellen -> IStream-Interface
                psOutImageFile = StrPtr(sOutImageFile)

                If SHCreateStreamOnFileEx(psOutImageFile, STGM_CREATE Or STGM_WRITE, 0&, 0&, _
                    0&, pIStream) = S_OK Then

                    ' Klasse für IStream initialisieren
                    Set IStream = New clsIStream

                    Call IStream.Initialize(pIStream)

                    ' ITranscodeImage-Interface erstellen
                    Set ITranscodeImage = New clsITranscodeImage

                    ' IShellItem konvertieren und in den FileStream schreiben
                    If ITranscodeImage.TranscodeImage(pIShellItem, tSize.cx, tSize.cy, _
                        ConvertTo, pIStream, lWidth, lHeight) = True Then

                        bRet = True

                    End If

                    ' Aufräumen
                    Set ITranscodeImage = Nothing

                    ' Aufräumen
                    Set IStream = Nothing

                End If

                ' Aufräumen
                Set IShellItem = Nothing

            End If

        End If

    End If

    TranscodeImageToDisc = bRet

End Function

' ----==== Konvertiert ein Bild und erstellt ein StdPicture ====----
Public Function TranscodeImageToPicture(ByVal ImageFile As String) As StdPicture

    Dim lWidth As Long
    Dim lHeight As Long
    Dim lStreamSize As Long
    Dim tIID As IID
    Dim tSize As SIZE
    Dim pImageFile As Long
    Dim pIStream As Long
    Dim pIShellItem As Long
    Dim pIID_IShellItem As Long
    Dim pIID_IPicture As Long
    Dim oPic As StdPicture
    Dim IPic As IPicture
    Dim IStream As clsIStream
    Dim IShellItem As clsIShellItem
    Dim ITranscodeImage As clsITranscodeImage

    ' existiert die Datei
    If FileExists(ImageFile) = True Then

        ' Dimensionen des Bildes vom IPropertyStore ermitteln
        ' Hier kann auch eine andere Größe angegeben werden. Das Bild wird
        ' dann entsprechend proportional skaliert.
        tSize = GetImageDimension(ImageFile)

        ' IID_IShellItem -> Type IID
        pIID_IShellItem = StrPtr(IID_IShellItem)

        If IIDFromString(pIID_IShellItem, tIID) = S_OK Then

            ' ein IShellItem-Interface von Datei erstellen
            pImageFile = StrPtr(ImageFile)

            If SHCreateItemFromParsingName(pImageFile, 0&, tIID, pIShellItem) = S_OK Then

                ' Klasse für IShellItem initialisieren
                Set IShellItem = New clsIShellItem

                Call IShellItem.Initialize(pIShellItem)

                ' einen IStream im Speicher erstellen
                If CreateStreamOnHGlobal(0&, True, pIStream) = S_OK Then

                    ' Klasse für IStream initialisieren
                    Set IStream = New clsIStream

                    Call IStream.Initialize(pIStream)

                    ' ITranscodeImage-Interface erstellen
                    Set ITranscodeImage = New clsITranscodeImage

                    ' IShellItem konvertieren und in den IStream schreiben
                    If ITranscodeImage.TranscodeImage(pIShellItem, tSize.cx, tSize.cy, _
                        TI_BITMAP, pIStream, lWidth, lHeight) = True Then

                        ' IID_IPicture -> Type IID
                        pIID_IPicture = StrPtr(IID_IPicture)

                        If IIDFromString(pIID_IPicture, tIID) = S_OK Then

                            ' Größe des IStream ermitteln
                            lStreamSize = CLng(IStream.Seek_Stream(0, STREAM_SEEK_END))

                            ' zurück an den Anfang des IStreams
                            Call IStream.Seek_Stream(0, STREAM_SEEK_SET)

                            ' IPicture vom IStream erstellen
                            If OleLoadPicture(pIStream, lStreamSize, False, tIID, IPic) = S_OK Then

                                ' IPicture -> StdPicture
                                Set oPic = IPic

                                ' Aufräumen
                                Set IPic = Nothing

                            End If
                        End If
                    End If

                    ' Aufräumen
                    Set ITranscodeImage = Nothing

                    ' Aufräumen
                    Set IStream = Nothing

                End If

                ' Aufräumen
                Set IShellItem = Nothing

            End If
        End If
    End If

    Set TranscodeImageToPicture = oPic

End Function

' ----==== Ermitteln der Bilddimensionen ====----
Private Function GetImageDimension(ByVal ImageFile As String) As SIZE

    Dim psIID As Long
    Dim pImageFile As Long
    Dim pImageWidth As Long
    Dim pImageHeight As Long
    Dim pIPropertyStore As Long
    Dim tIID As IID
    Dim tSize As SIZE
    Dim tPropImgWidth As PROPERTYKEY
    Dim tPropImgHeight As PROPERTYKEY
    Dim tPropVarWidth As PROPVARIANT
    Dim tPropVarHeight As PROPVARIANT
    Dim IPropertyStore As clsIPropertyStore

    ' existiert die Datei
    If FileExists(ImageFile) = True Then

        ' Canonical-Name -> PROPERTYKEY
        pImageWidth = StrPtr(ImageWidth)

        If PSGetPropertyKeyFromName(pImageWidth, tPropImgWidth) = S_OK Then

            ' Canonical-Name -> PROPERTYKEY
            pImageHeight = StrPtr(ImageHeight)

            If PSGetPropertyKeyFromName(pImageHeight, tPropImgHeight) = S_OK Then

                ' IID_IPropertyStore -> Type IID
                psIID = StrPtr(IID_IPropertyStore)

                If IIDFromString(psIID, tIID) = S_OK Then

                    ' IPropertyStore-Interface von Datei erstellen
                    pImageFile = StrPtr(ImageFile)

                    If SHGetPropertyStoreFromParsingName(pImageFile, 0&, GPS_DEFAULT, tIID, _
                        pIPropertyStore) = S_OK Then

                        ' Klasse für IPropertyStore initialisieren
                        Set IPropertyStore = New clsIPropertyStore

                        Call IPropertyStore.Initialize(pIPropertyStore)

                        ' PROPERTYKEY vom IPropertyStore auslesen -> PROPVARIANT
                        tPropVarWidth = IPropertyStore.GetValue(tPropImgWidth)
                        tPropVarHeight = IPropertyStore.GetValue(tPropImgHeight)

                        ' Für System.Image.HorizontalSize und System.Image.VerticalSize
                        ' ist der Variant-Type = VT_UI4
                        If tPropVarWidth.vt = VT_UI4 Then
                            If tPropVarHeight.vt = VT_UI4 Then

                                ' Werte stehe dann in PROPVARIANT.vData -> Type Size
                                tSize.cx = tPropVarWidth.vData
                                tSize.cy = tPropVarHeight.vData

                            End If
                        End If

                        ' Aufräumen
                        Set IPropertyStore = Nothing

                    End If
                End If
            End If
        End If
    End If

    GetImageDimension = tSize

End Function

' ----==== Existiert die Datei ====----
Private Function FileExists(FileName As String) As Boolean

    On Error Resume Next

    Dim ret As Long

    ret = Len(Dir$(FileName))

    If Err Or ret = 0 Then FileExists = False Else FileExists = True

End Function

' ----==== Dateierweiterung ermitteln ====----
Private Function GetFileExtension(ByVal ImageFile As String) As String

    GetFileExtension = Mid$(ImageFile, InStrRev(ImageFile, ".") + 1, Len(ImageFile))

End Function

' --- Ende Modul "modITranscodeImage" alias modITranscodeImage.bas ---

' ----- Anfang Klasse "clsIStream" alias clsIStream.cls  -----

' Autor: F. Schüler (frank@activevb.de)
' Datum: 11/2017

' IUnknown interface
' https://docs.microsoft.com/en-us/windows/desktop/api/unknwn/nn-unknwn-iunknown

' ISequentialStream interface
' https://docs.microsoft.com/de-de/windows/desktop/api/objidl/nn-objidl-isequentialstream

' IStream interface
' https://docs.microsoft.com/en-us/windows/desktop/api/objidl/nn-objidl-istream

Option Explicit

' ----==== Const ====----
Private Const ERR_BASE As Long = 40670
Private Const CLSID_Stream As String = ""
Private Const IID_IStream As String = "{0000000C-0000-0000-C000-000000000046}"

Private Enum E_vtbOffsets

    ' /*** IUnknown methods ***/
    vtb_QueryInterface
    vtb_AddRef
    vtb_Release

    ' /*** ISequentialStream methods ***/
    vtb_Read
    vtb_Write

    ' /*** IStream methods ***/
    vtb_Seek
    vtb_SetSize
    vtb_CopyTo
    vtb_Commit
    vtb_Revert
    vtb_LockRegion
    vtb_UnlockRegion
    vtb_Stat
    vtb_Clone
End Enum

' ----==== Variablen ====----
Private m_initialized As Boolean
Private m_Interface As Interface_Data

Public Function Read_Stream(ByRef pv() As Byte, ByVal cb As Long) As Long

    Dim lRet As Long
    Dim cbRead As Long
    Dim ppv As Long
    Dim pcbRead As Long

    ppv = VarPtr(pv(0))
    pcbRead = VarPtr(cbRead)

    If x_OleInvoke(vtb_Read, ppv, cb, pcbRead) Then

        lRet = cbRead

    End If

    Read_Stream = lRet

End Function

Public Function Write_Stream(ByRef pv() As Byte, ByVal cb As Long) As Long

    Dim lRet As Long
    Dim ppv As Long
    Dim cbWritten As Long
    Dim pcbWritten As Long

    ppv = VarPtr(pv(0))
    pcbWritten = VarPtr(cbWritten)

    If x_OleInvoke(vtb_Write, ppv, cb, pcbWritten) Then

        lRet = cbWritten

    End If

    Write_Stream = lRet

End Function

Public Function Seek_Stream(ByVal dlibMove As Currency, ByVal dwOrigin As _
    STREAM_SEEK) As Currency

    Dim cRet As Currency
    Dim libNewPosition As Currency
    Dim plibNewPosition As Long

    dlibMove = dlibMove / 10000
    plibNewPosition = VarPtr(libNewPosition)

    If x_OleInvoke(vtb_Seek, dlibMove, dwOrigin, plibNewPosition) Then

        cRet = libNewPosition * 10000

    End If

    Seek_Stream = cRet

End Function

Public Function SetSize(ByVal libNewSize As Currency) As Boolean

    Dim bRet As Boolean

    bRet = False
    libNewSize = libNewSize / 10000

    If x_OleInvoke(vtb_SetSize, libNewSize) Then

        bRet = True

    End If

    SetSize = bRet

End Function

Public Function CopyTo(ByVal pstm As Long, ByVal cb As Currency, ByRef _
    pcbRead As Currency, ByRef pcbWritten As Currency) As Boolean

    Dim bRet As Boolean
    Dim ppcbRead As Long
    Dim ppcbWritten As Long

    bRet = False
    cb = cb / 10000
    ppcbRead = VarPtr(pcbRead)
    ppcbWritten = VarPtr(pcbWritten)

    If x_OleInvoke(vtb_CopyTo, pstm, cb, ppcbRead, ppcbWritten) Then

        bRet = True

    End If

    CopyTo = bRet

End Function

Public Function Commit(Optional ByVal grfCommitFlags As STGC = STGC_DEFAULT) As _
    Boolean

    Dim bRet As Boolean

    bRet = False

    If x_OleInvoke(vtb_Commit, grfCommitFlags) Then

        bRet = True

    End If

    Commit = bRet

End Function

Public Function Revert() As Boolean

    Dim bRet As Boolean

    bRet = False

    If x_OleInvoke(vtb_Revert) Then

        bRet = True

    End If

    Revert = bRet

End Function

Public Function LockRegion(ByVal libOffset As Currency, ByVal cb As Currency, _
    ByVal dwLockType As LOCKTYPE) As Boolean

    Dim bRet As Boolean

    bRet = False
    cb = cb / 10000
    libOffset = libOffset / 10000

    If x_OleInvoke(vtb_LockRegion, libOffset, cb, dwLockType) Then

        bRet = True

    End If

    LockRegion = bRet

End Function

Public Function UnlockRegion(ByVal libOffset As Currency, ByVal cb As Currency, _
    ByVal dwLockType As LOCKTYPE) As Boolean

    Dim bRet As Boolean

    bRet = False
    cb = cb / 10000
    libOffset = libOffset / 10000

    If x_OleInvoke(vtb_UnlockRegion, libOffset, cb, dwLockType) Then

        bRet = True

    End If

    UnlockRegion = bRet

End Function

Friend Function Stat(ByRef pstatstg As STATSTG, Optional ByVal grfStatFlag As _
    STATFLAG = STATFLAG_DEFAULT) As Boolean

    Dim bRet As Boolean

    bRet = False

    If x_OleInvoke(vtb_Stat) Then

        bRet = True

    End If

    Stat = bRet

End Function

Public Function Clone() As Long

    Dim pRet As Long
    Dim ppstm As Long
    Dim pppstm As Long

    pppstm = VarPtr(ppstm)

    If x_OleInvoke(vtb_Clone, pppstm) Then

        pRet = ppstm

    End If

    Clone = pRet

End Function

' ----==== Helper Func ====----
Public Sub Initialize(ByVal pInterface As Long)

    m_Interface.owner = ObjPtr(Me)
    m_Interface.RaiseErrors = False
    m_Interface.ifc = pInterface
    m_initialized = True

End Sub

Private Sub Class_Terminate()

    Call ReleaseInterface(m_Interface)

End Sub

Public Sub RaiseError(Optional ByVal Raise As Boolean = False)

    m_Interface.RaiseErrors = Raise

End Sub

Private Function x_OleInvoke(ByVal vtb As E_vtbOffsets, ParamArray var()) As Boolean

    Dim ret As Long

    If Not m_initialized Then

        Call InterfaceError(m_Interface, ecd_OleInvoke)

    Else

        x_OleInvoke = oleInvoke(m_Interface, vtb, ret, True, var)

    End If

End Function

Public Sub x_RaiseError()

    With m_Interface

        If .ecd Then Err.Raise ERR_BASE + .ecd, App.EXEName & ".clsIStream", .etx

        .ecd = 0
        .etx = vbNullString

    End With

End Sub

' ------ Ende Klasse "clsIStream" alias clsIStream.cls  ------

' --- Anfang Klasse "clsIPropertyStore" alias clsIPropertyStore.cls  ---

' Autor: F. Schüler (frank@activevb.de)
' Datum: 09/2018

' IUnknown interface
' https://docs.microsoft.com/en-us/windows/desktop/api/unknwn/nn-unknwn-iunknown

' IPropertyStore interface
' https://msdn.microsoft.com/de-de/library/windows/desktop/bb761474(v=vs.85).aspx

Option Explicit

' ----==== Const ====----
Private Const ERR_BASE As Long = 40670
Private Const CLSID_PropertyStore As String = ""
Private Const IID_IPropertyStore As String = "{886D8EEB-8CF2-4446-8D02-CDBA1DBDCF99}"

Private Enum E_vtbOffsets

    ' /*** IUnknown methods ***/
    vtb_QueryInterface
    vtb_AddRef
    vtb_Release

    ' /*** IPropertyStore methods ***/
    vtb_GetCount
    vtb_GetAt
    vtb_GetValue
    vtb_SetValue
    vtb_Commit
End Enum

' ----==== Variablen ====----
Private m_initialized As Boolean
Private m_Interface As Interface_Data

Public Function GetCount() As Long

    Dim lRet As Long
    Dim cProps As Long
    Dim pcProps As Long

    pcProps = VarPtr(cProps)

    If x_OleInvoke(vtb_GetCount, pcProps) Then

        lRet = cProps

    End If

    GetCount = lRet

End Function

Friend Function GetAt(ByVal iProp As Long) As PROPERTYKEY

    Dim tRet As PROPERTYKEY
    Dim tPROPERTYKEY As PROPERTYKEY
    Dim ptPROPERTYKEY As Long

    ptPROPERTYKEY = VarPtr(tPROPERTYKEY)

    If x_OleInvoke(vtb_GetAt, iProp, ptPROPERTYKEY) Then

        tRet = tPROPERTYKEY

    End If

    GetAt = tRet

End Function

Friend Function GetValue(ByRef key As PROPERTYKEY) As PROPVARIANT

    Dim tRet As PROPVARIANT
    Dim pkey As Long
    Dim tPROPVARIANT As PROPVARIANT
    Dim ptPROPVARIANT As Long

    pkey = VarPtr(key)
    ptPROPVARIANT = VarPtr(tPROPVARIANT)

    If x_OleInvoke(vtb_GetValue, pkey, ptPROPVARIANT) Then

        tRet = tPROPVARIANT

    End If

    GetValue = tRet

End Function

Friend Function SetValue(ByRef key As PROPERTYKEY, ByRef propvar As PROPVARIANT) As Boolean

    Dim bRet As Boolean
    Dim pkey As Long
    Dim ppropvar As Long

    pkey = VarPtr(key)
    ppropvar = VarPtr(propvar)

    If x_OleInvoke(vtb_SetValue, pkey, ppropvar) Then

        bRet = True

    End If

    SetValue = bRet

End Function

Public Function Commit() As Boolean

    Dim bRet As Boolean

    If x_OleInvoke(vtb_Commit) Then

        bRet = True

    End If

    Commit = bRet

End Function

' ----==== Helper Func ====----
Public Sub Initialize(ByVal pInterface As Long)

    m_Interface.owner = ObjPtr(Me)
    m_Interface.RaiseErrors = False
    m_Interface.ifc = pInterface
    m_initialized = True

End Sub

Private Sub Class_Terminate()

    Call ReleaseInterface(m_Interface)

End Sub

Public Sub RaiseError(Optional ByVal Raise As Boolean = False)

    m_Interface.RaiseErrors = Raise

End Sub

Private Function x_OleInvoke(ByVal vtb As E_vtbOffsets, ParamArray var()) As Boolean

    Dim ret As Long

    If Not m_initialized Then

        Call InterfaceError(m_Interface, ecd_OleInvoke)

    Else

        x_OleInvoke = oleInvoke(m_Interface, vtb, ret, True, var)

    End If

End Function

Public Sub x_RaiseError()

    With m_Interface

        If .ecd Then Err.Raise ERR_BASE + .ecd, App.EXEName & ".clsIPropertyStore", .etx

        .ecd = 0
        .etx = vbNullString

    End With

End Sub

' --- Ende Klasse "clsIPropertyStore" alias clsIPropertyStore.cls  ---

' -------------- Ende Projektdatei Project1.vbp --------------

	

Diskussion  

Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.

Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.