Imports System
Imports System.Runtime.InteropServices
Imports System.Drawing
Imports System.Windows.Forms
Imports stdole
<System.Runtime.InteropServices.ComVisible(False)> _
Friend Class PictureWrapper
Inherits AxHost
Public Sub New()
MyBase.New("59EE46BA-677D-4d20-BF10-8D8067CB8B33")
End Sub
'Konvertierung eines System.Drawing.Image nach IPictureDisp (Type = Bitmap, HBITMAP)
Public Shared Shadows Function ImageToIPictureDisp(ByVal oImage As System.Drawing.Image) As IPictureDisp
Dim oResult As IPictureDisp
oResult = DirectCast(AxHost.GetIPictureDispFromPicture(oImage), IPictureDisp)
Return oResult
End Function
'Konvertierung eines System.Drawing.Icon nach IPictureDisp (Type = Icon, HICON)
Public Shared Shadows Function IconToIPictureDisp(ByVal oIcon As System.Drawing.Icon) As IPictureDisp
Dim oIml As New System.Windows.Forms.ImageList
Return BitmapToIcon.ConvertIconToIPictureDisp(oIcon)
End Function
'Klasse zum Umwandeln eines System.Drawing.Icon nach HICON
Private Class BitmapToIcon
Private Const ILC_COLORDDB As Integer = &HFE
Private Const ILC_COLOR As Integer = &H0
Private Const ILC_COLOR4 As Integer = &H4
Private Const ILC_COLOR8 As Integer = &H8
Private Const ILC_COLOR16 As Integer = &H10
Private Const ILC_COLOR24 As Integer = &H18
Private Const ILC_COLOR32 As Integer = &H20
'Um ein ICON-Handle zu erzeugen, muss der Weg über die ImageList von Windows gegangen werden.
<DllImport("comctl32.dll")> Private Shared Function ImageList_Add(ByVal himl As IntPtr, ByVal hbmImage As IntPtr, ByVal hbmMask As IntPtr) As Integer
End Function
<DllImport("comctl32.dll")> Private Shared Function ImageList_Create(ByVal cx As Integer, ByVal cy As Integer, ByVal flags As Integer, ByVal cInitial As Integer, ByVal cGrow As Integer) As IntPtr
End Function
<DllImport("comctl32.dll")> Private Shared Function ImageList_Destroy(ByVal himl As IntPtr) As Boolean
End Function
<DllImport("comctl32.dll")> Private Shared Function ImageList_GetIcon(ByVal himl As IntPtr, ByVal iIndex As Int32, ByVal iFlags As UInt32) As IntPtr
End Function
<DllImport("oleaut32.dll", EntryPoint:="OleCreatePictureIndirect", ExactSpelling:=True, PreserveSig:=False)> _
Private Shared Function OleCreateIPictureIndirect(<MarshalAs(UnmanagedType.AsAny)> ByVal pictdesc As Object, ByRef iid As System.Guid, ByVal fOwn As Boolean) As IPictureDisp
End Function
<StructLayout(LayoutKind.Sequential)> Private Class PICTDESC
Public cbSizeOfStruct As Integer
Public picType As Integer
Public union1 As IntPtr
Public union2 As Integer
Public union3 As Integer
Public Shared Function CreateIconPICTDESC(ByVal hicon As IntPtr) As PICTDESC
Dim oPictdesc As New PICTDESC
oPictdesc.cbSizeOfStruct = 12
oPictdesc.picType = 3 ' Quelle HICON
oPictdesc.union1 = hicon ' Handle auf das Icon
Return oPictdesc
End Function
Public Sub New()
End Sub
End Class
Public Shared Function ConvertIconToIPictureDisp(ByVal oIcon As System.Drawing.Icon) As IPictureDisp
Dim Result As IPictureDisp = Nothing
'GUID für IPictureDisp
Dim oIGuid As System.Guid = New System.Guid("7BF80980-BF32-101A-8BBB-00AA00300CAB")
Dim oStruct As PICTDESC = Nothing
Dim iTempResult As Integer = 0
Dim hImageList As IntPtr = Nothing
Dim iColorDepth As Integer = -1
Dim hIcon As IntPtr = Nothing
Dim oTempBMP As System.Drawing.Bitmap
Try
'Zunächst Umwandlung des System.Drawing.Icons nach IPictureDisp(HBITMAP)
oTempBMP = oIcon.ToBitmap
'Pixelformat auf Api-Konstante mappen
Select Case oTempBMP.PixelFormat
Case Imaging.PixelFormat.Format4bppIndexed
iColorDepth = ILC_COLOR4
Case Imaging.PixelFormat.Format8bppIndexed
iColorDepth = ILC_COLOR8
Case Imaging.PixelFormat.Format16bppArgb1555, _
Imaging.PixelFormat.Format16bppGrayScale, _
Imaging.PixelFormat.Format16bppRgb555, _
Imaging.PixelFormat.Format16bppRgb565
iColorDepth = ILC_COLOR16
Case Imaging.PixelFormat.Format24bppRgb
iColorDepth = ILC_COLOR24
Case Imaging.PixelFormat.Format32bppArgb, _
Imaging.PixelFormat.Format32bppPArgb, _
Imaging.PixelFormat.Format32bppRgb
iColorDepth = ILC_COLOR32
Case Else
iColorDepth = ILC_COLOR8
End Select
'Imagelist anlegen
hImageList = ImageList_Create(oIcon.Width, oIcon.Height, iColorDepth, 1, 1)
'Hinzufügen des des umgewandelten Bildes in die ImageList
iTempResult = ImageList_Add(hImageList, New IntPtr(PictureWrapper.ImageToIPictureDisp(oTempBMP).Handle), New IntPtr(0))
'Abrufen des Bitmaps als HICON
hIcon = ImageList_GetIcon(hImageList, 0, 0)
'Kapslung des HICON in PICTDESC
oStruct = PICTDESC.CreateIconPICTDESC(hIcon)
'Generierung eines IPictureDisp aus HICON
Result = OleCreateIPictureIndirect(DirectCast(oStruct, Object), oIGuid, True)
'ImageList wieder löschen
ImageList_Destroy(hImageList)
Catch ex As Exception
End Try
Return Result
End Function
End Class
End Class