um Dateien in Word immer im gleichen Layout anzuzeigen, öffnet man die Vorlage Normal.dot, gibt ein Zeichen ein, speichert sie ab und schließt die Datei. Dann wird die Datei wieder geöffnet, man löscht das Zeichen wieder, und speichert sie wieder ab. Durch diesen Umweg wird sichergestellt, daß auch die Formatänderungen mit abgespeichert werden. Natürlich muß beim Abspeichern die gewünschte Ansicht eingestellt sein.

in der Registry alle Werte suchen mit folgendem Inhalt: NoFileEdit
NoTrack
jeweils die Zeichenfolge auf 0 abändern.

Sub IndivFormat()
Dim Mldg, Titel, Voreinstellung, Wert
Mldg = "Wie soll die Größe geändert werden?"
Titel = "Schriftgröße ändern"
Voreinstellung = "2"
Wert = InputBox(Mldg, Titel, Voreinstellung)
ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:="AktPos"
Selection.HomeKey Unit:=wdStory
Set ListOfCharacters = ActiveDocument.Characters
For Each i In ListOfCharacters
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Font.Size = Selection.Font.Size + Wert
Selection.MoveRight Unit:=wdCharacter, Count:=1
Next i
Selection.GoTo What:=wdGoToBookmark, Name:="AktPos"
ActiveDocument.Bookmarks("AktPos").Delete
End Sub

'ein Seriendruckfeld mit der E-Mail-Anschrift muß im Dokument enthalten sein, die Bezeichnung muß mit feldname(email) übereinstimmen

Sub Mail_serie()
With ActiveDocument.MailMerge
.Destination = wdSendToEmail
.MailAsAttachment = False
.MailAddressFieldName = "email"
.MailSubject = ""
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=True
End With
End Sub

Public Sub TextInWordArtUmwandeln()
Dim strText As String
strText = Selection.Text
Selection.Delete
ActiveDocument.Shapes.AddTextEffect(msoTextEffect1, strText, _ "Arial Black", 36#, msoFalse, msoFalse, 50, 50).Select
End Sub

Datei entpacken und im Visual-Basic-Editor in Word "Datei importieren" wählen. Lottozahlengenerator

Aus Platzgründen habe ich dieses Dialogfeld zum >Download< (2KB) in eine Datei gepackt.
Bitte entpacken und im Visual-Basic-Editor in Word "Datei importieren" wählen.
Für den Aufruf des Dialogfeldes noch folgendes Makro eingeben: Sub Schriftprobe()
frmSchriftprobe.Show
End Sub

Sub PrintAllAutoTextEntries()
For Each i In ActiveDocument.AttachedTemplate.AutoTextEntries
Selection.TypeText Text:=i.Name & " steht für: "
i.Insert Where:=Selection.Range, RichText:=True
Selection.TypeParagraph
Next i
End Sub

Achtung!! der Fax- und Druckertreiber muß exakt mit der Menü-Anzeige Datei/Drucken übereinstimmen Sub FaxSenden()

Dim strFaxTreiber As String
Dim strDruckerTreiber As String
strFaxTreiber = "WinFax"
strDruckerTreiber = "Minolta Quick Page"
ActivePrinter = strFaxTreiber
Application.PrintOut
ActivePrinter = strDruckerTreiber
End Sub

Public AlleSymboleAnzeigen()
On Error GoTo Fehlerbehandlung
For intLeisten = 0 To 12
ErsteId = intLeisten * 300
LetzteId = ErsteId + 299
Set SL = CommandBars.Add
For intZähler = ErsteId To LetzteId
Set SF = SL.Controls.Add
SF.FaceId = intZähler
SF.TooltipText = "Id: " & intZähler
Next
SL.Name = ("Mögliche Symbole Nr." & intLeisten + 1)
SL.Width = 591
SL.Visible = True
Next
Fehlerbehandlung:
SF.Delete
SL.Name = ("Mögliche Symbole Nr." & intLeisten + 1)
SL.Width = 591
SL.Visible = True
End Sub

Sub ZweiKopienMitWasserzeichen()
'Ausdruck für Original
Application.PrintOut

'Wasserzeichen einfügen
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Or ActiveWindow.ActivePane.View.Type _
= wdMasterView Then
ActiveWindow.ActivePane.View.Type = wdPageView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader

Selection.HeaderFooter.Shapes.AddTextEffect(msoTextEffect1, "Kopie", _
"Arial Black", 36#, msoFalse, msoFalse, 240.75, 222.75).Select
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 0.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 280
Selection.ShapeRange.Width = 320
Selection.ShapeRange.Rotation = 330#
Selection.ShapeRange.RelativeHorizontalPosition = _
wdRelativeHorizontalPositionPage
Selection.ShapeRange.RelativeVerticalPosition = _
wdRelativeVerticalPositionPage
Selection.ShapeRange.Left = CentimetersToPoints(6)
Selection.ShapeRange.Top = CentimetersToPoints(7.86)
Selection.ShapeRange.LockAnchor = False
Selection.ShapeRange.WrapFormat.Type = wdWrapNone
Selection.ShapeRange.WrapFormat.Side = wdWrapBoth
Selection.ShapeRange.WrapFormat.DistanceTop = CentimetersToPoints(0)
Selection.ShapeRange.WrapFormat.DistanceBottom = CentimetersToPoints(0)
Selection.ShapeRange.WrapFormat.DistanceLeft = CentimetersToPoints(0.32)
Selection.ShapeRange.WrapFormat.DistanceRight = CentimetersToPoints(0.32)

ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

'Ausdruck für Kopie
Application.PrintOut

'Wasserzeichen löschen
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.HeaderFooter.Shapes.SelectAll
Selection.ShapeRange.Delete
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

Public WoBinIch()
If Selection.Information(wdWithInTable) = True Then
intZeile = Selection.Information(wdFirstCharacterLineNumber)
intSpalte = Selection.Information(wdStartOfRangeColumnNumber)
If intSpalte <= 26 Then
strSpalte = Chr$(64 + intSpalte)
Else
intSpalte = intSpalte - 26
strSpalte = "A" + Chr$(64 + intSpalte)
End If
MsgBox "Sie befinden sich in der Zelle " + strSpalte + LTrim$(Str$(intZeile))
Else
MsgBox "Sie befinden sich zur Zeit in keiner Tabelle."
End If
End Sub

Public Sub AktuelleDateiLöschen()
On Error GoTo Fehlerbehandlung

'Aktuellen Dokument-Namen ermitteln
strDokumentName = ActiveDocument.FullName
'Test, ob Dokument als Datei existiert
If Dir(strDokumentName) <> "" Then
rstResult = MsgBox("Soll die Datei >" + ActiveDocument.Name + "< gelöscht werden?", vbOKCancel)
'Datei soll gelöscht werden
If rstResult = 1 Then
ActiveDocument.Close
Kill strDokumentName
End If
Else
MsgBox "Datei wurde noch nicht gespeichert und kann deshalb auch nicht gelöscht werden.", vbCritical
End If
'Schluß und raus
Exit Sub

Fehlerbehandlung:
MsgBox "Fehler: " + Error(Err) + " (Fehler-ID:" + Str(Err) + ")", vbCritical
End Sub

Sub Zufallschriftart()
Dim Zeichen As Object, ZeichenCode As Integer
Dim schriftnr As Integer

If Selection.Type = wdSelectionNormal Then
Application.ScreenUpdating = False
For Each Zeichen In Selection.Characters
ZeichenCode = Asc(Zeichen.Text)
Do
schriftnr = Int((FontNames.Count - 2) * Rnd + 1)
Zeichen.Font.Name = FontNames(schriftnr)
If Zeichen.Font.Name = "Wingdings" Then
Zeichen.Font.Name = "Symbol"
ElseIf Zeichen.Font.Name = "Marlett" Then
Zeichen.Font.Name = "Symbol"
End If
Loop Until Asc(Zeichen.Text) = ZeichenCode
Next
Application.ScreenUpdating = True
Else
MsgBox "Es wurde kein Text markiert!", vbInformation, "Zufällige Schriftarten"
End
End If
End Sub