1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
| 'extraits de code pour le forum
Option Explicit
Public GED_N As String, GED_M As String, GED_D As String
Public ligne As Integer, colonne As Integer, compteur, n As Integer
Public l As Integer, C As Integer, i As Integer, Today As Object
Public r As Range, lieu As String
Public domicile As String, parenté As String, sa_dateN As Variant
Public Aujourdhui As Variant, son_age As Variant, annee As Variant
Public logoN As String, milogoN As String
Public logoM As String, milogoM As String, logoD As String, milogoD As String
Public lig, col, m As Integer, Jour As Variant, Heure As Variant
Public Z As Integer, k As Integer, fin As Integer
Public ws As Worksheet
Public wb As Workbook
Sub creation_gedcoms_d_apres_XL() '= lanceur
Dim fere As String, porte As String, site As String
Z = 3
compteur = 0
ThisWorkbook.Sheets("registre").Activate
ActiveSheet.Cells(Z, 1).Value = "Début: Nous sommes le" & " " & Date & " " & " à " & " " & Time
Z = Z + 1
GED_N = ""
Call transfere(fere) 'section naissances
Call transporte(porte) 'section mariages
Call transite(site) 'section décès
ThisWorkbook.Sheets("registre").Activate
ActiveSheet.Cells(Z, 5).Value = "Fin: Nous sommes le" & " " & Date & " " & "à" & " " & Time
End Sub
Sub transfere(fere)
Dim r As Range
Dim mes_logoN() As String, mes_milogoN() As String
Dim i As Integer
Dim tempsN As String, teteN As String, resuN As String, oursN As String
Dim bapN As String, papaN As String, dompereN As String, mamaN As String
Dim dommereN As String, parmarN As String, tem1N As String, tem2N As String
Dim remN As String, autresN As String, prepimprN As String, sousdirN As String, imprN As String
i = 1
lig = 1
ligne = 1
ReDim mes_logoN(50) As String
ReDim mes_milogoN(50) As String
ThisWorkbook.Sheets("range_logo").Activate
col = 1
i = lig
For lig = 1 To 47
mes_logoN(i) = ThisWorkbook.Sheets("range_logo").Cells(lig, col + 2).Value
mes_milogoN(i) = ThisWorkbook.Sheets("range_logo").Cells(lig, col).Value
logoN = mes_logoN(i)
milogoN = mes_milogoN(i)
Set wb = Workbooks.Open("E:\" & "3_G_E_N_E_A_L_O_G_I_E\Creation_sources_ged\test_mono_wbk\P_Fau_new_new_consolidation.xlsm")
i = i + 1
Next
For i = 1 To 47
Set r = ThisWorkbook.Sheets(logoN).Range("A1").CurrentRegion
For ligne = 3 To r.Rows.Count
logoN = mes_logoN(i)
Set ws = ActiveWorkbook.Sheets(logoN)
ws.Activate
mise_à_lheure_mise_a_jourN tempsN
en_teteN teteN
redaction_resuméN resuN
impressumN oursN
baptemeN bapN
pereN papaN
domicile_pereN dompereN
mereN mamaN
domicile_mereN dommereN
parrain_marraineN parmarN
témoin01N tem1N
témoin02N tem2N
remarquesN remN
autres_interessesN autresN
fin_et_donnees_dimpressionN prepimprN
If i > 47 Then
GoTo repertoire
End If
Next
Next
repertoire:
Call cree_sous_repertoireN(sousdirN)
GED_N = CreerGED_N(tempsN, teteN, resuN, oursN, _
bapN, papaN, dompereN, mamaN, _
dommereN, parmarN, tem1N, tem2N, _
remN, autresN, prepimprN, sousdirN) & "0 RTLR"
Call imprime_GED_N(imprN)
If ligne >= r.Rows.Count Then
Exit Sub
End If
ligne = ligne + 1
End Sub
Sub en_teteN(QteteN As String)
'ici une vingtaine de function traitant un ou quelques aspects de l'acte de naissance
End Sub
'suite de mon code:
Function CreerGED_N(tempsN As String, teteN As String, resuN As String, oursN As String, _
bapN As String, pereN As String, dompereN As String, mereN As String, _
dommereN As String, parmarN As String, tem1N As String, tem2N As String, _
remN As String, autresN As String, prepimprN As String, sousdirN)
End Function
Function imprime_GED_N(QimprN As String)
ThisWorkbook.Sheets("registre").Activate
Cells(Z, 1).Value = "Je lance l'impression des feuilles Naissances le" & " " & Jour & " " & "à" & " " & Heure
Z = Z + 1
'Crée un gedcom dans Word en utilisant Automation (liaison tardive)
Dim WordApp As Object
Dim saveasname As String
saveasname = "allged" & "_" & "feuilles_naissances" & "_" & Jour & "_" & Heure & ".docx"
'Lance Word et crée un objet
Set WordApp = CreateObject("Word.Application")
'Transmet les commandes à Word
With WordApp
.Documents.Add
With .Selection
.Font.Name = "courier new"
.Font.Size = 12
.ParagraphFormat.Alignment = 0
.Font.Bold = False
.TypeText TEXT:=GED_N
End With
End With
'Pour imprimer 'l'impresion est neutralisée; elle n'est pas indispensable au
'projet et consommerait des centaines de feuilles
'de plus elle ne démarre que par F8; le code ne la déclenche pas.
With WordApp
'.ActiveDocument.PrintOut , Range:=3, From:="1", To:="3"
'Pour sauvegarder 'la création de sous-répertoires ne ffonctionne pas mais daans
'la mesure où les données sont concentrées en 3 fichiers texte.
'elle n'est pas indispensable non plus.
.ActiveDocument.SaveAs "E:\" & "3_G_E_N_E_A_L_O_G_I_E\ALL_GED\" & milogoN & "\" & saveasname
'.ActiveDocument.SaveAs "E:\" & "3_G_E_N_E_A_L_O_G_I_E\ALL_GED\" & saveasname
'La sauvegarde ne produit pas un document complet mais s'interrompt en cours
'de traitement, pratiquement toujous au même endroit.
End With
ThisWorkbook.Sheets("registre").Activate
Cells(Z, 1).Value = saveasname
Z = Z + 1
i = i + 1
'Tuer l'objet
WordApp.Quit
Set WordApp = Nothing
End Function |
Partager