Die Community zu .NET und Classic VB.

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

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

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CLSIDFromString, CoCreateInstance, CoTaskMemFree, CreateStreamOnHGlobal, DispCallFunc, IIDFromString, OleLoadPicture, PSGetPropertyKeyFromName, RtlMoveMemory, SHCreateItemFromParsingName, SHCreateStreamOnFileEx, SHGetPropertyStoreFromParsingName, lstrlenW

Download: Download des Beispielprojektes [400,06 KB]

'Dieser Quellcode 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: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Schaltfläche "Command1"
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ütztes 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

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}"

Private Enum E_vtbOffsets
    '/*** IUnknown methods ***/
    vtb_QueryInterface
    vtb_AddRef
    vtb_Release
    '/*** IShellItem methods ***/
    vtb_BindToHandler
    vtb_GetParent
    vtb_GetDisplayName
    vtb_GetAttributes
    vtb_Compare
End Enum

' ----==== 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

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

    m_Interface.owner = ObjPtr(Me)
    m_Interface.RaiseErrors = True
    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 = True)

    m_Interface.RaiseErrors = Raise

End Sub

Private Function x_OleInvoke(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

Private Sub x_RaiseError()

    With m_Interface

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

        .ecd = 0
        .etx = ""

    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

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 = True

    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 = True)

    m_Interface.RaiseErrors = Raise

End Sub

Private Function x_OleInvoke(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

Private 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
    ecd As Interface_errCodes
    etx As String
    owner As Long
    RaiseErrors As Boolean
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
Private ole_var(10) As Variant
Private ole_chrptr As Long
Private ole_chr As String

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

    Dim lLen As Long
    Dim bBuffer() As Byte

    lLen = lstrlenW(lpStrPointer) * 2 - 1

    If lLen > 0 Then

        ReDim bBuffer(lLen)

        Call RtlMoveMemory(bBuffer(0), ByVal lpStrPointer, lLen)

        Call CoTaskMemFree(lpStrPointer)

        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

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

    If Not oleConvert(cid, car()) Then

        Call InterfaceError(Interface, ecd_OleConvert)

    ElseIf Not oleConvert(IID, iar()) Then

        Call InterfaceError(Interface, ecd_OleConvert)

    ElseIf CoCreateInstance(car(0), 0&, CLSCTX_INPROC, iar(0), Interface.ifc) <> _
        S_OK Then

        Call InterfaceError(Interface, ecd_InitInterface)

    Else

        InitInterface = True

    End If

End Function

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

    Dim lRet As Long

    If Interface.ifc Then

        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

        If ecd Then .ecd = ecd

        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

        ElseIf Not .RaiseErrors Then

        ElseIf .owner Then

            Call RtlMoveMemory(dmy, .owner, 4)

            Set obj = dmy

            Call RtlMoveMemory(dmy, 0&, 4)

            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

    If Interface.ifc = 0 Then

        Call InterfaceError(Interface, ecd_InvalidCall)

    Else

        If UBound(arr) >= 0 Then

            var = arr

            If IsArray(var) Then var = var(0)

            For lpc = 0 To UBound(var)

                ole_typ(lpc) = VarType(var(lpc))
                ole_var(lpc) = var(lpc)
                ole_ptr(lpc) = VarPtr(ole_var(lpc))

            Next

        End If

        Call DispCallFunc(Interface.ifc, cmd * 4, CC_STDCALL, VarType(ret), lpc, _
            ole_typ(0), ole_ptr(0), ret)

        oleInvoke = True

        If Not chk Then

        ElseIf VarType(ret) <> vbLong Then

        ElseIf ret <> S_OK Then

            Call InterfaceError(Interface, ecd_OleInvoke)

            oleInvoke = False

        End If

        If ole_chrptr Then

            lpc = lstrlenW(ole_chrptr)
            ole_chr = Space(lpc)

            Call RtlMoveMemory(ByVal StrPtr(ole_chr), ByVal ole_chrptr, lpc * 2)
            Call CoTaskMemFree(ole_chrptr)

            ole_chrptr = 0

        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 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
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
    Type 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

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 = True
    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 = True)
    
    m_Interface.RaiseErrors = Raise
    
End Sub

Private Function x_OleInvoke(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

Private 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

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 = True
    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 = True)

    m_Interface.RaiseErrors = Raise

End Sub

Private Function x_OleInvoke(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

Private 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 --------------