Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: E N T E R en Noviembre 12, 2013, 02:42:03 pm
-
Hola tengo un ListView donde le cargo imágenes del articulo, "La imagenes no son del mismo tamaño", se que si todas son iguales sale bien.
Asi me muestra.
(http://snag.gy/Mj52W.jpg)
Hay una manera de mejorar la visualización. Todas la imágenes tengo una carpeta y los cargo desde ahí.
-
Hola Enter, para que se muestren hay que hacer un calculo matematico por asi decirlo, la idea es pintar la imagen en un lienzo justificando su ancho o alto a una nueva medida standar para todas las imágenes., ademas utilizar el api SetStretchBltMode + StretchBlt
te paso un ejemplo y te explico abajo.
Option Explicit
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com
Private Declare Function StretchBlt Lib "gdi32.dll" (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 OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nStretchMode 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 CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Const DI_MASK = &H1
Const DI_IMAGE = &H2
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PICTDESC
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Function ResizePicture(ByRef ThePicture As IPicture, ByVal NewWidth As Long, ByVal NewHeight As Long, Optional BackColor As OLE_COLOR = vbWhite) As Boolean
On Error GoTo Fail
Dim Pic As PICTDESC, IID_IDispatch As GUID
Dim hDCMemory As Long, DC As Long
Dim PicDC As Long, OldhBmp As Long, PicW As Long, PicH As Long
Dim hImage As Long, OldhImage As Long
Dim hMask As Long, OldhMask As Long
Dim hIcon As Long, II As ICONINFO
Dim lWidth As Long, lHeight As Long
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 hBrush As Long
Dim oColor As Long
Dim tRECT As RECT
'Scale in Pixels
PicW = ScaleX(ThePicture.Width, vbHimetric, vbPixels)
PicH = ScaleY(ThePicture.Height, vbHimetric, vbPixels)
'Get Picture DC
PicDC = CreateCompatibleDC(0)
OldhBmp = SelectObject(PicDC, ThePicture.Handle)
'create buffer DC
DC = GetDC(0)
hDCMemory = CreateCompatibleDC(DC)
CLSIDFromString StrPtr("{7BF80981-BF32-101A-8BBB-00AA00300CAB}"), IID_IDispatch
If ThePicture.Type = vbPicTypeIcon Then
hMask = CreateBitmap(NewWidth, NewHeight, 1, 1, ByVal 0&)
OldhMask = SelectObject(hDCMemory, hMask)
DrawIconEx hDCMemory, 0, 0, ThePicture.Handle, NewWidth, NewHeight, 0, 0, DI_MASK
Call SelectObject(hDCMemory, OldhMask)
hImage = CreateCompatibleBitmap(DC, NewWidth, NewHeight)
OldhImage = SelectObject(hDCMemory, hImage)
DrawIconEx hDCMemory, 0, 0, ThePicture.Handle, NewWidth, NewHeight, 0, 0, DI_IMAGE
Call SelectObject(hDCMemory, OldhImage)
II.hbmColor = hImage
II.hbmMask = hMask
hIcon = CreateIconIndirect(II)
If hImage Then DeleteObject hImage
If hMask Then DeleteObject hMask
DeleteDC hDCMemory
ReleaseDC 0&, DC
With Pic
.cbSizeofStruct = Len(Pic)
.picType = ThePicture.Type
.hImage = hIcon
End With
DeleteObject SelectObject(PicDC, OldhBmp)
DeleteDC PicDC
Set ThePicture = Nothing
ResizePicture = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, ThePicture) = 0
Else
hImage = CreateCompatibleBitmap(DC, NewWidth, NewHeight)
OldhImage = SelectObject(hDCMemory, hImage)
HScale = NewWidth / PicW
VScale = NewHeight / PicH
MyScale = IIf(VScale >= HScale, HScale, VScale)
ReqWidth = (PicW * MyScale)
ReqHeight = (PicH * MyScale)
PLeft = ((NewWidth - ReqWidth) / 2)
PTop = ((NewHeight - ReqHeight) / 2)
OleTranslateColor BackColor, 0&, oColor
tRECT.Right = NewWidth
tRECT.Bottom = NewHeight
hBrush = CreateSolidBrush(oColor)
FillRect hDCMemory, tRECT, hBrush
SetStretchBltMode hDCMemory, 4
StretchBlt hDCMemory, PLeft, PTop, ReqWidth, ReqHeight, PicDC, 0, 0, PicW, PicH, vbSrcCopy
Call SelectObject(hDCMemory, OldhImage)
ReleaseDC 0&, DC
DeleteDC hDCMemory
DeleteObject SelectObject(PicDC, OldhBmp)
DeleteDC PicDC
With Pic
.cbSizeofStruct = Len(Pic)
.picType = ThePicture.Type
.hImage = hImage
.xExt = ThePicture.hPal
End With
ResizePicture = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, ThePicture) = 0
End If
Fail:
End Function
Private Sub Form_Load()
Dim PicTemp As StdPicture
Set PicTemp = LoadPicture("D:\Mis documentos\Mis imágenes\Nueva carpeta (2)\DSCN1663.JPG")
'Set PicTemp = LoadPicture("c:\Image.bmp")
If ResizePicture(PicTemp, 150, 150) Then
Me.Picture = PicTemp
End If
End Sub
en este ejemplo solo muestra en un form una imagen, redimencionada, ahora lo que tenes que hacer es llamar a la funcion (ResizePicture) y en ves de usar Me.Picture = PicTemp, pasarle el picTemp al ImageList.
si no se entiende pregunta.
Saludos.
-
Espectacular amigo Leandro quedo.
Muestra de como quedo.
(http://snag.gy/ilhCV.jpg)
Solo un problemita queria meter todo en un modulo como para tener mas ordenado por decirle pero me tira este error
(http://snag.gy/QNzh7.jpg)
Pero despues el resto quedo de maravillas, gracias
-
Tambien encontre aca similar al tuyo Leandro esta muy bueno tambien pero me quedo con el que vos me pasaste.
Dejo el link por si le sirve a alguien.
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=59422&lngWId=1 (http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=59422&lngWId=1)
-
Hola, el ejemplo de PSC utiliza GDI+ es mas completo porque te podes usar mas tipos de imágenes, para el caso tullo si solo usas jpg, no te seria necesario, te paso la función con lo que pedías antes, osea para ponerla dentro de un modulo y le quite una comprobación de si era un icono, total si vos usas imágenes jpg o bmp no es necesario.
Option Explicit
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com
Private Declare Function StretchBlt Lib "gdi32.dll" (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 OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PICTDESC
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Function ResizePicture(ByRef ThePicture As IPicture, ByVal NewWidth As Long, ByVal NewHeight As Long, Optional BackColor As OLE_COLOR = vbWhite) As Boolean
On Error GoTo Fail
Dim Pic As PICTDESC, IID_IDispatch As GUID
Dim hDCMemory As Long, DC As Long
Dim PicDC As Long, OldhBMP As Long
Dim hBitmap As Long, OldhBitmap As Long
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 hBrush As Long
Dim oColor As Long
Dim tRECT As RECT
Dim PicInfo As BITMAP
GetObject ThePicture.Handle, Len(PicInfo), PicInfo
PicDC = CreateCompatibleDC(0)
OldhBMP = SelectObject(PicDC, ThePicture.Handle)
DC = GetDC(0)
hDCMemory = CreateCompatibleDC(DC)
CLSIDFromString StrPtr("{7BF80981-BF32-101A-8BBB-00AA00300CAB}"), IID_IDispatch
hBitmap = CreateCompatibleBitmap(DC, NewWidth, NewHeight)
ReleaseDC 0&, DC
OldhBitmap = SelectObject(hDCMemory, hBitmap)
HScale = NewWidth / PicInfo.bmWidth
VScale = NewHeight / PicInfo.bmHeight
MyScale = IIf(VScale >= HScale, HScale, VScale)
ReqWidth = (PicInfo.bmWidth * MyScale)
ReqHeight = (PicInfo.bmHeight * MyScale)
PLeft = ((NewWidth - ReqWidth) / 2)
PTop = ((NewHeight - ReqHeight) / 2)
OleTranslateColor BackColor, 0&, oColor
tRECT.Right = NewWidth
tRECT.Bottom = NewHeight
hBrush = CreateSolidBrush(oColor)
FillRect hDCMemory, tRECT, hBrush
SetStretchBltMode hDCMemory, vbPaletteModeNone
StretchBlt hDCMemory, PLeft, PTop, ReqWidth, ReqHeight, PicDC, 0, 0, PicInfo.bmWidth, PicInfo.bmHeight, vbSrcCopy
Call SelectObject(hDCMemory, OldhBitmap)
DeleteDC hDCMemory
DeleteObject SelectObject(PicDC, OldhBMP)
DeleteDC PicDC
With Pic
.cbSizeofStruct = Len(Pic)
.picType = ThePicture.Type
.hImage = hBitmap
.xExt = ThePicture.hPal
End With
ResizePicture = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, ThePicture) = 0
Fail:
End Function
-
Maquina quedo Leandro te agradezco, ya estaba por cambiar todo a .NET pero con el código que me pasaste puedo continuar todavía en VB6.
Gracias...
-
Lo que no he podido ver son las imagenes que pones en el post...! Publica el ejemplo a ver como queda..! Por si alguien lo necesita...!
-
Lo que no he podido ver son las imagenes que pones en el post...! Publica el ejemplo a ver como queda..! Por si alguien lo necesita...!
Las imagenes si se ven papa, se ven todas. Ctrl + F5
-
Ya logre verlas...! Gracias doc...!
-
Yo tampoco puedo ver la imagenes, me fui al codigo fuente del navegador
http://snag.gy/Mj52W.jpg (http://snag.gy/Mj52W.jpg)
http://snag.gy/ilhCV.jpg (http://snag.gy/ilhCV.jpg)
Vi la diferencia entre la imagenes y se ve una gran diferencia pero mi 1era impresion de sorpresa fue !CARAJO
-
Buen dia. disculpas por revivir un tema de varios años, ENTER si algun andas por aca pueden subir tu ejemplo para poder vizualizar como te quedo el ejemplo, si no fuera mucho pedir. Gracias....