Module de lecture des fichiers dbf

Télécharger le projet
Commenter

Description

Module .bas contenant les fonctions qui permettent de lire un fichier dbf3 ou 4, et donc d'en récupérer la structure et les données.

Source / Exemple : 


Attribute VB_Name = "lectDBF"
'********************************************************************************
'*
'*  Module de lecture des fichiers DBF 3 et 4.
'*  Il suffit d'appeller la fonction lireDBF(nomDuFichier$)
'*  Les valeurs récupérées sont insérées dans la variable valchamp() en final,
'*  au format texte. Pour retrouver le bon format, il faut convertir selon
'*  les paramètres de champ(x).fieldType.
'*  Pour plus d'infos sur le format dbf, le fabuleux site http://www.wotsit.org
'*
'*  auteur : Laurent Jégou, jegou@univ-tlse2.fr
'*           Dept. de Géographie
'*           Université de Toulouse-Le Mirail
'********************************************************************************
'
Private Type fieldDbf 'Type Champ contenant les diverses infos.
    fieldName As String 'Nom du champ
    fieldType As String 'Type de données
    fieldLength As Long 'Longueur du champ (en DBF toutes les données sont écrites en texte, donc de longueur constante par champ.
    fieldDecimales As Byte 'Nombre de décimales
End Type
Private EOFH As Boolean 'Fin du fichier oui/non.
Private champ() As fieldDbf 'Tableau des champs.
Private nbchamps As Byte 'Nombre de champs de la table (max = 255).
Private numEnr As Integer 'Nombre d'enregistrements de la table.
Private valchamp() As String 'Variable texte recevant les valeurs de la table.

Public Sub lireDBF(ficdbf$)
Dim a As Byte
Dim b As Byte
Dim c As Byte
Dim d As Byte
Dim ha$
Dim hb$
Dim hc$
Dim hd$
Dim valeur As Integer
Dim vdbl As Double
Dim lastDate As Date 'Dernière date de modification du fichier.
Dim numBHeader As Integer 'Nombre de bits du header.
Dim numBEnr As Integer 'Nombre de bits par enregistrement.
Dim nc$
Dim cec As Byte 'Numéro du champ en cours
ReDim champ(255)
Open ficdbf$ For Binary Access Read As #1 'Ouverture du fichier en mode séquentiel binaire.
Get #1, , a
Get #1, , b
Get #1, , c
Get #1, , d
    ha$ = Hex$(a): If Len(ha$) = 1 Then ha$ = "0" & ha$
    hb$ = Hex$(b): If Len(hb$) = 1 Then hb$ = "0" & hb$
    hc$ = Hex$(c): If Len(hc$) = 1 Then hc$ = "0" & hc$
    hd$ = Hex$(d): If Len(hd$) = 1 Then hd$ = "0" & hd$
    hb$ = CByte("&h" & hb$)
    hc$ = CByte("&h" & hc$)
    hd$ = CByte("&h" & hd$)
    If Val(hb$) >= 100 Then hb$ = Str$(2000 + (Val(hb$) - 100)) 'Bug de l'an 2000...
    lastDate = CDate(hd$ & "/" & hc$ & "/" & hb$)
Get #1, , a
Get #1, , b
Get #1, , c
Get #1, , d
    ha$ = Hex$(a): If Len(ha$) = 1 Then ha$ = "0" & ha$
    hb$ = Hex$(b): If Len(hb$) = 1 Then hb$ = "0" & hb$
    hc$ = Hex$(c): If Len(hc$) = 1 Then hc$ = "0" & hc$
    hd$ = Hex$(d): If Len(hd$) = 1 Then hd$ = "0" & hd$
    numEnr = CDbl("&h" & hd$ & hc$ & hb$ & ha$)
    Get #1, , a
    Get #1, , b
    ha$ = Hex$(a): If Len(ha$) = 1 Then ha$ = "0" & ha$
    hb$ = Hex$(b): If Len(hb$) = 1 Then hb$ = "0" & hb$
    numBHeader = CInt("&h" & hb$ & ha$)
    Get #1, , a
    Get #1, , b
    ha$ = Hex$(a): If Len(ha$) = 1 Then ha$ = "0" & ha$
    hb$ = Hex$(b): If Len(hb$) = 1 Then hb$ = "0" & hb$
    numBEnr = CInt("&h" & hb$ & ha$)
For i = 1 To 20
    Get #1, , a
Next i
nbchamps = 0
cec = 1 'Initialisation du numéro de champ en cours.
header:
    Get #1, , a
    ha$ = Hex$(a)
    If Len(ha$) = 1 Then ha$ = "0" & ha$
    If ha$ = "0D" Then GoTo records
    Get #1, Seek(1) - 2, a
    getDbfFieldHeader (cec) 'Appel de la fonction de lescture du header.
    cec = cec + 1
GoTo header
records:
nbchamps = cec - 1
ReDim Preserve champ(nbchamps)
ReDim valchamp(nbchamps, numEnr)
Call lirecontenu
End Sub

Private Sub getDbfFieldHeader(cec)
Dim a As Byte
Dim ha$
Dim nf$ 'Nom du champ.
Dim finNom As Boolean
finNom = False
For i = 1 To 11
    Get #1, , a
    ha$ = Chr$(a)
    If a = 0 And finNom = False Then
        champ(cec).fieldName = nf$
        nf$ = ""
        finNom = True
    Else
        If finNom = False Then nf$ = nf$ + ha$
    End If
Next i
Get #1, , a
ha$ = Chr$(a)
Select Case ha$ 'Affectation du type de données du champ en cours.
    Case Is = "C"
        champ(cec).fieldType = "Texte"
    Case Is = "F"
        champ(cec).fieldType = "Flottant"
    Case Is = "N"
        champ(cec).fieldType = "Numérique"
    Case Else
        champ(cec).fieldType = "Autre"
End Select
Get #1, , a 'Décalage
Get #1, , a
Get #1, , a
Get #1, , a
Get #1, , a
ha$ = Hex$(a): If Len(ha$) = 1 Then ha$ = "0" & ha$
champ(cec).fieldLength = CByte("&h" & ha$) 'Affectation de la longueur.
Get #1, , a
ha$ = Hex$(a): If Len(ha$) = 1 Then ha$ = "0" & ha$
champ(cec).fieldDecimales = CByte("&h" & ha$) 'Affectation du nombre de décimales.
For i = 1 To 14
    Get #1, , a
Next i
End Sub

Public Sub lirecontenu() 'Après lecture du header général et des header de champs, lecture des données.
Dim a As Byte
Dim nc$ 'Variable de stockage des valeurs.
For i = 1 To numEnr
    Get #1, , a
    For j = 1 To nbchamps
        nc$ = ""
        For k = 1 To champ(j).fieldLength
            Get #1, , a
            If Chr$(a) <> " " Then nc$ = nc$ + Chr$(a)
        Next k
        valchamp(j, i) = nc$ 'Valeur de l'enregistrement J du champ I
    Next j
Next i
Close #1 'Fermeture du fichier
End Sub
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (LeCarto)