Merci de ton aide, je suis vraiment en galère.
désolé il est assez long:
'crackage clé
Dim lngHandle As Long 'Manipulation de la bdr
Dim sCheminCle As String 'Chemin dans la bdr de la clé à ouvrir et à fermer
If Application.Version = "11.0" Then
sCheminCle = "SoftwareMicrosoftOffice11.0WordOptions"
Else
If Application.Version = "10.0" Then
sCheminCle = "SoftwareMicrosoftOffice10.0WordOptions"
End If
End If
If RegOpenKeyEx(HKEY_CURRENT_USER, sCheminCle, 0, KEY_ALL_ACCESS, lngHandle) = 0 Then
If RegSetValueExLong(lngHandle, "SQLSecurityCheck", 0&, REG_DWORD, 0, 4) = 0 Then
RegCloseKey (lngHandle)
End If
End If
'ouverture word
Dim appWord As New Word.Application
Dim docWord As New Word.Document
With appWord
.Visible = True
Set docWord = .Documents.Open(Filename:=Chemin & NomFich, ReadOnly:=False)
.Activate
End With
'signet tableaubat1
Dim b As Integer
b = Cells(1, 2).Value
If Cells(1, 4).Value = 1 Then
Else
If b = 7 Then
Range("A2:D9" ).Copy
Else
If b = 6 Then
Range("A2:D8" ).Copy
Else
If b = 5 Then
Range("A2:D7" ).Copy
Else
If b = 4 Then
Range("A2:D6" ).Copy
Else
If b = 3 Then
Range("A2:D5" ).Copy
Else
If b = 2 Then
Range("A2:D4" ).Copy
Else
Range("A2:D3" ).Copy
End If
End If
End If
End If
End If
End If
With appWord
.Selection.HomeKey Unit:=wdStory
.Selection.Goto What:=wdGoToBookmark, Name:="tableaubat1"
End With
appWord.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
End If
'signet tableaubat2 collage deuxieme tableau
If Cells(1, 4).Value = 1 Then
Else
If b = 7 Then
Range("G2:O9" ).Copy
Else
If b = 6 Then
Range("G2:O8" ).Copy
Else
If b = 5 Then
Range("G2:O7" ).Copy
Else
If b = 4 Then
Range("G2:O6" ).Copy
Else
If b = 3 Then
Range("G2:O5" ).Copy
Else
If b = 2 Then
Range("G2:O4" ).Copy
Else
Range("G2:O3" ).Copy
End If
End If
End If
End If
End If
End If
With appWord
.Selection.Goto What:=wdGoToBookmark, Name:="tableaubat2"
End With
appWord.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
End If
'autre signets
Dim h As Integer
For h = 323 To 650
Dim Texte As Variant
Texte = Cells(h, 21).Value
With appWord
If Not Texte = "" Then
.Selection.Goto What:=wdGoToBookmark, Name:="a" & h
.Selection.TypeText Text:=Texte
End If
End With
Next
'tableau deper
For i = 1 To 7
Dim a As Variant
a = Cells(22, 2).Value
If Not a < i Then
Range(Cells(4, 29 + 28 * (i - 1)), Cells(37, 37 + 28 * (i - 1))).Copy
With appWord
.Selection.Goto What:=wdGoToBookmark, Name:="deper" & i
.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
End With
End If
Next
'etiquette
For j = 1 To 7
If Not a < j Then
Range(Cells(43, 38 + 28 * (j - 1)), Cells(58, 47 + 28 * (j - 1))).Copy
With appWord
.Selection.Goto What:=wdGoToBookmark, Name:="etiquette" & j
.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
End With
End If
Next
'recapitulatif
If Cells(1, 4).Value = 1 Then
Else
If b = 7 Then
Range("R2:U10" ).Copy
Else
If b = 6 Then
Range("R2:U9" ).Copy
Else
If b = 5 Then
Range("R2:U8" ).Copy
Else
If b = 4 Then
Range("R2:U7" ).Copy
Else
If b = 3 Then
Range("R2:U6" ).Copy
Else
If b = 2 Then
Range("R2:U5" ).Copy
Else
Range("R2:U3" ).Copy
End If
End If
End If
End If
End If
End If
With appWord
.Selection.Goto What:=wdGoToBookmark, Name:="recapitulatif"
End With
appWord.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
End If
'chauffage
If Cells(1, 4).Value = 1 Then
Else
If b = 7 Then
Range("AU2:AV10" ).Copy
Else
If b = 6 Then
Range("AU2:AV9" ).Copy
Else
If b = 5 Then
Range("AU2:AV8" ).Copy
Else
If b = 4 Then
Range("AU2:AV7" ).Copy
Else
If b = 3 Then
Range("AU2:AV6" ).Copy
Else
If b = 2 Then
Range("AU2:AV5" ).Copy
Else
Range("AU2:AV3" ).Copy
End If
End If
End If
End If
End If
End If
With appWord
.Selection.Goto What:=wdGoToBookmark, Name:="chauffage"
End With
appWord.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
End If
'cout chauffage
If Cells(1, 4).Value = 1 Then
Else
If b = 7 Then
Range("X2:Y9" ).Copy
Else
If b = 6 Then
Range("X2:Y8" ).Copy
Else
If b = 5 Then
Range("X2:Y7" ).Copy
Else
If b = 4 Then
Range("X2:Y6" ).Copy
Else
If b = 3 Then
Range("X2:Y5" ).Copy
Else
If b = 2 Then
Range("X2:Y4" ).Copy
Else
Range("X2:Y3" ).Copy
End If
End If
End If
End If
End If
End If
With appWord
.Selection.Goto What:=wdGoToBookmark, Name:="coutchauffage"
End With
appWord.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
End If
'Gconso Ginst
Range("BW2:BY3" ).Copy
With appWord
.Selection.Goto What:=wdGoToBookmark, Name:="consoinst"
End With
appWord.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
'suppression espaces
With appWord
.Selection.Find.ClearFormatting
With appWord.Selection.Find
.Text = " "
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Selection.Find.Execute Replace:=wdReplaceAll
End With
With appWord
.Selection.Find.ClearFormatting
With appWord.Selection.Find
.Text = " "
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Selection.Find.Execute Replace:=wdReplaceAll
End With
With appWord
.Selection.Find.ClearFormatting
With appWord.Selection.Find
.Text = " "
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Selection.Find.Execute Replace:=wdReplaceAll
End With
With appWord
.Selection.Find.ClearFormatting
With appWord.Selection.Find
.Text = " "
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Selection.Find.Execute Replace:=wdReplaceAll
End With
'suppression lignes blanches
With appWord
.Selection.Find.Execute
.Selection.Find.ClearFormatting
.Selection.Find.Replacement.ClearFormatting
With appWord.Selection.Find
.Text = "^13{2;}" ' rechercher partout 2 ou + retour chariots
.Replacement.Text = "^p" ' remplacer par un retour chariot
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = True ' Usage des caractères génériques
End With
.Selection.Find.Execute Replace:=wdReplaceAll
End With
'publipostage
With docWord.MailMerge
.OpenDataSource Name:=Chemin & NomBase, _
Connection:="Driver={Microsoft Excel Driver (*.xls)};" & _
"DBQ=" & Chemin & NomBase & "; ReadOnly=True;", _
SQLStatement:="SELECT * FROM [données générales, PH$]"
With docWord.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = 1
.LastRecord = 1
End With
.Execute Pause:=False
End With
End With
'fermeture word
Application.DisplayAlerts = False
docWord.Close SaveChanges:=False
Application.DisplayAlerts = True
'Ouvre la clé, supprime la valeur "SQLSecurityCheck" , ferme la clé (Retour à la normal)
If RegOpenKeyEx(HKEY_CURRENT_USER, sCheminCle, 0, KEY_ALL_ACCESS, lngHandle) = 0 Then
If RegDeleteValue(lngHandle, "SQLSecurityCheck" ) = 0 Then
RegCloseKey (lngHandle)
End If
End If
