insérer un filigramme par macro

[fenec]

Bonjour le forum

Une fois de plus besoin de vos lumières

Malgré de nombreuses recherchent je n’ai pas trouvé ce que je désire, alors voila ce que voudrais réaliser et savoir si cela est faisable

Dans mon projet j’aimerais insérer par l’intermédiaire d’une macro un filigramme « DUPLICATA » lors d’une réimpression de facture avec un mgs box

msgBox (« Faut-il mettre le filigramme ‘DUPLICATA’ ? »,vbyesno

Merci d’avance pour vos idées

Cordialement

Fenec

 

[Excel-lent]

Re : insérer un filigramme par macro

Bonjour Fenec,

En parlant de filigramme, à quoi penses-tu?

Utiliser l'astuce :
-> "Format" / "Feuille" / "Arrière plan..."
-> sélectionner une dessin comportant le texte DUPLICATA avec un fond blanc

ou bien l'astuce :
-> insérer une zone de texte
-> écrire dedans "DUPLICATA"
-> choisir une couleur pastel style gris clair par exemple
-> mettre cette zone de texte en arrière plan

Quelque soit la solution utilisé il te suffit de :
-> lancer l'enregistreur de macro : "Outils" / "macro" / "nouvelle macro..."
-> effectuer une des deux solutions ci-dessus
-> arrêter l'enregistreur de macro

Ensuite il te reste plus qu'à adapter la macro pour :
1/ que la macro s’exécute juste avant l'édition
pour cela remplacer Sub NomDeTaMacro() par Private Sub workbook_beforeprint()

2/ qu'une MsgBox s'affiche, pour cela rajouter une inputBox (pour cela utiliser l'aide, ou chercher sur le forum).

Et voilà, le tour est joué.

Tu as réalisé ta macro tout seul et elle correspond exactement à tes attentes 😉

Bonne journée

 

[fenec]

Re : insérer un filigramme par macro

Bonjour le forum

Merci Excel-lent pour ta réponse que je vais garder au cas où mais cela ne correspond pas à je que désire.

Je me suis sans doute mal expliqué car je pensais à une chose un peu plus simple, du moins en parole. En fait, je rappelle ma facture à l’aide d’une macro dans laquelle je voudrais par l’intermédiaire d’un mgbox activé ou non l’option filigramme de mon imprimante.

J’espère que ces précisions répondent à ta question
Merci encore de ton aide

Cordialement

Fenec

 

[youky(BJ)]

Re : insérer un filigramme par macro

Salut bien,
Cette ligne est à modifier en conséquence . . . "C:\Users\Bruno\Pictures\photo307.JPG"
Tu peux avant mettre ta MsgBox
Bruno

Sub Macro1()
    ActiveSheet.PageSetup.CenterHeaderPicture.Filename = _
        "C:\Users\Bruno\Pictures\photo307.JPG"
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "&G"
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.708661417322835)
        .RightMargin = Application.InchesToPoints(0.708661417322835)
        .TopMargin = Application.InchesToPoints(0.748031496062992)
        .BottomMargin = Application.InchesToPoints(0.748031496062992)
        .HeaderMargin = Application.InchesToPoints(2.28346456692913)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
End Sub

 

[fenec]

Re : insérer un filigramme par macro

re et merci Youky
je teste et reviens vers vous si besoin
bonne soirée

 

[youky(BJ)]

Re : insérer un filigramme par macro

Voici le fichier, je le fait en macro mais oups je sais plus le faire en manuel, bon le filigramme est peu utilisé.
Bruno

 

[fenec]

Re : insérer un filigramme par macro

Bonjour le forum

Je reviens vers vous une fois de plus car je ne parviens pas à mettre en pratique votre code
Vous joint donc un bout de mon fichier
Je désirerais insérer votre code dans ma macro duplicata
D’avance merci
Cordialement
Fenec

 

[youky(BJ)]

Re : insérer un filigramme par macro

Salut,
J'avais oublié de mettre l'image du filigramme, le voici donc.
IMPERATIF ce fichier est à copier dans le même répertoire que le fichier utilisé.

Voici le code rectifié
Bruno

Sub Dupliquer_facture()

''''''''''''Application.ScreenUpdating = False
         Application.ScreenUpdating = True
         
         Range("I14").Select
    Selection.Copy
    
         Dim Recf, Compar, Y, Msg
 Set Recf = Application.FileSearch
 With Recf
 Compar = InputBox("Fichiers dont le nom commence par :" & _
 Chr(13) & "(saisissez * pour obtenir tous les " & _
 "classeurs du répertoire)", "Classeurs commençant par...")
 If Compar <> "" Then
 .LookIn = "C:\Users\Philippe\Mes documents\Archives\Factures"
 .Filename = Compar & "*.*"
 If .Execute > 0 Then
 MsgBox .FoundFiles.Count & " fichier(s) trouvé(s)."
 For Y = 1 To .FoundFiles.Count
 If MsgBox("Voulez-vous ouvrir " & _
 .FoundFiles(Y), vbYesNo) = vbYes Then
 Workbooks.Open (.FoundFiles(Y))
 Mavariable = ActiveWorkbook.Name
 End If
 Next Y
 Else
 Msg = MsgBox("Aucun fichier correspondant à la " & _
 "recherche.", , "Désolé...")
 End If
 End If
 End With
  
  Range("E13:E17,I13:I15,C20:C35,E20:E35,G20:G35,H20:H35,I37:I38,H40:H41,H43:H44,H46:H49").Select
  
  For Each cel In Selection
  cel.Copy
  Windows("Bons de Commande & Facture.xls").Activate
  Sheets("Facture").Select
  Range(cel.Address).Select
  ActiveSheet.Paste
  Next cel
  
  Range("I13").Select
  Application.DisplayAlerts = False
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Windows(Mavariable).Activate
  ActiveWorkbook.Close savechanges:=True
  
  ActiveSheet.PageSetup.PrintArea = "$B$2:$J$58"
    With ActiveSheet.PageSetup
        
        .RightHeader = "Page &P de &N"
        
        .CenterFooter = _
         "S.A.R.L au capital de "
        
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0.196850393700787)
        
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlPortrait
        
        .Zoom = 59
       
End With
  
  Dim Ligne As Integer
     Dim Colonne As Byte
     Dim Fin As Integer
     Dim nbrCopie As Integer
        On Error Resume Next
          Fin = Range("C65535").End(xlUp).Row
    For Ligne = 1 To Fin
         For Colonne = 1 To 5
             If Cells(Ligne, Colonne) <> "" Then GoTo Saut
         Next Colonne
         Rows(Ligne & ":" & Ligne).EntireRow.Hidden = True
Saut:
     Next Ligne
        nbrCopie = InputBox("Combien de copie voulez-vous faire ?", Title:="Copies")
      If nbrCopie = 0 Then
         Rows("1:" & Fin).EntireRow.Hidden = False
         Exit Sub
     Else
    ActiveSheet.PageSetup.CenterHeaderPicture.Filename = _
     ThisWorkbook.Path & "\Dupli.Gif" ' on charge l'image dupli
   '''' ActiveSheet.PageSetup.PrintArea = "" ' définit zone d'impression
         ActiveWindow.SelectedSheets.PrintOut Copies:=nbrCopie, Collate:=True
     ActiveSheet.PageSetup.CenterHeaderPicture.Filename = "" 'on supprime le filigramme
     End If
       Rows("1:" & Fin).EntireRow.Hidden = False
  
  Range("Zone_a_remplir_Duplicata_Facture") = Empty
  

    Workbooks("Bons de Commande & Facture").Activate
ActiveWorkbook.Save
Application.ScreenUpdating = True



End Sub