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