Sección de código fuente Visual basic

Thumbnail de imágenes

Código fuente de un control ocx para hacer ThumbNail de gráficos

Para descargar solo el control ocx desde este enlace: Picture Thumbnail - tipo vista previa

La imagen se dibuja en la ventana del Usercontrol cada ves que se asigna la propiedad Picture del mismo, mediante el Api StretchBlt y SetStretchBltMode entre otras con la función Dibujar, que lleva como parámetro el gráfico, es decir es un valor de tipo picture

Una ves cargado una imagen, la misma se visualizará en forma centrada, y se adaptará al tamaño del control en forma proporcionada

Nota: El control no tiene todas las propiedades establecidas que posee un PictureBox, por ejemplo la de los métodos gráficos, Line, Circle, PaintPicture y algunas otras.

El código aunque parece un poco largo, en realidad es simple, solo que tiene una propiedad para cambiarle los bordes del control mediante el Api de windows ( el código que está en el módulo bas ) y la mayoría del código es para este asunto. Esto de los bordes es optativo, y haciendo algunos camios desde la ventana de UserControl, si se quiere se puede eliminar.

A continuación sigue el código fuente

Pasos para crear el control

Crear un nuevo proyecto de tipo Control Activex.
Añadir al proyecto un Formulario
Añadir un Módulo bas
Seleccionar la ventana del UserControl y en la propiedad Name del mismo colocar Picthumbnail

La ventana de explorador de proyectos de vb quedará de la siguiente forma:

A continuación sigue el código fuente a colocar en el UserControl, en el Módulo bas, y al final de la página el código en el Formulario para probar el control

Abrir la ventana de código del UserControl y pegar lo siguiente:

Option Explicit ' Declaración de funciones Api: ' StretchBlt Para copiar la imagen en el usercontrol Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, _ ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _ ByVal nHeight As Long, ByVal hSrcDC As Long, _ ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth _ As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) _ As Long Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, _ ByVal nStretchMode As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal _ hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long 'Eventos del Usercontrol Event Click() Event DblClick() Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Event Resize() ' Enum para los estilos de borde del control Enum Enum_Borde SinBorde = 0 Borde1 = 1 Borde2 = 2 Borde3 = 3 Borde4 = 4 Borde5 = 5 Borde6 = 6 Borde7 = 7 End Enum 'Variables locales Private m_BackColor As OLE_COLOR Private m_Picture As Picture Private m_BorderStyle As Enum_Borde '*********************************************************** 'Procedimientos, funciones y propiedades Private Sub UserControl_InitProperties() AutoRedraw = True m_BorderStyle = 7 End Sub Private Sub UserControl_ReadProperties(PropBag As PropertyBag) With PropBag m_BorderStyle = .ReadProperty("BordeEstilo", 7) Set m_Picture = .ReadProperty("Picture", Nothing) UserControl.BackColor = .ReadProperty("BackColor", &H8000000F) UserControl.Enabled = .ReadProperty("Enabled", True) Set MouseIcon = .ReadProperty("MouseIcon", Nothing) UserControl.MousePointer = .ReadProperty("MousePointer", 0) UserControl.ScaleHeight = .ReadProperty("ScaleHeight", 4545) UserControl.ScaleLeft = .ReadProperty("ScaleLeft", 0) UserControl.ScaleMode = .ReadProperty("ScaleMode", vbTwips) UserControl.ScaleTop = .ReadProperty("ScaleTop", 0) UserControl.ScaleWidth = .ReadProperty("ScaleWidth", 5670) End With End Sub Private Sub UserControl_WriteProperties(PropBag As PropertyBag) With PropBag Call .WriteProperty("BordeEstilo", m_BorderStyle, 7) Call .WriteProperty("Picture", m_Picture, Nothing) Call .WriteProperty("BackColor", UserControl.BackColor, &H8000000F) Call .WriteProperty("Enabled", UserControl.Enabled, True) Call .WriteProperty("MouseIcon", MouseIcon, Nothing) Call .WriteProperty("MousePointer", UserControl.MousePointer, 0) Call .WriteProperty("ScaleHeight", UserControl.ScaleHeight, 4545) Call .WriteProperty("ScaleLeft", UserControl.ScaleLeft, 0) Call .WriteProperty("ScaleMode", UserControl.ScaleMode, vbTwips) Call .WriteProperty("ScaleTop", UserControl.ScaleTop, 0) Call .WriteProperty("ScaleWidth", UserControl.ScaleWidth, 5670) End With End Sub 'Función que dibuja el archivo grafico seleccionado, en el UserControl '******************************************************************************* Public Function Dibujar(Img As Picture) On Error Resume Next Dim PLeft As Long, PTop As Long Dim ReqWidth As Long, ReqHeight As Long Dim HScale As Double, VScale As Double Dim MyScale As Double Dim ImgWidth As Long Dim ImgHeight As Long Dim SourceHDC As Long Dim Old_Scale As Integer 'Si m_Picture es nothing o 0 sale If m_Picture Is Nothing Or m_Picture = 0 Then Cls Exit Function End If 'Guarda la escala anterior y asigna a pixeles Old_Scale = UserControl.ScaleMode UserControl.ScaleMode = vbPixels ' Borra la imagen UserControl.Cls ' Convierte el valor de Himetric a pixeles ImgWidth = UserControl.ScaleX(Img.Width, vbHimetric, vbPixels) ImgHeight = UserControl.ScaleY(Img.Height, vbHimetric, vbPixels) ' Escala horizontal y vertical HScale = UserControl.ScaleWidth / ImgWidth VScale = UserControl.ScaleHeight / ImgHeight MyScale = IIf(VScale >= HScale, HScale, VScale) ReqWidth = ImgWidth * MyScale ReqHeight = ImgHeight * MyScale 'Posición Left y Top, para centrar el gráfico: valores x y PLeft = (ScaleWidth - ReqWidth) / 2 PTop = (ScaleHeight - ReqHeight) / 2 SourceHDC = CreateCompatibleDC(0) DeleteObject SelectObject(SourceHDC, Img.Handle) Call SetStretchBltMode(UserControl.hDC, vbPaletteModeNone) ' Si es un ícono usa PaintPicture, si no StretchBlt If Img.Type = 3 Then PaintPicture Img, PLeft, PTop, ReqWidth, ReqHeight Else 'Copia el gráfico en el Picture StretchBlt UserControl.hDC, PLeft, PTop, ReqWidth, ReqHeight, _ SourceHDC, 0, 0, ImgWidth, ImgHeight, vbSrcCopy DeleteDC SourceHDC End If UserControl.ScaleMode = Old_Scale End Function 'Propiedades ''''''''''''''''''''''''''''''''''''''''''''''''''' Property Get BackColor() As OLE_COLOR BackColor = UserControl.BackColor End Property Property Let BackColor(color As OLE_COLOR) UserControl.BackColor = color PropertyChanged "BackColor" End Property Property Let Picture(v As Picture) Set m_Picture = v End Property Property Get Picture() As Picture Set Picture = m_Picture End Property Property Set Picture(v As Picture) Set m_Picture = v PropertyChanged "Picture" If Not v Is Nothing Then Call Dibujar(m_Picture) End Property Property Get BordeEstilo() As Enum_Borde BordeEstilo = m_BorderStyle End Property Property Let BordeEstilo(ByVal v As Enum_Borde) If Ambient.UserMode = False Then MsgBox "Esta propiedad solo se puede establecer en ejecución", vbInformation Exit Property End If Refresh m_BorderStyle = v Select Case m_BorderStyle Case 0 BorderStyle = 0 Case 1 Call Restaurar_Borde(hWnd) BorderStyle = 1 Case Else Call Aplicar_Borde(hWnd, v) End Select Refresh PropertyChanged "BordeEstilo" End Property Public Property Get Enabled() As Boolean Enabled = UserControl.Enabled End Property Public Property Let Enabled(ByVal New_Enabled As Boolean) UserControl.Enabled() = New_Enabled PropertyChanged "Enabled" End Property Public Property Get hWnd() As Long hWnd = UserControl.hWnd End Property Public Property Get Image() As Picture Set Image = UserControl.Image End Property Public Property Get MouseIcon() As Picture Set MouseIcon = UserControl.MouseIcon End Property Public Property Set MouseIcon(ByVal New_MouseIcon As Picture) Set UserControl.MouseIcon = New_MouseIcon PropertyChanged "MouseIcon" End Property Public Property Get MousePointer() As Integer MousePointer = UserControl.MousePointer End Property Public Property Let MousePointer(ByVal New_MousePointer As Integer) UserControl.MousePointer() = New_MousePointer PropertyChanged "MousePointer" End Property Private Sub UserControl_Resize() On Local Error Resume Next RaiseEvent Resize If Not m_Picture Is Nothing Or m_Picture = 0 Then Call Dibujar(m_Picture) End If End Sub Public Property Get ScaleHeight() As Single ScaleHeight = UserControl.ScaleHeight End Property Public Property Let ScaleHeight(ByVal New_ScaleHeight As Single) UserControl.ScaleHeight() = New_ScaleHeight PropertyChanged "ScaleHeight" End Property Public Property Get ScaleLeft() As Single ScaleLeft = UserControl.ScaleLeft End Property Public Property Let ScaleLeft(ByVal New_ScaleLeft As Single) UserControl.ScaleLeft() = New_ScaleLeft PropertyChanged "ScaleLeft" End Property Public Property Get ScaleMode() As ScaleModeConstants ScaleMode = UserControl.ScaleMode End Property Public Property Let ScaleMode(ByVal New_ScaleMode As ScaleModeConstants) UserControl.ScaleMode() = New_ScaleMode PropertyChanged "ScaleMode" End Property Public Property Get ScaleTop() As Single ScaleTop = UserControl.ScaleTop End Property Public Property Let ScaleTop(ByVal New_ScaleTop As Single) UserControl.ScaleTop() = New_ScaleTop PropertyChanged "ScaleTop" End Property Public Property Get ScaleWidth() As Single ScaleWidth = UserControl.ScaleWidth End Property Public Property Let ScaleWidth(ByVal New_ScaleWidth As Single) UserControl.ScaleWidth() = New_ScaleWidth PropertyChanged "ScaleWidth" End Property '************************************************************************ ' Eventos '************************************************************************ Public Sub Refresh() UserControl.Refresh End Sub Private Sub UserControl_Click() RaiseEvent Click End Sub Private Sub UserControl_DblClick() RaiseEvent DblClick End Sub Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) RaiseEvent MouseDown(Button, Shift, X, Y) End Sub Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) RaiseEvent MouseMove(Button, Shift, X, Y) End Sub Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, _ X As Single, Y As Single) RaiseEvent MouseUp(Button, Shift, X, Y) End Sub

Código fuente en el módulo BAS

Este módulo se encarga de cambiarle el estilo de los bordes a la ventana al UserControl)

Option Explicit Public Enum sedBorderStyle sedNone sedSunken sedSunkenOuter sedRaised sedRaisedInner sedBump sedEtched End Enum Private Enum sedBorderWidth sbwNone sbwSingle sbwDouble End Enum Private Const SED_OLDPROC As String = "SED_OLDPROC" Private Const SED_OLDGWLSTYLE As String = "SED_OLDGWLSTYLE" Private Const SED_OLDGWLEXSTYLE As String = "SED_OLDGWLEXSTYLE" Private Const SED_BORDERS As String = "SED_BORDERS" Private Const WM_NCPAINT As Long = &H85 Private Const SWP_FRAMECHANGED As Long = &H20 Private Const SWP_NOMOVE As Long = &H2 Private Const SWP_NOOWNERZORDER As Long = &H200 Private Const SWP_NOSIZE As Long = &H1 Private Const SWP_NOZORDER As Long = &H4 Private Const BDR_RAISED As Long = &H5 Private Const BDR_RAISEDINNER As Long = &H4 Private Const BDR_RAISEDOUTER As Long = &H1 Private Const BDR_SUNKEN As Long = &HA Private Const BDR_SUNKENINNER As Long = &H8 Private Const BDR_SUNKENOUTER As Long = &H2 Private Const BF_LEFT As Long = &H1 Private Const BF_RIGHT As Long = &H4 Private Const BF_TOP As Long = &H2 Private Const BF_BOTTOM As Long = &H8 Private Const BF_RECT As Long = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM) Private Const GWL_WNDPROC As Long = (-4) Private Const GWL_STYLE As Long = (-16) Private Const GWL_EXSTYLE As Long = (-20) Private Const WS_THICKFRAME As Long = &H40000 Private Const WS_BORDER As Long = &H800000 Private Const WS_EX_WINDOWEDGE As Long = &H100 Private Const WS_EX_CLIENTEDGE As Long = &H200 Private Const WS_EX_STATICEDGE As Long = &H20000 Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _ ByVal hDC As Long) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, _ lpRect As RECT) As Long Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, _ qrc As RECT, _ ByVal edge As Long, _ ByVal grfFlags As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, _ ByVal hWndInsertAfter As Long, _ ByVal X As Long, _ ByVal Y As Long, _ ByVal cx As Long, _ ByVal cy As Long, _ ByVal wFlags As Long) As Long Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _ (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, _ ByVal Msg As Long, ByVal wParam As Long, _ ByVal lParam As Long) As Long Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, _ ByVal lpString As String) As Long Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, _ ByVal lpString As String, ByVal hData As Long) As Long Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, _ ByVal lpString As String) As Long Public Sub Aplicar_Borde(ByVal lngHWnd As Long, ByVal eBorderStyle As sedBorderStyle) Dim lRet As Long lRet = GetProp(lngHWnd, SED_OLDPROC) If lRet <> 0 Then SetWindowLong lngHWnd, GWL_WNDPROC, lRet Else SetProp lngHWnd, SED_OLDGWLSTYLE, GetWindowLong(lngHWnd, GWL_STYLE) SetProp lngHWnd, SED_OLDGWLEXSTYLE, GetWindowLong(lngHWnd, GWL_EXSTYLE) End If pSetBorder lngHWnd, eBorderStyle lRet = SetWindowLong(lngHWnd, GWL_WNDPROC, AddressOf pWindowProc) SetProp lngHWnd, SED_OLDPROC, lRet SetProp lngHWnd, SED_BORDERS, CLng(eBorderStyle) Call SetWindowPos(lngHWnd, 0, 0, 0, 0, 0, _ SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOOWNERZORDER Or SWP_NOZORDER Or SWP_FRAMECHANGED) End Sub Private Sub pDrawBorder(ByVal lngHWnd As Long, _ ByVal wParam As Long, _ ByVal lBorderType As sedBorderStyle) Dim lMode As Long Dim hDC As Long Dim Rec As RECT If lBorderType = sedNone Then Exit Sub hDC = GetWindowDC(lngHWnd) Call GetWindowRect(lngHWnd, Rec) With Rec .Right = .Right - .Left .Bottom = .Bottom - .Top .Left = 0 .Top = 0 End With lMode = 0 Select Case lBorderType Case sedRaised lMode = BDR_RAISED Case sedRaisedInner lMode = BDR_RAISEDINNER Case sedSunken lMode = BDR_SUNKEN Case sedSunkenOuter lMode = BDR_SUNKENOUTER Case sedEtched lMode = BDR_SUNKENOUTER Or BDR_RAISEDINNER Case sedBump lMode = BDR_SUNKENINNER Or BDR_RAISEDOUTER End Select Call DrawEdge(hDC, Rec, lMode, BF_RECT) Call ReleaseDC(lngHWnd, hDC) End Sub Private Sub pSetBorder(ByVal lngHWnd As Long, _ ByVal eBorderStyle As sedBorderStyle) Dim pWidth As sedBorderWidth Select Case eBorderStyle Case sedNone pWidth = sbwNone Case sedRaised pWidth = sbwDouble Case sedRaisedInner pWidth = sbwSingle Case sedSunken pWidth = sbwDouble Case sedSunkenOuter pWidth = sbwSingle Case sedEtched pWidth = sbwDouble Case sedBump pWidth = sbwDouble End Select Select Case pWidth Case sbwNone pWinStyleNeg lngHWnd, GWL_STYLE, WS_BORDER Or WS_THICKFRAME Call pWinStyleNeg(lngHWnd, GWL_EXSTYLE, _ WS_EX_STATICEDGE Or WS_EX_CLIENTEDGE Or WS_EX_WINDOWEDGE) Case sbwSingle pWinStyleNeg lngHWnd, GWL_STYLE, WS_BORDER Or WS_THICKFRAME pWinStyleNeg lngHWnd, GWL_EXSTYLE, WS_EX_CLIENTEDGE Or WS_EX_WINDOWEDGE pWinStyleAdd lngHWnd, GWL_EXSTYLE, WS_EX_STATICEDGE Case sbwDouble pWinStyleNeg lngHWnd, GWL_STYLE, WS_BORDER Or WS_THICKFRAME pWinStyleNeg lngHWnd, GWL_EXSTYLE, WS_EX_STATICEDGE Or WS_EX_WINDOWEDGE pWinStyleAdd lngHWnd, GWL_EXSTYLE, WS_EX_CLIENTEDGE End Select Call SetWindowPos(lngHWnd, 0, 0, 0, 0, 0, _ SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOOWNERZORDER Or SWP_NOZORDER Or SWP_FRAMECHANGED) End Sub Private Sub pWindowProc(ByVal lngHWnd As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) Select Case uMsg Case WM_NCPAINT Call pDrawBorder(lngHWnd, wParam, GetProp(lngHWnd, SED_BORDERS)) Case Else CallWindowProc GetProp(lngHWnd, SED_OLDPROC), lngHWnd, uMsg, wParam, lParam End Select End Sub Private Sub pWinStyleAdd(ByVal lngHWnd As Long, _ ByVal lStyle As Long, _ ByVal lFlags As Long) Call SetWindowLong(lngHWnd, lStyle, GetWindowLong(lngHWnd, lStyle) Or lFlags) End Sub Private Sub pWinStyleNeg(ByVal lngHWnd As Long, _ ByVal lStyle As Long, _ ByVal lFlags As Long) Call SetWindowLong(lngHWnd, lStyle, GetWindowLong(lngHWnd, lStyle) And Not lFlags) End Sub Public Sub Restaurar_Borde(ByVal lngHWnd As Long) Dim lRet As Long lRet = GetProp(lngHWnd, SED_OLDPROC) If lRet <> 0 Then lRet = SetWindowLong(lngHWnd, GWL_WNDPROC, lRet) SetWindowLong lngHWnd, GWL_STYLE, GetProp(lngHWnd, SED_OLDGWLSTYLE) SetWindowLong lngHWnd, GWL_EXSTYLE, GetProp(lngHWnd, SED_OLDGWLEXSTYLE) Call SetWindowPos(lngHWnd, 0, 0, 0, 0, 0, _ SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOOWNERZORDER Or SWP_NOZORDER Or SWP_FRAMECHANGED) Call RemoveProp(lngHWnd, SED_OLDPROC) Call RemoveProp(lngHWnd, SED_OLDGWLSTYLE) Call RemoveProp(lngHWnd, SED_OLDGWLEXSTYLE) Call RemoveProp(lngHWnd, SED_BORDERS) End If End Sub

Código fuente en el formulario:

Colocar en el formulario los siguientes controles, mas o menos como muestra el gráfico que está al comienzo de la página:

Un control DirListBox
Un control FileListBox
Un DriveListBox
Un ListBox
Una instancia del control ocx

Código fuente en Form1

Option Explicit ' Código del formulario '******************************** Private Sub Dir1_Change() File1 = Dir1 End Sub Private Sub Drive1_Change() Dir1 = Drive1 End Sub 'Carga el gráfico seleccionado en el FileListBox Private Sub File1_Click() Picthumbnail1.Picture = LoadPicture(File1.Path & "\" & File1.FileName) End Sub 'CArga los valores para la propiedad Borde Private Sub Form_Load() For i = 1 To 7 List1.AddItem "Borde " & i Next List1.ListIndex = 6 File1.Pattern = "*jpg;*.bmp;*.gif;*.ico" End Sub 'Esto cambia el borde del ocx Private Sub List1_Click() If List1.ListIndex = -1 Then Exit Sub Picthumbnail1.BordeEstilo = List1.ListIndex End Sub

Enlaces relacionados

Buscar en Recursos vb