Attribute VB_Name = "NewMacros"
Sub Delphi()
Attribute Delphi.VB_Description = "Reconnaissance d’un code Delphi dans Word"
Attribute Delphi.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.Delphi"
' Delphi Macro
' Macro créée le 15/02/2000 par JackPot e-mail:alexandre@alapetite.fr
' Dans un document Microsoft Word 2000, reconnaît les mots clefs et les commentaires
' d’un code source Pascal Objet de Borland Delphi
' Pour l’utiliser, démarrer word
' Cliquer sur le menu >Outils>Macro>Visual Basic Editor>
' Dans Visual Basic Editor, choisir >Fichier>Importer un ficher>
' rechercher alors ce fichier .bas et cliquer sur >ouvrir>

Dim clefs As Variant  'tous les mots clefs du Pascal Objet de Delphi
clefs = Array("and", "array", "as", "asm", "begin", "case", "class", "const", "constructor", _
"destructor", "dispinterface", "div", "do", "downto", "else", "end", "except", "exports file", _
"finalization", "finally", "for", "function", "goto", "if", "implementation", "in", "inherited", _
"initialization", "inline", "interface", "is", "Label", "library", "Mod", "nil", "not", _
"object", "of", "or", "out", "packed", "procedure", "program", "property", "raise", _
"record", "repeat", "resourcestring", "set", "shl", "shr", "string", "then", "threadvar", _
"to", "try", "type", "unit", "until", "uses", "var", "while", "with", "xor", _
"at", "on", _
"absolute", "abstract", "assembler", "automated", "cdecl", "contains", "default dispid", _
"dynamic export", "external", "far", "forward", "implements", "index", "message", "name", _
"near", "nodefault", "overload", "override", "package", "pascal", "private", "protected", _
"public", "published", "read", "readonly", "register", "reintroduce", "requires", "resident", _
"safecall", "stdcall", "stored", "virtual", "write", "writeonly")

	With Selection.Find
	.ClearFormatting               'recherche standard
	.Replacement.ClearFormatting   'réinitialise la police
	.Replacement.Font.Bold = True  'les mots seront en gras
	End With

'Recherche les mots clefs dans le texte pour les mettre en gras
Dim cpt As Integer
	For cpt = 0 To (UBound(clefs) - 1)           'parcours tout le tableau
	DoEvents                                     'temps pour windows
		With Selection.Find
		.Text = clefs(cpt)                        'cherche chaque mots du tableau
		.Replacement.Text = clefs(cpt)            'remplace par le même mot en gras
		.Forward = True                           'recherche en merche avant
		.Wrap = wdFindContinue                    'continue la recherche au début du document
		.Format = True
		.MatchCase = False                        'ne tient pas compte majuscule/minuscule
		.MatchWholeWord = True                    'ce doit être un mot complet, isolé
		.MatchWildcards = False                   'désative les recherches par sonorité ...
		.MatchSoundsLike = False
		.MatchAllWordForms = False
		End With
	Selection.Find.Execute Replace:=wdReplaceAll 'recherche et remplace
	Next cpt

Dim nb As Byte
'pour les commentaires (*...*)
	With Selection
	.Find.ClearFormatting
	.Find.Forward = True
	.Find.Wrap = wdFindContinue
	.Find.MatchWholeWord = False
	.Find.Format = True
		Do While .Find.Execute(FindText:="(*") = True
		.MoveEnd Unit:=wdCharacter, Count:=1
		securite = 1
			Do
			DoEvents                                     'temps pour windows
			.MoveEndUntil Cset:="*", Count:=wdForward    's’arrête avant le premier *
			.MoveEnd Unit:=wdCharacter, Count:=1         'sélectionne le *
			nb = .MoveEndUntil(Cset:=")", Count:=1)      'teste si le caractère qui suit est )
			Loop While Not ((nb = 1) Or (.End >= ActiveDocument.Content.End)) 'garde fou si pas de *)
		.MoveEnd Unit:=wdCharacter, Count:=1 'sélectionne la )
		.Font.Italic = True
		.Font.Color = wdColorViolet
		.Font.Bold = False
		.SetRange Start:=.End, End:=.End 'supprime la sélection, place le curseur à sa fin
		Loop
	End With

'pour les commentaires {...}
	With Selection
	.Find.ClearFormatting
	.Find.Forward = True
	.Find.Wrap = wdFindContinue
	.Find.MatchWholeWord = False
	.Find.Format = True
		Do While .Find.Execute(FindText:="{") = True
		DoEvents
		.MoveEndUntil Cset:="}", Count:=wdForward  's’arrête avant la première }
		.MoveEnd Unit:=wdCharacter, Count:=1       'sélectionne la }
		.Font.Italic = True
		.Font.Color = wdColorViolet
		.Font.Bold = False
		.SetRange Start:=.End, End:=.End 'supprime la sélection, place le curseur à sa fin
		Loop
	End With

'pour les commentaires //...
	With Selection
	.Find.ClearFormatting
	.Find.Forward = True
	.Find.Wrap = wdFindContinue
	.Find.MatchWholeWord = False
	.Find.Format = True
		Do While .Find.Execute(FindText:="//") = True
		DoEvents
		.MoveEndUntil Cset:=Chr$(13), Count:=wdForward 's’arrête avant la première P
		.Font.Italic = True
		.Font.Color = wdColorViolet
		.Font.Bold = False
		.SetRange Start:=.End, End:=.End 'supprime la sélection, place le curseur à sa fin
		Loop
	End With

'change la police du document complet
Selection.WholeStory
	With Selection.Font
	.Name = "Courier New"
	.Size = 10
	End With
End Sub