Import vcard avec champ plusieurs lignes

Bonjour,

j'ai codé un module pour importer mes vcard vers un tableau.

Le texte du champ noté de mon vcard est très long.

Il est coupé et mis sur plusieurs lignes.

ce que j'essaye de faire c'est importer toutes les lignes de ce champ dans une cellule.

j'ai mis le xlsm et le vcard dans un zip

Pas simple merci de vos idées et de votre aide

Bonjour,

Après

                End Select

ajoute cette ligne :

                If InStr(ligne, ":") = 0 Then new_Contact(21, i) = new_Contact(21, i) & ligne

ps : jamais vu un programme aussi mal indenté ! Bravo ...

Bonjour,

c'est tout le texte après NOTE: qu'il faut copier dans une cellule.

Je crois deviner peut-être qu'il y a une limite du nombre de caractère à 255 sur une seule ligne.

Faut que je trouve une autre solution pour insérer tout le texte.

As-tu essayé la modification proposée ?

A priori, j'avais réussi à tout mettre dans une cellule excel avec un simple copier/coller.

Oui, j'ai un message d'erreur

Peux-tu me faire une copie d'écran ?

sur quelle ligne ?

quel type d'erreur ?

Si c'est bien cette erreur, cela n'a rien à voir avec la demande.

J'avais essayé en allégeant le code (de façon à y voir clair !) avec juste un debug.print et je récupérais bien l'intégralité de la zone

oui ce message rapporte : Erreur 13: incompatibilité de type

je sais pas pourquoi.

c'est quand la valeur est transposée dans la cellule

je vais te proposer quelque chose de plus simple à partir de ton code !

un premier jet rapide ... à peaufiner !

edit : suppression du fichier pour ne garder que le dernier du fil

oui c'est bien

par contre j'ai les autres champs

Merci

Un peu plus propre encore

Option Explicit 'Module 2 import contacts vCard v3.0
Public F1 As Worksheet
Sub Import_vCard()
Dim ChemDossier As String, ligne As String, S1() As String, S2() As String, List_vcf() As String, Fichier As String, n_fichier2 As String
Dim i As Integer, f As Integer, Id As Integer, nbtel As Integer, derlig As Integer, num_fichier As Integer

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 = ""

    Id = Application.Max(Sheets("Data1").Range("A:A"))
    nbtel = 0

    For i = 1 To UBound(List_vcf)
        derlig = Cells(Rows.Count, "V").End(xlUp).Row + 1
        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 UCase(Left(S1(0), 3))

                Case "NOT"
                    Cells(derlig, "V") = correction(S1(1)) ' Note

                End Select
                If InStr(ligne, ":") = 0 Then Cells(derlig, "V") = Cells(derlig, "V") & correction(ligne)
            End If
        Wend
        Close f
    Next i

    If i = 0 Then Exit Sub

End If

Cells.EntireRow.AutoFit

If i > 1 Then MsgBox "    " & i - 1 & " contact(s) vCard ajouté(s)." & Chr(10) & Chr(10) & "", vbInformation, "Import vCard"

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 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, "\,", ",")
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 Function

Pour les autres champs, ils étaient tous inhibés dans ta macro.

Il faudrait me donner la correspondance entre le code de la VCARD et la colonne de la feuille.

Dans tous les cas, le sujet posté est lui résolu puisqu'il s'agissait d'importer plusieurs lignes dans la même cellule.

edit : suppression du fichier pour ne garder que le dernier du fil

Merci pour ton temps passé,

c'est super. testé ca marche bien.

sur la correction plutot que de remplacer \ fair un Chr(10).

Tous les champs sont en base 0:

ex : Case "N", et

colonne 6 = S2(1) ' Prénom

colonne 7 = S2(0) ' Nom

dans le vcard c'est : N:nom fam;prnom;;société test socpas fait;

en faisant un split apres chaque ;

S2(0) c'est nom fam;

S2(1) c'est prnom

etc

je suis passé en base 1 et j'ai mis le numéro de colonne.

merci

C'est surtout \n qui est un retour à la ligne.

A priori il n'aime pas trop chr(10), j'emploie alors vbcrlf.

Bon , j'aurais aimé connaître la correspondance en n° de colonne de tout en fait ...

BEGIN
VERSION
PRODID
UID
FN
N
TITLE
ROLE
ORG
EMAIL;TYPE=WORK
EMAIL;TYPE=OTHER
TEL;TYPE=WORK
TEL;TYPE=OTHER
TEL;TYPE=HOME
TEL;TYPE=CELL
ADR;TYPE=WORK
URL;TYPE=WORK
NOTE
REV
X-SIRET
X-VAT
X-THUNDERBIRD-ETAG
END

Je vais chercher ...

oui je comprend faut reprendre la 1er version du fichier que j'ai posté et ajouter 1 à chaque numero de colonne comme je suis passé en base : 'new_Contact(6, i) = S2(1) ' Prénom qui fait Cells(derlig, 7) = S2(1) ' Prénom

j'ai ça pour l'instant

Case "N", "N;" ' en split s2, s1 en variable seule et (1) c'est le rang dans le fichier VCF apres le ; qui correspond, ouvrir avec bloc note pour voir
S2 = Split(S1(1), ";")
'new_Contact(7, i) = S2(1) ' Prénom
Cells(derlig, 7) = S2(1) ' Prénom
'new_Contact(8, i) = S2(0) ' Nom
Cells(derlig, 8) = S2(0) ' Nom

'  new_Contact(29, i) = S2(3) ' Ajout prefixe pour affichage android
'Case "FN"
 '   new_Contact(28, i) = S1(1) ' Ajout nom affiché pour affichage android
Case "TIT"
Cells(derlig, 11) = S1(1) 'Fonction

'    new_Contact(11, i) = S1(1) 'Fonction

Case "ORG"
Cells(derlig, 10) = S1(1) ' Société

'    new_Contact(10, i) = S1(1) ' Société

Case "ROL"
Cells(derlig, 9) = S1(1) ' secteur

'    new_Contact(9, i) = S1(1) ' secteur

Case "ADR" 'adresse
S2 = Split(S1(1), ";")
Cells(derlig, 18) = S2(2)  ' Ad

juste les champ non utile :

BEGIN :pas besoin

VERSION :pas besoin

PRODID :pas besoin

UID :pas besoin

FN :pas besoin

N

TITLE

ROLE

ORG

EMAIL;TYPE=WORK

EMAIL;TYPE=OTHER :pas besoin

TEL;TYPE=WORK

TEL;TYPE=OTHER

TEL;TYPE=HOME

TEL;TYPE=CELL

ADR;TYPE=WORK

URL;TYPE=WORK

NOTE

REV :pas besoin

X-SIRET

X-VAT

X-THUNDERBIRD-ETAG :pas besoin

END :pas besoin

Avec le vcard test :

edit : suppression du fichier pour ne garder que le dernier du fil

merci beaucoup Steelson pour ton aide vraiment.

je vais regarder ca demain, bonne soirée.

Tu peux enlever correction là où ce n'est pas strictement nécessaire

Mon seul soucis est que le nom ou l'adresse ne soit pas toujours complet (question de nombre de membres séparés par ;)

Bonjour,

je viens de voir ça.

Case "ADR n'est pas trouvé

c'est pur ca que j'avais mis Select Case UCase(Left(S1(0), 3)) selection par Ucase

en majuscule sur 3 lettres

les noms parfois N ou N;

Case "N", "N;"

si non On Error Resume Next sin non il se produit une erreur

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: