Quelques bouts de macros Word que j'ai fait seul ou en collaboration avec les newsgroups word

Pour des macros de manipulation de Word à partir d'excel, regarder xl_et_autres_applis.htm

Remplacer du texte par une image, Olivier L. me vint alors en aide

Sub Test()
' Macro recorded 20/07/99
Selection.Find.ClearFormatting
With Selection.Find
.Text = "gggg"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
While Selection.Find.Execute
Selection.InlineShapes.AddPicture FileName:= "C:\mes images\Decor.gif", LinkToFile:=False, SaveWithDocument:=True
Wend
End sub

Envoyer un message (une méthode parmi d'autres)

Documents("Feedback.doc").HasRoutingSlip = True
With Documents("Feedback.doc").RoutingSlip
.Subject = "Your feedback please..."
.AddRecipient Recipient:="Tad Orman"
.AddRecipient Recipient:="David Simpson"
.Delivery = wdOneAfterAnother
End With
Documents("Status.doc").Route

Fusionner un fichier dans un document word

Selection.InsertFile FileName:="Scanner.RTF", ConfirmConversions:=False 'attention, ici la conversion sera faite automatiquement

Nombre de fois où le document été ouvert : MsgBox ActiveDocument.BuiltInDocumentProperties(WdBuiltInProperty.wdPropertyRevision)

Afficher la boîte "insérer un fichier"

Sub test()
SendKeys "%t{Home}{Enter}"
With dialogs(wdDialogInsertFile)
.Display
End With
End Sub

Afficher la boite "ficher ouvrir"

With dialogs(wdDialogFileOpen)
.Name = "*.zip"
.show
End With

Récupérer le chemin d'accès à un fichier après l'avoir sélectionné dans une boîte de dialogue

De: Guy Moncomble <guy.moncomble@wanadoo.fr.nospam>
Objet: Re: Nom de fichier dans une variable
Date : mercredi 4 octobre 2000 09:42

Public Function fstrFichierUtilisateur() As String
Dim MyDialog As Dialog, RetourDial As Integer
Dim Nom As String, Chemin As String, NomComplet As String
Set MyDialog = Dialogs(wdDialogFileOpen)
RetourDial = MyDialog.Display
If RetourDial = -1 Then
Nom = MyDialog.Name
Chemin = CurDir
' NomComplet = Chemin & "\" & Nom
fstrFichierUtilisateur = Chemin & "\" & Nom
Else
fstrFichierUtilisateur = ""
End If
End Function

Insérer la valeur d'une variable avant le signet Word "test"

ActiveDocument.Bookmarks("test").range.InsertBefore
ActiveDocument.Variables("Value1")

Sélectionner le texte entre deux signets
MyText = ActiveDocument.range(Start:=ActiveDocument.Bookmarks("AAA").range.Start, End:=ActiveDocument.Bookmarks("BBB").range.End

Connaître le contenu d'une ligne (il y a aussi une macro pour "Boucler ligne par ligne sur le document" dans cette page)

Set raline = ActiveDocument.Bookmarks("\Line").range
MsgBox raline
raline.select

on peut aussi écrire : ActiveDocument.Bookmarks("\Line").range.Select

Nombre de mots dans un document

NoOfWords = ActiveDocument.ComputeStatistics(wdStatisticWords)
MsgBox "There are " & NoOfWords & " words in this document."

Nombre de mots dans une variable chaîne

Sub CountWordsInString()
Dim MyString As String
Dim Temp As String
Dim MyWords() As String
Dim numWords As Integer
Dim NextWord As String

MyString = "This is my string with periods. This is my string with
periods."
Temp = MyString
numWords = 0
While InStr(Temp, " ") > 0
y = InStr(Temp, " ")
NextWord = Left(Temp, y - 1)
If Right(NextWord, 1) = "." Then NextWord = Left(NextWord,
Len(NextWord) - 1)
ReDim Preserve MyWords(numWords)
MyWords(numWords) = NextWord
Temp = Right(Temp, Len(Temp) - y)
numWords = numWords + 1
Wend
ReDim Preserve MyWords(numWords)
If Right(Temp, 1) = "." Then Temp = Left(Temp, Len(Temp) - 1)
MyWords(numWords) = Temp
numWords = numWords + 1
MsgBox "There are " & numWords & " words in the string"
End Sub

Ouvrir l'application Word et désactiver ces macros

Set myobj = CreateObject("Word.Application")
myobj.WordBasic.DisableAutoMacros

Trouver les cellules vides d'une table

Sélectionner une table : Selection.Tables(1).Select
Sélectionner la ligne ou colonne d'une table : Set oTable = ActiveDocument.Tables(1) : Set oColumn = oTable.Columns(1) : oColumn.Select
Sélectionner tout le texte d'une cellule : CellText = Selection.Cells(1).range.Text : CellText = Left(CellText, Len(CellText) - 1)
Inscrire du texte au début de chaque case de la première ligne d'une table : For i = 1 To 4: ActiveDocument.Tables(1).Cell(1, i).range.InsertBefore "test" & i: Next i

Atteindre la fin de la première page

Sub EndofPageone()
With Selection
.GoTo what:=wdGoToPage, Which:=wdGoToAbsolute, Count:=1
.GoTo what:=wdGoToBookmark, Name:="\page"
.Collapse direction:=wdCollapseEnd
End With
End Sub

Trouver la première ligne vide du document

Sub test
Dim myrange as range
Dim ParagraphCounter as Integer
Dim FoundAFull as Boolean
Dim FoundAnEmpty as Boolean

'Start at first paragraph and locate the first "full" paragraph,
'i.e., one that actually contains some text
ParagraphCounter = 1
Do While ParagraphCounter <= ActiveDocument.Paragraphs.Count
If ActiveDocument.Paragraphs(ParagraphCounter).range.Characters.Count > 1
Then
FoundAFull = True
Exit Do
Else
ParagraphCounter = ParagraphCounter + 1
End If
Loop

'quit if no "full" paragraph was found
If FoundAFull = False Or ParagraphCounter = ActiveDocument.Paragraphs.Count
Then
'make an entry in the log file, cuz this doc is empty, except possibly for
last paragraph
MsgBox ActiveDocument.Name & " appears to be empty."
Exit Sub
End If

'locate the first empty paragraph following the full paragraph
ParagraphCounter = ParagraphCounter + 1
Do While ParagraphCounter <= ActiveDocument.Paragraphs.Count
If ActiveDocument.Paragraphs(ParagraphCounter).range.Characters.Count = 1
Then
FoundAnEmpty = True
Exit Do
Else
ParagraphCounter = ParagraphCounter + 1
End If
Loop

'quit if no empty paragraph was found
If FoundAnEmpty = False Or ParagraphCounter =
ActiveDocument.Paragraphs.Count Then
'make an entry in the log file, cuz this doc is all one solid block of text
MsgBox ActiveDocument.Name & " appears to be one solid block of text."
Exit Sub
End If

'set myrange to represent entire first block of text
'(block of text starts at start of document
'and runs until first empty paragraph after that
Set myrange = ActiveDocument.Paragraphs.First.range
myrange.End = ActiveDocument.Paragraphs(ParagraphCounter).range.End

end sub

Chercher et remplacer dans une colonne en particulier

Public Sub TestMe()

Dim celCurrent As Word.Cell

For Each celCurrent In ActiveDocument.Tables(1).Columns(1).Cells

celCurrent.range.Find.Execute FindText:="ME", MatchCase:=True, MatchWholeWord:=True, MatchWildcards:=False,
MatchSoundsLike:=False, MatchAllWordForms:=False, Forward:=True, Wrap:=wdFindStop, Format:=False, ReplaceWith:="Will",
Replace:=wdReplaceAll

Next celCurrent

End Sub

Boucler sur chaque table

Sub Table_count()

For i = 1 To ActiveDocument.Tables.Count
Selection.GoTo what:=wdGoToTable, Which:=wdGoToNext, Count:=i
'ActiveDocument.Tables(i).Select 'To select the table
'Your code
Next i
End Sub

Un bookmark ou autre, est-il dans une table

Accéder au bookmark, ou rechercher votre texte, puis utiliser l'instruction Selection.Information(wdWithInTable) poour savoir si le point d'insertion est dans une table ou non

If ActiveDocument.Bookmarks("my bookmark") .range.Information(wdWithinTable) Then msgbox "The 'my bookmark' bookmark is in a table"

Détecter le mot courant ("sélectionné" actuellement)

Le code suivant affichera le mot précédent et le suivant, ainsi que le numéro d'index du mot courant. Si plus d'un mot sont sélectionnés, le code agira que sur le premier mot de la sélection

Dim myrange As range
Dim i As Integer
Dim WordIndex As Integer

Set myrange = Selection.Words.First.Previous(wdWord, 1)
MsgBox myrange.Text
Set myrange = Selection.Words.First.Next(wdWord, 1)
MsgBox myrange.Text

For i = 1 To ActiveDocument.Words.Count
If Selection.Characters.First.Inrange(ActiveDocument.Words(i)) Then
WordIndex = i
Exit For
End If
Next i
MsgBox WordIndex

Compter le nombre de page pour chaque section

x = 0
For Each oSection In ActiveDocument.Sections
x = x + 1
oSection.range.Select
NoOfPages = Selection.Information(wdActiveEndPageNumber)
MsgBox "Section " & x & " has " & NoOfPages & " pages."
Next oSection

Numéro de la page de la sélection :

page = Selection.Information(wdActiveEndPageNumber) 'numéro ne tenant pas compte de votre numérotation
Selection.Information(wdActiveEndAdjustedPageNumber) ''numéro en tenant compte je crois

Insérer une page après le curseur

Dim rngDoc as Word.range
Set rngDoc = ActiveDocument.range
'Use the following two lines whenever you need a new page
rngDoc.Collapse
rngDoc.InsertBreak(wdPageBreak)

Changer le mode d'affichage

Sub ModeNormal()
If ActiveWindow.View.SplitSpecial = wdPaneNone Then
ActiveWindow.ActivePane.View.Type = wdNormalView
Else
ActiveWindow.View.Type = wdNormalView
End If

End Sub
Sub ModePage()
If ActiveWindow.View.SplitSpecial = wdPaneNone Then
ActiveWindow.ActivePane.View.Type = wdPrintView
Else
ActiveWindow.View.Type = wdPrintView
End If

End Sub

Autres modes d'affichage: wdMasterView,wdnormalview,wdwebview,wdprintpreview,wdprintview,wdoutlineview

Utilisez la propriété Percentage pour modifier la taille du texte à l'écran : ActiveDocument.ActiveWindow.View.Zoom.Percentage = 120
Utilisez la propriété SeekView pour visualiser les commentaires, les notes de fin, ou encore l'en-tête ou le pied de page du document.

L'exemple suivant montre comment afficher le pied de page en cours dans la fenêtre active en mode Page.

With ActiveDocument.ActiveWindow.View
.Type = wdPrintView
.SeekView = wdSeekCurrentPageFooter
End With

Boucler sur listes (puces numérotées) nommées 1.4.3, 2.1, cela boucle je crois également sur les têtes de section

Dim myStartingrange As range
Set myStartingrange = ActiveDocument.range(Start:=0, End:=0)
Dim myEndingrange As range
Set myEndingrange = ActiveDocument.range(Start:=0, End:=0)
Dim myTarget as String

myTarget = "2.1"

Do Until myEndingrange.ListFormat.ListString = myTarget
Set myEndingrange = myStartingrange.GoToNext(wdGoToHeading)
If myEndingrange.IsEqual(myStartingrange) Then
MsgBox "Section Not Found"
Exit Sub
End If
myStartingrange.Setrange myEndingrange.Start, myEndingrange.End
Loop
myEndingrange.Select

Changer l'imprimante sélectionnée : WordBasic.FilePrintSetup PrinterName$, DoNotSetAsSysDefault:=1

Effacer les lignes vides (moins de deux caractères) (sur ma demande, mais il doit y avoir mieux en utilisant les méthodes trim ou substitute pour ôter les espaces .......)

Sub DeleteEmptyLines()
Application.ScreenUpdating = False
With Selection
.HomeKey Unit:=wdStory

Do Until _
.MoveDown(Unit:=wdParagraph, Count:=1, Extend:=wdExtend) = 0
If .Characters.Count < 2 Then
.range.Delete
Else
.Collapse direction:=wdCollapseEnd
End If
Loop

.Collapse direction:=wdCollapseEnd
End With
Application.ScreenUpdating = True
End Sub

Effacer tous les hyperliens

NoOfHyperlinks = ActiveDocument.Hyperlinks.Count
For counter = 1 To NoOfHyperlinks
ActiveDocument.Hyperlinks(1).range.Delete
Next counter

Colorier les erreurs d'orthographe

Sub spellcheck()
MYErr = ActiveDocument.SpellingErrors.Count
If MYErr = 0 Then
end
Else
MsgBox MYErr & " spelling errors found. " 'MAKES A MESSAGE BOX APPEAR WITH TOTAL OF SPELLING ERRORS
End If

Set MYERRORS = ActiveDocument.SpellingErrors
Err = MYERRORS.Count
For Each MYErr In MYERRORS
MYErr.HighlightColorIndex = wdRed
next MYErr

end sub

Compter le nombre de colonnes dans tout le document (parcourt les différents paragraphes)

Dim i As Integer
Dim oPara As Paragraph

For i = 1 To ActiveDocument.Paragraphs.Count
Set oPara = ActiveDocument.Paragraphs(i)
oPara.range.Text = Left(oPara.range.Text, Len(oPara.range.Text) - 1) _
& "_" & vbCr
Next i

Automatiquement renseigner les propriétés à la fermeture

Private Sub Autoclose()
Dim SaveMe As Object 'Saves Summary Information
Set SaveMe = dialogs(wdDialogFileSummaryInfo)
SaveMe.Title = "Filename or other"
SaveMe.Subject = Format(Date, "MM/dd/YYYY")
SaveMe.Keywords = "Template, Wizard"
SaveMe.Author = "Gordon McKenzie" ' or something like environ("user")
SaveMe.Comments = Format(Date, "mm/dd/yyyy")
'SaveMe.Comments = "Text"
'Comments doesn't work - let me know if you get it to work
SaveMe.Execute
'SaveMe.show 'If you want to see it...
End Sub

Taille de la ligne la plus longue du document 'à ma demande

Sub LineLength()
Dim length As Integer, longlength As Integer
Selection.HomeKey unit:=wdStory
For j = 0 To ActiveDocument.BuiltInDocumentProperties(wdPropertyLines)
length = Len(Selection.Sentences(1))
If length > longlength Then longlength = length
Selection.MoveDown
Next
MsgBox "The longest line is " & longlength & " characters."
End Sub

Changer l'allure du curseur

System.Cursor = wdCursorWait
System.Cursor = wdCursorNormal

Passer un argument à une macro affectée lors d'un OnAction

With MyCommandBarButton
.OnAction = "MyMacro 0"
.OnAction = "MyMacro False"
End With
True=-1

Empêcher l'utilisateur de travailler sur le document pendant l'impression : Options.PrintBackground = False

Imprimer l'image d'arrière-plan

Sub ImpFiligrane()
'La Zone d'impression DOIT être préalablement définie
Dim ZoneImpr As Range
Set ZoneImpr = Range(ActiveSheet.PageSetup.PrintArea)
ZoneImpr.CopyPicture xlScreen, xlBitmap
ActiveSheet.Paste Destination:=ZoneImpr
ActiveWindow.SelectedSheets.PrintPreview
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Delete
End Sub

Imprimer la page courante ' Macro enregistrée le 29/06/99 par Clément Marcotte

Sub Imprime_la_page_courante()
Application.PrintOut FileName:="", Range:=wdPrintCurrentPage, Item:= wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
Collate:=True, Background:=True, PrintToFile:=False
End Sub

Celle-ci permet de n'imprimer que la sélection à l'écran

Sub Imprime_la_sélection()
' Macro enregistrée le 19/01/00 par Clément Marcotte
Application.PrintOut FileName:="", Range:=wdPrintSelection, Item:= wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
Collate:=True, Background:=True, PrintToFile:=False
End Sub

Boucler ligne par ligne sur le document

' Move the insertion point to the beginning of the document.
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
' Loop number of lines in document.
x = ActiveDocument.BuiltInDocumentProperties("NUMBER OF LINES")
For i = 1 To x
' Select a line.
ActiveDocument.Bookmarks("\LINE").Select
Indhold = Trim(Selection)

'here you can do whatever you want to the line contained in the var.
Indhold

' Display line number. Just for test reasons, don't do it on your
150.000 lines new book manuscript ;-)
MsgBox "Line: " & i
' Move to next line.
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdMove
Next i

Exécuter une macro d'un classeur excel

Sub RunExcelProcedure()

' Declare an object variable of type Application
Dim XL As Excel.Application

Set XL = New Excel.Application' Open a new instance of Excel and assign to object variable
XL.Workbooks.Open ("C:\Data\Excel\JVMacros.xls")' Open the workbook that contains the macro to run
' XL.Visible = True' Remove remark from next line to make Excel visible
XL.Run ("HelloMacro")' Call Run method of Excel's Application object
XL.Quit' Call the Quit method of Excel's Application object

' Reset variable to nothing
Set XL = Nothing

End Sub

Ajouter un point à la fin de chaque paragraphe (sur ma demande)

Cette macro ajoutera un point (full stop) à la fin de chaque paragraphe qui ne se termine pas déjà par ? ou . ou !
Elle met également en capitale la première lettre du premier mot juste après (vous pouvez effacer les lignes correspondantes).
Elle tient compte des signes de ponctuation anglais mais pas des guillemets ou des signes allemands, mais doit pouvoir facilement être modifiée pour ces cas.

Public Sub TidyUpListWithCapsAndPeriods()
'Formats first word of each paragraph with an initial cap
'unless it is already all caps. Ends each paragraph with a period
'unless it already ends with a ! or ? Handles quotes OK, I think.
'John Nurick Locum Destination Consulting, August 1999

Dim P As Paragraph, n As Long, raPara As range, raFirst As range

For Each P In Selection.Paragraphs
'Skip empty paragraphs
If Asc(P.range.Characters.First) > 33 Then
Set raPara = P.range
'Locate first word in case para begins with (number)(tab) text
Set raFirst = P.range
raFirst.Collapse wdCollapseStart
raFirst.MoveEnd wdCharacter, 6
raPara.MoveStart wdCharacter, InStr(1, raFirst.Text, vbTab)
'Capitalise first word if necessary
With raPara.Words.First
If .Case <> wdUpperCase Then
.Case = wdTitleWord
End If
End With
'add a period at the end if necessary
With raPara.Characters
n = .Count - 1
If .Item(n) = " " Then .Item(n).Delete
n = .Count - 1 'deleting one trailing space will delete all
trailing spaces but one!
Do While InStr(1, " " & "'" & Chr(39) & Chr(145) & Chr(146) &
_
Chr(147) & Chr(148), .Item(n))
n = n - 1
Loop
Select Case .Item(n)
Case ".", "?", "!"
'what we want; do nothing
Case ",", ";", ":", "-", "–", "—"
.Item(n).Text = "."
Case Else
.Item(n).InsertAfter "."
End Select
End With
End If
Next P
End Sub

Si vous voulez ajouter un point à la fin de chaque ligne, il vous faudrait partir du bas du document et remonter une ligne à la fois (cela évite que word fasse lui-même un retour à la ligne). Puis il faudrait utiliser l'instruction Set raLine = ActiveDocument.Bookmarks("\Line").range pour obtenir le texte de la ligne en cours, et utiliser quelques morceaux de code de la macro ci-dessus.