Attribute VB_Name = "modICON"
Option Explicit
'
'
'=============================================================================================================
'
' modICON Module
' --------------
'
' Created By  : Kevin Wilson
'               http://www.TheVBZone.com   ( The VB Zone )
'               http://www.TheVBZone.net   ( The VB Zone .net )
'
' Last Update : May 17, 2000
'
' VB Versions : 5.0 / 6.0
'
' Requires    : ImageList Control (from Microsoft Windows Common Controls 5 or 6) OLE Automation (reference to
'               STDOLE2.TLB or OLEPRO32.DLL)
'
' Description : This module makes it easy to save any kind of picture as a standard Windows icon (.ICO) file.
'               This module allows you to specify the transparent / mask color of the icon to be created, and
'               will allow you to make an icon at any dimentions... not just 16x16 or 32x32.  The icon will be
'               created to the same size as the picture to save.
'
' WARNING     : If you try to make an icon that is too big, you may get an "Out Of Memory" error.
'
' Example Use :
'
'   If SaveICO("C:\Test.ico", Me.Icon, ImageList1, 0, True, &H800000) = False Then
'     MsgBox "An error occured while saving the icon to file.", vbOKOnly + vbExclamation
'   End If
'
'=============================================================================================================
'
' LEGAL:
'
' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit
' given where credit is due.  Also, it is not required, but it would be appreciated if you would mention
' somewhere in your compiled program that that your program makes use of code written and distributed by
' Kevin Wilson (www.TheVBZone.com).  Feel free to link to this code via your web site or articles.
'
' You may NOT take this code and pass it off as your own.  You may NOT distribute this code on your own server
' or web site.  You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products,
' utilities, or applications that directly compete with products, utilities, and applications created by Kevin
' Wilson, TheVBZone.com, or Wilson Media.  You may NOT take this code and sell it for profit without first
' obtaining the written consent of the author Kevin Wilson.
'
' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without
' warning or notice.  Copyright© by Kevin Wilson.  All rights reserved.
'
'=============================================================================================================


Public Function SaveICO(ByVal FilePath As String, ByVal ThePicture As StdPicture, ByRef Temp_ImgageList As ImageList, ByVal BackColor As Long, Optional ByVal UseMask As Boolean = False, Optional ByVal MaskColor As Long = 0, Optional ByVal PromptToOverwrite As Boolean = True) As Boolean
On Error GoTo ErrorTrap
  
  Dim LI As ListImage
  Dim ThePic As StdPicture
  Dim MyAnswer As VbMsgBoxResult
  
  ' Check if the information is valid
  If FilePath = "" Then
    MsgBox "Invalid file save path specified.", vbOKOnly + vbExclamation, "  Error"
    Exit Function
  ElseIf Dir(FilePath) <> "" Then
    If PromptToOverwrite = True Then
      MyAnswer = MsgBox(FilePath & Chr(13) & "This file already exists." & Chr(13) & Chr(13) & "Replace existing file?", vbYesNo + vbExclamation, "  Confirm File Overwrite")
    Else
      MyAnswer = vbYes
    End If
    If MyAnswer <> vbYes Then
      Exit Function
    End If
  ElseIf ThePicture = 0 Then
    MsgBox "Invalid picture specified to save as icon,", vbOKOnly + vbExclamation, "  Error"
    Exit Function
  End If
  
  ' Delete any pre-existing file
  Kill FilePath
  
  ' If the picture is already an Icon, save it out and exit
  If ThePicture.Type = vbPicTypeIcon Then
    SavePicture ThePicture, FilePath
    GoTo CleanUp
  End If
  
  ' Setup the ImageList control
  Temp_ImgageList.ListImages.Clear
  Temp_ImgageList.ImageHeight = ThePicture.Height / Screen.TwipsPerPixelY
  Temp_ImgageList.ImageWidth = ThePicture.Width / Screen.TwipsPerPixelX
  Temp_ImgageList.BackColor = BackColor
  Temp_ImgageList.MaskColor = MaskColor
  Temp_ImgageList.UseMaskColor = UseMask
  
  ' Set the picture
  Set LI = Temp_ImgageList.ListImages.Add(, , ThePicture)
  
  ' Extract the picture as an icon file
  Set ThePic = LI.ExtractIcon
  If ThePic = 0 Then
    Exit Function
  End If
  
  ' Save the picture
  SavePicture ThePic, FilePath
  SaveICO = True
  
CleanUp:
  
  ' Clean Up
  Set ThePic = Nothing
  Set LI = Nothing
  
  Exit Function
  
ErrorTrap:
  
  If Err.Number = 0 Then      ' No Error
    Resume Next
  ElseIf Err.Number = 20 Then ' Resume Without Error
    Resume Next
  Else                        ' Other Error
    MsgBox Err.Source & " encountered the following error:" & Chr(13) & Chr(13) & "Error Number = " & CStr(Err.Number) & Chr(13) & "Error Description = " & Err.Description, vbOKOnly + vbExclamation, "  Error  -  " & Err.Description
    Err.Clear
    SaveICO = False
    Resume CleanUp
  End If
  
End Function