XL 2019 QR code pour Vcard

australopitheque · 1 Octobre 2021

bonjour a tous
j'ai en piochant a gauche et a droite des idées pour mon projet.
j'explique je voulait a partir de donnée perso (nom , prénom ,adresse etc etc) crée un qrcode pour y faire ma carte de visite avec du contenue vcard dans le qrcode.
mais j'ai du mal avec la mise en page de ma carte de visite (mettre en gras certaine partie, voir colorisation et l'ajout d'un logo sur la carte en arrière plan style filigrane.
je voulait avoir votre avis et conseil.

Compte Supprimé 979 · 2 Octobre 2021

Bonjour Australopitheque et bienvenue sur ce forum

Joli petite trouvaille ton générateur de QRcode au format vcard

Pour le texte, tu seras obligé de passer par du code VBA, pas d'autre choix
Voici un code explicatif de ce qu'on peut faire, à adapter à tes besoins

VB:

Sub FormatPartieCellule()
Dim motdebut As String, montant As String, motfin As String, compte As String, a As String, b As String, c As String, d As String

motdebut = "Merci de verser la somme de : "
montant = Format(Range("B3"), "#,##0.00 €")
motfin = "  sur le compte bancaire "
compte = "000-1234567-89"

'on écrit la phrase en D17
Range("D17") = motdebut & montant & motfin & compte

' on compte le nombre de caractères
a = Len(motdebut)
b = Len(montant)
c = Len(compte)
d = Len(Range("D17"))

' on met le montant dans les formats désirés (à partir de a, le nombre de caractères de b)
With Range("D17").Characters(Start:=a, Length:=b + 1).Font
    .Bold = True 'gras
    .ColorIndex = 3 'rouge
    .Italic = True 'italique
    .Underline = xlUnderlineStyleSingle 'souligné
End With

'on met le compte en gras
Range("D17").Characters(Start:=d - c + 1, Length:=c).Font.Bold = True

End Sub

@+

australopitheque · 2 Octobre 2021

merci pour ton aide j'ai fait une mise en form vb comme tu me l'a conseillé.
et crée une zone de texte de mise en forme qui ce reproduit dans ma fenêtre de carte de visite.
dés modification des données tout ce mets en forme, texte et qr code.

VB:

Dim noEvents As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tmp, ch As String, i As Long, j As Long
    If noEvents Then Exit Sub
    If Not Intersect(Target, [B11:B33]) Is Nothing Then
        tmp = [C11:C33].Value
        For i = 1 To 23
            ch = ch & " " & tmp(i, 1)
        Next i
        noEvents = True
        [D2].Value = Mid(ch, 2)
        i = 1
        For j = 0 To 22
            With [D2].Characters(i, Len(tmp(j + 1, 1)) + 1).Font
                .Color = [c11].Offset(j).Font.Color
                .Bold = [c11].Offset(j).Font.Bold
                .Italic = [c11].Offset(j).Font.Italic
            End With
            i = i + Len(tmp(j + 1, 1)) + 1
        Next j
        noEvents = False
    End If
End Sub

australopitheque · 2 Octobre 2021

bonjour
par contre comment faire répéter la zone d'impression sur la même feuille ?
j'ai fait un bouton avec macro simple d'apercu et après d'impression si on choisie de le faire.
mais je voit pas du tout comment faire pour faire une mosaique de l'impressions sur la même feuille.(faire plusieur carte sur la même impression)

VB:

Sub imprimer_apercu()
'
' imprimer_apercu Macro
'
Application.Dialogs(xlDialogPrintPreview).Show
'
End Sub

dysorthographie · 2 Octobre 2021

australopitheque à dit:

merci pour ton aide j'ai fait une mise en form vb comme tu me l'a conseillé.
et crée une zone de texte de mise en forme qui ce reproduit dans ma fenêtre de carte de visite.
dés modification des données tout ce mets en forme, texte et qr code.

VB:

Dim noEvents As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tmp, ch As String, i As Long, j As Long
    If noEvents Then Exit Sub
    If Not Intersect(Target, [B11:B33]) Is Nothing Then
        tmp = [C11:C33].Value
        For i = 1 To 23
            ch = ch & " " & tmp(i, 1)
        Next i
        noEvents = True
        [D2].Value = Mid(ch, 2)
        i = 1
        For j = 0 To 22
            With [D2].Characters(i, Len(tmp(j + 1, 1)) + 1).Font
                .Color = [c11].Offset(j).Font.Color
                .Bold = [c11].Offset(j).Font.Bold
                .Italic = [c11].Offset(j).Font.Italic
            End With
            i = i + Len(tmp(j + 1, 1)) + 1
        Next j
        noEvents = False
    End If
End Sub

Dans cette version ton QrCode ne fonctionne pas!
tu retraite pas le format de ton url!

Voila un exemple

VB:

Private Function AssainirURL(MonURL As String) As String
On Error GoTo FonctionErreur

Dim URLtemporaire As String

URLtemporaire = MonURL
URLtemporaire = Replace(URLtemporaire, "%", "%25", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, Chr(10), "%0A", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, Chr(13), "%0D", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, ":", "%3A", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, " ", "%20", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, """", "%22", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "#", "%23", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "$", "%24", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "&", "%26", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "'", "%27", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "(", "%28", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "°", "%C2%B0", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, ")", "%29", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "*", "%2A", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "+", "%2B", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, ",", "%2C", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, ";", "%3B", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "<", "%3C", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "=", "%3D", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, ">", "%3E", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "?", "%3F", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "@", "%40", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "[", "%5B", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "]", "%5D", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "^", "%5E", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "`", "%60", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "{", "%7B", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "|", "%7C", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "}", "%7D", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "~", "%7E", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "¢", "%C2%A2", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "£", "%C2%A3", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "¥", "%C2%A5", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "|", "%A6", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "§", "%C2%A7", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "«", "%C2%AB", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "¬", "%C2%AC", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "¯", "%C2%AF", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "º", "%C2%BA", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "±", "%C2%B1", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ª", "%C2%AA", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, ",", "%B4", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "µ", "%C2%B5", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "»", "%C2%BB", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "¼", "%C2%BC", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "½", "%C2%BD", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "¿", "%C2%BF", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "À", "%C3%80", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Á", "%C3%81", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Â", "%C3%82", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ã", "%C3%83", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ä", "%C3%84", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Å", "%C3%85", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Æ", "%C3%86", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ç", "%C3%87", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "È", "%C3%88", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "É", "%C3%89", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ê", "%C3%8A", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ë", "%C3%8B", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ì", "%C3%8C", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Í", "%C3%8D", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Î", "%C3%8E", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ï", "%C3%8F", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ð", "%C3%90", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ñ", "%C3%91", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ò", "%C3%92", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ó", "%C3%93", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ô", "%C3%94", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Õ", "%C3%95", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ö", "%C3%96", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ø", "%C3%98", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ù", "%C3%99", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ú", "%C3%9A", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Û", "%C3%9B", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ü", "%C3%9C", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Ý", "%C3%9D", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "Þ", "%C3%9E", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ß", "%C3%9F", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "à", "%C3%A0", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "á", "%C3%A1", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "â", "%C3%A2", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ã", "%C3%A3", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ä", "%C3%A4", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "å", "%C3%A5", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "æ", "%C3%A6", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ç", "%C3%A7", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "è", "%C3%A8", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "é", "%C3%A9", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ê", "%C3%AA", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ë", "%C3%AB", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ì", "%C3%AC", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "í", "%C3%AD", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "î", "%C3%AE", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ï", "%C3%AF", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ð", "%C3%B0", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ñ", "%C3%B1", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ò", "%C3%B2", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ó", "%C3%B3", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ô", "%C3%B4", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "õ", "%C3%B5", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ö", "%C3%B6", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "÷", "%C3%B7", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ø", "%C3%B8", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ù", "%C3%B9", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ú", "%C3%BA", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "û", "%C3%BB", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ü", "%C3%BC", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ý", "%C3%BD", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "þ", "%C3%BE", compare:=vbBinaryCompare)
URLtemporaire = Replace(URLtemporaire, "ÿ", "%C3%BF", compare:=vbBinaryCompare)

AssainirURL = URLtemporaire
Exit Function

FonctionErreur:
AssainirURL = CVErr(xlValue)

End Function

australopitheque · 2 Octobre 2021

bonjour
tu parle de l'adresse web ?
oui celle là je l'avais oublié en traitement mais est facile a modifié.
voilà corrigé avec mon bouton aperçu avant impression.
me manque plus que la mosaïque ou multiple car une carte par feuille ça va couter chère en feuille ^^,mais je voit pas comment faire.

australopitheque · 2 Octobre 2021

salut
merci de l'intérêt mais je comprend pas ta modification car quand je teste avec mon téléphone je n'est aucun soucis de qrcode.
j'ai bien importer le contact et quand je vais plus loin ,cela ce met dans les bonne case et complet.

Compte Supprimé 979 · 2 Octobre 2021

Bonjour australopitheque

Je ne comprends pas ton monologue, tu parles tout seul ou tu t'es trompé de forum

Edit : arf non il me manque le post #5 (peut-être un membre ignoré

punaise au moins c'est efficace

)

A+

australopitheque · 2 Octobre 2021

oui j'avais fait une réponse a sont poste modifier #5

australopitheque · 2 Octobre 2021

ajout du filigrane dans la cellule de la carte imprimable.
mais toujours pas de possibilité d'impression multiple de ma carte sur une feuille.
si vous avez une piste

australopitheque · 2 Octobre 2021

bon je me répond a moi même

la seul solution que j'ai trouver, mais qui me parait lourd est une copie multiple sur une autre page et de copier en image lié plusieurs fois et d'avoir un autre bouton impression supplémentaire.
toutes ces images ce mettent a jours mais alourdissent l'ensemble je trouve.
peut etre un vb qui reproduirait ça en mémoire au moment de faire l'impression??

Compte Supprimé 979 · 2 Octobre 2021

Re,

Edit : j'avais bien compris, et effectivement la seule solution c'est avec une page dédiée un copie / collage spécial image liée

Je n'ai mis que 2 images sinon ça devient trop volumineux

Ca peut-être fait en VBA bien sur

Bonne soirée

australopitheque · 2 Octobre 2021

je te remercie au moins ca me dit que j'ai la bonne réflexion et prit la bonne direction.
reste plus cas trouver comment faire en vb, mais ce soir je cale ^^.
je me pencherai dessus plus tard ou du moins si tu as un exemple ,ça m'arrangerai, car je voit pas comment le prendre.

peut être partir de ce code que je vient de trouver.

VB:

Sub Pics()
Dim f1 As Worksheet, f2 As Worksheet
Application.ScreenUpdating = False

Set f1 = Sheets("Feuil1")
Set f2 = Sheets("Feuil2")

'Défnition de la zone à copier
f1.Range("C3:I10").Copy
'Collage de la photo
With f2
    .Range("E1").Select
    .Pictures.Paste.Name = "Pics1"
    Application.CutCopyMode = False
End With

With ThisWorkbook
    .Names.Add Name:="PicsOn", RefersTo:="=1"
    .Names.Add Name:="Pics1", RefersToR1C1:= _
        "=IF(PicsOn=1,Feuil1!R3C3:R10C9,"""")"
End With
    f2.Shapes.Range(Array("Pics1")).Select
    Selection.Formula = "=Pics1"
End Sub
Sub TurnOffPictures()
    ThisWorkbook.Names("PicsOn").RefersTo = "0"
End Sub
Sub TurnOnPictures()
    ThisWorkbook.Names("PicsOn").RefersTo = "1"
End Sub

australopitheque · 3 Octobre 2021

bon j'ai fait ça mais j'ai un soucis pour mettre ça en boucle pour répétition
il me fait la copie dans ma page d'impression (mais pas le filigrane)mais je cherche a comment mettre une boucle pour qu'il me fasse plusieurs copie en dessous.
ça doit être simple mais .....je butte et je doit faire une erreur quelque part j'ai l'impression..

VB:

Sub Pics()
Dim f1 As Worksheet, f2 As Worksheet
Application.ScreenUpdating = False
Set f1 = Sheets("QR code vcard")
Set f2 = Sheets("impresion multiple")


    f1.Range("d2:e2").Copy
    With f2
   
    f2.Range("A2").PasteSpecial xlPasteColumnWidths
    f2.Range("A2").PasteSpecial xlPasteAllUsingSourceTheme
    Application.CutCopyMode = False
    End With
    f2.Range("b2").Value = ""
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

australopitheque · 6 Décembre 2022

bonjour, re déterrage du post j'ai un très petit soucis de mise en forme dans la copie.
en gros dans la cellule faite pour téléphone, j'y est mis la forme spécial téléphonique,
car je perdait le premier zéro.
mais lors de la copie il perd cette mise en forme dans la zone préparer pour copie multiple.
je pense que l'erreur est dans cette macro.

VB:

Dim noEvents As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tmp, ch As String, i As Long, j As Long
    If noEvents Then Exit Sub
    If Not Intersect(Target, [B11:B33]) Is Nothing Then
        tmp = [C11:C33].Value
        For i = 1 To 23
            ch = ch & " " & tmp(i, 1)
        Next i
        noEvents = True
        [D2].Value = Mid(ch, 2)
        i = 1
        For j = 0 To 22
            With [D2].Characters(i, Len(tmp(j + 1, 1)) + 1).Font
                .Color = [c11].Offset(j).Font.Color
                .Bold = [c11].Offset(j).Font.Bold
                .Italic = [c11].Offset(j).Font.Italic
            End With
            i = i + Len(tmp(j + 1, 1)) + 1
        Next j
        noEvents = False
    End If
End Sub

XL 2019 QR code pour Vcard

XLDnaute Nouveau

Pièces jointes

Compte Supprimé 979

Guest

XLDnaute Nouveau

Pièces jointes

XLDnaute Nouveau

XLDnaute Accro

XLDnaute Nouveau

Pièces jointes

XLDnaute Nouveau

Compte Supprimé 979

Guest

XLDnaute Nouveau

XLDnaute Nouveau

Pièces jointes

XLDnaute Nouveau

Compte Supprimé 979

Guest

Pièces jointes

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Nouveau

Discussions similaires

Partager cette page

Statistiques des forums