Tipps u. Makros fuer Word97

dritte Seite von Makros und Tipps für Word
» [1][2][3]

Layout für neue Dokumente
immer die gleiche Ansicht unabhängig von der letzten Speicherung

Bearbeitungszeit aktivieren
zählt bei jedem Öffnen der Datei die Dauer der Bearbeitung

Schriftarten anzeigen (3KB)
mit einem Probesatz in einer Word-Datei listet dieses Makro alle installierten Schriftarten auf. Datei entpacken und im Visual-Basic-Editor in Word "Datei importieren" wählen.

globale Änderung von Schriftgrößen
mit diesem Word-Makro wird der komplett formatierte Text im Dokument um den von Ihnen eingebenen Wert vergrößert oder verkleinert.

Seriendokumente per E-Mail versenden
Dieses Makro versendet Ihre Seriendokumente in Word per E-Mail. Für die Mail-Anschrift muß ein Seriendruckfeld vorhanden sein.

Text in Wordart umwandeln
markierter Text wird direkt in Wordart umgewandelt

Lottozahlengenerator (1KB)
wählt für Ihren Tippzettel die Zahlen per Zufall aus.
Datei entpacken und im Visual-Basic-Editor in Word "Datei importieren" wählen.

Schrift auswählen in einem Userform-Dialogfeld.
zeigt einen markierten Text sofort in der gewählten Schriftart an.

Autotext-Einträge auflisten
listet sämtliche Autotext-Einträge einer Word-Datei

Fax senden direkt aus Word
ohne lästiges Umschalten des Druckers.Als Erweiterung in der Symbolleiste einfach per Klick

Symbole anzeigen
mit diesem Makro werden alle verfügbaren Symbole von Word angezeigt

Ausdruck Original+Kopie
der zweite Ausdruck ist mit einem Wasserzeichen als Kopie gekennzeichnet

Tabellenadressierung
für die Formeleingabe in Word fehlt oft die genaue Adressierung, mit diesem Makro fällt das Abzählen weg

Aktuelle Datei löschen
selbsterklärend

Zufallschriftart
markierte Texte werden nach dem Zufallsprinzip aller installierten Schriftarten angezeigt

» [1][2][3]

Zufallsschriftart (jeder Buchstabe in einer anderen Schriftart)

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

Aktuelle Datei löschen

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

Adresse (Spalten und Zeilen) von Tabelle erfragen

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

Ausdruck Original und Kopie mit Wasserzeichen

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

Alle verfügbaren Symbole anzeigen

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

Fax senden direkt aus Word

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

Autotext-Einträge auflisten

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

Schrift auswählen (Userform-Dialogfeld)

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

Text in Wordart umwandeln

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

Seriendokument per E-Mail

'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

globale Änderung von Schriftgrößen

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

Bearbeitungszeit aktivieren

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

Layout für neue Dokumente

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.