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
|
Sub majbiblio()
Dim Wrd As Word.Application
Dim fl As Worksheet
Dim NoLigne As Long, i As Long, LeText As String, LaRech As String
Dim fichier As String, fichiersav As String
'ouverture et sauveegarde du fichier word sous un autre nom
fichier = CStr(Cells(2, 14).Value)
fichiersav = Mid(fichier, 1, Len(fichier) - 4) & "-biblio.doc"
'mettre la ligne suivante en comment pour debogage
On Error GoTo anticipatedend ' si le fichier est ouvert, n'existe pas ...
Set fl = ActiveSheet
Set Wrd = CreateObject("Word.Application")
Wrd.Visible = False ' à passer en true si besoin de debogage
Wrd.DisplayAlerts = wdAlertsNone
Wrd.Documents.Open FileName:=(fichier)
Wrd.ActiveDocument.SaveAs FileName:=(fichiersav)
'verification du tableau biblio.xls pour voir s'il ne manque pas de référence
nbvar = Application.CountA(Range("d:d")) 'title est dans la colonne d, supposée sans trous
For i = 1 To nbvar
If IsEmpty(fl.Cells(i, 10)) = True Then
MsgBox "Check your reference names in your bibliography"
GoTo quitnow
End If
Next i
Wrd.Selection.HomeKey Unit:=wdStory
rerun:
Wrd.Selection.EndKey
Wrd.Selection.ExtendMode = False
With Wrd.Selection.Find
.Text = "\ref{"
.Execute
End With
With Wrd.Selection
.ExtendMode = True 'Étend la sélection à la balise suivante
With .Find
.Text = "}"
.Execute
End With
End With
'******************************************************************
LeText = Wrd.Selection
If LeText = Chr(13) Or LeText = Chr(7) Then
GoTo normalend
End If
LaRech = Mid(LeText, 6, Len(LeText) - 5 - 1)
If IsEmpty(LeText) = False Then
trouve = False
For i = 2 To nbvar
cequejech = fl.Cells(i, 10).Value
If InStr(1, cequejech, LaRech, 1) <> 0 Then
valref = CStr(fl.Cells(i, 2))
Wrd.Selection.Delete
Wrd.Selection.InsertAfter valref
trouve = True
i = nbvar
End If
Next
If trouve = False Then
Wrd.ActiveDocument.SaveAs FileName:=(fichiersav)
Message = MsgBox(LaRech & " n'est pas un mot clé valide, arrêter ?", vbYesNo + vbQuestion, "Reference error")
If Message = vbYes Then GoTo quitnow Else GoTo rerun
End If
GoTo rerun
End If
GoTo normalend
'******************************************************************
anticipatedend:
MsgBox "File already opened or wrong name and/or directory"
GoTo quitnow:
'******************************************************************
normalend:
Wrd.ActiveDocument.SaveAs FileName:=(fichiersav)
With Wrd.Selection.Find
.Text = "Bibliography and References"
.Execute
End With
If Wrd.Selection = Chr(13) Or Wrd.Selection = Chr(7) Then
MsgBox "Insert somewhere in your file the term : " & " Bibliography and References"
GoTo quitnow
End If
Wrd.Selection.EndKey
Wrd.Selection.Goto what:=wdGoToLine, which:=wdGoToNext
Range("B1:I" & nbvar).Copy
Wrd.Selection.PasteSpecial DataType:=wdPasteBitmap, Placement:=wdInLine
Wrd.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Application.CutCopyMode = False
Wrd.ActiveDocument.SaveAs FileName:=(fichiersav)
'******************************************************************
quitnow:
Wrd.Quit
End Sub |
Partager