mcommondialog.bas

智能邮件管理信息系统

    PSD_INHUNDREDTHSOFMILLIMETERS = &H8
    PSD_DISABLEMARGINS = &H10
    PSD_DISABLEPRINTER = &H20
    PSD_NoWarning = &H80
    PSD_DISABLEORIENTATION = &H100
    PSD_ReturnDefault = &H400
    PSD_DISABLEPAPER = &H200
    PSD_ShowHelp = &H800
    PSD_EnablePageSetupHook = &H2000
    PSD_EnablePageSetupTemplate = &H8000
    PSD_EnablePageSetupTemplateHandle = &H20000
    PSD_EnablePagePaintHook = &H40000
    PSD_DisablePagePainting = &H80000
End Enum


Public Enum EPageSetupUnits
    epsuInches
    epsuMillimeters
End Enum

' Common dialog errors

Private Declare Function CommDlgExtendedError Lib "COMDLG32" () As Long

Public Enum EDialogError
    CDERR_DIALOGFAILURE = &HFFFF

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

    PDERR_PRINTERCODES = &H1000&
    PDERR_SETUPFAILURE = &H1001&
    PDERR_PARSEFAILURE = &H1002&
    PDERR_RETDEFFAILURE = &H1003&
    PDERR_LOADDRVFAILURE = &H1004&
    PDERR_GETDEVMODEFAIL = &H1005&
    PDERR_INITFAILURE = &H1006&
    PDERR_NODEVICES = &H1007&
    PDERR_NODEFAULTPRN = &H1008&
    PDERR_DNDMMISMATCH = &H1009&
    PDERR_CREATEICFAILURE = &H100A&
    PDERR_PRINTERNOTFOUND = &H100B&
    PDERR_DEFAULTDIFFERENT = &H100C&

    CFERR_CHOOSEFONTCODES = &H2000&
    CFERR_NOFONTS = &H2001&
    CFERR_MAXLESSTHANMIN = &H2002&

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

    CCERR_CHOOSECOLORCODES = &H5000&
End Enum

' Hook and notification support:
Private Type NMHDR
    hwndFrom As Long
    idfrom As Long
    code As Long
End Type
'// Structure used for all file based OpenFileName notifications
Private Type OFNOTIFY
    hdr As NMHDR
    lpOFN As Long           ' Long pointer to OFN structure
    pszFile As String ';        // May be NULL
End Type

'// Structure used for all object based OpenFileName notifications
Private Type OFNOTIFYEX
    hdr As NMHDR
    lpOFN As Long       ' Long pointer to OFN structure
    psf As Long
    LPVOID As Long          '// May be NULL
End Type

Private Type OFNOTIFYshort
    hdr As NMHDR
    lpOFN As Long
End Type

' Messages:
Private Const WM_DESTROY = &H2
Private Const WM_NOTIFY = &H4E
Private Const WM_NCDESTROY = &H82
Private Const WM_GETDLGCODE = &H87
Private Const WM_INITDIALOG = &H110
Private Const WM_COMMAND = &H111
Private Const WM_USER = &H400


' Notification codes:
Private Const H_MAX As Long = &HFFFF + 1
Private Const CDN_FIRST = (H_MAX - 601)
Private Const CDN_LAST = (H_MAX - 699)

'// Notifications when Open or Save dialog status changes
Private Const CDN_INITDONE = (CDN_FIRST - &H0)
Private Const CDN_SELCHANGE = (CDN_FIRST - &H1)
Private Const CDN_FOLDERCHANGE = (CDN_FIRST - &H2)
Private Const CDN_SHAREVIOLATION = (CDN_FIRST - &H3)
Private Const CDN_HELP = (CDN_FIRST - &H4)
Private Const CDN_FILEOK = (CDN_FIRST - &H5)
Private Const CDN_TYPECHANGE = (CDN_FIRST - &H6)
Private Const CDN_INCLUDEITEM = (CDN_FIRST - &H7)

' Messages which can be sent to the standard dialog elements
Private Const CDM_FIRST = (WM_USER + 100)
Private Const CDM_LAST = (WM_USER + 200)

Private Const CDM_GETSPEC = (CDM_FIRST + &H0)
Private Const CDM_GETFILEPATH = (CDM_FIRST + &H1)
Private Const CDM_GETFOLDERPATH = (CDM_FIRST + &H2)
Private Const CDM_GETFOLDERIDLIST = (CDM_FIRST + &H3)
Private Const CDM_SETCONTROLTEXT = (CDM_FIRST + &H4)
Private Const CDM_HIDECONTROL = (CDM_FIRST + &H5)
Private Const CDM_SETDEFEXT = (CDM_FIRST + &H6)

' IDs for standard common dialog controls
Private Const ID_OPEN = &H1  'Open or Save button
Private Const ID_CANCEL = &H2 'Cancel Button
Private Const ID_HELP = &H40E 'Help Button
Private Const ID_READONLY = &H410 'Read-only check box
Private Const ID_FILETYPELABEL = &H441 'Files of type label
Private Const ID_FILELABEL = &H442 'File name label
Private Const ID_FOLDERLABEL = &H443 'Look in label
Private Const ID_LIST = &H461 'Parent of file list
Private Const ID_FORMAT = &H470 'File type combo box
Private Const ID_FOLDER = &H471 'Folder combo box
Private Const ID_FILETEXT = &H480 'File name text box

Private Const DWL_MSGRESULT = 0
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

' ==========================================================================
' Implementation:
' ==========================================================================

' Array of custom colors lasts for life of app
Private alCustom(0 To 15) As Long, fNotFirst As Boolean
Public Enum EPrintRange
    eprAll
    eprPageNumbers
    eprSelection
End Enum
Private m_lApiReturn As Long
Private m_lExtendedError As Long
Private m_dvmode As DevMode
Private m_oEventSink As Object

Public Function DialogHook(ByVal hDlg As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long)
Dim tNMH As NMHDR
Dim tOFNs As OFNOTIFYshort
Dim tOF As OPENFILENAME

    If Not (m_oEventSink Is Nothing) Then

        Select Case msg
        Case WM_INITDIALOG
            DialogHook = m_oEventSink.InitDialog(hDlg)

        Case WM_NOTIFY
            CopyMemory tNMH, ByVal lParam, Len(tNMH)
            Select Case tNMH.code
            Case CDN_SELCHANGE
                ' Changed selected file:
                DialogHook = m_oEventSink.FileChange(hDlg)
            Case CDN_FOLDERCHANGE
                ' Changed folder:
                DialogHook = m_oEventSink.FolderChange(hDlg)
            Case CDN_FILEOK
                ' Clicked OK:
                If Not m_oEventSink.ConfirmOK() Then
                    SetWindowLong hDlg, DWL_MSGRESULT, 1
                    DialogHook = 1
                Else
                    SetWindowLong hDlg, DWL_MSGRESULT, 0
                End If
            Case CDN_HELP
                ' Help clicked
            Case CDN_TYPECHANGE
                DialogHook = m_oEventSink.TypeChange(hDlg)
            Case CDN_INCLUDEITEM
                ' Hmmm
            End Select

        Case WM_COMMAND
            m_oEventSink.WMCommand hDlg, wParam, lParam

        Case WM_DESTROY
            Debug.Print "WM_DESTROY"
            m_oEventSink.DialogClose


        End Select
    End If
End Function


Public Property Get APIReturn() As Long
    'return object's APIReturn property
    APIReturn = m_lApiReturn
End Property
Public Property Get ExtendedError() As Long
    'return object's ExtendedError property
    ExtendedError = m_lExtendedError
End Property

Private Sub Class_Initialize()
#If fComponent Then
    InitColors
#End If
End Sub

Function VBGetOpenFileName2(Filename As String, _
                           Optional FileTitle As String, _
                           Optional FileMustExist As Boolean = True, _
                           Optional MultiSelect As Boolean = False, _
                           Optional ReadOnly As Boolean = False, _
                           Optional HideReadOnly As Boolean = False, _
                           Optional Filter As String = "All (*.*)| *.*", _
                           Optional FilterIndex As Long = 1, _
                           Optional InitDir As String, _
                           Optional DlgTitle As String, _
                           Optional DefaultExt As String, _
                           Optional Owner As Long = -1, _
                           Optional flags As Long = 0, _
                           Optional Hook As Boolean = False, _
                           Optional hInstance As Long = 0, _
                           Optional TemplateName As Long = 0 _
                        ) As Boolean
Dim opfile As OPENFILENAME, s As String, afFlags As Long

   m_lApiReturn = 0
   m_lExtendedError = 0

   With opfile
      .lStructSize = Len(opfile)

      ' Add in specific flags and strip out non-VB flags

      .flags = (-FileMustExist * OFN_FILEMUSTEXIST) Or _
             (-MultiSelect * OFN_ALLOWMULTISELECT) Or _
              (-ReadOnly * OFN_READONLY) Or _
              (-HideReadOnly * OFN_HIDEREADONLY)
      .flags = .flags And Not OFN_ENABLEHOOK

      ' Owner can take handle of owning window
      If Owner <> -1 Then .hwndOwner = Owner
      ' InitDir can take initial directory string
      .lpstrInitialDir = InitDir
      ' DefaultExt can take default extension
      .lpstrDefExt = DefaultExt
      ' DlgTitle can take dialog box title
      .lpstrTitle = DlgTitle

      If (.flags And OFN_ALLOWMULTISELECT) = OFN_ALLOWMULTISELECT Then
         .flags = .flags Or OFN_EXPLORER
      End If

      If flags And OFN_ENABLETEMPLATE Then
         If hInstance > 0 Then
            .flags = .flags Or OFN_ENABLETEMPLATE
            .hInstance = hInstance
            .lpTemplateName = TemplateName
         End If
      End If

   ' To make Windows-style filter, replace | and : with nulls
   Dim ch As String, i As Integer
   For i = 1 To Len(Filter)
      ch = Mid$(Filter, i, 1)
      If ch = "|" Or ch = ":" Then
          s = s & vbNullChar
      Else
          s = s & ch
      End If
   Next

   ' Put double null at end
   s = s & vbNullChar & vbNullChar
   .lpstrFilter = s
   .nFilterIndex = FilterIndex

   ' Pad file and file title buffers to maximum path
   If (.flags And OFN_ALLOWMULTISELECT) = OFN_ALLOWMULTISELECT Then
      s = Filename & String$(8192 - Len(Filename), 0)
      .lpstrFile = s
      .nMaxFile = 8192
      s = FileTitle & String$(8192 - Len(FileTitle), 0)
      .lpstrFileTitle = s
      .nMaxFileTitle = 8192
   Else
       s = Filename & String$(MAX_PATH - Len(Filename), 0)
      .lpstrFile = s
      .nMaxFile = MAX_PATH
      s = FileTitle & String$(MAX_FILE - Len(FileTitle), 0)
      .lpstrFileTitle = s
      .nMaxFileTitle = MAX_FILE
   End If
   ' All other fields set to zero

   m_lApiReturn = GetOpenFileName(opfile)

   Set m_oEventSink = Nothing

   Select Case m_lApiReturn
   Case 1
      ' Success
      VBGetOpenFileName2 = True

      If (.flags And OFN_ALLOWMULTISELECT) = OFN_ALLOWMULTISELECT Then
         Filename = .lpstrFile
      Else
         Filename = StrZToStr(.lpstrFile)
         FileTitle = StrZToStr(.lpstrFileTitle)
      End If
      flags = .flags
      ' Return the filter index
      FilterIndex = .nFilterIndex
      ' Look up the filter the user selected and return that
      Filter = FilterLookup(.lpstrFilter, FilterIndex)
      If (.flags And OFN_READONLY) Then ReadOnly = True

   Case 0
      ' Cancelled
      VBGetOpenFileName2 = False
      Filename = ""
      FileTitle = ""
      flags = 0
      FilterIndex = -1
      Filter = ""

   Case Else
      ' Extended error
      m_lExtendedError = CommDlgExtendedError()
      VBGetOpenFileName2 = False
      Filename = ""
      FileTitle = ""
      flags = 0
      FilterIndex = -1
      Filter = ""

   End Select

   Set m_oEventSink = Nothing
End With

End Function

Function VBGetOpenFileName(Filename As String, _
                           Optional FileTitle As String, _
                           Optional FileMustExist As Boolean = True, _
                           Optional MultiSelect As Boolean = False, _
                           Optional ReadOnly As Boolean = False, _
                           Optional HideReadOnly As Boolean = False, _
                           Optional Filter As String = "All (*.*)| *.*", _
                           Optional FilterIndex As Long = 1, _
                           Optional InitDir As String, _
                           Optional DlgTitle As String, _
                           Optional DefaultExt As String, _
                           Optional Owner As Long = -1, _
                           Optional flags As Long = 0, _
                           Optional Hook As Boolean = False _
                        ) As Boolean
   flags = flags And Not OFN_ENABLETEMPLATE
   VBGetOpenFileName = VBGetOpenFileName2( _
            Filename, FileTitle, FileMustExist, MultiSelect, _
            ReadOnly, HideReadOnly, Filter, FilterIndex, InitDir, DlgTitle, _
            DefaultExt, Owner, flags, Hook)
End Function
Private Function lHookAddress(lPtr As Long) As Long
    'Debug.Print lPtr
    lHookAddress = lPtr
End Function
Private Function StrZToStr(s As String) As String