|
Trouver une ressource
Vous ne trouvez pas de réponse à votre problème ? Alors posez la question dans le forum. Souvenez-vous qu'il n'y a jamais de question bête, mais rester dans l'ignorance parce que l'on n'ose pas poser une question, ça c'est une erreur !
CHARGER UNE MSFLEXGRID OU UNE LISTVIEW À PARTIR D'UN FICHIER TEXTE (ET VICE-VERSA) EN TENANT COMPTE DE LA TAILLE DES COLONNES [MODULE]
Information sur la source
Description
bonjour, juste un module qui peut se révéler pratique (aux vues des nombreuses demandes sur le forum) pour remplir une flex ou LV à partir d'un fichier texte, et de créer le fichier selon leur contenu
Source
- ' ---------------------------------------------------------------------------------
- ' [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
' ---------------------------------------------------------------------------------
' [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
Conclusion
4 fonctions à utiliser, pas bien compliqué. une form exemple est néanmoins fournie
Fichier Zip
Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !
Télécharger le zip
Historique
- 05 décembre 2007 18:38:26 :
- code (pour ne pas DL le zip)
Sources du même auteur
Sources de la même categorie
Sources en rapport avec celle ci
Commentaires et avis
Discussions en rapport avec ce code source dans le forum
Lecture d'un fichier Hexa [ par SEB73460 ]
Bonjour,Pourriez-vous m'indiquer la marche à suivre pour pouvoir lire et affcher le contenu d'un fichier Hexadécimal dans un listviewEn effet, je souh
sos listview [ par joseph6610 ]
salutje suis intersse par le code vb6 j ai volut Envoyer les collonnes selectionner dans un listview,dans un fichier par la methode Envoyer ver.l aide
Aide pour un TrreView et ListView [ par J_il ]
Bonjour à tous,J'ai un souci de compréhension ! J'ai fais énormément de recherche avant de finalement poser ma question car je n'arrive aps à comprend
Supprimer les caracteres > taille de mon fichier [ par SEB73460 ]
Bonsoir à tous,En vb.netVoila, je visualise les octets d'un fichier dans un listview Je voudrai ne pas afficher plus que la taille de mon fichier à sa
Synchroniser 2 ListView [ par neo2k2 ]
Bonjour, Ma demande est assez urgente car dans le cadre de mon association, je souhaiterais comparer le contenu de 2 ListView.Ma Form contient 2 ListV
Sauver des couleurs [ par jepimo ]
Bonjour à tous,Je suis débutant, je modifi la couleur du text d'une TextBox avec ColorDialog1, et j'aimerais sauvegarder cette couleur puis la rechage
Sauver correctement un fichier excel ? [ par Jacky7 ]
Bonjour a tous,J'ai fait un prog qui me permet d'ouvrir une feuille excel ou de la créer si elle n'existe pas puis d'écrire dedans et de la re sauvega
Importer un fichier CSV vers un listview [ par Razor_rws1 ]
Salut, comme c'est indiqué dans le titre, je cherche un moyen simple et rapide d'importer les données d'un ficher CSV vers un listview.Merci de votre
Fin d'un fichier Hexa [ par SEB73460 ]
Bonsoir,Voila, j'ouvre un fichier Hexadecimal dans un listview ( 16 colonne de 2 octets chacune )Mais à la fin de mon fichier je me retrouve avec des
sauver ac un nom de fichier variable (Débutant!) [ par jule29 ]
Bonjour,J'utilise le VBA sous excel pour un probleme d'optimisation. je genere des formes de maniere aléatoire (en utisant l'agorithme d'halton) et je
|
Téléchargements
Logiciels à télécharger sur le même thème :
Comparez les prix Nouvelle version
|