Attribute VB_Name = "modExportExcel"
Option Explicit
'Mettre un boutton export Excel sur les ecrans concerner


'Sur la methode click
' appeler cette function en passant en parrametre un liste view


Private Const OF_SHARE_EXCLUSIVE = &H10
Private Declare Function lopen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
Private Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long


Public Function exportListView2Excel(ByRef lvwMateriel As ListView, FichierXls As String) As String   'export Genere
'lvwMateriel.ListItems

Dim xlApp As Excel.Application
Dim classeur As Excel.Workbook
Dim feuille As Excel.Worksheet
Dim Plage As Excel.Range




Dim mFso As New Scripting.FileSystemObject


   
Dim fin As Boolean
Dim NumLigneEnCour As Integer
Dim NumColumEnCour As Integer
Dim Cle As String
Dim NomFichier As String
Dim ItmLvw      As ListItem
Dim y     As Integer
Dim x      As Integer
Dim Indice As String
fin = False
  NomFichier = FichierXls
  exportListView2Excel = ""
On Error GoTo ErrHandler

    
    Set xlApp = New Excel.Application
    xlApp.DisplayAlerts = False
    's'il existe, on l'efface
    If mFso.FileExists(NomFichier) Then
        If TestFile(NomFichier) = False Then
            Call mFso.DeleteFile(NomFichier, True)
        Else
            NomFichier = FindNewFile(NomFichier)
        End If
    End If
    
    'création du fichier
    xlApp.Workbooks.Add
    
    'on va chercher la feuille
    Set feuille = xlApp.Workbooks.Item(1).Sheets.Item(1)
    
    Set Plage = feuille.Range("A1").CurrentRegion
    'Plage.Clear
    
    NumLigneEnCour = 1 '  entete
        
    ' Récupère le nom des colonnes
    For x = 1 To lvwMateriel.ColumnHeaders.Count
        Plage.Range(Chr(x + 65 - 1) & "1").Value = CStr(lvwMateriel.ColumnHeaders(x).Text)
        Plage.Range(Chr(x + 65 - 1) & "1").Font.Bold = True
    Next x


    NumLigneEnCour = 2 ' corps

  
    ' Lecture ligne par ligne de la liste
    For x = 1 To lvwMateriel.ListItems.Count
        
        
        
        'If NumLigneEnCour = 1 Then
        Plage.Range("A" & NumLigneEnCour).Value = CStr(lvwMateriel.ListItems(x))


        ' Récupère les SubItems de X sur la même ligne
        For y = 1 To lvwMateriel.ColumnHeaders.Count - 1
            Indice = Chr(y + 65) & (x + 1)
            If lvwMateriel.ListItems(x).SubItems(y) <> "" Then
                If InStr(2, lvwMateriel.ListItems(x).SubItems(y), ".") > 0 And InStr(3, lvwMateriel.ListItems(x).SubItems(y), ".") > 0 Then
                    'cas Version
                    Plage.Range(Indice).Value = CStr(lvwMateriel.ListItems(x).SubItems(y))
                Else
                    If MyIsDateSemaine(lvwMateriel.ListItems(x).SubItems(y)) Then
                        Plage.Range(Indice).Value = "'" & lvwMateriel.ListItems(x).SubItems(y)
                    Else
                        If Not MyIsDate(lvwMateriel.ListItems(x).SubItems(y)) Then
                            Plage.Range(Indice).Value = CStr(lvwMateriel.ListItems(x).SubItems(y))
                        Else
                            Plage.Range(Indice).Value = "'" & Format(lvwMateriel.ListItems(x).SubItems(y), "dd/mm/yyyy")
                        End If
                    End If
                End If
            End If
        Next y
            
        NumLigneEnCour = NumLigneEnCour + 1
    
    '    If x > 500 Then GoTo finExportNormal
    Next x
    
finExportNormal:
    
    Set Plage = Nothing
    Set feuille = Nothing
   ' classeur.Close True
        
    'sauvegarde
    xlApp.Workbooks.Item(1).SaveAs NomFichier
    'ferme
    xlApp.Workbooks.Close
    'on quitte Excel
    xlApp.Quit
    
    Set classeur = Nothing
    Set xlApp = Nothing
    
     exportListView2Excel = NomFichier
    
Exit Function
ErrHandler:
    MsgBox err.Description, vbCritical, "Optistock export exel"
End Function

Private Function MyIsDate(ByRef x As String) As Boolean
Dim IsDateSemaine As Boolean
    
    If IsDate(x) Then
        
        MyIsDate = True
        Exit Function
    End If


End Function

Private Function MyIsDateSemaine(ByRef x As String) As Boolean
Dim IsDateSemaine As Boolean
    
        IsDateSemaine = False
        
    If IsDate(x) Then
        'Gestion de DateSemaine
        ' yyyy/mm - 31
        

        
        If Val(Right(x, 4)) Then IsDateSemaine = True
        If (Mid(x, 5, 1) = "/") And IsDateSemaine = True Then IsDateSemaine = True
        If Val(Mid(x, 6, 2)) And IsDateSemaine = True Then IsDateSemaine = True
        If (Mid(x, 8, 3) = " - ") And IsDateSemaine = True Then IsDateSemaine = True
        
        
        If IsDateSemaine Then
        'Une DateSemaine doit etre gerer comme une chaine
            MyIsDateSemaine = True
            Exit Function
        End If
    
    
        'Fin Gestion de DateSemaine
    
    End If
    


End Function

Public Function Lancer(ff As Form, fullPath As String) As Boolean
Dim lapi As Long
On Error GoTo fin
    Lancer = False
    lapi = ShellExecute(ff.hwnd, "open", fullPath, vbNull, vbNull, 5)
    Lancer = True
    Exit Function
fin:
    Lancer = False

End Function

Public Function TestFile(FileToOpen As String) As Boolean
    
Dim hFile As Long
    
    TestFile = False
    hFile = -1
    '------------------------------------------------------------------------
    'Ouvre le fichier en mode exclusif & refuse l'accès en lecture & écriture
    'aux autres processus
    '------------------------------------------------------------------------
    hFile = lopen(FileToOpen, OF_SHARE_EXCLUSIVE)
    '---------------------------------------------------------------------
    'Si le fichier est déjà ouvert en lecture ou en écriture par un autre
    'processus ou bien par le processus courant la fonction _lopen renvoie -1.
    '---------------------------------------------------------------------
    If hFile <> -1 Then
        '------------------------------------------
        'fermeture du fichier si tout se passe bien
        '------------------------------------------
        lclose (hFile)
    ElseIf (hFile = -1) And (err.LastDllError = 32) Then
        TestFile = True
    End If
    
End Function

Public Function FindNewFile(f As String) As String
Dim mFso As New Scripting.FileSystemObject

Dim NomFichier As String
Dim extentionFichier As String
Dim pathFichier As String
Dim Num As Integer
Dim newFichier As String
Dim actuelFichier As String

    Num = 0
    
    newFichier = ""
    actuelFichier = f
    While newFichier = ""
        Num = Num + 1
        extentionFichier = mFso.GetExtensionName(actuelFichier)
        If extentionFichier <> "" Then
            NomFichier = Replace(mFso.getFileName(actuelFichier), "." & extentionFichier, "")
            pathFichier = Replace(f, mFso.getFileName(actuelFichier), "")
        
            If (extentionFichier <> "" And NomFichier <> "" And pathFichier <> "") Then
                newFichier = pathFichier & NomFichier & Format("000", Num) & "." & extentionFichier
            
                If mFso.FileExists(newFichier) Then
                    'Fichier existe trouver un nouveau
                    actuelFichier = newFichier
                    newFichier = ""
                Else
                    'Fichier n'éxiste  pas ces le bon
                    actuelFichier = newFichier
                End If
            End If
        
        End If
    
    Wend
    
    FindNewFile = newFichier

End Function

