VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CommonDialog"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
 
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long
Private Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long
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
Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PrintDlg) As Long
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
 
Private Type ChooseColor
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As Long
    Flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type


Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64
Private Const FW_BOLD = 700


Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type

Private Type CHOOSEFONT
    lStructSize As Long
    hwndOwner As Long
    hDC As Long
    lpLogFont As Long
    iPointSize As Long
    Flags As Long
    rgbColors As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
    hInstance As Long
    lpszStyle As String
    nFontType As Integer
    MISSING_ALIGNMENT As Integer
    nSizeMin As Long
    nSizeMax As Long
End Type

Private Type OpenFilename
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    iFilterIndex 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 Type PrintDlg
    lStructSize As Long
    hwndOwner As Long
    hDevMode As Long
    hDevNames As Long
    hDC As Long
    Flags As Long
    nFromPage As Integer
    nToPage As Integer
    nMinPage As Integer
    nMaxPage As Integer
    nCopies As Integer
    hInstance As Long
    lCustData As Long
    lpfnPrintHook As Long
    lpfnSetupHook As Long
    lpPrintTemplateName As String
    lpSetupTemplateName As String
    hPrintTemplate As Long
    hSetupTemplate As Long
End Type

Private Const CDERR_DIALOGFAILURE = &HFFFF
Private Const CDERR_FINDRESFAILURE = &H6
Private Const CDERR_GENERALCODES = &H0
Private Const CDERR_INITIALIZATION = &H2
Private Const CDERR_LOADRESFAILURE = &H7
Private Const CDERR_LOADSTRFAILURE = &H5
Private Const CDERR_LOCKRESFAILURE = &H8
Private Const CDERR_MEMALLOCFAILURE = &H9
Private Const CDERR_MEMLOCKFAILURE = &HA
Private Const CDERR_NOHINSTANCE = &H4
Private Const CDERR_NOHOOK = &HB
Private Const CDERR_NOTEMPLATE = &H3
Private Const CDERR_REGISTERMSGFAIL = &HC
Private Const CDERR_STRUCTSIZE = &H1

Private Const FNERR_BUFFERTOOSMALL = &H3003
Private Const FNERR_FILENAMECODES = &H3000
Private Const FNERR_INVALIDFILENAME = &H3002
Private Const FNERR_SUBCLASSFAILURE = &H3001

Private iAction As Integer         ' Action
Private bCancelError As Boolean    ' CancelError
Private lColor As Long             ' Color
Private lCopies As Long            ' lCopies
Private sDefaultExt As String      ' sDefaultExt
Private sDialogTitle As String     ' DialogTitle
Private sFileName As String        ' FileName
Private sFileTitle As String       ' FileTitle
Private sFilter As String          ' Filter
Private iFilterIndex As Integer    ' FilterIndex
Private lFlags As Long             ' Flags
Private bFontBold As Boolean       ' FontBold
Private bFontItalic As Boolean     ' FontItalic
Private sFontName As String        ' FontName
Private lFontSize As Long          ' FontSize
Private bFontStrikethru As Boolean ' FontStrikethru
Private bFontUnderline As Boolean  ' FontUnderline
Private lFromPage As Long          ' FromPage
Private lhDC As Long               ' hDC
Private lHelpCommand As Long       ' HelpCommand
Private sHelpContext As String     ' HelpContext
Private sHelpFile As String        ' HelpFile
Private sHelpKey As String         ' HelpKey
Private sInitDir As String         ' InitDir
Private lMax As Long               ' Max
Private lMaxFileSize As Long       ' MaxFileSize
Private lMin As Long               ' Min
Private objObject As Object        ' Object
Private iPrinterDefault As Integer ' PrinterDefault
Private lToPage As Long            ' ToPage
Private lApiReturn As Long         ' APIReturn
Private lExtendedError As Long     ' ExtendedError

Public Property Get Filter() As String
    
    Filter = sFilter

End Property

' diálogo de selección de color
Public Sub ShowColor()
    Dim tChooseColor As ChooseColor
    Dim alCustomColors(15) As Long, lCustomColorSize As Long, lCustomColorAddress As Long, _
      lMemHandle As Long
    Dim n As Integer
        
    On Error GoTo ShowColorError
    
    iAction = 3         ' Action = ShowColor
    lApiReturn = 0
    lExtendedError = 0
    
    
    tChooseColor.lStructSize = Len(tChooseColor)
    tChooseColor.hwndOwner = lhDC
    tChooseColor.rgbResult = lColor

    For n = 0 To UBound(alCustomColors)
        alCustomColors(n) = &HFFFFFF
    Next
    
    ' reservamos memoria necesaria para colores "personalizados"
    lCustomColorSize = Len(alCustomColors(0)) * 16
    lMemHandle = GlobalAlloc(GHND, lCustomColorSize)
    If lMemHandle = 0 Then
        Exit Sub
    End If
    lCustomColorAddress = GlobalLock(lMemHandle)
    If lCustomColorAddress = 0 Then
        Exit Sub
    End If
    
    ' copiamos los colores "personalizados"
    CopyMemory ByVal lCustomColorAddress, alCustomColors(0), lCustomColorSize
 
    tChooseColor.lpCustColors = lCustomColorAddress
    tChooseColor.Flags = lFlags
           
    lApiReturn = ChooseColor(tChooseColor)
    Select Case lApiReturn
        Case 0          ' usuario canceló
            If bCancelError Then
                On Error GoTo 0
                Err.Raise Number:=vbObjectError + 894, Description:="Cancel Pressed"
                Exit Sub
            End If
        Case 1          ' usuario seleccionó un color
            lColor = tChooseColor.rgbResult
        Case Else       ' ocurrió un error
            lExtendedError = CommDlgExtendedError
    End Select

Exit Sub

ShowColorError:
    Exit Sub
End Sub

' diálogo de tipos de letra
Public Sub ShowFont()
    Dim tLogFont As LOGFONT
    Dim tChooseFont As CHOOSEFONT
    Dim lLogFontSize As Long, lLogFontAddress As Long, lMemHandle As Long, lReturn As Long, lBytePoint As Long
    Dim sFont As String
    
    On Error GoTo ShowFontError
    
    iAction = 4         'Action = ShowFont
    lApiReturn = 0
    lExtendedError = 0

    If bFontBold Then
        tLogFont.lfWeight = FW_BOLD
    End If
    If bFontItalic Then
        tLogFont.lfItalic = 1
    End If
    If bFontUnderline Then
        tLogFont.lfUnderline = 1
    End If
    If bFontStrikethru Then
        tLogFont.lfStrikeOut = 1
    End If
    tChooseFont.lStructSize = Len(tChooseFont)
    lLogFontSize = Len(tLogFont)
    
    ' reservamos memoria para guardar una copia de 'tLogFont'
    lMemHandle = GlobalAlloc(GHND, lLogFontSize)
    If lMemHandle = 0 Then
        Exit Sub
    End If
    lLogFontAddress = GlobalLock(lMemHandle)
    If lLogFontAddress = 0 Then
        Exit Sub
    End If
    CopyMemory ByVal lLogFontAddress, tLogFont, lLogFontSize
 
    tChooseFont.lpLogFont = lLogFontAddress
    tChooseFont.iPointSize = lFontSize * 10
    tChooseFont.Flags = lFlags
    
    lApiReturn = CHOOSEFONT(tChooseFont)
    
    Select Case lApiReturn
        Case 0          ' usuario canceló
            If bCancelError Then
                Err.Raise 2001
                Exit Sub
            End If
        Case 1          ' usuario eligió un tipo de letra
            CopyMemory tLogFont, ByVal lLogFontAddress, lLogFontSize
            If tLogFont.lfWeight >= FW_BOLD Then
                bFontBold = True
            Else
                bFontBold = False
            End If
            If tLogFont.lfItalic = 1 Then
                bFontItalic = True
            Else
                bFontItalic = False
            End If
            If tLogFont.lfUnderline = 1 Then
                bFontUnderline = True
            Else
                bFontUnderline = False
            End If
            If tLogFont.lfStrikeOut = 1 Then
                bFontStrikethru = True
            Else
                bFontStrikethru = False
            End If
            FontName = sByteArrayToString(tLogFont.lfFaceName())
            lFontSize = CLng(tChooseFont.iPointSize / 10)
        Case Else       ' error
            lExtendedError = CommDlgExtendedError
    End Select
    
    Exit Sub

ShowFontError:
    Exit Sub
End Sub

' mostrar ayuda
Public Sub ShowHelp()
    Dim sHelpFileBuff As String
    Dim lData As Long
    
    On Error GoTo ShowHelpError
    
    iAction = 6         ' Action = ShowHelp
    lApiReturn = 0
    lExtendedError = 0

    sHelpFileBuff = sHelpFile & Chr(0)
    lData = 0
    lApiReturn = WinHelp(lhDC, sHelpFile, lHelpCommand, lData)
    
    Select Case lApiReturn
        Case 0
            lExtendedError = CommDlgExtendedError
        Case Else
            lExtendedError = CommDlgExtendedError
    End Select
        
    Exit Sub

ShowHelpError:
    Exit Sub
End Sub

' muestra diálogo de abrir fichero
Public Sub ShowOpen()

    ShowFileDialog 1

End Sub

' muestra diálogo de impresora
Public Sub ShowPrinter()
    Dim tPrintDlg As PrintDlg
    
    On Error GoTo ShowPrinterError
    
    iAction = 5         ' Action = ShowPrint
    lApiReturn = 0
    lExtendedError = 0

    tPrintDlg.lStructSize = Len(tPrintDlg)
    tPrintDlg.hDC = lhDC
    tPrintDlg.Flags = lFlags
    tPrintDlg.nFromPage = lFromPage
    tPrintDlg.nToPage = lToPage
    tPrintDlg.nMinPage = lMin
    tPrintDlg.nMaxPage = lMax
    tPrintDlg.nCopies = lCopies
    lApiReturn = PrintDlg(tPrintDlg)
    
    Select Case lApiReturn
        Case 0      ' usuario canceló
            If bCancelError Then
                Err.Raise 2001
                Exit Sub
            End If
        Case 1      ' usuario pulsó 'Aceptar'
            lFromPage = tPrintDlg.nFromPage
            lToPage = tPrintDlg.nToPage
            lMin = tPrintDlg.nMinPage
            lMax = tPrintDlg.nMaxPage
            lCopies = tPrintDlg.nCopies
        Case Else   ' error
            lExtendedError = CommDlgExtendedError
    End Select

    Exit Sub

ShowPrinterError:
    Exit Sub
End Sub

' muestra diálogo de guardar fichero
Public Sub ShowSave()

    ShowFileDialog 2

End Sub

Public Property Get FileName() As String
    
    FileName = sFileName

End Property

Public Property Let FileName(ByVal vNewValue As String)
    
    sFileName = vNewValue

End Property

Public Property Let Filter(ByVal vNewValue As String)
    
    sFilter = vNewValue

End Property

Public Property Get Action() As Integer
    
    Action = iAction

End Property

Public Property Get FilterIndex() As Integer
    
    FilterIndex = iFilterIndex

End Property

Public Property Let FilterIndex(ByVal vNewValue As Integer)
    
    iFilterIndex = vNewValue

End Property

Public Property Get CancelError() As Boolean
    
    CancelError = bCancelError

End Property

Public Property Let CancelError(ByVal vNewValue As Boolean)
    
    bCancelError = vNewValue

End Property

Public Property Get Color() As Long
    
    Color = lColor

End Property

Public Property Let Color(ByVal vNewValue As Long)
    
    lColor = vNewValue

End Property

Public Property Get Copies() As Long
    
    Copies = lCopies

End Property

Public Property Let Copies(ByVal vNewValue As Long)
    
    lCopies = vNewValue

End Property

Public Property Get DefaultExt() As String
    
    DefaultExt = sDefaultExt

End Property

Public Property Let DefaultExt(ByVal vNewValue As String)
    
    sDefaultExt = vNewValue

End Property

Public Property Get DialogTitle() As String
    
    DialogTitle = sDialogTitle

End Property

Public Property Let DialogTitle(ByVal vNewValue As String)
    
    sDialogTitle = vNewValue

End Property

Public Property Get Flags() As Long
    
    Flags = lFlags

End Property

Public Property Let Flags(ByVal vNewValue As Long)
    
    lFlags = vNewValue

End Property

Public Property Get FontBold() As Boolean
    
    FontBold = bFontBold

End Property

Public Property Let FontBold(ByVal vNewValue As Boolean)
    
    bFontBold = vNewValue

End Property

Public Property Get FontItalic() As Boolean
    
    FontItalic = bFontItalic

End Property

Public Property Let FontItalic(ByVal vNewValue As Boolean)
    
    bFontItalic = vNewValue

End Property

Public Property Get FontName() As String
    
    FontName = sFontName

End Property

Public Property Let FontName(ByVal vNewValue As String)
    
    sFontName = vNewValue

End Property

Public Property Get FontSize() As Long
    
    FontSize = lFontSize

End Property

Public Property Let FontSize(ByVal vNewValue As Long)
    
    lFontSize = vNewValue

End Property

Public Property Get FontStrikethru() As Boolean
    
    FontStrikethru = bFontStrikethru

End Property

Public Property Let FontStrikethru(ByVal vNewValue As Boolean)
    
    bFontStrikethru = vNewValue

End Property

Public Property Get FontUnderline() As Boolean
    
    FontUnderline = bFontUnderline

End Property

Public Property Let FontUnderline(ByVal vNewValue As Boolean)
    
    bFontUnderline = vNewValue

End Property

Public Property Get FromPage() As Long
    
    FromPage = lFromPage

End Property

Public Property Let FromPage(ByVal vNewValue As Long)
    
    lFromPage = vNewValue

End Property

Public Property Get hDC() As Long
    
    hDC = lhDC

End Property

Public Property Let hDC(ByVal vNewValue As Long)
    
    lhDC = vNewValue

End Property

Public Property Get HelpCommand() As Long
    
    HelpCommand = lHelpCommand

End Property

Public Property Let HelpCommand(ByVal vNewValue As Long)
    
    lHelpCommand = vNewValue

End Property

Public Property Get HelpContext() As String
    
    HelpContext = sHelpContext

End Property

Public Property Let HelpContext(ByVal vNewValue As String)
    
    sHelpContext = vNewValue

End Property

Public Property Get HelpFile() As String
    
    HelpFile = sHelpFile

End Property

Public Property Let HelpFile(ByVal vNewValue As String)
    
    sHelpFile = vNewValue

End Property

Public Property Get HelpKey() As String
    
    HelpKey = sHelpKey

End Property

Public Property Let HelpKey(ByVal vNewValue As String)
    
    sHelpKey = vNewValue

End Property

Public Property Get InitDir() As String
    
    InitDir = sInitDir

End Property

Public Property Let InitDir(ByVal vNewValue As String)
    
    sInitDir = vNewValue

End Property

Public Property Get Max() As Long
    
    Max = lMax

End Property

Public Property Let Max(ByVal vNewValue As Long)
    
    lMax = vNewValue

End Property

Public Property Get MaxFileSize() As Long
    
    MaxFileSize = lMaxFileSize

End Property

Public Property Let MaxFileSize(ByVal vNewValue As Long)
    
    lMaxFileSize = vNewValue

End Property

Public Property Get Min() As Long
    
    Min = lMin

End Property

Public Property Let Min(ByVal vNewValue As Long)
    
    lMin = vNewValue

End Property

Public Property Get Object() As Object
    
    Object = objObject

End Property

Public Property Let Object(vNewValue As Object)
    
    objObject = vNewValue

End Property

Public Property Get PrinterDefault() As Integer
    
    PrinterDefault = iPrinterDefault

End Property

Public Property Let PrinterDefault(ByVal vNewValue As Integer)
    
    iPrinterDefault = vNewValue

End Property

Public Property Get ToPage() As Long
    
    ToPage = lToPage

End Property

Public Property Let ToPage(ByVal vNewValue As Long)
    
    lToPage = vNewValue

End Property

Public Property Get FileTitle() As String
    
    FileTitle = sFileTitle

End Property

Public Property Let FileTitle(ByVal vNewValue As String)
    
    sFileTitle = vNewValue

End Property

Public Property Get APIReturn() As Long
    
    APIReturn = lApiReturn

End Property

Public Property Get ExtendedError() As Long
    
    ExtendedError = lExtendedError

End Property

' elimina Chr(0) finales de una cadena
Private Function sLeftOfNull(ByVal sIn As String)
    Dim lNullPos As Long
    
    sLeftOfNull = sIn
    lNullPos = InStr(sIn, Chr(0))
    If lNullPos > 0 Then
        sLeftOfNull = Mid(sIn, 1, lNullPos - 1)
    End If
    
End Function

' prepara una cadena para usarla como filtro en las APIs de diálogos de ficheros
Private Function sAPIFilter(ByVal sIn As String) As String
    Dim lChrNdx As Long
    Dim sOneChr As String, sOutStr As String
    
    ' convierte '|' en nulos
    For lChrNdx = 1 To Len(sIn)
        sOneChr = Mid(sIn, lChrNdx, 1)
        If sOneChr = "|" Then
            sOutStr = sOutStr & Chr(0)
        Else
            sOutStr = sOutStr & sOneChr
        End If
    Next
    
    sOutStr = sOutStr & Chr(0)
    sAPIFilter = sOutStr
    
End Function

' convierte un 'array' de bytes en una cadena
Private Function sByteArrayToString(abBytes() As Byte) As String
    Dim lBytePoint As Long, lByteVal As Long
    Dim sOut As String
    
    lBytePoint = LBound(abBytes)
    Do While lBytePoint <= UBound(abBytes)
        lByteVal = abBytes(lBytePoint)
        
        If lByteVal = 0 Then
            sByteArrayToString = sOut
            Exit Function
        Else
            sOut = sOut & Chr(lByteVal)
        End If
        
        lBytePoint = lBytePoint + 1
    Loop
    
    sByteArrayToString = sOut
    
End Function

' muestra el diálogo de ficheros
Private Sub ShowFileDialog(ByVal iAction As Integer)
    Dim tOpenFile As OpenFilename
    Dim lMaxSize As Long
    Dim sFileNameBuff As String, sFileTitleBuff As String
    
    On Error GoTo ShowFileDialogError
    
    iAction = iAction
    lApiReturn = 0
    lExtendedError = 0
    
    tOpenFile.lStructSize = Len(tOpenFile)
    tOpenFile.hwndOwner = lhDC
    tOpenFile.lpstrFilter = sAPIFilter(sFilter)
    tOpenFile.iFilterIndex = iFilterIndex
    If lMaxFileSize > 0 Then
        lMaxSize = lMaxFileSize
    Else
        lMaxSize = 255
    End If
    sFileNameBuff = sFileName
    ' rellenamos con espacios
    Do While Len(sFileNameBuff) < lMaxSize - 1
        sFileNameBuff = sFileNameBuff & " "
    Loop
    sFileNameBuff = Left(sFileNameBuff, lMaxSize - 1)
    sFileNameBuff = sFileNameBuff & Chr(0)
    tOpenFile.lpstrFile = sFileNameBuff
    tOpenFile.nMaxFile = lMaxSize
    sFileTitleBuff = sFileTitle
    ' rellenamos con espacios
    Do While Len(sFileTitleBuff) < lMaxSize - 1
        sFileTitleBuff = sFileTitleBuff & " "
    Loop
    sFileTitleBuff = Left(sFileTitleBuff, lMaxSize - 1)
    sFileTitleBuff = sFileTitleBuff & Chr(0)
    tOpenFile.lpstrFileTitle = sFileTitleBuff
    tOpenFile.lpstrInitialDir = sInitDir
    tOpenFile.lpstrTitle = sDialogTitle
    tOpenFile.Flags = lFlags
    tOpenFile.lpstrDefExt = sDefaultExt
        
    Select Case iAction
        Case 1      ' ShowOpen
            lApiReturn = GetOpenFileName(tOpenFile)
        Case 2      ' ShowSave
            lApiReturn = GetSaveFileName(tOpenFile)
        Case Else
            Exit Sub
    End Select
    
    Select Case lApiReturn
        Case 0      ' usuario canceló
            If bCancelError Then
                Err.Raise 2001
                Exit Sub
            End If
        Case 1      ' usuario seleccionó (o introdujo) un fichero
            sFileName = sLeftOfNull(tOpenFile.lpstrFile)
            sFileTitle = sLeftOfNull(tOpenFile.lpstrFileTitle)
        Case Else   ' error
            lExtendedError = CommDlgExtendedError
    End Select
    
    Exit Sub

ShowFileDialogError:
    Exit Sub
End Sub