VBA-Tutorial / Beispiele Teil 1

Noch ungesammelte Beispiel-Skripte

Textausgabe - Range-Objekt

ActiveDocument.Range.Paragraphs.Count

Liefert Anzahl der Absätze in einem Dokument

Set rng = ActiveDocument.Paragraphs(3).Range
With rng
.InsertBefore "Neuer Absatz."
End With

Gibt vor Absatz 3 Text aus

InsertAfter

Fügt den angegebenen Text am Ende eines Bereichs oder einer Markierung ein. Nach Anwendung dieser Methode wird der Bereich oder die Markierung erweitert, damit der neue Text einbezogen wird.

InsertParagraphBefore

Fügt einen neuen Absatz vor der angegebenen Auswahl oder dem Bereich ein.

InsertParagraph

Ersetzt den angegebenen Bereich oder die angegebene Markierung durch einen neuen Absatz.

InsertSymbol

Fügt ein Symbol an der Stelle des angegebenen Bereichs oder der angegebenen Markierung ein.

InsertParagraphBefore, InsertParagraphAfter

Fügt einen neuen Absatz vor bzw. nach der angegebenen Auswahl oder dem Bereich ein.

Dim rng As Range
Set rng = ActiveDocument.Paragraphs(3).Range
With ActiveDocument.Paragraphs.Last.Range
	.InsertParagraphAfter
	.InsertAfter "Neuer Absatz."
End With

Beispiel: Ausgabe von drei Textzeilen

Selection.TypeText Text:="Zeile1"
Selection.TypeParagraph
Selection.TypeText Text:="Zeile2"
Selection.TypeParagraph
Selection.TypeText Text:="Zeile3"
Selection.TypeParagraph

Text formatieren

Sub FormatText()
'
' Aktuelle Selection mit spezieller Laufweite formatieren
'

With Selection.Font

.Name = "Arial"
.Size = 11
.Bold = False
.Italic = False
.Underline = wdUnderlineNone
.UnderlineColor = wdColorAutomatic
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.Color = wdColorBlack
.Engrave = False
.Superscript = False
.Subscript = False
.Spacing = 2
.Scaling = 100
.Position = 0
.Kerning = 0
.Animation = wdAnimationNone

	End With

End Sub

Umgang mit Seiten

Gehe zu Seite 2

Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="2"

Anzahl der Seiten feststellen

Function NumberOfPage() As Integer
'
' Anzahl der Seiten zurückgeben
'
	Dim i As Integer
	Selection.EndKey Unit:=wdStory
	i = Selection.Information(wdActiveEndPageNumber)
	NumberOfPage = i

End Function

VB Skript aufrufen

VB-Objekte

Dim fs as Object
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists("C:\WIINDOWS") Then
	MsgBox "Ordner existiert"
Else
	MsgBox "Ordner existiert nicht"
End If

fs.CopyFolder "d:\dokumente","e:\"

UserForm

Modal
Wenn ein UserForm gebunden ist, sollte der Benutzer Informationen liefern oder das UserForm schließen, bevor irgendein Teil der Anwendung verwendet wird. Es wird kein nachfolgender Code ausgeführt, bis das UserForm verborgen oder entladen ist. Obwohl andere Formulare in der Anwendung deaktiviert werden, wenn ein UserForm angezeigt wird, geschieht dies nicht bei anderen Anwendungen.

Wenn das UserForm ungebunden ist, kann der Benutzer andere Formulare oder Fenster anzeigen, ohne das UserForm zu schließen.

Ungebundene Formulare werden nicht in der Taskleiste angezeigt und befinden sich nicht in der Aktivierreihenfolge des Fensters.

Ein Excel-Sheet ohne Excel aufrufen - Hierzu in eine UserForm das Excel-Objekt hinzufügen.

Private Sub Spreadsheet1_BeforeCommand(ByVal EventInfo As OWC.SpreadsheetEventInfo)
	With EventInfo
		If .Command = ssClear Then
			MsgBox "Nichts löschen"
			.ReturnValue = False
		End If
	End With
End Sub


Private Sub CoFill_Click()
	Dim i As Integer
	For i = 1 To 10
		Spreadsheet1.ActiveSheet.Range("C" & Trim(Str(i))) = i
	Next i
End Sub

Sub EinfügenNurText()
	Selection.PasteSpecial DataType:=wdPasteText
End Sub

Sub EinfügenNurText()
	On Error GoTo EinfFehler
	Selection.PasteSpecial DataType:=wdPasteText
	Exit Sub
EinfFehler:
		If Err.Number = 4605 Then
		MsgBox "Die Zwischenablage ist leer"
		ElseIf Err.Number = 5342 Then
	MsgBox "Kein Text in der Zwischenablage"
		Else 'Für alle Fälle ...
		Err.Raise Err.Number, Err.Source
	End If
End Sub

Die Makro-Module können auch in eine separate Vorlage gespeichert und in den Autostart-Ordner abgespeichert werden. Zum Bearbeiten muss diese Dokumentvorlage jeweils geöffnet werden

Aufruf des Makro-Editor Alt + F11

Eine spezielle Symbolleiste erstellen

Sub MakeSym()
'
' Symbolleiste erstellen
'
	Dim cbNewBar As CommandBar
	Dim ctlBtn As CommandBarButton

	If Not SymVorhanden("Makros") Then
		Set cbNewBar = CommandBars.Add(Name:="Makros")
		With cbNewBar
		Set ctlBtn = .Controls.Add
		With ctlBtn
			.Caption = "111"
			.Style = msoButtonCaption
			.OnAction = "111"
			.BeginGroup = True
			End With
		Set ctlBtn = .Controls.Add

		End With
		.Protection = msoBarNoCustomize
		.Position = msoBarTop
		.Visible = True

	End With
	End If
End Sub

Private Function SymVorhanden(strMenuName As String) As Boolean
'
' Prüfen, ob Symbolleiste vorhanden
'
	On Error GoTo ERRORHANDLER
	Dim cbNewBar As CommandBar
	Set cbNewBar = Application.CommandBars("Makros")
	SymVorhanden = True
	Exit Function
ERRORHANDLER:
	SymVorhanden = False
End Function

Eine spezielle Menuleiste erstellen

Sub MakeMenu()
'
' Check ob Menu existiert
'
Dim objmenu As CommandBarControl
Dim objBefehl As CommandBarButton

If MenuVorhanden("&Makros") = False Then
	Set objmenu = CommandBars("Menu Bar").Controls.Add(Type:=msoControlPopup, Before:=10)
	With objmenu
		.Caption = "&Makros"

		'1. Befehl anlegen
		Set objBefehl = .Controls.Add(Type:=msoControlButton)	
		With objBefehl
			.Caption = "&111"
			.Style = msoButtonIconAndCaption
			.OnAction = "111"
		End With

		2. Befehl anlegen
		Set objBefehl = .Controls.Add(Type:=msoControlButton)
			With objBefehl
		:

		End With
	End With

End If

End Sub

Private Function MenuVorhanden(strMenuName As String) As Boolean
	Dim objmenu As Object
	For Each objmenu In CommandBars("Menu Bar").Controls
		If objmenu.Caption = strMenuName Then
			MenuVorhanden = True
		End If
	Next
End Function

Variablen und Konstanten

'Globale Variablen
'Public .. as ...

'Globale Konstanten
Public Const StrLogonBytec As String = "lschlageter@freicon.de"
Public Const sss As String = "..."

An das Ende eines Word-Dokumentes springen, 3 Zeilen löschen und einen Text einfügen

Sub NachPos()
'
' nachposls Makro
' Makro aufgezeichnet am 21.09.2004 von lschlageter
'
	Selection.EndKey Unit:=wdStory
	Selection.TypeBackspace
	Selection.TypeBackspace
	Selection.TypeBackspace
	ChangeFileOpenDirectory "D:\Wordvorlagen\"
	Selection.InsertFile FileName:="nachposls2.doc", Range:="", _
	ConfirmConversions:=False, Link:=False, Attachment:=False
End Sub

Sub URL()
'
' URL aufrufen und einen String in die Zwischenablage aufnehmen
'
	Dim AnwID
	Dim Mydata
	AnwID = Shell("c:\programme\intern~1\iexplore.exe http://www.lars-web.com/", 1)
	Set Mydata = New DataObject

	Mydata.SetText StrLogonBytec
	Mydata.PutInClipboard

End Sub

Sub Logo()
'
' Grafik und Text in die Kopfzeile der ersten Seite einfügen
'
Dim rng As Range

	'In die Seitenansicht wechseln
	If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow.ActivePane.View.Type = wdOutlineView Then
		ActiveWindow.ActivePane.View.Type = wdPrintView
	End If

	'In die Kopfzeile wechseln
	ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader

	'Grafik einfügen
	Selection.InlineShapes.AddPicture FileName:= "D:\Wordvorlagen\logo.jpg", LinkToFile:=False, SaveWithDocument:=True
	Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
	Selection.TypeParagraph ' Neuer Absatz

	'Text einfügen
	Selection.Text = "LogoUnterschrift"
	FormatText
	Selection.ParagraphFormat.Alignment = wdAlignParagraphRight 'Rechts formatieren


	ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub