5/5 (6 avis)
Vue 16 236 fois - Téléchargée 990 fois
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
24 janv. 2012 à 21:30
Un grand merci, il m'a bien aidé et encore aujourd'hui,
Après des légères modifications, je l'ai adapté pour un soft perso de conversion multiple dbf, csv, mdb,html, accdb, fic.
Tout sa dans un ListView à ma sauce de VulgarisBarbarian !
Faudra que je pense à mettre mon joujou ici ! même si c'est tout écrit en VB5~VB6 ! Et ma note: 10/10 !
2 oct. 2008 à 21:14
Encore bravo à LeCarto....
FanLaBise...
17 mars 2008 à 22:52
df
8 juil. 2007 à 08:27
8 juil. 2007 à 02:58
je veux me connecter à une dbf avec VB en utilisant les options d'ArcGis.
aidez moi s'il vous plait
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.