Tipp-Upload: VB 5/6 0456: Alle von Windows unterstütze Bildformate in ein Bitmap oder JPEG konvertieren oder in eine PictureBox laden.
von Frank Schüler
Ü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.
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 |
Verwendete API-Aufrufe: CLSIDFromString, CoCreateInstance, CoTaskMemFree, CreateStreamOnHGlobal, DispCallFunc, IIDFromString, OleLoadPicture, PSGetPropertyKeyFromName, RtlMoveMemory, SHCreateItemFromParsingName, SHCreateStreamOnFileEx, SHGetPropertyStoreFromParsingName, lstrlenW |
Download: |
' 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.