CHARGER UNE MSFLEXGRID OU UNE LISTVIEW À PARTIR D'UN FICHIER TEXTE (ET VICE-VERSA) EN TENANT COMPTE DE LA TAILLE DES COLONNES [MODULE]

'   ---------------------------------------------------------------------------------
'   [AFCK] (PCPT)       Module Mod_ReadWrite                      v1.0.1  05 dec 2007
'   ---------------------------------------------------------------------------------
'
'   Nécessite :
'           Mod_ReadWrite.bas [*]
'           Msflxgrd.ocx "Microsoft FlexGrid Control 6.0 (SP6)"
'           MSCOMCTL.OCX "Microsoft Windows Common Controls 6.0 (SP6)"
'
'
'           ----------------
'             DESCRIPTION
'           ----------------
'           permet de charger et d'enregistrer un fichier texte
'               d'après une MsFlexGrid ou une ListView
'
'
'
'           ----------------
'             HISTORIQUE
'           ----------------
'   v1.0.1      05-12-2007
'                   .GetArrayFile, FileFolderExists, IsArrayNull,
'                       LeftToChar, RightFromChar, SetArrayFile
'                   .FillFlexGridFromFile, SaveFileFromFlexGrid
'                   .FillListViewFromFile, SaveFileFromListView
'
'
'
'           ----------------
'             INFORMATION
'           ----------------
'               .GetArrayFile       : modif de http://www.codyx.org/snippet_lire-toutes-lignes-fichier-texte_22.aspx#67
'               .FileFolderExists   : http://www.codyx.org/snippet_savoir-si-fichier-existe_65.aspx#208
'               .IsArrayNull        : http://www.codyx.org/snippet_savoir-si-tableau-existe-dimension_231.aspx#747
'
'   ---------------------------------------------------------------------------------
'   dernière version                       http://www.vbfrance.com/code.aspx?ID=44934
'   ---------------------------------------------------------------------------------



Option Explicit
'
'   =====================   CONSTANTE       =====================
Private Const INVALID_FILE_ATTRIBUTES       As Long = &HFFFFFFFF
'
'   =====================   API             =====================
Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long



'   =============================================================
'                           MéTHODES
'   =============================================================
'
'
'   *- REMPLI UNE FLEXGRID à PARTIR D'UN FICHIER TEXTE -*
Public Sub FillFlexGridFromFile(oFG As MSFlexGrid, ByVal sPath As String, Optional ByVal sColumnsSepar As String = vbTab, Optional ByVal sRowsSepar As String = vbCrLf, Optional ByVal bFirstColAsHeader As Boolean = True)
'   nécessite "Microsoft FlexGrid Control 6.0 (SP6)"

'   récupère le tableau du fichier
    Dim aRows() As String
    Call GetArrayFile(sPath, aRows, sRowsSepar)
    
    With oFG
        .Visible = False
'       tableau rempli ?
        If Not IsArrayNull(aRows) Then
            Dim i As Integer, j As Integer, aCols() As String
'           clear (on laisse une ligne et une colonne pour garder le header de la couleur désirée)
            .Rows = 1: .Cols = IIf(bFirstColAsHeader, 1, 0): .Clear
            For i = 0 To UBound(aRows)
                aCols = Split(aRows(i), sColumnsSepar)
                    If i = 0 Then
'                       header
                        .Rows = 1: .Cols = UBound(aCols) + 1
                        For j = 0 To UBound(aCols)
                            .ColWidth(j) = Val(LeftToChar(aCols(j), ":"))
                            .TextMatrix(0, j) = RightFromChar(aCols(j), ":")
                        Next j
                    Else
'                       cellules
                        .Rows = .Rows + 1
                        For j = 0 To UBound(aCols)
                            .TextMatrix(i, j) = aCols(j)
                        Next j
                    End If
                Erase aCols
            Next i
            Erase aRows
        End If
        .Visible = True
    End With
End Sub
'
'
'   *- ENREGISTRE UNE FLEXGRID DANS UN FICHIER TEXTE -*
Public Sub SaveFileFromFlexGrid(oFG As MSFlexGrid, ByVal sPath As String, Optional ByVal sColumnsSepar As String = vbTab, Optional ByVal sRowsSepar As String = vbCrLf)
'   nécessite "Microsoft FlexGrid Control 6.0 (SP6)"

    Dim aRows() As String, i As Integer, j As Integer
    
    With oFG
'       dimensionne le tableau selon la grid
        ReDim aRows(.Rows - 1)

'       header
        aRows(0) = vbNullString
        For j = 0 To .Cols - 1
            aRows(0) = aRows(0) & CStr(.ColWidth(j)) & ":" & .TextMatrix(0, j) & sColumnsSepar
        Next j
        aRows(0) = LeftToChar(aRows(0), sColumnsSepar, True)

'       cellules
        For i = 1 To .Rows - 1
            aRows(i) = vbNullString
            For j = 0 To .Cols - 1
                aRows(i) = aRows(i) & .TextMatrix(i, j) & sColumnsSepar
            Next j
            aRows(i) = LeftToChar(aRows(i), sColumnsSepar, True)
        Next i
    End With

'   sauve
    Call SetArrayFile(sPath, aRows, sRowsSepar)
    Erase aRows
End Sub
'
'
'   *- REMPLI UNE LISTVIEW à PARTIR D'UN FICHIER TEXTE -*
Public Sub FillListViewFromFile(oLV As ListView, ByVal sPath As String, Optional ByVal sColumnsSepar As String = vbTab, Optional ByVal sRowsSepar As String = vbCrLf)
'   nécessite "Microsoft Windows Common Controls 6.0 (SP6)"

'   récupère le tableau du fichier
    Dim aRows() As String
    Call GetArrayFile(sPath, aRows, sRowsSepar)
    
    With oLV
        .Visible = False
'       tableau rempli?
        If Not IsArrayNull(aRows) Then
            Dim i As Integer, j As Integer, aCols() As String, Litem As ListItem
'           clear
            .ListItems.Clear: .ColumnHeaders.Clear
            For i = 0 To UBound(aRows)
                aCols = Split(aRows(i), sColumnsSepar)
                    If i = 0 Then
'                       header
                        For j = 0 To UBound(aCols)
                            .ColumnHeaders.Add , , RightFromChar(aCols(j), ":")
                            .ColumnHeaders.Item(j + 1).Width = Val(LeftToChar(aCols(j), ":"))
                        Next j
                    Else
'                       cellules
                        Set Litem = .ListItems.Add(, , aCols(0))
                        For j = 1 To UBound(aCols)
                            Litem.SubItems(j) = IIf(LenB(aCols(j)) > 0, aCols(j), vbNullString)
                        Next j
                    End If
                Erase aCols
                Set Litem = Nothing
            Next i
            Erase aRows
        End If
        .Visible = True
    End With
End Sub
'
'
'   *- ENREGISTRE UNE LISTVIEW DANS UN FICHIER TEXTE -*
Public Sub SaveFileFromListView(oLV As ListView, ByVal sPath As String, Optional ByVal sColumnsSepar As String = vbTab, Optional ByVal sRowsSepar As String = vbCrLf)
'   nécessite "Microsoft Windows Common Controls 6.0 (SP6)"

    Dim aRows() As String, i As Integer, j As Integer
    
    With oLV
'       dimensionne le tableau selon la listview
        ReDim aRows(.ListItems.Count)

'       header
        aRows(0) = vbNullString
        For j = 1 To .ColumnHeaders.Count
            aRows(0) = aRows(0) & CStr(Round(.ColumnHeaders.Item(j).Width)) & ":" & .ColumnHeaders(j).Text & sColumnsSepar
        Next j
        aRows(0) = LeftToChar(aRows(0), sColumnsSepar, True)

'       cellules
        For i = 1 To .ListItems.Count
            aRows(i) = .ListItems(i).Text & sColumnsSepar
            For j = 1 To .ColumnHeaders.Count - 1
                aRows(i) = aRows(i) & .ListItems(i).SubItems(j) & sColumnsSepar
            Next j
            aRows(i) = LeftToChar(aRows(i), sColumnsSepar, True)
        Next i
    End With

'   sauve
    Call SetArrayFile(sPath, aRows, sRowsSepar)
    Erase aRows
End Sub



'   =============================================================
'                           PROCéDURES/FONCTIONS
'   =============================================================
'
'
'   *- RETOURNE LE CONTENU D'UN FICHIER, COMPLET ET SOUS FORME DE TABLEAU -*
Private Function GetArrayFile(ByVal sPath As String, Optional ByRef aLines As Variant, Optional ByVal sRowsSepar As String = vbCrLf) As String
    Dim FF As Integer
    If FileFolderExists(sPath) Then
        FF = FreeFile
        Open sPath For Input As #FF
            GetArrayFile = Input(LOF(FF), #FF)
        Close #FF
        aLines = Split(GetArrayFile, sRowsSepar)
    End If
End Function
'
'
'   *- EXISTANCE FICHIER/DOSSIER -*
Private Function FileFolderExists(ByRef vsPath As String) As Boolean
    FileFolderExists = (GetFileAttributes(vsPath) <> INVALID_FILE_ATTRIBUTES)
End Function
'
'
'   *- TABLEAU DIMENSIONNé -*
Private Function IsArrayNull(ByRef aArray() As String) As Boolean
    IsArrayNull = ((Not (Not aArray)) = 0)
End Function
'
'
'   *- GAUCHE JUSQU'à UN CARACTèRE (EXCLUS) -*
Private Function LeftToChar(ByVal sStr As String, ByVal sSepar As String, Optional bLast As Boolean = False) As String
    Dim iPos As Integer
    If bLast Then iPos = InStrRev(sStr, sSepar) * 2 - 1 Else iPos = InStrB(1, sStr, sSepar)
    
    If iPos <= 0 Then
        LeftToChar = vbNullString
    Else
        LeftToChar = LeftB$(sStr, iPos - 1)
    End If
End Function
'
'
'   *- DROITE DEPUIS UN CARACTèRE (EXCLUS) -*
Private Function RightFromChar(ByVal sStr As String, ByVal sSepar As String) As String
    Dim iPos As Integer
    iPos = InStrB(1, sStr, sSepar)
    If iPos = 0 Then
        RightFromChar = vbNullString
    Else
        RightFromChar = RightB$(sStr, LenB(sStr) - iPos - 1)
    End If
End Function
'
'
'   *- SAUVE UN TABLEAU DANS UN FICHIER -*
Private Sub SetArrayFile(ByVal sPath As String, ByRef aLines() As String, Optional sRowsSepar As String = vbCrLf)
    Dim FF As Integer
    FF = FreeFile
    Open sPath For Output As #FF
        Print #FF, Join(aLines, sRowsSepar);
    Close #FF
End Sub

Télécharger le zip

05 décembre 2007 18:38:26 :

code (pour ne pas DL le zip)