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 clasicoGetOpenFileName.


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

Muy bueno compañero, ahora esta mas claro e inclusive la imagen esta centrada

Saludos