Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Création papier cadeau automatique [RESOLU]

C

christ-94

XLDnaute Occasionnel
Bonjour

Je cherche a crée mon propre papier cadeau, avec un texte en word art
avec une macro qui me fera apparaitre mon texte m'importe ou dans la feuille avec des polices de différente couleurs et différentes formes en VBA
J'ai bien réussi a crée mon premier texte , mais je n'arrive géré la police

exemple de papier

Merci de votre aide
 

Pièces jointes

  • Papier cadeau.jpg
    72.4 KB · Affichages: 135
Dernière édition:
Trier par date Trier par votes
C

christ-94

XLDnaute Occasionnel
Re : Création papier cadeau automatique

Re-bonjour

J'ai bien reusi a faire 200 texte avec des tailles, couleur differentes mais je n'arrive pas a change la police du texte

 
Vote positif 0 Vote négatif

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique

Bonjour,

un essai à adapter éventuellement à ton projet....
Code: 
Option Explicit
Sub test()
Dim t As String, i As Byte, s As Shape, p() As Variant
t = "Test"
p = Array("Arial", "Arial Black", "Courier", "Times New Roman")
Randomize
With ActiveSheet
    For i = 1 To 100
        Set s = .Shapes.AddTextEffect(msoTextEffect1, t, p(Int(4 * Rnd)), _
             Int((30 + 1) * Rnd + 10), msoTrue, msoFalse, .Range("A" & i).Left, .Range("A" & i).Top)
        With s
            .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
            .IncrementRotation Int((Rnd * 89) + 1)
        End With
    Next i
End With
End Sub

bon après midi
@+

Edition : manquait les points pour appli bloc "with"
 
Dernière édition:
Vote positif 0 Vote négatif

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique

Bonjour,

une autre version qui gère le positionnement des formes sur la feuille... A adapter selon la longueur du prénom...

Code: 
Option Explicit
Sub test()
Dim t As String, i As Long, j As Long, s As Shape, p() As Variant
Application.ScreenUpdating = False
t = "Test"
p = Array("Arial", "Arial Black", "Courier New", "Times New Roman", "Comic Sans MS", "Lucida Console")
Randomize
With ActiveSheet
    With .Shapes
        If .Count > 0 Then .SelectAll: Selection.Delete
    End With
    For i = 1 To 100 Step 5
        For j = 1 To 20 Step 1
        Set s = .Shapes.AddTextEffect(msoTextEffect1, t, p(Int(6 * Rnd)), _
             Int((30 + 1) * Rnd + 10), msoTrue, msoFalse, .Cells(i, j).Left, .Cells(i, j).Top)
        With s
            .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
            .IncrementRotation Int(361 * Rnd)
        End With
        Next j
    Next i
End With
Application.ScreenUpdating = True
End Sub

bonne journée
@+
 
Vote positif 0 Vote négatif

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique

Re,

un autre type de répartition...
Code: 
Option Explicit
Sub test()
Dim t As String, i As Long, j As Long, s As Shape, p() As Variant, k As Long
Application.ScreenUpdating = False
t = "Test"
p = Array("Arial", "Arial Black", "Courier New", "Times New Roman", "Comic Sans MS", "Lucida Console")
Randomize
With ActiveSheet
    With .Shapes
        If .Count > 0 Then .SelectAll: Selection.Delete
    End With
    For i = 1 To 100 Step 5
        'For j = 1 To 20 Step 1
        For j = 1 + (k Mod 2) To 20 - (k Mod 2) Step 2
        Set s = .Shapes.AddTextEffect(msoTextEffect1, t, p(Int(6 * Rnd)), _
             Int((30 + 1) * Rnd + 10), msoTrue, msoFalse, .Cells(i, j).Left, .Cells(i, j).Top)
        With s
            .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
            .IncrementRotation Int(361 * Rnd)
        End With
        Next j
        k = k + 1
    Next i
End With
Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
C

christ-94

XLDnaute Occasionnel
Re : Création papier cadeau automatique

Bonjour
Je viens de faire un test "super fonctionne parfaitement comme toujours"
Moi j'ai fait celui-ci, bien moins performent mais qui fonctionne
dans tous les cas le rendu est super


Encore un grand merci a toi pour cette super MACRO
 
Vote positif 0 Vote négatif

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique [RESOLU]

Re,

en variant les effets...
Code: 
Option Explicit
Sub test()
Dim t As String, i As Long, j As Long, s As Shape, p() As Variant, f() As Variant, k As Long
Application.ScreenUpdating = False
t = "Test"
p = Array("Arial", "Arial Black", "Courier New", "Times New Roman", "Comic Sans MS", "Lucida Console")
f = Array(0, 2, 4, 5, 10, 13, 16, 18, 24, 29)
Randomize
With ActiveSheet
    With .Shapes
        If .Count > 0 Then .SelectAll: Selection.Delete
    End With
    For i = 1 To 100 Step 5
        'For j = 1 To 20 Step 1
        For j = 1 + (k Mod 2) To 20 - (k Mod 2) Step 2
        Set s = .Shapes.AddTextEffect(f(Int(10 * Rnd)), t, p(Int(6 * Rnd)), _
             Int((30 + 1) * Rnd + 10), msoTrue, msoFalse, .Cells(i, j).Left, .Cells(i, j).Top)
        With s
            .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
            .IncrementRotation Int(361 * Rnd)
        End With
        Next j
        k = k + 1
    Next i
End With
Application.ScreenUpdating = True
End Sub

A noter, sont utilisées les valeurs se rapportant aux différentes constantes(exemple msoTextEffect1 = 0) ....
 
Vote positif 0 Vote négatif

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique [RESOLU]

Re, bonjour Michel

un dernier pour la route... tirages aléatoires sur toutes les polices installées sur l'ordi et sur tous les effets disponible + texte gras et italique...
Code: 
Sub test2()
Dim t As String, i As Long, j As Long, s As Shape, p() As Variant, k As Long
Application.ScreenUpdating = False
t = "Test"
With CommandBars.FindControl(ID:=1728)
    ReDim p(.ListCount - 1)
    For i = LBound(p) To UBound(p)
        p(i) = .List(i + 1)
    Next i
End With
Randomize
With ActiveSheet
    With .Shapes
        If .Count > 0 Then .SelectAll: Selection.Delete
    End With
    For i = 1 To 100 Step 5
        'For j = 1 To 20 Step 1
        For j = 1 + (k Mod 2) To 20 - (k Mod 2) Step 2
        Set s = .Shapes.AddTextEffect(Int(29 * Rnd), t, p(Int((UBound(p) + 1) * Rnd)), _
             Int((30 + 1) * Rnd + 10), Int((0 - -1 + 1) * Rnd + -1), Int((0 - -1 + 1) * Rnd + -1), _
             .Cells(i, j).Left, .Cells(i, j).Top)
        With s
            .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
            .IncrementRotation Int(361 * Rnd)
        End With
        Next j
        k = k + 1
    Next i
End With
Application.ScreenUpdating = True
End Sub

tous les arguments sont maintenant aléatoires....
 
Vote positif 0 Vote négatif
C

christ-94

XLDnaute Occasionnel
Re : Création papier cadeau automatique [RESOLU]

Merci pour cette dernier version

par contre cette ligne
.Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
Cliquez pour agrandir...
active le contour comment le faire aleatoirement

J'ai envelloppe un cadeau avec " un CD " super resultat il faut essayer

Merci encore , mes cadeaux son super
 
Dernière édition:
Vote positif 0 Vote négatif

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique [RESOLU]

Re,

peut être en modifiant cette partie comme suit, enfin si j'ai bien compris... doit dépendre de l'effet tiré aléatoirement lors de la création....
Code: 
        With s
            .Fill.Visible = Int((0 - -1 + 1) * Rnd + -1)
            .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
            .IncrementRotation Int(361 * Rnd)
        End With
 
Vote positif 0 Vote négatif
C

christ-94

XLDnaute Occasionnel
Re : Création papier cadeau automatique [RESOLU]

Merci pour cette modification
hélas cela ne n'a pas fonctionne
J'ai toujours le contour sur tous les textes je souhaite que cela soit aléatoire
en tout cas merci pour ta patience et ton travail
j'espere que ce code donnera des idées, le résultat est superbe , je me répète

 
Vote positif 0 Vote négatif
C

christ-94

XLDnaute Occasionnel
Re : Création papier cadeau automatique [RESOLU]

j'ai modifier le code

If Int((0 - -1 + 1) * Rnd + -1) = 0 Then
.Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
End If
Cliquez pour agrandir...

pas très beau mais efficace

Merci Pierrot
et Bonne fête à tous

Ps pour un meilleur rendu , utiliser du papier de couleur
 
Vote positif 0 Vote négatif
G

Guest

Guest
Re : Création papier cadeau automatique [RESOLU]

Bonjour, Chris,
Pierrot
MJ

si je peux me permettre, proposition:
Code: 
         With s
             .Fill.Visible = Round(Rnd, 0) * -1
             If .Fill.Visible Then .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
             .IncrementRotation Int(361 * Rnd)
         End With

[Edit]

Et en déplaçant le Randomize juste en dessous du premier For cela sera mieux réparti:

Code: 
For i = 1 To 100 Step 5
Randomize
'......


A+
 
Dernière modification par un modérateur:
Vote positif 0 Vote négatif

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique [RESOLU]

Re,

si je peux me permettre, proposition:
Cliquez pour agrandir...
bien sur Hasco, toujours un plaisir. Bien vu le "Round", bravo ... Avec tes indications, cela devrait donner ceci :
Code: 
Option Explicit
Sub test()
Dim t As String, i As Long, j As Long, s As Shape, p() As Variant, k As Long
Application.ScreenUpdating = False
t = "Test"
With CommandBars.FindControl(ID:=1728)
    ReDim p(.ListCount - 1)
    For i = LBound(p) To UBound(p)
        p(i) = .List(i + 1)
    Next i
End With
With ActiveSheet
    With .Shapes
        If .Count > 0 Then .SelectAll: Selection.Delete
    End With
    For i = 1 To 100 Step 5
        Randomize
        'For j = 1 To 20 Step 1
        For j = 1 + (k Mod 2) To 20 - (k Mod 2) Step 2
            Set s = .Shapes.AddTextEffect(Int(29 * Rnd), t, p(Int((UBound(p) + 1) * Rnd)), _
                Int((30 + 1) * Rnd + 10), Round(Rnd, 0) * -1, Round(Rnd, 0) * -1, _
                .Cells(i, j).Left, .Cells(i, j).Top)
            With s
                With .Fill
                    .Visible = Round(Rnd, 0) * -1
                    If .Visible Then .ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
                End With
                .IncrementRotation Int(361 * Rnd)
            End With
        Next j
        k = k + 1
    Next i
End With
Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Question
Microsoft 365 Création d'un fichier entier par rapport à des entrées via UserForm
Réponses
1
Affichages
384
job75
D
  • Question
XL 2013 Graphique comparatif par fournisseur
Réponses
2
Affichages
2 K
Decouverte Excel
D
R
  • Question
Autres Sheets - updater les valeurs d'un formulaire
Réponses
4
Affichages
651
Raka
R
E
  • Question
Microsoft 365 Calendrier automatique personnalisé
2
Réponses
21
Affichages
4 K
Eric&
E
  • Question
XL 2016 Tableau de bord "Suivis des Evènements Indésirables" ?
2
Réponses
21
Affichages
8 K
ChTi160
N
  • Question
Commander Word à partir d'Excel
Réponses
0
Affichages
2 K
nak
N
T
  • Question
base salarié pour création de contrat
Réponses
7
Affichages
6 K
tchock
T
K
  • Question
[RESOLU] Cerveau 1 - Ordinateur 0! Tableau et tri automatique
Réponses
7
Affichages
2 K
kabol
K
S
  • Question
amélioration & création macro (tournée transport)
Réponses
10
Affichages
2 K
skun
S
S
  • Question
changment couleur selon texte automatique
Réponses
9
Affichages
2 K
silver74
S
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…