Imports System
Imports System.Runtime.InteropServices
 
Public Class BitmapToIcon
 
    <DllImport("user32.dll")> _
    Private Shared Function DestroyIcon(ByVal handle As System.IntPtr) As _
    Boolean
    End Function
 
 
    ''' <summary>Bitmap in ein 16*16 /32*32 Icon konvertieren</summary>
    ''' <param name="bmp">Bitmap, die in ein Icon konvertiert werden soll</param>
    ''' <param name="iconpath">Pfad des zu erstellenden Icons</param>
    ''' <param name="AllowOverwrite">Überschreiben des Icon erlauben?</param>
    ''' <param name="Iconsize">Größe des Icons (Pixel)</param>
    ''' <returns>Alles OK?</returns>
    Public Shared Function ConvertBitmapToIcon _
                       (ByVal bmp As Bitmap, ByVal iconpath As String, _
                        Optional ByVal AllowOverwrite As Boolean = False, _
                        Optional ByVal Iconsize As Integer = 16) As Boolean
 
        If bmp Is Nothing Then Return False
 
        Dim icondir As String = IO.Path.GetDirectoryName(iconpath)
        If Not IO.Directory.Exists(icondir) Then Return False
 
        If Not Iconsize = 32 Then Iconsize = 16
 
        Try
            If Not AllowOverwrite Then
                If IO.File.Exists(iconpath) Then Return False
            End If
 
            Using ibmp As New Bitmap(iconsize, iconsize), _
                gr As Graphics = Graphics.FromImage(ibmp), _
                fs As New IO.FileStream(iconpath, _
                        IO.FileMode.OpenOrCreate, _
                        IO.FileAccess.Write, IO.FileShare.None)
 
 
                'Anpassung der Bitmap Größe 
                'unter Beachtung des Seitenverhältnisses
                Dim w As Integer = Iconsize
                Dim h As Integer = CInt(bmp.Height * w / bmp.Width)
                If h > Iconsize Then
                    h = Iconsize
                    w = CInt(bmp.Width * h / bmp.Height)
                End If
 
                Dim destrect As New Rectangle _
                     ((Iconsize - w) \ 2, (Iconsize - h) \ 2, w, h)
                Dim srcrect As New Rectangle(0, 0, bmp.Width, bmp.Height)
 
                'Hintergrundfarbe des Icon
                gr.Clear(Drawing.Color.White)
 
                'Bitmap in Icon-Größe zeichnen
                gr.DrawImage(bmp, destrect, srcrect, Drawing.GraphicsUnit.Pixel)
 
                'Icon aus dem Handle des gezeichneten Bitmap erstellen
                Dim ico As Icon = Icon.FromHandle(ibmp.GetHicon())
 
                'Icondatei erstellen
                ico.Save(fs)
 
                'Ressourcen des Icon freigeben !!!
                DestroyIcon(ico.Handle)
 
                Return True
            End Using
        Catch
            Return False
        End Try
    End Function
End Class