Sub Creation_Dossier()
'Si on on n'est pas sur une fiche de la base on sort de la procedure :
If ActiveCell.Value = "" Or ActiveCell.Row = 1 Then 'Exit Sub
MsgBox "La cellule active est vide ou est un en-tête de colonne." & Chr(13) & _
"La commande a été annulée."
Exit Sub
Else
End If
'Definition du chemin du dossier de travail (chemin seul)
Dim Chemin_Dossier As String
Chemin_Dossier = ThisWorkbook.Path
'Vérification du chemin enregistré
'MsgBox "Le fichier actuel se trouve dans le répertoire '" & Chemin_Dossier & "'"
'Definition du nom du dossier client à créer (nom seul)
Dim Nom_Dossier
Set Nom_Dossier = Cells(ActiveCell.Row, 2)
'Vérification du nom du dossier à créer
'MsgBox "Le nom du dossier à créer est '" & Nom_Dossier & "'"
'Définition complète du dossier client à créer (chemin + nom)
Dim Dossier
Dossier = Chemin_Dossier & "\" & Nom_Dossier
'Vérification du nom complet du dossier à créer
'MsgBox "Le nom COMPLET du dossier à créer est '" & Dossier & "'"
'Création du dossier client
Dim fso ' As Scripting.FileSystemObject
Dim fd ' As Scripting.Folder
Set fso = CreateObject("Scripting.FileSystemObject")
'Vérification de l'exsitance du dossier à créer
If Not fso.folderexists(Dossier) Then
'fso.copyfolder Dossier_Modele, Dossier
MkDir Dossier
'Set fd = fso.créatefolder(Dossier)
MsgBox "Le dossier " & Dossier & " a été créé"
Else
Msg = "ATTENTION : Le dossier :" & Chr(13) & _
Dossier & Chr(13) & _
"existe déjà !" & Chr(13) & _
"Êtes-vous sûr de vouloir continuer la copie des documents ?" & Chr(13) & _
"Si vous continuez, les nouveaux documents écraseront les éventuels fichiers existants dans ce dossier."
Style = vbYesNo + vbCritical + vbDefaultButton1
Title = "> DOSSIER EXISTANT !!! <"
Réponse = MsgBox(Msg, Style, Title, Help, Context)
If Réponse = vbNo Then
Exit Sub
End If
End If
'Déclaration et définition des variables à copier dans Word
Dim Date_Commande 'Date de la Lettre de Commande
Date_Commande = Cells(ActiveCell.Row, 1)
MsgBox "Date de commande :" & Date_Commande
Dim Client_RV1 'Date du premier RDV
Client_RV1 = Cells(ActiveCell.Row, 26)
MsgBox "1er RDV :" & Client_RV1
Dim Client_RV1_Heure 'Heure du premier RDV
Client_RV1_Heure = Format(Cells(ActiveCell.Row, 33), "hh:mm")
'Client_RV1_Heure = Cells(ActiveCell.Row, 33)
MsgBox "1er RDV Heure :" & Client_RV1_Heure
Dim Client_RV2 'Date du second RDV
Client_RV2 = Cells(ActiveCell.Row, 27)
MsgBox "2nd RDV :" & Client_RV2
Dim Client_RV3 'Date du troisième RDV
Client_RV3 = Cells(ActiveCell.Row, 28)
MsgBox "3ème RDV :" & Client_RV3
Dim Client_RV4 'Date du quatrième RDV
Client_RV4 = Cells(ActiveCell.Row, 29)
MsgBox "4ème RDV :" & Client_RV4
Dim Client_RV5 'Date du cinquième RDV
Client_RV5 = Cells(ActiveCell.Row, 30)
MsgBox "5ème RDV :" & Client_RV5
Dim Client_RV6 'Date du sixième RDV
Client_RV6 = Cells(ActiveCell.Row, 31)
MsgBox "6ème RDV :" & Client_RV6
Dim Client_RV7 'Date du septième RDV
Client_RV7 = Cells(ActiveCell.Row, 32)
MsgBox "7ème RDV :" & Client_RV7
Dim Date_Fin_LC_Calculee 'Date de commande + 90 jours prenant en compte WE et jours fériés
Date_Fin_LC_Calculee = Cells(ActiveCell.Row, 3)
MsgBox "Date de finde LC calculée :" & Date_Fin_LC_Calculee
Dim Site_Realisation 'Site où va se réaliser la prestation
Site_Realisation = Cells(ActiveCell.Row, 6)
MsgBox "Site :" & Site_Realisation
Dim Consultant_Initiales 'Initiales du consultant
Consultant_Initiales = Cells(ActiveCell.Row, 34)
MsgBox "Initiales du consultant :" & Consultant_Initiales
Dim Consultant_Nom 'Nom du consultant
Consultant_Nom = Cells(ActiveCell.Row, 35)
MsgBox "Nom & prénom du consultant :" & Consultant_Nom
Dim Consultant_Mail 'Mail du consultant
Consultant_Mail = Cells(ActiveCell.Row, 36)
MsgBox "Mail du consultant :" & Consultant_Mail
Dim Agence 'Agence du bénéficiaire
Agence = Cells(ActiveCell.Row, 8)
MsgBox "Agence :" & Pole_Emploi_Agence
Dim Conseiller_Nom 'Nom du conseiller du bénéficiaire
Conseiller_Nom = Cells(ActiveCell.Row, 9)
MsgBox "Nom du conseiller :" & Conseiller_Nom
Dim Conseiller_Prenom 'Prénom du conseiller du bénéficiaire
Conseiller_Prenom = Cells(ActiveCell.Row, 10)
MsgBox "Prénom du conseiller :" & Conseiller_Prenom
Dim Lettre_Comm ' Référence de la Lettre de Commande
Lettre_Comm = Cells(ActiveCell.Row, 13)
MsgBox "Référence de la Lettre de Commande :" & Lettre_Comm
Dim Module_Entree 'Module d'entrée du bénéficiaire
Module_Entree = Cells(ActiveCell.Row, 14)
MsgBox "Module d'entrée du bénéficiaire :" & Module_Entree
Dim Client_EC 'Titre du bénéficiaire (Mademoiselle, Madame ou Monsieur)
Dim Client_Nom 'Nom du bénéficiaire
Dim Client_Prenom 'Prénom du bénéficiaire
Dim Client_Identifiant 'Identifiant Pole Emploi du bénéficiaire
Client_EC = Cells(ActiveCell.Row, 16)
Client_Nom = Cells(ActiveCell.Row, 17)
Client_Prenom = Cells(ActiveCell.Row, 18)
Client_Identifiant = Cells(ActiveCell.Row, 19)
MsgBox "Bénéficiaire :" & Client_EC & " " & Client_Nom & " " & Client_Prenom & " (Id : " & Client_Identifiant & ")"
'Definition du chemin du dossier modèle source
Dim Dossier_Modele As String
Dossier_Modele = ThisWorkbook.Path & "\Base_Documents"
'MsgBox "Les fichiers de base se trouvent dans le répertoire : '" & Dossier_Modele & "'"
'Définition des fihciers sources
Dim Fichier_1er_M1
Dim Fichier_1er_M3
Dim Fichier_M1
Dim Fichier_M2
Dim Fichier_M3
Dim Fichier_Bilan
Dim Fichier_Stat
Fichier_1er_M1 = Dossier_Modele & "\01-M2C-1er-M1.dot"
Fichier_1er_M3 = Dossier_Modele & "\01-M2C-1er-M3.dot"
Fichier_M1 = Dossier_Modele & "\02-M2C-M1.dot"
Fichier_M2 = Dossier_Modele & "\03-M2C-M2.dot"
Fichier_M3 = Dossier_Modele & "\04-M2C-M3.dot"
Fichier_Bilan = Dossier_Modele & "\05-M2C-B.dot"
Fichier_Stat = Dossier_Modele & "\06-M2C-Stat.dot"
'MsgBox "Les fichiers sources sont :" & Chr(13) & _
Fichier_1er_M1 & Chr(13) & Fichier_1er_M3 & Chr(13) & _
Fichier_M1 & Chr(13) & Fichier_M2 & Chr(13) & Fichier_M3 & Chr(13) & _
Fichier_Bilan & Chr(13) & Fichier_Stat
'Définition des fihciers à créer
Dim New_Fichier_1er_M1
Dim New_Fichier_1er_M3
Dim New_Fichier_M1
Dim New_Fichier_M2
Dim New_Fichier_M3
Dim New_Fichier_Bilan
Dim New_Fichier_Stat
New_Fichier_1er_M1 = Dossier & "\" & Nom_Dossier & "_1er_M1.doc"
New_Fichier_1er_M3 = Dossier & "\" & Nom_Dossier & "_1er_M3.doc"
New_Fichier_M1 = Dossier & "\" & Nom_Dossier & "_M1.doc"
New_Fichier_M2 = Dossier & "\" & Nom_Dossier & "_M2.doc"
New_Fichier_M3 = Dossier & "\" & Nom_Dossier & "_M3.doc"
New_Fichier_Bilan = Dossier & "\" & Nom_Dossier & "_B.doc"
New_Fichier_Stat = Dossier & "\" & Nom_Dossier & "_S.doc"
'MsgBox "Les futurs fichiers à créer sont :" & Chr(13) & _
New_Fichier_1er_M1 & Chr(13) & New_Fichier_1er_M3 & Chr(13) & _
New_Fichier_M1 & Chr(13) & New_Fichier_M2 & Chr(13) & New_Fichier_M3 & Chr(13) & _
New_Fichier_Bilan & Chr(13) & New_Fichier_Stat
'Détermination du module d'entrée
Dim Module_Depart As String
Module_Depart = Cells(ActiveCell.Row, 14)
MsgBox "Le module d'entrée est " & Module_Depart
'Copie des fichiers adéquats
If Module_Depart = "M3" Then
Msg = "Les fichiers à créer sont :" & Chr(13) & _
New_Fichier_1er_M3 & Chr(13) & New_Fichier_M3 & Chr(13) & _
New_Fichier_Bilan & Chr(13) & New_Fichier_Stat
Style = vbYesNo + vbCritical + vbDefaultButton1
Title = "> COPIE DES FICHIERS DE BASE <"
Réponse = MsgBox(Msg, Style, Title, Help, Context)
If Réponse = vbYes Then
FileCopy Fichier_1er_M3, New_Fichier_1er_M3
FileCopy Fichier_M3, New_Fichier_M3
FileCopy Fichier_Bilan, New_Fichier_Bilan
FileCopy Fichier_Stat, New_Fichier_Stat
'On definit un objet Word puis on l'ouvre :
'Dim WordApp As Word.Application 'instance de l'appli Word
'Dim WordDoc As Word.Document 'instance du document Word à ouvrir
Set WordApp = CreateObject("Word.application")
Set WordDoc = WordApp.Documents.Open(New_Fichier_1er_M3)
'On met Word au premier plan (True) ou en arrière plan (False) durant la procédure
WordApp.Visible = True
WordApp.Selection.Find.ClearFormatting
WordApp.Selection.Find.Text = "LETTRE_COMMANDE"
WordApp.Selection.Find.Replacement.ClearFormatting
WordApp.Selection.Find.Replacement.Text = Lettre_Comm
WordApp.Selection.Find.Execute Replace:=Word.WdReplace.wdReplaceAll
'On enregistre et on ferme le document word
WordDoc.Close True
'On laisse au systeme le temps d'enregistrer le fichier
DoEvents
'On quitte Word :
WordApp.Quit
'On vide les objets WordApp & WdDoc :
Set WordApp = Nothing
Set WordDoc = Nothing
Else
MsgBox "Les fichiers n'ont pas été copiés !"
Exit Sub
End If
Else
If Module_Depart = "M2" Then
Msg = "Les fichiers à créer sont :" & Chr(13) & _
New_Fichier_1er_M1 & Chr(13) & _
New_Fichier_M2 & Chr(13) & New_Fichier_M3 & Chr(13) & _
New_Fichier_Bilan & Chr(13) & New_Fichier_Stat
Style = vbYesNo + vbCritical + vbDefaultButton1
Title = "> COPIE DES FICHIERS DE BASE <"
Réponse = MsgBox(Msg, Style, Title, Help, Context)
If Réponse = vbYes Then
FileCopy Fichier_1er_M1, New_Fichier_1er_M1
FileCopy Fichier_M2, New_Fichier_M2
FileCopy Fichier_M3, New_Fichier_M3
FileCopy Fichier_Bilan, New_Fichier_Bilan
FileCopy Fichier_Stat, New_Fichier_Stat
Else
MsgBox "Les fichiers n'ont pas été copiés !"
Exit Sub
End If
Else
Msg = "Les fichiers à créer sont :" & Chr(13) & _
New_Fichier_1er_M1 & Chr(13) & New_Fichier_M1 & Chr(13) & _
New_Fichier_M2 & Chr(13) & New_Fichier_M3 & Chr(13) & _
New_Fichier_Bilan & Chr(13) & New_Fichier_Stat
Style = vbYesNo + vbCritical + vbDefaultButton1
Title = "> COPIE DES FICHIERS DE BASE <"
Réponse = MsgBox(Msg, Style, Title, Help, Context)
If Réponse = vbYes Then
FileCopy Fichier_1er_M1, New_Fichier_1er_M1
FileCopy Fichier_M1, New_Fichier_M1
FileCopy Fichier_M2, New_Fichier_M2
FileCopy Fichier_M3, New_Fichier_M3
FileCopy Fichier_Bilan, New_Fichier_Bilan
FileCopy Fichier_Stat, New_Fichier_Stat
Else
MsgBox "Les fichiers n'ont pas été copiés !"
Exit Sub
End If
End If
End If
End Sub
!!
