Buenas, les dejo el código de un common dialog de windows para poder hacer vista previa de imágenes. El código no lo inventé yo, si no que lo saque de este enlace que me pasó Post-Newbye
http://www.planet-source-code.com/vb...howCode.asp?tx tCodeId=63920&lngWId=1
y el autor es
Giorgio Brausi.
El ejemplo de este Tano, tiene 6 cuadros de dialogo, vista previa de imagen, para poder seleccionar un archivo y borrarlo
Vista previa de videos, y un par mas. El código es un verdadero enjambre de estructuras, rutinas y funciones Api, es un quilombo.
Lo que hice yofue extraer el código solo del cuadro de dialogo de vista previa de archivos de imagen, tarea que me llevó unas 3 horas.
Aparte cuando terminé de extrer el código, funciones api constantes etc.. solo de ese cuadro de dialogo, y lo probé, noté un bug terrible que colgaba el vb. Yo pensé que era porque le habia metido mano yo, pero me di cuenta que tiene un error el proyecto, y es que si le sacan los controles que están en el formulario frmcontrols, no se porqúe se cuelga todo, cosa inexplicable ya que esos controles no hacian referencia en ningun momento en el proyecto a una ninguna parte del codigo, cosa muy rara.
bueno,aparte le añadí comentarios a mi manera, exepto algunas que no entiendo para que sirven.
El funcionamiento es mediante una clase que manipula las propiedades del cuadro de dialogo. La funcionApi para abrir es el clasico
GetOpenFileName.
Para poder incrustar un PictureBox dentro del cuadro de dialogo, hay que usar la funcion Api SetParent y varias otras funciones que lo que hacen es redimensionar el cuadro de dialogo para poder incrustar el Cd al costado derecho, como SetWindowPos, GetWindowrect screenToClient , y ademas usa otras funciones una de retrollamada (creo se le diceasi) para poder notificar los mensajes que ocurren cuando interactuamos con el Cd, por ejemplo cuando seleccionamos un archivo se dispara la notificacion llamada
CDN_SELCHANGE, cuando apretamos el boton de abrir archivo se dispara
CDN_FILEOK, cuando cerramos la ventana del dialogo se ejecuta el valor
WM_DESTROY,....etc...
Otra cosa es que le cambie el código original porque el cuadro de dialogo usaba2 picture box que estaban agregados en tiempo de diseñoen un formulario, unode los picboxcontenia la imagen temporal y el otro lo mostraba
Ahora el Picture y la imagense crean en tiempo de ejecucion mediante el metodo Add de la col Controls (mucho mejor) y la imagen se carga en una variable. Otra es que el redimensionado de la imagen es a escala, cosa que el código original no, ya que las imagenes se veian todas desproporcionadas.
Si le encuentran algun bug avisen, y un saludo para Giorgio
Agregar un command1, un modulo bas y un modulo de clase llamado cVistaPrevia
Pd: el código parece largo,pero en realidad es muy corto comparado al otro
En un Formulario
Código:
Option Explicit
Dim CD As cVistaPrevia
Private Sub Command1_Click()
Dim archivo As String 'almacena la ruta devuelta
Set unform = Me 'Creamois una variable de tipo Form y la igualamos con el form que llama al CD
'El metodo Abrir lleva en el parámetro el Formulario que utiliza el CD
archivo = CD.Abrir(unform)
'Mostramos la ruta y nombre del archivo seleccionado
If archivo <> "" Then
MsgBox "El archivo seleccionado es: " & vbCrLf & vbCrLf & UCase(archivo)
End If
End Sub
Private Sub Form_Load()
'Creamos una instancia de la clase para usar el Commondialog
Set CD = New cVistaPrevia
'Le ponemos algunas propiedades al cuadro de dialogo
With CD
.CancelError = True 'por si se aprieta cancelar
.InitDir = App.Path 'Directorio inicial
.DialogTitle = "Abrir archivo de imagen" 'El titulo del cuadro
.Filter2 = BMP + EMF + GIF + ICO + JPG + WMF 'Las extenciones a mostrar
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Eliminamos la referencia
Set CD = Nothing
End Sub
En un modulo de clase llamado cVistaPrevia
Código:
Option Explicit
'Variables locales para las propiedades del Common Dialog
Private mvarCancelError As Boolean
Private mvarDefaultExt As String
Private mvarDialogTitle As String
Private mvarFileName As String
Private mvarFileTitle As String
Private mvarFilter As String
Private mvarFilterIndex As Integer
Private mvarFlags As Long
Private mvarInitDir As String
'Estructura para los tipos de archivos
Public Enum enumFILTER
TODOS = 1
BMP = 2
EMF = 8
GIF = 32
ICO = 64
JPG = 128
WMF = 2048
End Enum
'Copia local de los tipos de extenciones
Private mvarFilter2 As enumFILTER
'Esta propiedad establece el Filtro de extenciones a cargar en el Combo del commondialog
Public Property Let Filter2(ByVal vData As enumFILTER)
Dim s As String
'Todos los archivos
If vData And TODOS Then
s = Chr(0) & "Todos los Archivos (*.*)" & Chr(0) & "*.*"
Else
'BMP
If vData And BMP Then
s = s & Chr(0) & "Imagen de Mapa de Bits (*.bmp)" & Chr(0) & "*.bmp"
End If
'EMF
If vData And EMF Then
s = s & Chr(0) & "Enhanced Metafile (*.emf)" & Chr(0) & "*.emf"
End If
'GIF
If vData And GIF Then
s = s & Chr(0) & "archivos GIF (*.gif)" & Chr(0) & "*.gif"
End If
'ICO
If vData And ICO Then
s = s & Chr(0) & "Archivo de Iconos (*.ico)" & Chr(0) & "*.ico"
End If
'JPG
If vData And JPG Then
s = s & Chr(0) & "Archivo JPG (*.jpg)" & Chr(0) & "*.jpg"
End If
'WMF
If vData And WMF Then
s = s & Chr(0) & "Windows Metafile (*.wmf)" & Chr(0) & "*.wmf"
End If
End If
mvarFilter2 = vData
mvarFilter = Mid$(s, 2)
End Property
'Para leer el valor de la propiedad Filter
Public Property Get Filter2() As enumFILTER
Filter2 = mvarFilter2
End Property
'Propiedad para el directorio inicial cuando se llame al Commondialog
Public Property Let InitDir(ByVal vData As String)
mvarInitDir = vData
End Property
Public Property Get InitDir() As String
InitDir = mvarInitDir
End Property
'Flags del cd
Public Property Let Flags(ByVal vData As Long)
mvarFlags = vData
End Property
Public Property Get Flags() As Long
Flags = mvarFlags
End Property
'Propiedad FilterIndex del cuadro de dialogo
Public Property Let FilterIndex(ByVal vData As Integer)
mvarFilterIndex = vData
End Property
Public Property Get FilterIndex() As Integer
FilterIndex = mvarFilterIndex
End Property
Private Property Let Filter(ByVal vData As String)
mvarFilter = vData
End Property
Private Property Get Filter() As String
Filter = mvarFilter
End Property
'Propiedad FileName del cd
Public Property Let FileName(ByVal vData As String)
mvarFileName = vData
End Property
Public Property Get FileName() As String
FileName = mvarFileName
End Property
'El titulo del cuadro de dialogo
Public Property Let DialogTitle(ByVal vData As String)
mvarDialogTitle = vData
End Property
Public Property Get DialogTitle() As String
DialogTitle = mvarDialogTitle
End Property
'Propiedad CancelError
Public Property Let CancelError(ByVal vData As Boolean)
mvarCancelError = vData
End Property
Public Property Get CancelError() As Boolean
CancelError = mvarCancelError
End Property
' Función para abrir el cuadro de diálogo
Public Function Abrir(unform As Form) As String
Dim FError As Long
Flags = OFN_EXPLORER Or _
OFN_HIDEREADONLY Or _
OFN_LONGNAMES Or _
OFN_PATHMUSTEXIST Or _
OFN_ENABLEHOOK Or _
OFN_FILEMUSTEXIST
'El form que llama al CD debe estar en Pixeles
unform.ScaleMode = vbPixels
'abrimos el cuadro de dialogo pasandole las propiedades y opciones
Abrir = showOpen(unform, FError, mvarFilter, mvarInitDir, mvarDialogTitle, mvarFilterIndex, mvarFlags)
End Function
En un modulo bas
Código:
Option Explicit
Public Const SWP_SHOWWINDOW = &H40
Public Const WM_USER = &H400
Public Const CDM_FIRST = (WM_USER + 100)
Public Const CDM_GETFILEPATH = (CDM_FIRST + &H1)
'Constante de notificacion cuando se destruye el Commondialog
Private Const WM_DESTROY As Long = &H2
'funciones Api para el cuadro de dialogo abrir archivo
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
'recupera el Path
Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer
'Para los errores
Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
'apra obtener nombres de clase de ventanas
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
'devuelve el Handle de una ventana padre
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
'Ni idea
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Sub CopyMemory2 Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, ByVal Source As Any, ByVal Length As Long)
'recupera las dimensiones de una ventana pasandole su Hwnd, lo devuelve en una estructura Rect
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
'Posiciona y dimensiona una ventana
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
'Para enviar y recuperar mensajes
Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
'Esta se usa para posicionar el PictureBox dentro del cuadro de dialogo
Declare Function SetParent Lib "user32" (ByVal hwndChild As Long, ByVal hWndNewParent As Long) As Long
'ni idea
Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Public unform As Form 'Variable para hacer referencia al formulario que utiliza el cd
'Para poder crear un Picture dinamico mediante el metodo add de la coleeccion controls
Public MiPicture As Control
Dim archivo As String
'Estructuras para coordenadas y dimensiones de las ventanas y objetos, en este caso el cd
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
left As Long
top As Long
Right As Long
Bottom As Long
End Type
'Estructura para las opciones del cuadro de dialogo
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
' Estructura usada en la Notificaciones de mensajes
Type OPENFILENAME2
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As Long
lpstrCustomFilter As Long
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As Long
nMaxFile As Long
lpstrFileTitle As Long
nMaxFileTitle As Long
lpstrInitialDir As Long
lpstrTitle As Long
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Type NMHDR
hwndFrom As Long
idFrom As Long
code As Long
End Type
'estructura para la rutina de Notificacion de mensajes del cuadro de dialogo
Type OFNOTIFY
hdr As NMHDR
lpOFN As OPENFILENAME2
pszFile As Long 'String ' May be NULL
End Type
'Constantes de notificaciones de mensajes del CommonDialog
Public Const CDN_FIRST = (-601)
Public Const CDN_LAST = (-699)
Public Const CDN_INITDONE = (CDN_FIRST - &H0)
Public Const CDN_SELCHANGE = (CDN_FIRST - &H1)
Public Const CDN_FOLDERCHANGE = (CDN_FIRST - &H2)
Public Const CDN_SHAREVIOLATION = (CDN_FIRST - &H3)
Public Const CDN_HELP = (CDN_FIRST - &H4)
Public Const CDN_FILEOK = (CDN_FIRST - &H5)
Public Const CDN_TYPECHANGE = (CDN_FIRST - &H6)
Public Const WM_NOTIFY = &H4E
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_EXPLORER = &H80000
Public Const OFN_LONGNAMES = &H200000
Public Const lst1 = &H460
'variable para almacenar la imagen
Public picTemp As IPictureDisp
Public gAdattaImmagine As Integer
Public gszPath As String
'variables para las dimensiones de la imagen del Picture box
Dim centro1 As Single, centro2 As Single
Dim Ancho As Single, Alto As Single, Porcentaje As Single
'Esta función es de notificación y se dispara
'cada vez que se produce un evento en el Commondialog
'llamando luego a la función CDNotify que procesa las acciones y eventos que ocurren
' en el CD
Function CDCallBack(ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
Dim retV As Long
On Error GoTo CDCallBack_Error
retV = False
Select Case msg
Case WM_NOTIFY
retV = CDNotify(hWnd, lp)
'Esto se ejecuta cuando se destruye el commondialog, es decir cuando se cierra la ventana
Case WM_DESTROY
'Removemos el Picture de vista previa creado dinamicamente
unform.Controls.Remove "MiPicture1"
'Eliminamos las variables de referencia
Set MiPicture = Nothing
Set unform = Nothing
Set picTemp = Nothing
End Select
CDCallBack = retV
On Error GoTo 0
Exit Function
CDCallBack_Error:
Resume Next
End Function
'Función que procesa las acciones ocurridas en el Commondialog
' por ejemplo cuando le damos al boton Abrir, Cerrar, cambiamos de carpeta etc...
Public Function CDNotify(ByVal hWnd As Long, ByVal lp As Long) As Long
Const MAX_PATH = 255
Dim hdlgParent As Long
Dim rc As RECT, rcDesk As RECT, rL As RECT
Dim lpon As OFNOTIFY, hLV As Long, pt As POINTAPI
CopyMemory2 lpon, lp&, Len(lpon)
Select Case lpon.hdr.code
'Esta aciión se produce cuando apenas se inicializa el Commondialog
Case CDN_INITDONE: ' Este es el primer evneto que se dispara cuando se abre el CD
hdlgParent = GetParent(hWnd) ' Handle
GetWindowRect hdlgParent, rc ' Obtenesmos Dimensiones del Common Dialog
hLV = GetDlgItem(hdlgParent, lst1) ' handle del List del Commondialog
GetWindowRect hLV, rL ' Obtenemos el rectangulo del List
pt.X = rL.left
pt.Y = rL.top
ScreenToClient hdlgParent, pt
'Alto del Picture
MiPicture.Height = (rL.Bottom - rL.top)
'Ancho del Picture
MiPicture.Width = MiPicture.Height * 1.2 ' square
'Left del Picture
MiPicture.left = (pt.X * 3) + (rL.Right - rL.left)
'Top del Picture
MiPicture.top = pt.Y
rc.Right = rL.Right + MiPicture.Width + (pt.X * 4)
'Ponemos el PictureBox en el Commondialog con las medidas y
' coordenadas obtenidas anteriormente con el Api SetParent
' donde hdlgparent es el hwnd del dialogo
SetParent MiPicture.hWnd, hdlgParent
'Hacemos el PictureBox visible
MiPicture.Visible = True
' Esto es para las coordenadas de la posicion del Common dialog
With rcDesk
.left = 0
.top = 0
.Right = Screen.Width / Screen.TwipsPerPixelX
.Bottom = Screen.Height / Screen.TwipsPerPixelY
End With
'La función SetwindowPos redimensiona el Cuadro de dialogo
'es decir lo hace mas ancho para poder meter el PictureBox a la derecha
SetWindowPos hdlgParent, 0, _
(rcDesk.Right - (rc.Right - rc.left)) / 2, _
(rcDesk.Bottom - (rc.Bottom - rc.top)) / 2, _
rc.Right - rc.left, _
rc.Bottom - rc.top, _
SWP_SHOWWINDOW
'CDN_FILEOK Se dispara cuando apretamos Abrir del Commondialog
Case CDN_FILEOK:
hdlgParent = GetParent(hWnd) 'Handle del commondialog
gszPath = String$(MAX_PATH, 0) 'Buffer para el Path que nos devuelve
'Lo obtenemos mediante esta api
SendMessageByString hdlgParent, CDM_GETFILEPATH, MAX_PATH, gszPath
'Le eliminamos los espacios nulos
eliminarNull gszPath
'Se dispara cuando seleccionamos un archivo del ComonDialog
Case CDN_SELCHANGE:
hdlgParent = GetParent(hWnd) 'handle del cd
gszPath = String$(MAX_PATH, 0) 'buffer
SendMessageByString hdlgParent, CDM_GETFILEPATH, MAX_PATH, gszPath
eliminarNull gszPath 'Eliminamos los espacios nulos
If gszPath = "" Then Exit Function ' Si el path seleccionado está vacio salimos
On Error Resume Next
'cargamos la imagen en esta variable
Set picTemp = LoadPicture(gszPath)
'Llamamos a esta sub que calcula las dimensiones de la imagen
'para poder dibujarla en el Picbox
calcularDimensionImg
'refrescamos por las deudas
MiPicture.Refresh
'Se dispara cuando desplegamos el combo con los tipos de archivos del Cuadro de dialogo
Case CDN_TYPECHANGE
hdlgParent = GetParent(hWnd)
Case CDN_SHAREVIOLATION 'Error share violation
MsgBox "Error general!", vbCritical
End Select
Exit Function
Salta:
End Function
Sub eliminarNull(st As String)
Dim p As Long
p = InStr(st, vbNullChar)
If p > 0 Then
st = left$(st, p - 1)
End If
End Sub
Function showOpen(ByVal unform As Form, FError&, Filter$, IDir$, Title$, Index%, Flags&, Optional sFileName$) As String
showOpen = 0: FError = 0
Dim O As OPENFILENAME
Dim szFile$, szFilter$, szInitialDir$, szTitle$
Dim result As Long, Buffer As String
Dim File$, FullPath$
szFile$ = sFileName & String$(256 - Len(sFileName), 0)
szFilter$ = Filter$
szInitialDir$ = IDir$
szTitle$ = Title$
'Llenamos la estructura con las opciones del cuadro de diálogo
O.lStructSize = Len(O)
O.hwndOwner = unform.hWnd
O.Flags = Flags&
O.lpstrFilter = szFilter$ & vbNullChar
O.nFilterIndex = Index%
O.lpstrFile = szFile
O.nMaxFile = Len(szFile$)
O.lpstrFileTitle = szFile$ & vbNullChar
O.lpstrInitialDir = szInitialDir$ & vbNullChar
O.lpstrTitle = szTitle$ & vbNullChar
O.lpfnHook = VBGetProcAddress(AddressOf CDCallBack)
'Llamamos a esta Sub para crear el Picture en forma dinamica
' y que luego se colocará en el cuadro de dialogo
CrearPicture
'Abrimos el cuadro de dialogo llamando a la Api y pasandole la estructura anterior
'con los datos
result = GetOpenFileName(O)
'Por si ocurre un error
FError& = CommDlgExtendedError()
If result = 0 Then
showOpen = 3
End If
If (InStr(O.lpstrFileTitle, Chr$(0)) - 1) = 0 Then
FullPath$ = left$(O.lpstrFile, InStr(O.lpstrFile, Chr(0)) - 1)
File$ = szFile$
Else
File$ = left$(O.lpstrFileTitle, InStr(O.lpstrFileTitle, Chr$(0)) - 1)
FullPath$ = left$(O.lpstrFile, O.nFileOffset) & File$
End If
Buffer = String(255, 0)
GetFileTitle FullPath$, Buffer, Len(Buffer)
showOpen = FullPath$
End Function
Public Function VBGetProcAddress(ByVal lpfn As Long) As Long
VBGetProcAddress = lpfn
End Function
Private Sub CrearPicture()
'Creamos un Picture en tiempo de ejecucion usando el metodo Add de la coleccion controls de los formularios
Set MiPicture = unform.Controls.Add("VB.PictureBox", "MiPicture1")
With MiPicture
.BackColor = vbButtonFace
'El autoredraw es necesariop ya que la imagen no se carga con LoadPicture
'si no que se dibuja mediante el método PaintPicture
.AutoRedraw = True
End With
End Sub
'Esta sub determina el porcentaje de reescalado para poder dibujar la imagen
'en forma proporcionada en el PictureBox
Private Sub calcularDimensionImg()
'Almacenamos el ancho y alto de la imagen
Ancho = picTemp.Width
Alto = picTemp.Height
If Ancho < MiPicture.Width And Alto < MiPicture.Height Then
MiPicture.Cls
MiPicture.PaintPicture picTemp, 0, 0, MiPicture.ScaleWidth, MiPicture.ScaleHeight
Exit Sub
End If
'Sacamos el porcentaje para reescalar la imàgen
If Ancho > MiPicture.Width Or Alto > MiPicture.Height Then
If Ancho > Alto Then
Porcentaje = (MiPicture.Width * 100) / Ancho
Else
Porcentaje = (MiPicture.Height * 100) / Alto
End If
CentrarPicture
Exit Sub
End If
If Ancho <= MiPicture.Width Or Alto <= MiPicture.Height Then
If Ancho > Alto Then
Porcentaje = (MiPicture.Width * 100) / Ancho
Else
Porcentaje = (MiPicture.Width * 100) / Alto
End If
End If
End Sub
Public Sub CentrarPicture()
'SAcamos el porcentaje del ancho y el alto
Ancho = ((Ancho * Porcentaje) / 100) / 0.99
Alto = ((Alto * Porcentaje) / 100) / 0.99
'La posicion X e y de la imagen dentro del Picture
centro1 = (MiPicture.Width - Ancho) / 2
centro2 = (MiPicture.Height - Alto) / 2
'Borramos la imagen
MiPicture.Cls
'Dibujamos la imagen de la variable en el Picture
MiPicture.PaintPicture picTemp, centro1, centro2, Ancho, Alto
'eliminamos la variable imagen
End Sub
salu2