Classe File

'
' clsFile : classe File
'
' Permet de manipuler des fichiers
'
' Auteur: ChF
'
' Property
'    Name   : nom du fichier
'    Path   : répertoire (uniquement si ouvert par fdlgOpen)
'    fLen   : longeur
'    Buffer : contenu du fichier
'    FullName : Retourne le nom complete avec le repertoire
'
' Méthodes
'    Create : Cree l'objet
'    Destroy    : Détruit l'objet
'    GetNew : Demande à l'utilisateur de choisir un nouveau nom et chemin pour
'         créer un nouveau fichier (BDial Save)
'    CreateNew  : Cree un nouveau fichier (de BDial)
'    fDlgOpen   : Ouvre un nouveau fichier (BDial open)
'    fOpen  : Ouvre un fichier (pas de BDial)
'    fClose  : Ferme le fichier
'    fRename : Renomme le fichier
'    fGet   : Lit le fichier
'    fPut   : Ecrit dans le fichier
'    fCopy  : copie le fichier avec anim shell
'    fDelete    : Delete le fichier avec anim shell
'    fMove      : Deplace le fichier avec anim shell
'    Execute    : Execute le fichier
'    IsExist    : Retourne True si le fichier existe, False dans la cas contraire
'
Option Compare Database
Option Explicit

Private clsHeader As Integer
Private clsName As Variant
Private clsDirectory As String
Private clslngValue As Long
Private clsBuffer As Variant
Private clsFileLen As Long
Private clsHwnd As Long

' COMMDLG API Declarations
Private Type udtOPENFILENAME
         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 clsOpenFile As udtOPENFILENAME

Private Declare Function API_GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As udtOPENFILENAME) As Long
Private Declare Function API_GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As udtOPENFILENAME) As Long


Private Const OFN_READONLY = &H1
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHOWHELP = &H10
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOLONGNAMES = &H40000                      '  force no long names for 4.x modules
Private Const OFN_EXPLORER = &H80000                         '  new look commdlg
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_LONGNAMES = &H200000                       '  force long names for 3.x modules

'
' API pour Methode Execute
'
Private Const SW_ERASE = &H4
Private Const SW_HIDE = 0
Private Const SW_INVALIDATE = &H2
Private Const SW_MAX = 10
Private Const SW_MAXIMIZE = 3
Private Const SW_MINIMIZE = 6
Private Const SW_NORMAL = 1
Private Const SW_OTHERUNZOOM = 4
Private Const SW_OTHERZOOM = 2
Private Const SW_PARENTCLOSING = 1
Private Const SW_PARENTOPENING = 3
Private Const SW_RESTORE = 9
Private Const SW_SCROLLCHILDREN = &H1
Private Const SW_SHOW = 5
Private Const SW_SHOWDEFAULT = 10
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWNA = 8
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOWNORMAL = 1
Private Declare Function API_ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

'
'API pour creation fichier temporaire
'
'************************************************
'API pour gestion des fichiers temporaires
'************************************************
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

' UI_CopyStringToGlobal variables
Private APIResults As Long

Public Property Get Name() As String
    Name = IIf(IsNull(clsName), "", clsName)
End Property
Public Property Let Name(Value As String)
'Purpose    : Affect Name to clsName and Path to clsDirectory
'Inputs     : file name value with/without path indication
'             Ex. c:\Program Files\MyFile.txt
'Assumes    :
'Returns    :
'Effects    : clsName contains then file name and clsDirectory may contain directory value if exist in
'             input Value
'             Ex: Value=c:\Program Files\Myfile.txt, clsName<-MyFile.txt and clsDirectory<-c:\Program Files\ Dim s As New clsString Dim p As New clsString With s .Value="Value" .Value=".Reverse" If .index("\") <> 0 Then
            p.Value = .subStr(1, .index("\") - 1)
            clsName = p.Reverse
            p.Value = .subStr(.index("\"))
            clsDirectory = p.Reverse
        Else
            clsName = Value
        End If
    End With
    Set p = Nothing
    Set s = Nothing
End Property
Public Property Get Buffer() As Variant
'Purpose    : Returns the file buffer of data
'Inputs     :
'Assumes    :
'Returns    : File Data
'Effects    :

    Buffer = clsBuffer
End Property
Public Property Get fLen() As Long
'Purpose    : Returns len of file
'Inputs     :
'Assumes    :
'Returns    : Len of file
'Effects    :

    fLen = clsFileLen
End Property
Public Property Let Path(Value As String)
'Purpose    : Set the directory (or path) of the file
'Inputs     : Directory value
'Assumes    :
'Returns    :
'Effects    : clsDirectory contains the path file
'             a back slash is added if needed at the end of directory
    
    If Mid(Value, Len(Value)) <> "\" Then Value = Value & "\"
    clsDirectory = Value
End Property
Public Property Get Path() As String
'Purpose    : Return the path (or directory) of the file
'Inputs     :
'Assumes    :
'Returns    : The directory value or empty string
'Effects    :

    Path = Trim(IIf(IsNull(clsDirectory), "", clsDirectory))
End Property
Public Property Get FullPath() As String
    FullPath = Path & Name
End Property

Public Function Create(hwnd As Long) As Boolean
'Purpose    : Initializes the File object
'Inputs     : hWnd                  Handle of window
'Assumes    :
'Returns    : True / False
'Effects    : Private property are initialized

    Create = True
    clsName = Null
    clsDirectory = Null
    clsHeader = 0
    clsHwnd = hwnd
End Function
Public Function Destroy()
'Purpose    : Destroy the File Object
'Inputs     :
'Assumes    :
'Returns    :
'Effects    : Only the Object is destroy, not the file. The file is only closed

    fClose
End Function
Public Function GetNew(ByVal strFilter As String, ByVal strDefExt As String, ByVal strTitle As String, Optional ByVal strInitDir As Variant, Optional ByVal strFileName As Variant) As Boolean
'Purpose    : Get a new File and Path through a shell dialog box
'Inputs     : strFilter     Filter to apply as Filter Name|Filter Value|Filter Name|Filter Value....
'              Sample: All Files (*.*)|*.*|Text Files (*.txt)|*.txt
'             strDefExt     Default filter
'              Sample: *.*
'             strTilte      Tilte of the dialog box
'             strInitDir (optional) : Directory open at then bdial opening
'                                     If missing, clsDirectory is used
'             strInitFile (optional) : Name of ther default file to get
'              Sample: MyFile.txt
'                                      If missing clsName is used

'Assumes    :
'Returns    : True/False
'Effects    : If a file is selected, clsName and clsDirectory contain the name and path of the selected file
'             If a file is selected, a new file is created

Dim Df As String * 257
Dim s As New clsString

    If IsMissing(strInitDir) Then strInitDir = Path
    If IsMissing(strFileName) Then strFileName = Name
   
    With clsOpenFile
         .lStructSize = Len(clsOpenFile)
         .hWndOwner = hWndAccessApp
         
        With s
            .Value = strFilter
            If Not .Right(1) = "|" Then .Add "|"
        End With
         .lpstrFilter = s.Substitue("|", Chr$(0))
         .lpstrCustomFilter = Chr$(0)
         .nMaxCustFilter = 0
         .nFilterIndex = 1
         
         Df = strFileName
         .lpstrFile = Df
         .nMaxFile = Len(clsOpenFile.lpstrFile) - 1
         
         .lpstrFileTitle = clsOpenFile.lpstrFile
         .nMaxFileTitle = clsOpenFile.nMaxFile
         
         .lpstrInitialDir = strInitDir
        
         .lpstrTitle = strTitle
         
         .Flags = 0               'OFN_FILEMUSTEXIST Or OFN_SHAREAWARE
         
         .nFileOffset = 0
         .nFileExtension = 0
         
         .lpstrDefExt = strDefExt
         
         .lCustData = 0
         .lpfnHook = 0
         .lpTemplateName = 0
         
         .hInstance = 0                                      'Instance of application that holds the custom template file
         .lpstrCustomFilter = Chr$(0)                              'No custom file filter attributes given
         .nMaxCustFilter = 0                                 'Length of custom file filter
    End With

    'Show the open file common dialog
    On Error Resume Next
    APIResults = API_GetSaveFileName(clsOpenFile)
    If Err <> 0 Then
        MsgBox Error
    Else
        If APIResults <> 0 Then
             Name = Left(Trim(clsOpenFile.lpstrFileTitle), Len(Trim(clsOpenFile.lpstrFileTitle)) - 1)
             Path = Left(Trim(clsOpenFile.lpstrInitialDir), Len(Trim(clsOpenFile.lpstrInitialDir)))
        End If
    End If
    '
    ' Libere les ressources
    '
    Set s = Nothing
    
    GetNew = True
End Function
Public Function CreateNew(Optional opt As Integer = 0)
'Purpose    : Creates a new file silently
'Inputs     : Optional : f_CreateStandard (default) : Create a standard file using Name and Path
'                        f_CreateTemporyFile : Create a tempory file.
'                                                  If Path="" then then file is create in
'                                                    then tempory windows directory.
'                                                  If Path<>"" then the file is create in Path
'Assumes    : clsName and clsDirectory contain the file name and directory to create for a standard file
'Returns    :
'Effects    : A new file is creates, or an error occurs.
Dim filename As String * 2048
Dim tempPath As String * 4096
Dim Dummy As Long

    If (opt And f_CreateStandard) = f_CreateStandard Then
        clsHeader = FreeFile
        Open FullPath For Binary Access Read Write As clsHeader Len = 1
    ElseIf (opt And f_CreateTemporyFile) = f_CreateTemporyFile Then
        If Len(Path) <> 0 Then
            tempPath = Path & vbNullChar
        Else
            Dummy = GetTempPath(4096, tempPath)
        End If
        Dummy = GetTempFileName(tempPath, "tmp", 0, filename)
        Name = Trim(filename)
    End If
    
End Function
Public Function fDlgOpen(ByVal strFilter As String, ByVal strDefExt As String, ByVal strTitle As String, Optional ByVal strInitDir As Variant, Optional ByVal strFileName As Variant) As Variant
Dim Df As String * 257
Dim s As New clsString

    If IsMissing(strInitDir) Then strInitDir = Path
    If IsMissing(strFileName) Then strFileName = Name
    
    With clsOpenFile
        .lStructSize = Len(clsOpenFile)
        .hWndOwner = hWndAccessApp
        With s
            .Value = strFilter
            If Not .Right(1) = "|" Then .Add "|"
        End With
        .lpstrFilter = s.Substitue("|", Chr$(0))
        .lpstrCustomFilter = Chr$(0)
        .nMaxCustFilter = 0
        .nFilterIndex = 1
         
        Df = strFileName
        .lpstrFile = Df
        .nMaxFile = Len(clsOpenFile.lpstrFile) - 1
        
        .lpstrFileTitle = clsOpenFile.lpstrFile
        .nMaxFileTitle = clsOpenFile.nMaxFile
        
        .lpstrInitialDir = strInitDir
        
        .lpstrTitle = strTitle
        
        .Flags = OFN_FILEMUSTEXIST Or OFN_SHAREAWARE
        
        .nFileOffset = 0
        .nFileExtension = 0
        
        .lpstrDefExt = strDefExt
        
        .lCustData = 0
        .lpfnHook = 0
        .lpTemplateName = 0
        
        .hInstance = 0                                      'Instance of application that holds the custom template file
        .lpstrCustomFilter = Chr$(0)                              'No custom file filter attributes given
        .nMaxCustFilter = 0                                 'Length of custom file filter
     End With
    'Show the open file common dialog
    On Error Resume Next
    APIResults = API_GetOpenFileName(clsOpenFile)
    If Err <> 0 Then
        MsgBox Error
    Else
        If APIResults <> 0 Then
             Name = Left(Trim(clsOpenFile.lpstrFile), Len(Trim(clsOpenFile.lpstrFile)) - 1)
        End If
    End If
  

    fOpen
End Function
Public Function fOpen()
    If Not IsNull(clsName) Then
        clsHeader = FreeFile
        Open clsName For Binary Access Read Write As clsHeader Len = 1
        clsFileLen = FileLen(clsName)
    End If
End Function
Public Function fClose()
    Close clsHeader
End Function
Public Function fRename(newName As String)
    fClose
    Name FullPath As newName
    Name = newName
End Function
Public Function fCopy(Target As String)
Dim r As Long
    fClose
    r = fApiCopyFile(clsHwnd, Target, FOF_NOCONFIRMATION, FullPath)
    If r = 0 Then
        MsgBox "Error copying file " & FullPath & " to " & Target
    End If
End Function
Public Function fDelete()
Dim r As Long
    fClose
    r = fApiDeleteFile(clsHwnd, FOF_NOCONFIRMATION, FullPath)
    If r = 0 Then
        MsgBox "Error deleting " & FullPath
    End If
End Function
Public Function fMove(Target As String)
Dim r As Long
    fClose
    r = fApiMoveFile(clsHwnd, Target, FOF_NOCONFIRMATION, FullPath)
    If r = 0 Then
        MsgBox "Error moving " & FullPath & " to " & Target
    Else
        Path = Target
    End If
End Function
Public Function Execute(Optional Ordre As String = "")
Dim r As Long
    On Error Resume Next
    Shell FullPath & " " & Ordre, vbNormalFocus
    If Err <> 0 Then
        r = API_ShellExecute(hWndAccessApp, Ordre, FullPath, vbNull, Path, SW_SHOWMAXIMIZED)
    End If
    On Error GoTo 0
End Function
Public Function IsExist() As Boolean
Dim r As String
    On Error Resume Next
    If Len(Trim(Name)) = 0 Then
        IsExist = False
        Exit Function
    End If
    r = Dir(Path & Name)
    If Len(r) <> 0 Then
        IsExist = True
    Else
        IsExist = False
    End If
    On Error GoTo 0
End Function
Public Function FGet(Optional Lng As Variant) As Boolean
Dim T As String * 4096
Dim i As Integer
    If IsMissing(Lng) Then
        Lng = clsFileLen
    End If
    clsBuffer = ""
    For i = 1 To (Lng \ 4096) + 1
        Get clsHeader, , T
        clsBuffer = clsBuffer & T
    Next i
End Function
Public Function fPut(Text As Variant) As Boolean
Dim T As String
    T = CStr(Text)
    Put clsHeader, , T
End Function
Public Function SetTemporyName(Optional intOpt As Integer = f_NoCreate)
'Purpose    : set a tempory file name and path if path is not set
'Inputs     : Optional : f_NoCreate (default) : do not create a file
'                        f_Create :the tempory file is created
'Assumes    : clsName and clsDirectory contain the file name and directory to create
'Returns    :
'Effects    : A new file is creates, or an error occurs.
Dim filename As String * 2048
Dim tempPath As String * 4096
Dim Dummy As Long

    If Len(Path) <> 0 Then
        tempPath = Path & vbNullChar
    Else
        Dummy = GetTempPath(4096, tempPath)
    End If
    Dummy = GetTempFileName(tempPath, "tmp", 0, filename)
    Name = Left(filename, InStr(filename, Chr$(0)) - 1)
    If (intOpt And f_NoCreate) = f_NoCreate Then
        fDelete
    End If

End Function