Esta es una función que sirve para dibujar un icono con la mayor calidad al tamaño más aproximado a un rectángulo sin que se deforme el icono.
Es decir si tenes un picture de 60 x 60 pixels la función busca el icono de mayor calidad y con el tamaño más aproximado o sea en este caso podria ser de 48 x 48, si el icono no tiene estas medidas deberia pasar a 32 x 32 y asi hasta encontrar el adecuado.
Esta función puede servir para hacer una vista previa de un icono o el uso que ustedes le puedan llegar a encontrar.
Para probar pongan un Picture1 un Commondialog1 y un Command1
Option Explicit
' --------------------------------------------------------------------------------
' Autor: Leandro I. Ascierto
' Web: www.leandroascierto.com.ar
' Fecha: Martes 13 de Octubre de 2009
' --------------------------------------------------------------------------------
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef pDst As Any, ByRef pSrc As Any, ByVal ByteLen As Long)
Private Declare Function CreateIconFromResourceEx Lib "user32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal Flags As Long) As Long
Private Declare Function DrawIconEx Lib "user32.dll" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function DestroyIcon Lib "user32.dll" (ByVal hIcon As Long) As Long
Private Type RECTF
nLeft As Single
nTop As Single
nWidth As Single
nHeight As Single
End Type
Private Type IconHeader
ihReserved As Integer
ihType As Integer
ihCount As Integer
End Type
Private Type IconEntry
ieWidth As Byte
ieHeight As Byte
ieColorCount As Byte
ieReserved As Byte
iePlanes As Integer
ieBitCount As Integer
ieBytesInRes As Long
ieImageOffset As Long
End Type
Const DI_MASK = &H1
Const DI_IMAGE = &H2
Const DI_NORMAL = DI_MASK Or DI_IMAGE
Private Const IconVersion As Long = &H30000
Private Function DrawIconToRect(ByVal hdc As Long, ByVal IcoFileName As String, RF As RECTF) As Boolean
On Error GoTo ErrOut
Dim tIconHeader As IconHeader
Dim tIconEntry() As IconEntry
Dim bytIcoData() As Byte
Dim FF As Integer
Dim MaxBitCount As Long
Dim MaxSize As Long
Dim Aproximate As Long
Dim IconID As Long
Dim i As Long
Dim hIcon As Long
If Dir(IcoFileName) <> "" Then
FF = FreeFile
Open IcoFileName For Binary Access Read As FF
ReDim bytIcoData(LOF(FF) - 1)
Get #FF, , bytIcoData()
Close #FF
Call CopyMemory(tIconHeader, bytIcoData(0), Len(tIconHeader))
If tIconHeader.ihCount >= 1 Then
ReDim tIconEntry(tIconHeader.ihCount - 1)
Call CopyMemory(tIconEntry(0), bytIcoData(Len(tIconHeader)), Len(tIconEntry(0)) * tIconHeader.ihCount)
IconID = -1
For i = 0 To tIconHeader.ihCount - 1
If tIconEntry(i).ieBitCount > MaxBitCount Then MaxBitCount = tIconEntry(i).ieBitCount
Next
Debug.Print MaxBitCount
For i = 0 To tIconHeader.ihCount - 1
If MaxBitCount = tIconEntry(i).ieBitCount Then
MaxSize = CLng(tIconEntry(i).ieWidth) + CLng(tIconEntry(i).ieHeight)
If MaxSize > Aproximate And MaxSize <= (RF.nWidth + RF.nHeight) Then
Aproximate = MaxSize
IconID = i
End If
End If
Next
If IconID = -1 Then Exit Function
With tIconEntry(IconID)
hIcon = CreateIconFromResourceEx(bytIcoData(.ieImageOffset), .ieBytesInRes, 1, IconVersion, .ieWidth, .ieHeight, &H0)
If hIcon = 0 Then Exit Function
DrawIconToRect = DrawIconEx(hdc, RF.nLeft + (RF.nWidth / 2) - (.ieWidth / 2), RF.nTop + (RF.nHeight / 2) - (.ieHeight / 2), hIcon, 0, 0, 0, 0, DI_NORMAL)
DestroyIcon hIcon
End With
End If
End If
ErrOut:
End Function
Private Sub Command1_Click()
Dim TR As RECTF
TR.nWidth = Picture1.ScaleWidth
TR.nHeight = Picture1.ScaleHeight
CommonDialog1.Filter = "Icono *.ico | *.ico"
CommonDialog1.ShowOpen
Picture1.Cls
DrawIconToRect Picture1.hdc, CommonDialog1.FileName, TR
End Sub
Private Sub Form_Load()
Me.ScaleMode = vbPixels
With Picture1
.ScaleMode = vbPixels
.BorderStyle = False
.BackColor = vbRed
'medidas que seguramente no tiene un icono,por lo tanto deberia dibujar uno de 48 si no lo hay uno de 32 .etc
.Width = 60
.Height = 60
End With
End Sub
