Import vcard avec champ plusieurs lignes
Comment cela pas trouvé ?!
ADR;TYPE=WORK:;;rue;test localité;;CP910;Francetu m'as dit qu'il allait en colonne 18
Cells(derlig, 18) = S2(2) ' Ad
j'ai même mis en 18, 19, 20 et 21 conformément à ton fichier
je sais pourquoi parce que les adresses sont parfois en home
ADR;TYPE=HOME:
dans mes vcard y a pas 2 adresses c'est soit home ou work .
faut juste mettre
Case "ADR" 'adresseautrement c'est parfait
une question sur :
If derlig = 5 And Cells(4, 8) = "" Then derlig = 4cells 4,8 vide je comprend pas
sinon la première ligne du tableau (la 4) serait restée vierge au démarrageune question sur :
If derlig = 5 And Cells(4, 8) = "" Then derlig = 4
plus besoin, j'en ai profité pour ré-écrire plus proprement
pur l'url
comme y a un split sur : et q'une url contient :
j'avais mis :
Case "URL" ' url site web
Cells(derlig, 17) = "" ' Pas de site WEB
Cells(derlig, 17) = S1(1) ' Site WEB sans HTTP
On Error Resume Next
Cells(derlig, 17) = S1(1) & ":" & S1(2) ' Site WEB avec HTTP +ajout:et il manque ORG:
Case "ORG" ' Société
ajouter 10, S1(1)comme y a un split sur : et q'une url contient :
exact
j'espère qu'on ne rencontrera pas un : dans une note !!
je n'ai jamais adopté la stratégie de Left(_,3) car pour le téléphone seul le dernier numéro serait alors retenu
néanmoins j'ai modifié le select pour donner plus de souplesse
et pris un vrai module de lecture des caractères unicode https://forum.excel-pratique.com/viewtopic.php?p=662819#p662819
Sub Import_vCard()
Dim ChemDossier As String, ligne As String, List_vcf() As String, Fichier As String, f As Integer
Dim S1() As String, S2() As String
Dim i As Integer, num_fichier As Integer
With ActiveSheet.ListObjects(1)
ChemDossier = ChoixDossier
If Not ChemDossier = "" Then
Fichier = Dir(ChemDossier & "\*.vcf")
If Fichier = "" Then
MsgBox "Pas de fichier vCard dans ce dossier !", vbExclamation, "OUPS ..."
Exit Sub
End If
Do
i = i + 1
ReDim Preserve List_vcf(1 To i)
List_vcf(i) = Fichier
Fichier = Dir
Loop Until Fichier = ""
On Error Resume Next
' .DataBodyRange.Delete ' effacement si nécessaire
On Error GoTo 0
For i = 1 To UBound(List_vcf)
.ListRows.Add
f = FreeFile
Open ChemDossier & "\" & List_vcf(i) For Input As f
While Not EOF(f)
Line Input #f, ligne
If Len(ligne) > 0 Then
S1 = Split(ligne, ":")
Select Case True
Case S1(0) = "N"
S2 = Split(S1(1), ";")
ajouter 8, S2(0): ajouter 7, S2(1)
Case S1(0) = "TITLE"
ajouter 9, S1(1)
Case S1(0) = "ROLE"
ajouter 11, S1(1)
Case S1(0) = "ORG"
ajouter 10, S1(1)
Case S1(0) = "EMAIL;TYPE=WORK"
ajouter 16, S1(1)
Case S1(0) = "TEL;TYPE=WORK"
ajouter 12, S1(1)
Case S1(0) = "TEL;TYPE=OTHER"
ajouter 13, S1(1)
Case S1(0) Like "ADR*"
S2 = Split(S1(1), ";")
ajouter 18, S2(2): ajouter 19, S2(5): ajouter 20, S2(3): ajouter 21, S2(6)
Case S1(0) Like "URL*"
If UBound(S1) >= 2 Then
ajouter 17, S1(1) & ":" & S1(2)
Else
ajouter 17, S1(1)
End If
Case S1(0) = "NOTE"
ajouter 22, S1(1)
Case S1(0) = "X-SIRET"
ajouter 26, S1(1)
Case S1(0) = "X-VAT"
ajouter 27, S1(1)
End Select
If InStr(ligne, ":") = 0 Then ajouter 22, Mid(ligne, 2, Len(ligne)), True
End If
Wend
Close f
Next i
If i = 0 Then Exit Sub
End If
End With
Cells.EntireRow.AutoFit
If i > 1 Then MsgBox " " & i - 1 & " contact(s) vCard ajouté(s)." & Chr(10) & Chr(10) & "", vbInformation, "Import vCard"
End Subgénial , super merci beaucoup pour ton aide.
le code est parfait
pour NOTE si : sont présent la ligne saute
avec une autre fonction si existe : dans note supprimer les : avant d'insérer
pour avoir tous les numero de tel selon tous les type de numero et le format de vcard 3.0 ou 4.0 :
Case S1(0) Like "TEL*"
If S1(0) Like "*W*;*V*" Then ajouter 12, S1(1) 'Tel_fix_Pro
If S1(0) Like "*WORK*" Then ajouter 12, S1(1) 'Tel_fix_Pro
If S1(0) Like "*WORK;V*" Then ajouter 10, S1(1) 'Tel_fix_Pro
If S1(0) Like "*OTHER*" Then ajouter 13, S1(1) 'Tel_Autre
If S1(0) Like "*CEL*" Then ajouter 14, S1(1) 'Tel_Mobil
If S1(0) Like "*FAX*" Then ajouter 15, S1(1) 'Faxca te parait jouable ?
le code entier
Option Explicit
Public F1 As Worksheet
'final v3
Sub Import_vCard()
Dim ChemDossier As String, ligne As String, List_vcf() As String, Fichier As String, f As Integer
Dim S1() As String, S2() As String
Dim i As Integer, num_fichier As Integer
With ActiveSheet.ListObjects(1)
ChemDossier = ChoixDossier
If Not ChemDossier = "" Then
Fichier = Dir(ChemDossier & "\*.vcf")
If Fichier = "" Then
MsgBox "Pas de fichier vCard dans ce dossier !", vbExclamation, "OUPS ..."
Exit Sub
End If
Do
i = i + 1
ReDim Preserve List_vcf(1 To i)
List_vcf(i) = Fichier
Fichier = Dir
Loop Until Fichier = ""
On Error Resume Next
' .DataBodyRange.Delete ' effacement si nécessaire
On Error GoTo 0
For i = 1 To UBound(List_vcf)
.ListRows.Add
f = FreeFile
Open ChemDossier & "\" & List_vcf(i) For Input As f
While Not EOF(f)
Line Input #f, ligne
If Len(ligne) > 0 Then
S1 = Split(ligne, ":")
Select Case True
Case S1(0) = "N"
S2 = Split(S1(1), ";")
ajouter 8, S2(0): ajouter 7, S2(1)
Case S1(0) = "TITLE"
ajouter 11, S1(1)
Case S1(0) = "ROLE"
ajouter 9, S1(1)
Case S1(0) = "ORG"
ajouter 10, S1(1)
Case S1(0) Like "*MAIL*"
ajouter 16, S1(1)
Case S1(0) Like "*TEL*"
If S1(0) Like "*W*;*V*" Then ajouter 12, S1(1) 'Tel_fix_Pro
If S1(0) Like "*WORK*" Then ajouter 12, S1(1) 'Tel_fix_Pro
If S1(0) Like "*WORK;V*" Then ajouter 12, S1(1) 'Tel_fix_Pro
If S1(0) Like "*OTHER*" Then ajouter 13, S1(1) 'Tel_Autre
If S1(0) Like "*M2*" Then ajouter 13, S1(1) 'Tel_Autre
If S1(0) Like "*CEL*" Then ajouter 14, S1(1) 'Tel_Mobil
If S1(0) Like "*FAX*" Then ajouter 15, S1(1) 'Fax
Case S1(0) Like "ADR*"
S2 = Split(S1(1), ";")
ajouter 18, S2(2): ajouter 19, S2(5): ajouter 20, S2(3): ajouter 21, S2(6)
Case S1(0) Like "URL*"
If UBound(S1) >= 2 Then
ajouter 17, S1(1) & ":" & S1(2)
Else
ajouter 17, S1(1)
End If
Case S1(0) = "NOTE"
ajouter 22, correction2(S1(1))
Case S1(0) = "X-SIRET"
ajouter 26, S1(1)
Case S1(0) = "X-VAT"
ajouter 27, S1(1)
End Select
If InStr(ligne, ":") = 0 Then ajouter 22, Mid(ligne, 2, Len(correction2(ligne))), True
End If
Wend
Close f
Next i
If i = 0 Then Exit Sub
End If
Set F1 = Worksheets("Data1")
F1.Rows("4:" & F1.Range("A" & Rows.Count).End(xlUp).Row).RowHeight = 30
End With
'Set F1 = Worksheets("Data1")
'F1.Rows("4:" & F1.Range("A" & Rows.Count).End(xlUp).Row).RowHeight = 30
If i > 1 Then MsgBox " " & i - 1 & " contact(s) vCard ajouté(s)." & Chr(10) & Chr(10) & "", vbInformation, "Import vCard"
End Sub
Sub ajouter(col As Integer, ceci As String, Optional ajout As Boolean = False)
With ActiveSheet.ListObjects(1)
.ListColumns(col).DataBodyRange(.ListRows.Count, 1) = IIf(ajout, .ListColumns(col).DataBodyRange(.ListRows.Count, 1), "") & correction(ceci)
End With
End Sub
' Code SilkyRoad
Function ChoixDossier() As String
Dim Dossier As FileDialog
Set Dossier = Application.FileDialog(msoFileDialogFolderPicker)
Dossier.Show
On Error GoTo errhdlr
ChoixDossier = Dossier.SelectedItems(1)
Exit Function
errhdlr:
ChoixDossier = ""
End Function
Function correction2(texte_not As String)
correction2 = texte_not
correction2 = Replace(correction2, ":", "")
End Function
Function correction(texte As String)
correction = texte
correction = Replace(correction, "ç", "ç")
correction = Replace(correction, "à¨", "è")
correction = Replace(correction, "è", "è")
correction = Replace(correction, "é", "é")
correction = Replace(correction, "â", "â")
correction = Replace(correction, "Ã", "à")
correction = Replace(correction, " à ", " à ")
correction = Replace(correction, " à ", " à ")
correction = Replace(correction, " Â ", " ")
correction = Replace(correction, " à Â", " à ")
correction = Replace(correction, " Ã Â ", " à ")
correction = Replace(correction, " Ã Â ", " à ")
correction = Replace(correction, " Ã Â ", " à ")
correction = Replace(correction, " à ", " à ")
correction = Replace(correction, " à‚Â ", "")
correction = Replace(correction, "à‹", "Ë")
correction = Replace(correction, "à¢", "â")
correction = Replace(correction, "à®", "î")
correction = Replace(correction, "à´", "ô")
correction = Replace(correction, "àª", "ê")
correction = Replace(correction, "’", "'")
correction = Replace(correction, "\n", vbCrLf)
correction = Replace(correction, "\", ", ")
correction = Replace(correction, " http //", "http://")
correction = Replace(correction, " https //", "https://")
correction = Replace(correction, ",", "")
'correction = Replace(correction, ".", "")
correction = Replace(correction, " , ", "")
correction = Replace(correction, "m²", "m²")
'correction = Replace(correction, "/", "-")
End Functionpour NOTE si : sont présent la ligne saute
avec une autre fonction si existe : dans note supprimer les : avant d'insérer
oui mais comment distinguer de la première ligne NOTE ?
il faudrait ajouter un flag ... ce que je vais faire
pour avoir tous les numero de tel selon tous les type de numero et le format de vcard 3.0 ou 4.0 :
Case S1(0) Like "TEL*" If S1(0) Like "*W*;*V*" Then ajouter 12, S1(1) 'Tel_fix_Pro If S1(0) Like "*WORK*" Then ajouter 12, S1(1) 'Tel_fix_Pro If S1(0) Like "*WORK;V*" Then ajouter 10, S1(1) 'Tel_fix_Pro If S1(0) Like "*OTHER*" Then ajouter 13, S1(1) 'Tel_Autre If S1(0) Like "*CEL*" Then ajouter 14, S1(1) 'Tel_Mobil If S1(0) Like "*FAX*" Then ajouter 15, S1(1) 'Faxca te parait jouable ?
excellente idée si cela fonctionne, c'est tout l'intérêt d'être passé au select true (qui n'est rien d'autre qu'un if ... elseif peut-être plus efficace mais moins élégant !).
mets à jour le code pour éviter cette litanie de remplacement, je suis parti d'un code plus "professionnel", cf dernière mouture
je la renvoie demain quand j'aurais traité le cas de NOTE
In fine, pour NOTES je me suis basé sur la présence d'un espace en début de ligne. Il faudrait peut-être en tenir compte ici https://forum.excel-pratique.com/viewtopic.php?f=2&t=130241&p=799408#p799408
J'ai aussi remarqué que NOTES se terminait ps un astérisque que je n'ai pas enlevé ici.
' lignes NOTES multiples
If Left(ligne, 1) = " " Then ajouter 22, Mid(ligne, 2, Len(ligne)), TrueBonjour,
Parfait ça fonctionne tres bien et plus rapide.
C'est exactement ce dont j'avais besoin.
Un grand merci à toi Steelson.
Ps l'astérisque c'est moi qui l'avais rajouté pour voir si tout le texte était placé dans la cellule.
Cool
Bonjour,
je viens de remarquer un truc c'est que quand l'adresse est longue,
j'ai un message d'erreur et il n'y a que la première partie dans ma cellule.
La limite de 76 caractères sur une ligne dans un vcard y est pour quelque chose.
j'ai des contacts avec des adresses qui sont parfois sur 3 lignes.
Pour l'export, ajoute :
=transformer(____________la ligne concernée______________) & vbcrlfet cela pour toutes les lignes potentiellement concernées.
cela devrait fonctionner.
exemple
& transformer("ADR;TYPE=HOME:;;" & Adr_pro & ";" & Ville_pro & ";;" & CP_pro & ";" & Pays) & vbCrLf _Pour l'import, c'est super compliqué car la zone est ensuite éclatée en découpant selon ;
Je vais réfléchir (mais pas tout de suite), cela passera sans doute par une seule zone d'abord, qu'on éclatera ensuite dans un second temps.
En fait c'est pas sur l'export le probleme c'est sur l'import.
J'ai mis un fichier vcard dans mon dernier post.
OUi je pense aussi on rassemble tout la ligne entière puis on split apres chaque ;
Voici, avec ajout d'une colonne
Bonjour Steelson,
j'ai testé ton code ça fonctionne super, un grand merci à toi.
Jean