Public fic, fic_sig As String
Sub Creation_BC_OP()
'nécéssite d'activer la référence Microsoft Word xx.x Object Library
Dim i&, j&, x1&, pos& ' Long
Dim NomDoc$, celle_qu$ ' String
Dim s As Object
Dim Chemin As String
Dim nom_societe As String
Dim WordApp As Word.Application ' NE PAS OUBLIER DE PRECISER WORD pour EXCEL
Dim WordDoc As Word.Document
Dim signet As Word.Bookmark
Dim rg As Word.Range
Dim Img As Word.InlineShape
' " "
Application.ScreenUpdating = False
'*************************************************
'où est le document Word
Chemin = ThisWorkbook.Path & "\" ' MODIFIER SI DOC # REPERTOIRE DE CE FICHIER EXCEL
'Le nom du fichier Word à ouvrir
'Fichier = "Controle.docx" ' NOM DU FICHIER SQUELETTE WORD
'Chemin et nom du fichier Image à insérer
FichierImage = ThisWorkbook.Path & "\" & "AN1 AP1 SIG.png"
nom_societe = Cells(1, 5).Value ' le nom de la sociéte qui est en E1
Cells(4, 2).Select ' on positionne le curseur dans la cellule B4
Application.ScreenUpdating = False ' bloc de defilement ecran
' ON REMPLI SEULEMENT LA PAGE DE GARDE DU DOC WORD
'**************************************************
num_actif_onglet = ActiveSheet.Index ' recupere de nom de l'onglet actif
dg = Cells(Rows.Count, 1).End(xlUp).Row + 1 'defini le nombre de lignes à traiter
Num_dos = 0
For x = 4 To dg ' boucle pour traiter toutes les lignes du doc
indic = Cells(x, 1)
Select Case indic
Case "fait"
GoTo suite1
' test si des croix dans le cases interdites
Case "x"
'Set WordApp = CreateObject("word.application")
' Déclaration du traitement d’erreur initial
On Error Resume Next
' Initialisation de Word
Set WordApp = GetObject(, "Word.Application")
If Err <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
If Err <> 0 Then
MsgBox "La macro n'a pas pu ouvrir !", vbExclamation
End
End If
End If
On Error GoTo 0
' laisser l'application visible
WordApp.Visible = True
'Chemin = "C:\Users\JM-essai\"
cellule_D = Cells(x, 2).Value 'cellule N°BDC
cellule_N = Cells(x, 5).Value 'cellule nom
cellule_P = Cells(x, 6).Value 'cellule prénom
fic = cellule_N & "_" & cellule_P & "_" & cellule_D & "_BC" 'Nom du nouveau fichier à créer
NomDoc = Chemin & fic & ".docm" ' définition du chemin et nom du doc au créer
'******* choix du fichier àutiliser ******
nom = InputBox("Saisie le fichier à utiliser 1 ou 2 : ")
If nom = 1 Then nom_doc_vierge = "02-fichier word2" & ".docm"
If nom = 2 Then nom_doc_vierge = "02-fichier word - Copie.docm"
Set WordDoc = WordApp.Documents.Open(ThisWorkbook.Path & "\" & nom_doc_vierge)
WordDoc.SaveAs NomDoc ' On enregistre le doc word. là le doc est vide
'************************************
' ***** on renseigne le document Wort à partir du fichier Excel *****
'Teste si le signet existe
With WordDoc
If .Bookmarks.Exists("signature") Then
Set signet = .Bookmarks("signature") ' Signet
Set rg = .Bookmarks("signature").Range ' Range
'supprimer les images si déjà présentes
'dans le signet
With rg
While .InlineShapes.Count > 0
.InlineShapes(1).Delete
Wend
signet.Select
Set Img = signet.Range.InlineShapes.AddPicture(FichierImage, True, False, rg)
End With
End If
'Si tu veux travailler avec l'image insérée - Dimension, rogner...
With Img
'Pour définir plusieurs caractéristiques de l'image
.PictureFormat.CropRight = 0.6 ' X valeur à définir
.PictureFormat.CropTop = 0.6 ' Y valeur à définir
.ScaleHeight = 10
.ScaleWidth = 10
.LockAspectRatio = msoTrue ' Garde les proportions donc mettre H ou L mais pas les 2
'.Height = 35
.Width = 120 ' Là j'ajuste juste en L pas la Hauteur
End With
.Bookmarks.Add "signat", rg
End With
'02-*** Pour remplir tous les champs texte BC à partir du doc EXCEL ***
WordDoc.Bookmarks("Texte5").Range.Text = Cells(x, 5) 'renseigne NOM
WordDoc.Bookmarks("Texte6").Range.Text = Cells(x, 6) 'renseigne PRENOM
WordDoc.Bookmarks("Texte7").Range.Text = Cells(x, 7) 'renseigne ADRESSE
WordDoc.Bookmarks("Texte8").Range.Text = Cells(x, 8) 'renseigne CP
WordDoc.Bookmarks("Texte9").Range.Text = Cells(x, 9) 'renseigne VILLE
WordDoc.Bookmarks("Texte17").Range.Text = Cells(x, 9) 'renseigne VILLE 1
WordDoc.Bookmarks("Texte10").Range.Text = Cells(x, 10) 'renseigne TEL
WordDoc.Bookmarks("Texte12").Range.Text = Cells(x, 12) 'renseigne DATE
Application.ScreenUpdating = True ' on retabli la vue ecran
WordDoc.Close True 'on ferme word
Set WordDoc = Nothing
WordApp.Quit ' on quitte word
Set WordApp = Nothing
Case Else
GoTo suite1
suite1:
End Select
fin:
'***** Fin de la boucle de remplissage du doc Word *****
Next x ' retour pour vérifier s'il y a encore des donnée à traiter
'Beep
Application.ScreenUpdating = True
Call import_signature
End Sub
