Esta es una revision conjunta de Luciano y mia sobre el recurso que mostraba como lanzar los Cuadros de dialogo de Abrir y Guardar como mediante el API de Windows sin utilizar ningun OCX, componente ActiveX o libreria que no venga de serie con Windows.

El codigo corrige un ligero error en la implementacion de los filtros del codigo de Luciano y a su vez Luciano corrige un error en mi implementacion que provocaba que el cuadro de dialogo de Guardar como devolviera el nombre del archivo sin la extension seleccionada.

El siguiente codigo debe ir en un modulo BAS:

Código:

Option Explicit

Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_EXPLORER = &H80000

Private 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

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Dim ofn As OPENFILENAME

'Muestra el cuadro de dialogo para abrir archivos:
Public Function OpenFile(hwnd As Long, Filter As String, Title As String, InitDir As String, Optional Filename As String, Optional FilterIndex As Long) As String
 On Local Error Resume Next

 Dim ofn As OPENFILENAME
 Dim a As Long
 
 ofn.lStructSize = Len(ofn)
 ofn.hwndOwner = hwnd
 ofn.hInstance = App.hInstance
 
 If VBA.Right$(Filter, 1) <> "|" Then Filter = Filter + "|"
 
 For a = 1 To Len(Filter)
 If Mid$(Filter, a, 1) = "|" Then Mid(Filter, a, 1) = Chr(0)
 Next
 
 ofn.lpstrFilter = Filter
 ofn.lpstrFile = Space$(254)
 ofn.nMaxFile = 255
 ofn.lpstrFileTitle = Space$(254)
 ofn.nMaxFileTitle = 255
 ofn.lpstrInitialDir = InitDir
 If Not Filename = vbNullString Then ofn.lpstrFile = Filename & Space$(254 - Len(Filename))
 ofn.nFilterIndex = FilterIndex
 ofn.lpstrTitle = Title
 ofn.flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST
 a = GetOpenFileName(ofn)

 If a Then
   OpenFile = Trim$(ofn.lpstrFile)
   If VBA.Right$(VBA.Trim$(OpenFile), 1) = Chr(0) Then OpenFile = VBA.Left$(VBA.Trim$(ofn.lpstrFile), Len(VBA.Trim$(ofn.lpstrFile)) - 1)
   
 Else
   OpenFile = vbNullString
   
 End If
 
End Function

'Muestra el cuadro de dialogo para guardar archivos:
Public Function SaveFile(hwnd As Long, Filter As String, Title As String, InitDir As String, Optional Filename As String, Optional FilterIndex As Long) As String
 On Local Error Resume Next<br style="color: rgb(0, 0, 255);">
 Dim ofn As OPENFILENAME
 Dim a As Long
 
 ofn.lStructSize = Len(ofn)
 ofn.hwndOwner = hwnd
 ofn.hInstance = App.hInstance
 
 If VBA.Right$(Filter, 1) <> "|" Then Filter = Filter + "|"
 
 For a = 1 To Len(Filter)
 If Mid(Filter, a, 1) = "|" Then Mid(Filter, a, 1) = Chr(0)
 Next
 
 ofn.lpstrFilter = Filter
 ofn.lpstrFile = Space(254)
 ofn.nMaxFile = 255
 ofn.lpstrFileTitle = Space(254)
 ofn.nMaxFileTitle = 255
 ofn.lpstrInitialDir = InitDir
 If Not Filename = vbNullString Then ofn.lpstrFile = Filename & Space(254 - Len(Filename))
 ofn.nFilterIndex = FilterIndex
 ofn.lpstrTitle = Title
 ofn.flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_CREATEPROMPT Or OFN_EXPLORER
 a = GetSaveFileName(ofn)

 If a Then
   SaveFile = Trim$(ofn.lpstrFile)
   If VBA.Right$(Trim$(SaveFile), 1) = Chr(0) Then SaveFile = VBA.Left$(Trim$(ofn.lpstrFile), Len(Trim$(ofn.lpstrFile)) - 1)
       
       'Comprobamos si el nombre ya contiene la extension, si no la tiene se la añadimos:
       Dim Ext As String
       Ext = GetExtension(ofn.lpstrFilter, ofn.nFilterIndex)
       If Not UCase(Right(DLG_SaveFile, 4)) = UCase(Ext) Then DLG_SaveFile = DLG_SaveFile + Ext

 Else
   SaveFile = vbNullString
   
 End If
 
End Function
<br style="color: rgb(0, 153, 51);">'Extrae la extension seleccionada del filtro:
Private Function GetExtension(sfilter As String, pos As Long) As String
 Dim Ext() As String
 
 Ext = Split(sfilter, vbNullChar)
 
 If pos = 1 And Ext(pos) <> "*.*" Then
 GetExtension = "." & Replace(Ext(pos), "*.", "")
  
 ElseIf pos = 1 And Ext(pos) = "*.*" Or InStr(Ext(pos + 1), "*.*") Then
 GetExtension = vbNullString
 
 Else
 GetExtension = "." & Replace(Ext(pos + 1), "*.", "")
 
 End If
 
End Function

Forma de uso:

Código:

Dim Filename As String

'Muestra el cuadro de dialogo Abrir con un filtro de 3 tipos 
'apuntando al directorio por defecto del explorador:
Filename = OpenFile(Me.hwnd, "Archivo de texto|*.txt|Mapa de bits|*.bmp|Todos los archivos|*.*", "Abrir documento", vbNullString)

'Muestra cuadro de dialogo Guardar como apuntando al directorio del programa con un nombre predefinido <br style="color: rgb(0, 153, 51);">'y con el segundo filtro preseleccionado:<br style="color: rgb(0, 153, 102);">Filename = SaveFile(Me.hwnd, "Archivo de texto|*.txt|Mapa de bits|*.bmp", "Guardar como...", App.Path, "sin nombre", 2)

Salu2...

Edited by: [EX3]