GESTION DE DOCUMENTS OUVERTS DANS UNE APPLICATION

'************************************************************************'
'************************************************************************'
'**                                                                    **'
'**              DOCUMENT IN APPLICATION MANAGEMENT CLASS              **'
'**                                                                    **'
'************************************************************************'
'************************************************************************'



'----------------------------   ATTRIBUTES   ----------------------------'
'Author = Santiago Diez (santiago.diez@free.fr)
'Website = http://santiago.diez.free.fr
'Webpage = http://www.vbfrance.com/code.aspx?ID=38402
'Date = 12 JULY 2006  12:47
'Version = 2.0

'----------------------------   COPYRIGHT   -----------------------------'
'I worked on  that module for  me and for  you. You are  allowed to do the
'following  as long  as you  specify my  name and  website  (please  don't
'laught, one day it will be a real website):
'- use the code, partially or totally
'- change the code partially
'If you ever improve the features of  that module, fix any bug or find any
'way to make it better, please write to me for feedback.

'---------------------------   DESCRIPTION   ----------------------------'
'This class module provides  you with a powerfull way to  manage the files
'you open in your application.
'Each instance  of objDocInApp  is able  to communicate  with the  user to
'select a file to open or to save  to. It deals with read-only or modified
'documents and prompt the user for any decision to take.
'The class does  not actualy open or save documents,  each application has
'its  own  way  to  read  or write  them.  Your  application  provide  the
'procedures for  reading and writing  files, all  the rest is  provided by
'this powerfull tool.
'It's able to:
'- prompt the user to select a file to open
'- prompt the user to save changes before close, exit or open another file
'- prompt the user to select the location to save a file to (or save as)
'- force the user to save as if read-only attributes have been detected
'- display error messages if your own  application was not able to create,
'open, reopen or save documents.

'---------------------------   HOW IT WORKS   ---------------------------'
'The class is  based on the Microsoft  Common Dialog Control.
'Create an  object for each  file you open  in your application.  Call the
'class methods for the create, open, modify, save and close events and use
'the class events to code creating, opening, saving and closing files.

'--------------   PUBLIC EVENTS, PROPERTIES AND METHODS   ---------------'
'Call SetDialog(CommonDialogControl As Control, [DialogOptions As
'               dlgOptions])
'Call SetButtons([ArrayOfButtonsReOpen], [ArrayOfButtonsSave],
'                [ArrayOfButtonsSaveAs], [ArrayOfButtonsClose],
'                [ArrayOfButtonsProperties])
'Call SetLanguage([ReopenWarning], [ModifiedWarning], [ReadOnlyWarning],
'                 [OpenCaption], [SaveAsCaption], [ReadOnlyCaption],
'                 [NewError], [OpenError], [SaveError], [CloseError],
'                 [DocumentDefaultName], [DocumentDefaultExt],
'                 [DocumentDefaultFilter])
'Property Get Path() As String
'Property Get Name() As String
'Property Get Ext() As String
'Property Get ReadOnly() As String
'Boolean = Request(rType As RequestType, [FileName], [DefaultExt],
'                  [InitDir], [Filter], [FilterIndex])
'Call Confirm(cType As ConfirmationType)
'Call Modify

'-----------------------------   EXAMPLES   -----------------------------'
'Say, you want a form that display, modify and save documents.
'First reference COMDLG32.OCX in your project  components and add a Common
'Dialog Control (CommonDialog1) to your form.
'First reference COMDLG32.OCX in your project  components and add a Common
'Dialog  Control  (CommonDialog1) to  your  form.  Add buttons  to  create
'(btn_Create), open  (btn_Reopen), reopen  (btn_reopen), save  (btn_Save),
'save as (btn_SaveAs) and close (btn_Close).
'Then your form code is nothing but that:
'
'   Private WithEvents DocInApp As objDocInApp
'   Private Sub Form_Load()
'       Set DocInApp = New objDocInApp
'       Call DocInApp.SetDialogBox(CommonDialog1)
'   End Sub
'   Private Sub btn_Create_Click()
'       Call DocInApp.AskNew
'   End Sub
'   Private Sub btn_Open_Click()
'       Call DocInApp.AskOpen
'   End Sub
'   Private Sub btn_reopen_Click()
'       Call DocInApp.AskReOpen
'   End Sub
'   Private Sub btn_Save_Click()
'       Call DocInApp.AskSave
'   End Sub
'   Private Sub btn_SaveAs_Click()
'       Call DocInApp.AskSave(True)
'   End Sub
'   Private Sub btn_Close_Click()
'       Call DocInApp.AskClose
'   End Sub
'   Private Sub Form_Unload(Cancel As Integer)
'       If Not DocInApp.AskClose Then Cancel = 1
'   End Sub
'   Private Sub DocInApp_CreateDoc(Title As String)
'       'Write here the way you create a new document (blank, not saved)
'       'Do not consider any user interaction, DocInApp does it for you
'       On Error GoTo Err_Unattend
'       'Do not forgot to confirm creation
'       DocInApp.ConfirmCreate
'   Err_Unattend:
'       'Let DocInApp display the error message
'   End Sub
'   Private Sub DocInApp_OpenDoc(Path As String, Title As String)
'       'Write here the way you display a file from address "Path"
'       'Do not consider any user interaction, DocInApp does it for you
'       On Error GoTo Err_Unattend
'       'Do not forgot to confirm opening
'       DocInApp.ConfirmOpen
'   Err_Unattend:
'       'Let DocInApp display the error message
'   End Sub
'   Private Sub DocInApp_SaveDoc(Path As String, Title As String)
'       'Write here the way you save a document to address "Path"
'       'Do not consider any user interaction, DocInApp does it for you
'       On Error GoTo Err_Unattend
'       'Do not forgot to confirm save
'       DocInApp.ConfirmSave
'   Err_Unattend:
'       'Let DocInApp display the error message
'   End Sub
'   Private Sub DocInApp_CloseDoc()
'       'Write here the way you close a document
'       'Do not consider any user interaction, DocInApp does it for you
'       On Error GoTo Err_Unattend
'       'Do not forgot to confirm close
'       DocInApp.ConfirmClose
'   Err_Unattend:
'       'Let DocInApp display the error message
'   End Sub

'-------------------------------   BUGS   -------------------------------'
'If your application raises an error  while creating, opening or reopening
'a document, it is asked to close it.
'If your application  raises an error while closing the  document, you may
'have a half-created or half-opened document displayed.
'In both cases, an error message is displayed.
'Options "dlgNoReadOnlySelect" only works for save as dialog box. It means
'that "objDocInApp"  may return  a read-only  or right-protected  document
'after a "AskOpen"  method and without being  aware of it. The  bug occurs
'when invoquing the "AskSave" method.

'-----------------------------   SOURCES   ------------------------------'
'MSDN January 2001

'------------------------   REQUIRED LIBRARIES   ------------------------'
'msvbvm60.dll, VB6.OLB, VB6FR.DLL (Always required)
'COMDLG32.OCX (Common Dialog Control)

'--------------------   REQUIRED MODULES AND FORMS   --------------------'
'None

'-----------------------------   OPTIONS   ------------------------------'
Option Base 0
Option Compare Text
Option Explicit



'+----------------------------------------------------------------------+'
'+                              CONSTANTS                               +'
'+----------------------------------------------------------------------+'



'+----------------------------------------------------------------------+'
'+                           TYPES AND ENUMS                            +'
'+----------------------------------------------------------------------+'
'Enum: dlgOptions
'   Enumeration of the options to setup the open/save file dialog box.
'------------------------------------------------------------------------'
Enum dlgOptions
    '(Open/Save) Dialog box will not follow shell links (shortcuts)
    dlgNoFollowLinks = cdlOFNNoDereferenceLinks
    '(Open/Save) Dialog box will not modify CurDir value
    dlgNoChangeCurDir = cdlOFNNoChangeDir
    '(Open) Dialog box will not display read-only check box
    dlgHideReadOnlyCheckBox = cdlOFNHideReadOnly
    '(Open) Dialog box will check read-only check box
    dlgCheckReadOnly = cdlOFNReadOnly
    '(Open) User will be prompted to create inexistent file
    dlgCreatePrompt = cdlOFNCreatePrompt
    '(Save) User will be prompted to overwrite existing file
    dlgOverWritePrompt = cdlOFNOverwritePrompt
End Enum
'------------------------------------------------------------------------'
'Enum: RequestType
'   Enumeration of the request types accessible to application.
'------------------------------------------------------------------------'
Enum RequestType
    reqNew
    reqOpen
    reqReOpen
    reqSave
    reqSaveAs
    reqClose
    reqProperties
End Enum
'------------------------------------------------------------------------'
'Enum: ConfirmType
'   Enumeration of the events confirmation accessible to application.
'------------------------------------------------------------------------'
Enum ConfirmationType
    confNew
    confOpen
    confSave
    confClose
End Enum



'+----------------------------------------------------------------------+'
'+                                EVENTS                                +'
'+----------------------------------------------------------------------+'
'   Events  are raised to  notify the  application to actually  display or
'   close documents or perfom read/write operations on files.
'------------------------------------------------------------------------'
'Event: CreateDoc
'   Parameters: None
'------------------------------------------------------------------------'
Event NewDoc()
'------------------------------------------------------------------------'
'Event: OpenDoc
'   Parameters: Path: (String) The absolute path to a specific file.
'------------------------------------------------------------------------'
Event OpenDoc(Path As String)
'------------------------------------------------------------------------'
'Event: SaveDoc
'   Parameters: Path: (String) The absolute path to a specific file.
'------------------------------------------------------------------------'
Event SaveDoc(Path As String)
'------------------------------------------------------------------------'
'Event: CloseDoc
'   Parameters: None
'------------------------------------------------------------------------'
Event CloseDoc()



'+----------------------------------------------------------------------+'
'+                              PROPERTIES                              +'
'+----------------------------------------------------------------------+'
'Common Dialog Control used for dialog boxes (write only).
'------------------------------------------------------------------------'
Private ComDlg As Control
'------------------------------------------------------------------------'
'Buttons of the application managed by the object.
'------------------------------------------------------------------------'
Private btnReopen
Private btnSave
Private btnSaveAs
Private btnClose
Private btnProp
'------------------------------------------------------------------------'
'Status of the document in calling application (write only).
'------------------------------------------------------------------------'
Private Created As Boolean
Private Opened As Boolean
Private Modified As Boolean
Private Saved As Boolean
Private Closed As Boolean
'------------------------------------------------------------------------'
'Document properties in calling application (read only).
'------------------------------------------------------------------------'
Private docPath As String
Private docName As String
Private docExt As String
Private docReadOnly As Boolean
'------------------------------------------------------------------------'
'Next document properties (neither read nor write).
'------------------------------------------------------------------------'
Private newPath As String
Private newName As String
Private newExt As String
Private newReadOnly As Boolean
'------------------------------------------------------------------------'
'Captions and messages of the interface (write only).
'------------------------------------------------------------------------'
Private wrnReopen As String
Private wrnModified As String
Private wrnReadOnly As String
Private captOpen As String
Private captSaveAs As String
Private captReadOnly As String
Private errNew As String
Private errOpen As String
Private errSave As String
Private errClose As String
Private docDefaultName As String
Private docDefaultExt As String
Private docDefaultFilter As String
'------------------------------------------------------------------------'
'Properties accessible to the application.
'------------------------------------------------------------------------'
Property Get Path() As String
    Path = docPath
End Property
Property Get Name() As String
    Name = docName
End Property
Property Get Ext() As String
    Ext = docExt
End Property
Property Get ReadOnly() As String
    ReadOnly = docReadOnly
End Property



'+----------------------------------------------------------------------+'
'+                              INITIALIZE                              +'
'+----------------------------------------------------------------------+'
'Sub: Class_Initialize
'   Executed when an instance of the class is created.
'   Parameters: None
'------------------------------------------------------------------------'
Private Sub Class_Initialize()
    'Set default language
    SetLanguage _
        "If you reopen a file, all changes will be lost." & vbCrLf & _
            "Are you sure you want to reopen %0?", _
        "The containt of file %0 has been modified." & vbCrLf & _
            "Would you like to save changes?", _
        "%0 is read-only." & vbCrLf & _
            "To save a copy, clic OK and give the document a differen" & _
            "t name in the Save as dialog box.", _
        "Open", "Save as", "Read-only", _
        "Unable to create %0.", _
        "Unable to open %0.", _
        "Unable to save %0.", _
        "Unable to close %0.", _
        "New document", "txt", "All files (*.*)|*.*"
End Sub

'------------------------------------------------------------------------'
'Sub: SetDialog
'   Set the Common Dialog Control and  options used for the open/save file
'   dialog boxes.
'   Parameters: CommonDialogControl: The reference to a control.
'               DialogOptions (Optional):   The  options   to  setup   the
'                   open/save  file dialog  box, see  Enum dlgOptions  for
'                   more informations.
'------------------------------------------------------------------------'
Sub SetDialog(CommonDialogControl As Control, Optional DialogOptions As _
dlgOptions)
    DialogOptions = dlgOverWritePrompt
    On Error Resume Next
    Set ComDlg = CommonDialogControl
    ComDlg.CancelError = True
    ComDlg.Flags = cdlOFNExplorer _
                 + cdlOFNFileMustExist _
                 + cdlOFNNoReadOnlyReturn _
                 + DialogOptions
End Sub

'------------------------------------------------------------------------'
'Sub: SetButtons
'   Set  the buttons  managed by  the  object. objDocInApp  can enable  or
'   disable controls depending on the document status.
'   Parameters: ArrayOfButtonsReOpen (Optional):  An array of  controls of
'                   the application that are used to reopen documents
'               ArrayOfButtonsSave (Optional): An array of controls of the
'                   application that are used to save documents
'               ArrayOfButtonsSaveAs (Optional):  An array of  controls of
'                   the application that are used to save documents as
'               ArrayOfButtonsClose (Optional):  An array  of controls  of
'                   the application that are used to close documents
'               ArrayOfButtonsProperties (Optional): An  array of controls
'                   of  the application  that are  used  to get  documents
'                   properties
'------------------------------------------------------------------------'
Sub SetButtons(Optional ArrayOfButtonsReOpen, Optional _
ArrayOfButtonsSave, Optional ArrayOfButtonsSaveAs, Optional _
ArrayOfButtonsClose, Optional ArrayOfButtonsProperties)
    On Error Resume Next
    btnReopen = ArrayOfButtonsReOpen
    btnSave = ArrayOfButtonsSave
    btnSaveAs = ArrayOfButtonsSaveAs
    btnClose = ArrayOfButtonsClose
    btnProp = ArrayOfButtonsProperties
End Sub

'------------------------------------------------------------------------'
'Sub: SetLanguage
'   Set the messages  displayed by the object. To display  the name of the
'   document in a string, use %0.
'   Parameters: ReopenWarning (Optional):  The message displayed  before a
'                   document is reopened
'               ModifiedWarning (Optional):  The  message  displayed  when
'                   closing a modified not saved document
'               ReadOnlyWarning (Optional):  The  message  displayed  when
'                   saving a read-only document
'               OpenCaption (Optional):  The caption  of  the "Open"  file
'                   dialog box
'               SaveAsCaption (Optional):  The caption  of  the "Save  as"
'                   file dialog box
'               ReadOnlyCaption (Optional): The caption of  a file that is
'                   open with read-only attributes
'               NewError (Optional):    The   message    displayed    when
'                   application was unable to create a new document
'               OpenError (Optional):   The    message   displayed    when
'                   application was unable to open a document
'               SaveError (Optional):   The    message   displayed    when
'                   application was unable to save a document
'               CloseError (Optional):   The   message    displayed   when
'                   application was unable to close a document
'               DocumentDefaultName (Optional): The default  name given to
'                   new document
'               DocumentDefaultExt (Optional): The default extension given
'                   to new document
'               DocumentDefaultFilter (Optional): The  default filter used
'                   by the open/save file dialog boxes
'------------------------------------------------------------------------'
Sub SetLanguage(Optional ReopenWarning, Optional ModifiedWarning, _
Optional ReadOnlyWarning, Optional OpenCaption, Optional SaveAsCaption, _
Optional ReadOnlyCaption, Optional NewError, Optional OpenError, _
Optional SaveError, Optional CloseError, Optional DocumentDefaultName, _
Optional DocumentDefaultExt, Optional DocumentDefaultFilter)
    If Not IsMissing(ReopenWarning) _
    Then wrnReopen = ReopenWarning
    If Not IsMissing(ModifiedWarning) _
    Then wrnModified = ModifiedWarning
    If Not IsMissing(ReadOnlyWarning) _
    Then wrnModified = ModifiedWarning
    If Not IsMissing(OpenCaption) _
    Then captOpen = OpenCaption
    If Not IsMissing(SaveAsCaption) _
    Then captSaveAs = SaveAsCaption
    If Not IsMissing(ReadOnlyCaption) _
    Then captReadOnly = ReadOnlyCaption
    If Not IsMissing(NewError) _
    Then errNew = NewError
    If Not IsMissing(OpenError) _
    Then errOpen = OpenError
    If Not IsMissing(SaveError) _
    Then errSave = SaveError
    If Not IsMissing(CloseError) _
    Then errClose = CloseError
    If Not IsMissing(DocumentDefaultName) _
    Then docDefaultName = DocumentDefaultName
    If Not IsMissing(DocumentDefaultExt) _
    Then docDefaultExt = DocumentDefaultExt
    If Not IsMissing(DocumentDefaultFilter) _
    Then docDefaultFilter = DocumentDefaultFilter
End Sub



'+----------------------------------------------------------------------+'
'+                               REQUEST                                +'
'+----------------------------------------------------------------------+'
'Function: Request
'   Perform requested action on the active document. Returns "True" if the
'   action was succesfully completed.
'   Parameters: rType: Numeric value (Long)  indicating the type of action
'                   to perform. See Enum "RequestType" for values.
'               FileName (Optional):
'               DefaultExt (Optional):
'               InitDir (Optional):
'               Filter (Optional):
'               FilterIndex (Optional):
'------------------------------------------------------------------------'
Function Request(rType As RequestType, Optional FileName, Optional _
DefaultExt, Optional InitDir, Optional Filter, Optional FilterIndex) As _
Boolean
    Dim NextAction As String
    Select Case rType
        'Case new document
        Case reqNew
            'Ask to close active document
            If AskClose(InitDir, Filter, FilterIndex, DefaultExt) Then
                'Ask to make a new document
                If AskNew(FileName, DefaultExt) Then
                    'Complete action "close"
                    If ActionClose() Then
                        'Complete action "new"
                        Request = ActionNew()
                    End If
                End If
            End If
        'Case open document
        Case reqOpen
            'Ask to close active document
            If AskClose(InitDir, Filter, FilterIndex, DefaultExt) Then
                'Ask to select a document
                If AskOpen(FileName, InitDir, Filter, FilterIndex) Then
                    'Complete action "close"
                    If ActionClose() Then
                        'Complete action "open"
                        Request = ActionOpen()
                    End If
                End If
            End If
        'Case re-open document
        Case reqReOpen
            'Ask to confirm re-open
            If AskReOpen() Then
                'Complete action "close"
                If ActionClose() Then
                    'Complete action "open"
                    Request = ActionOpen()
                End If
            End If
        'Case save document
        Case reqSave
            'Ask to save document
            If AskSave(InitDir, Filter, FilterIndex, DefaultExt) Then
                'Complete action "save"
                Request = ActionSave()
            End If
        'Case save document as
        Case reqSaveAs
            'Ask to save the document as
            If AskSaveAs(FileName, InitDir, _
            Filter, FilterIndex, DefaultExt) Then
                'Complete action "save"
                Request = ActionSave()
            End If
        'Case close document
        Case reqClose
            'Ask to close active document
            If AskClose(InitDir, Filter, FilterIndex, DefaultExt) Then
                'Complete action "close"
                Request = ActionClose()
            End If
        Case reqProperties
            MsgBox "Not available yet."
    End Select
End Function



'+----------------------------------------------------------------------+'
'+                              QUESTIONS                               +'
'+----------------------------------------------------------------------+'
'Function: AskNew
'   Prepares new attributes.
'   Returns "True".
'   Parameters: FileName (Optional):   A string  expression  that  specify
'                   the name of the new document (it is not a path).
'               DefaultExt (Optional):  A string  expression that  specify
'                   the extension of the new document.
'------------------------------------------------------------------------'
Private Function AskNew(Optional FileName, Optional DefaultExt) As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    'Set new document path
    newPath = ""
    'Set new document name
    If IsMissing(FileName) _
    Then newName = docDefaultName _
    Else newName = FSO.GetBaseName(FileName)
    'Set document extension
    If IsMissing(DefaultExt) _
    Then newExt = docDefaultExt _
    Else newExt = DefaultExt
    'Set document status
    newReadOnly = False
    'Returns succes
    AskNew = True
End Function

'------------------------------------------------------------------------'
'Function: AskOpen
'   Prompt the user to select a file to open and store selection in global
'   variables "newPath", "newName", "newExt" and "newReadOnly".
'   Returns "True" if the user pressed OK, "False" if he pressed Cancel.
'   Parameters: FileName (Optional): A string  expression that specify the
'                   filename displayed  (and selected)  first in  the open
'                   file dialog box.  It may include drive,  path, pattern
'                   and qualified network path. In  such case it overrides
'                   InitDir parameter.
'               InitDir (Optional):  A string expression that  specify the
'                   directory displayed first in the open file dialog box.
'               Filter (Optional):  A string expression that  specify wich
'                   type of file the user is allowed to select.
'                   Syntax "Description1|Filter1|Description2|Filter2"
'                   Parts: Description: A string expression describing the
'                              type of file.
'                          Filter:  A  string  expression  specifying  the
'                              filename extensions.
'                          Use the pipe ("|")  to separate the description
'                          and filter  values and use the  semicolon (";")
'                          to separate extensions.
'               FilterIndex (Optional):  A numeric  expression  specifying
'                   the default filter
'------------------------------------------------------------------------'
Private Function AskOpen(Optional FileName, Optional InitDir, Optional _
Filter, Optional FilterIndex) As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error GoTo Err_UserPressCancel
    'Set dialog box caption
    ComDlg.DialogTitle = captOpen
    'Set dialog box initial directory
    If IsMissing(InitDir) _
    Then ComDlg.InitDir = "" _
    Else ComDlg.InitDir = InitDir
    'Set dialog box initial filename
    If IsMissing(FileName) _
    Then ComDlg.FileName = "" _
    Else ComDlg.FileName = FileName
    'Set dialog box filter
    If IsMissing(Filter) _
    Then ComDlg.Filter = docDefaultFilter _
    Else ComDlg.Filter = Filter
    'Set dialog box filter index
    If IsMissing(FilterIndex) _
    Then ComDlg.FilterIndex = 1 _
    Else ComDlg.FilterIndex = FilterIndex
    'Show open file dialog box
    ComDlg.ShowOpen
    'Store user selection in newVariables
    newPath = ComDlg.FileName
    newName = ComDlg.FileTitle
    newExt = FSO.GetExtensionName(newPath)
    newReadOnly = CBool(ComDlg.Flags And cdlOFNReadOnly) _
               Or CBool(FSO.GetFile(newPath).Attributes And 1)
    'Return success
    AskOpen = True
Exit Function
'User pressed cancel
Err_UserPressCancel:
End Function

'------------------------------------------------------------------------'
'Function: AskReOpen
'   Prompt the user about risks of losing changes.
'   Returns "True" if the user confirms re-opening, "False" if not.
'   Parameters: None
'------------------------------------------------------------------------'
Private Function AskReOpen() As Boolean
    'Prompt user
    Select Case MsgBoxA(wrnReopen, vbQuestion + vbYesNoCancel)
        Case vbYes
            'Set newVariables to previous value
            newPath = docPath
            newName = docName
            newExt = docExt
            newReadOnly = docReadOnly
            'Return success
            AskReOpen = True
    End Select
End Function

'------------------------------------------------------------------------'
'Function: AskSave
'   Returns "True"  if the document can  actually be saved to  its current
'   path. Otherwise, returns the "AskSavAs" answer.
'   Parameters: InitDir (Optional):  A string expression that  specify the
'                   directory displayed first in the save file dialog box.
'                   Used only in case document has no path (new document).
'               Filter (Optional):  A string expression that  specify wich
'                   type of file the user is  allowed to select. Used only
'                   if document has to be saved as.
'                   Syntax "Description1|Filter1|Description2|Filter2"
'                   Parts: Description: A string expression describing the
'                              type of file.
'                          Filter:  A  string  expression  specifying  the
'                              filename extensions.
'                          Use the pipe ("|")  to separate the description
'                          and filter  values and use the  semicolon (";")
'                          to separate extensions.
'               FilterIndex (Optional):  A numeric  expression  specifying
'                   the default filter
'               DefaultExt (Optional):  A string  expression that  specify
'                   wich extension  is added to  filename if  no extension
'                   and no  filter is  specified ("*.*")  or if  extension
'                   does not fit filter specifications  nor any known file
'                   type. Used only if document has to be saved as.
'------------------------------------------------------------------------'
Private Function AskSave(Optional InitDir, Optional Filter, Optional _
FilterIndex, Optional DefaultExt) As Boolean
    'If document has no path (new document)
    If docPath = "" Then
        AskSave = AskSaveAs(docName, InitDir, Filter, _
                            FilterIndex, docExt)
    'If document has a path
    Else
        'If document is read-only
        If docReadOnly Then
            Call MsgBoxA(wrnReadOnly, vbExclamation)
            AskSave = AskSaveAs(docPath, , Filter, _
                                FilterIndex, docExt)
        'Document has a path and is not read-only
        Else
            newPath = docPath
            newName = docName
            newExt = docExt
            newReadOnly = docReadOnly
            'Ready to save
            AskSave = True
        End If
    End If
End Function

'------------------------------------------------------------------------'
'Function: AskSaveAs
'   Prompt the user to select a path to save the active document and store
'   selection  in  global  variables "newPath",  "newName",  "newExt"  and
'   "newReadOnly".
'   Returns "True" if the user pressed OK, "False" if he pressed Cancel.
'   Parameters: FileName (Optional): A string  expression that specify the
'                   filename displayed  (and selected)  first in  the save
'                   file dialog box.  It may include drive,  path, pattern
'                   and qualified network path. In  such case it overrides
'                   InitDir parameter.
'               InitDir (Optional):  A string expression that  specify the
'                   directory displayed first in the save file dialog box.
'               Filter (Optional):  A string expression that  specify wich
'                   type of file the user is allowed to select.
'                   Syntax "Description1|Filter1|Description2|Filter2"
'                   Parts: Description: A string expression describing the
'                              type of file.
'                          Filter:  A  string  expression  specifying  the
'                              filename extensions.
'                          Use the pipe ("|")  to separate the description
'                          and filter  values and use the  semicolon (";")
'                          to separate extensions.
'               FilterIndex (Optional):  A numeric  expression  specifying
'                   the default filter
'               DefaultExt (Optional):  A string  expression that  specify
'                   wich extension  is added to  filename if  no extension
'                   and no  filter is  specified ("*.*")  or if  extension
'                   does not fit filter specifications  nor any known file
'                   type.
'------------------------------------------------------------------------'
Private Function AskSaveAs(Optional FileName, Optional InitDir, Optional _
Filter, Optional FilterIndex, Optional DefaultExt) As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error GoTo Err_UserPressCancel
    'If there is an active document
    If docName <> "" Then
        'Set dialog box caption
        ComDlg.DialogTitle = captSaveAs
        'Set dialog box initial directory
        If IsMissing(InitDir) _
        Then ComDlg.InitDir = FSO.GetParentFolder(docPath) _
        Else ComDlg.InitDir = InitDir
        'Set dialog box initial filename
        If IsMissing(FileName) _
        Then ComDlg.FileName = docName _
        Else ComDlg.FileName = FileName
        'Set dialog box filter
        If IsMissing(Filter) _
        Then ComDlg.Filter = docDefaultFilter _
        Else ComDlg.Filter = Filter
        'Set dialog box filter index
        If IsMissing(FilterIndex) _
        Then ComDlg.FilterIndex = 1 _
        Else ComDlg.FilterIndex = FilterIndex
        'Set dialog box default extension
        If IsMissing(DefaultExt) _
        Then ComDlg.DefaultExt = docDefaultExt _
        Else ComDlg.DefaultExt = DefaultExt
        'Show save file dialog box
        ComDlg.ShowSave
        'Store user selection in newVariables
        newPath = ComDlg.FileName
        newName = ComDlg.FileTitle
        newExt = FSO.GetExtensionName(newPath)
        newReadOnly = False
    End If
    'Return success
    AskSaveAs = True
Exit Function
'User pressed cancel
Err_UserPressCancel:
End Function

'------------------------------------------------------------------------'
'Function: AskClose
'   Prompt the user to save changes.
'   Returns "True" if  the user pressed No, "False" if  he pressed Cancel.
'   If  the user  chooses  Yes, returns  "True"  only  after document  was
'   succesfully saved.
'   Parameters: InitDir (Optional):  A string expression that  specify the
'                   directory displayed first in the save file dialog box.
'                   Used only in case user wants to save changes.
'               Filter (Optional):  A string expression that  specify wich
'                   type of file the user is  allowed to select. Used only
'                   in case user wants to save changes.
'                   Syntax "Description1|Filter1|Description2|Filter2"
'                   Parts: Description: A string expression describing the
'                              type of file.
'                          Filter:  A  string  expression  specifying  the
'                              filename extensions.
'                          Use the pipe ("|")  to separate the description
'                          and filter  values and use the  semicolon (";")
'                          to separate extensions.
'               FilterIndex (Optional):  A numeric  expression  specifying
'                   the default filter
'               DefaultExt (Optional):  A string  expression that  specify
'                   wich extension  is added to  filename if  no extension
'                   and no  filter is  specified ("*.*")  or if  extension
'                   does not fit filter specifications  nor any known file
'                   type. Used only in case user wants to save changes.
'------------------------------------------------------------------------'
Private Function AskClose(Optional InitDir, Optional Filter, Optional _
FilterIndex, Optional DefaultExt) As Boolean
    'If document was modifified
    If Modified Then
        'Prompt user
        Select Case MsgBoxA(wrnModified, vbExclamation + vbYesNoCancel)
            'User wants to save changes
            Case vbYes
                If AskSave(InitDir, Filter, FilterIndex, DefaultExt) Then
                    'Close is accepted after document was saved
                    AskClose = ActionSave()
                End If
            'User doesn't want to save changes
            Case vbNo
                'Close is accepted anyway
                AskClose = True
        End Select
    'Document was not modifified
    Else
        AskClose = True
    End If
End Function



'+----------------------------------------------------------------------+'
'+                               ACTIONS                                +'
'+----------------------------------------------------------------------+'
'Function: ActionNew
'   Sends an event to the application to create a new document.
'   Returns "True" if the application actually created the document.
'   Parameters: None
'------------------------------------------------------------------------'
Private Function ActionNew() As Boolean
    'Raise the NewDoc event
    Created = False
    RaiseEvent NewDoc
    'If document was created
    If Created Then
        'Set document properties
        docPath = newPath
        docName = newName
        docExt = newExt
        docReadOnly = newReadOnly
        Modified = False
        'Display document title
        Call DisplayTitle
        Call EnableButtons(False, True, True, True, False)
        'Return succes
        ActionNew = True
    'If document was not created
    Else
        Call MsgBoxA(errNew, vbExclamation)
    End If
End Function

'------------------------------------------------------------------------'
'Function: ActionOpen
'   Sends an event to the application to open a specified document.
'   Returns "True" if the application actually opened the document.
'   Parameters: None
'------------------------------------------------------------------------'
Private Function ActionOpen() As Boolean
    'Raise the OpenDoc event
    Opened = False
    RaiseEvent OpenDoc(newPath)
    'If document was opened
    If Opened Then
        'Set document properties
        docPath = newPath
        docName = newName
        docExt = newExt
        docReadOnly = newReadOnly
        Modified = False
        'Display document title
        Call DisplayTitle
        Call EnableButtons(True, True, True, True, True)
        'Return succes
        ActionOpen = True
    'If document was not opened
    Else
        Call MsgBoxA(errOpen, vbExclamation)
    End If
End Function

'------------------------------------------------------------------------'
'Function: ActionSave
'   Sends  an event to  the application to save  the active document  to a
'   specified path.
'   Returns "True" if the application actually saved the document.
'   Parameters: None
'------------------------------------------------------------------------'
Private Function ActionSave() As Boolean
    'If there is an active document
    If docName <> "" Then
        'Raise the SaveDoc event
        Saved = False
        RaiseEvent SaveDoc(newPath)
        'If document was saved
        If Saved Then
            'Set document properties
            docPath = newPath
            docName = newName
            docExt = newExt
            docReadOnly = False
            Modified = False
            'Display document title
            Call DisplayTitle
            Call EnableButtons(True, True, True, True, True)
            'Return succes
            ActionSave = True
        'If document was not saved
        Else
            Call MsgBoxA(errSave, vbExclamation)
        End If
    End If
End Function

'------------------------------------------------------------------------'
'Function: ActionClose
'   Sends an event to the application to close the active document.
'   Returns "True" if the application actually closed the document.
'   Parameters: None
'------------------------------------------------------------------------'
Private Function ActionClose() As Boolean
    'If there is an active document
    If docName <> "" Then
        'Raise the SaveDoc event
        Closed = False
        RaiseEvent CloseDoc
        'If document was closed
        If Closed Then
            'Set document properties
            docPath = ""
            docName = ""
            docExt = ""
            docReadOnly = False
            Modified = False
            'Display document title
            Call DisplayTitle
            Call EnableButtons(False, False, False, False, False)
            'Return succes
            ActionClose = True
        'If document was not closed
        Else
            Call MsgBoxA(errClose, vbExclamation)
        End If
    'There is no active document
    Else
        ActionClose = True
    End If
End Function



'+----------------------------------------------------------------------+'
'+                            CONFIRMATIONS                             +'
'+----------------------------------------------------------------------+'
'Function: Confirm
'   Procedure executed by the application  to confirm actions requested by
'   the object.
'   Parameters: cType:  Numeric  value  (Long)   indicating  the  type  of
'                   confirmation  sent   by  the  application.   See  Enum
'                   "ConfirmationType" for values.
'------------------------------------------------------------------------'
Sub Confirm(cType As ConfirmationType)
    Select Case cType
        Case confNew
            Created = True
        Case confOpen
            Opened = True
        Case confSave
            Saved = True
        Case confClose
            Closed = True
    End Select
End Sub



'+----------------------------------------------------------------------+'
'+                            MODIFICATIONS                             +'
'+----------------------------------------------------------------------+'
'Sub: Modify
'   Set flag "Modified" to "True".
'   Parameters: None
'------------------------------------------------------------------------'
Sub Modify()
    If docName <> "" Then Modified = True
End Sub



'+----------------------------------------------------------------------+'
'+                           OTHER FUNCTIONS                            +'
'+----------------------------------------------------------------------+'
'Function: MsgBoxA
'   Prompt the user with  a message box in which appears  the name or path
'   of the active document.
'   Parameters: Prompt:  A string  expression  specifying  the message  to
'                   display, "%0" string  will be replaced by  the name or
'                   path of the active document.
'   Buttons (Optional):  Numeric expression  that  is  the sum  of  values
'                   specifying the number and type  of buttons to display,
'                   the icon  style to  use, the  identity of  the default
'                   button,  and  the  modality of  the  message  box.  If
'                   omitted, the default value for buttons is 0.
'------------------------------------------------------------------------'
Private Function MsgBoxA(ByVal Prompt, Buttons As VbMsgBoxStyle)
    Prompt = Replace(Prompt, "%0", IIf(docPath = "", docName, docPath))
    MsgBoxA = MsgBox(Prompt, Buttons, App.Title)
End Function

'------------------------------------------------------------------------'
'Sub: DisplayTitle
'   Modify the text displayed in the application main form title bar.
'   Parameters: None
'------------------------------------------------------------------------'
Private Sub DisplayTitle()
    Dim Title As String
    If docName = "" Then
        Title = App.Title
    ElseIf docReadOnly Then
        Title = docName & " [" & captReadOnly & "] - " & App.Title
    Else
        Title = docName & " - " & App.Title
    End If
    On Error Resume Next
    ComDlg.Parent.Caption = Title
End Sub

'------------------------------------------------------------------------'
'Sub: EnableButtons
'   Set the enabled status of the  buttons managed by the object depending
'   on the document status.
'   Parameters: EnableReOpen: Status of the "Reopen" buttons
'               EnableSave: Status of the "Save" buttons
'               EnableSaveAs: Status of the "Save as" buttons
'               EnableClose: Status of the "Close" buttons
'               EnableProperties: Status of the "Properties" buttons
'------------------------------------------------------------------------'
Private Sub EnableButtons(EnableReopen As Boolean, EnableSave As _
Boolean, EnableSaveAs As Boolean, EnableClose As Boolean, EnableProp As _
Boolean)
    Call EnableArrayOfButtons(btnReopen, EnableReopen)
    Call EnableArrayOfButtons(btnSave, EnableSave)
    Call EnableArrayOfButtons(btnSaveAs, EnableSaveAs)
    Call EnableArrayOfButtons(btnClose, EnableClose)
    Call EnableArrayOfButtons(btnProp, EnableProp)
End Sub

'------------------------------------------------------------------------'
'Sub: EnableArrayOfButtons
'   Set the enabled status of an array of buttons.
'   Parameters: ArrayOfButtons: An array of controls
'               Enabled: Status of the buttons in the array
'------------------------------------------------------------------------'
Private Sub EnableArrayOfButtons(ArrayOfButtons, Enabled As Boolean)
    Dim i As Long
    On Error Resume Next
    For i = LBound(ArrayOfButtons) To UBound(ArrayOfButtons)
        ArrayOfButtons(i).Enabled = Enabled
    Next
End Sub

Télécharger le zip

06 juillet 2006 17:53:09 :

Version 1.5 (04/07/2006 21:56) Correction de commentaires, mise en forme et syntaxe. Correction d'un bug dans la methode "AskReOpen". Correction d'un message d'erreur dans la methode "AskClose"

12 juillet 2006 18:12:46 :

Version 2.0 (2006 JULY 12 12:47) 1) Changement du nom de la classe 2) Refonte globale des noms de proprietes et de methodes. 3) Ajout de la methode SetLanguage qui permet facilement de modifier le contenu des boites de message. A utiliser en parallele avec un fichier de ressource. 4) Ajout de la methode SetButtons qui permet de donner le controle de certains boutons a DocInApp qui s'occupe de les activer ou les desactiver selon les circonstances (par exemple empecher l'acces au bouton fermer si aucun document n'est ouvert. 5) Clarification des methodes en AskSomething et ActionSomething qui offre plus de souplesse dans l'execution et rend le module plus lisible. 5) Correction de commentaires (mise en forme et contenu).