AW: Wordvorlage öffnen, versch. Versionen
07.11.2021 19:27:17
Peter
Hallo,
anbei meine Daten von VBA. Die Datei kann ich nicht hochladen da zu umfangreich:
Mein Code für das Öffnen der Dokumentenvorlage:
Option Explicit
'Anfang - für Userform unverschiebbar machen
#If Win64 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function DeleteMenu Lib "user32" ( _
ByVal hMenu As LongPtr, _
ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
Private Declare PtrSafe Function GetSystemMenu Lib "user32" ( _
ByVal hwnd As LongPtr, _
ByVal bRevert As Long) As LongPtr
Private hwnd As LongPtr
#Else 'ohne PtrSafe unten bleibt Text rot - Kompilierung nicht möglich - aber bei alter Version nicht erforderlich
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function DeleteMenu Lib "user32" ( _
ByVal hMenu As Long, _
ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
Private Declare PtrSafe Function GetSystemMenu Lib "user32" ( _
ByVal hwnd As Long, _
ByVal bRevert As Long) As Long
Private hwnd As Long
#End If
Private Const MF_BYCOMMAND = &H0
Private Const SC_MOVE = &HF010
'Ende - für Userform unverschiebbar machen
Private WrdApp As Object, wrdDoc As Object
Private strDName As String
Private strPfad As String
Private strName As String
Private strEndung As String
Dim blnTMP As Boolean 'benötigt für Private Function OffApp(ByVal strApp As String, Optional blnVisible As Boolean = True) As Object
Function IstDateiOffen(Dateiname As String) As Boolean
Dim DateiNr As Long
Dim FehlerNr As Long
On Error Resume Next
DateiNr = FreeFile()
Open Dateiname For Input Lock Read As #DateiNr
Close DateiNr
FehlerNr = Err
On Error GoTo 0
Select Case FehlerNr
Case 0
IstDateiOffen = False
Case 70
IstDateiOffen = True
Case Else
Error FehlerNr
End Select
End Function
'Auswahl, welches Worddokument geöffnet werden soll
Private Sub ComboBox1_Change()
Dim pfad As String
With Worksheets("Worddaten")
pfad = .Range("B76")
If ComboBox1 "" Then
TextBox2.Value = pfad & ComboBox1.Value '.Cells(ComboBox1.ListIndex + 2, 34)
CommandButton4.Enabled = True
Label7.Font.Size = 12
Label7.Caption = "bitte Button ""WordBrief-Basisvorlage öffnen"" drücken"
End If
End With
If ComboBox1 = "" Then
TextBox2.Value = ""
Label7.Font.Size = 12
Label7.Caption = "bitte WordBrief-Basisvorlage auswählen"
End If
End Sub
'Beenden
Private Sub CommandButton1_Click()
If ComboBox1.Value = "" Then
Label7.Caption = "Word-Datei bereits beendet" _
& vbLf & "Formular wird geschlossen"
UF_Buchungen2.Show
Unload Me
ElseIf ComboBox1.Value > "" Then
'beim Beenden Worddatei und Word schliessen
CommandButton12 = True
UF_Buchungen2.Show
Unload Me
End If
End Sub
'Auswahl löschen - Auswahlbereich
Private Sub CommandButton15_Click()
ListBox1.Value = ""
If ListBox1.ListIndex = -1 Then
CommandButton6.Enabled = False
Else
CommandButton6.Enabled = True
End If
End Sub
'Übertrag von Logo
Private Sub CommandButton3_Click()
Dim objDocument As Object
Dim strPathDat As String
Dim strPathLogo As String
Dim sFile As String
Dim DieDatei As Boolean 'benötigt für Prüfung ob Worddatei geöffnet ist
If TextBox2 = "" Then
Label7.Font.Size = 11
Label7.Caption = vbLf & "keine WordBrief-Basisvorlage vorhanden!"
Exit Sub
End If
DieDatei = IstDateiOffen(TextBox2.Value)
If DieDatei = False Then
'MsgBox "Datei ist schon geöffnet"
Label7.Caption = "WordBrief-Basisvorlage ist nicht geöffnet" & vbLf & " Vorgang beendet"
Exit Sub
ElseIf DieDatei = True Then
'MsgBox "Datei ist schon geöffnet"
Label7.Font.Size = 11
Label7.Caption = vbLf & "WordBrief-Basisvorlage ist geöffnet"
strPathDat = TextBox2
'Debug.Print strPathDat
strPathLogo = Worksheets("Worddaten").Range("B72")
sFile = strPathLogo & "CvL_Logo.jpg"
'Debug.Print sFile
Set objDocument = GetObject(PathName:=strPathDat)
objDocument.InlineShapes.AddPicture Filename:=sFile, LinkToFile:=False, SaveWithDocument:=True
objDocument.Application.Run "Curser_nach_rechts"
Set objDocument = Nothing
End If
End Sub
'WordBrief-Basisvorlage öffnen
Private Sub CommandButton4_Click()
'Wichtig! Die Deklarationen müssen damit CommandButton4 richtig ausgeführt wird für alles in der Zeile direkt unter Option Explicit stehen
Dim wb As Workbook 'benötigt für ThisWorkbook
Dim wksWd As Worksheet 'benötigt für Worksheets
'Anfang fügt die erforderlichen Kontodaten in Tabelle "Worddaten" ein
Call Kontodaten_in_Worddaten_für_Wordbrief_erstellen
'Ende fügt die erforderlichen Kontodaten in Tabelle "Worddaten" ein
Set wb = ThisWorkbook 'benötigt für Worksheets
Set wksWd = wb.Sheets("Worddaten") 'benötigt für Textboxes
With wksWd
'Anfang Einlesen der Daten für Kontoinhaber
ListBox1.List = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value
'Ende Einlesen der Daten für Kontoinhaber
End With
If ComboBox1.Value = "" Then
Label7.Font.Size = 12
Label7.Caption = vbLf & " bitte Worddatei auswählen!"
Exit Sub
Else
strDName = TextBox2.Value
'Debug.Print strDName
End If
Set WrdApp = CreateObject("Word.Application")
'WrdApp.Visible = True
WrdApp.Visible = False 'False = nicht sichtbar 'dadurch wird erst das aktualisierte Dokument1 angezeigt
WrdApp.WindowState = 1 '0 = Normal; 1 = Maximized; 2 = Minimized
Set wrdDoc = WrdApp.Documents.Open(strDName) 'öffnet das Vorlage-Dokument
WrdApp.Run "pfadAktualisieren"
wrdDoc.SelectContentControlsByTag("Pflichtfeld").Item(1).Range = "Test"
WrdApp.Visible = True 'True = sichtbar 'dadurch wird erst das aktualisierte Dokument1 angezeigt
With Label7
.BackColor = &HC0FFC0
.Caption = "WordBrief-Basisvorlage geöffnet!"
End With
CommandButton1.Enabled = False
CommandButton4.Enabled = False
CommandButton12.Enabled = True
CommandButton3.Enabled = True
CommandButton6.Enabled = True
CommandButton15.Enabled = True
ListBox1.Enabled = True
CommandButton1.Enabled = False
''aufheben von Set darf hier nicht erfolgen erst beim Schliessen
'Set wrdDoc = Nothing
'Set wrdApp = Nothing
End Sub
'WordBrief-Basisvorlage schliessen
Private Sub CommandButton12_Click()
' Wichtig!!
' unter "Extras" - "Verweise" einen Verweis auf die "Microsoft Word X.0 Object-Library" setzen!
'Wichtig! Die Deklarationen müssen damit CommandButton2 richtig ausgeführt wird für alles in der Zeile direkt unter Option Explicit stehen
'Anfang löscht die Kontodaten wieder aus Tabelle "Worddaten"
Call Worddaten_Eintrag_ändern_rückgängig
'Ende löscht die Kontodaten wieder aus Tabelle "Worddaten"
'Anfang Umwandeln von Mergeformat auf Charformat
wrdDoc.Application.Run "Umwandeln_Mergeformat_zu_Charformat"
'Ende Umwandeln von Mergeformat auf Charformat
If Not WrdApp Is Nothing Then
On Error Resume Next
wrdDoc.Save = True
wrdDoc.Save
wrdDoc.SelectContentControlsByTag("Pflichtfeld").Item(1).Range = "Test1"
wrdDoc.Close True
If WrdApp.Documents.Count = 0 Then WrdApp.Quit
On Error GoTo 0
Set wrdDoc = Nothing
Set WrdApp = Nothing
End If
With Label7
.BackColor = &HC0FFC0
.Caption = "gewähltes Worddokument geschlossen!"
End With
'leert die Worddateien-Auswahl
Label7.Caption = "WordBrief-Basisvorlage gespeichert und geschlossen!"
ComboBox1.Enabled = True
ComboBox1.ListIndex = -1
TextBox2 = ""
ComboBox1.Enabled = True
CommandButton12.Enabled = False
ListBox1.Clear
ListBox1.Enabled = False
CommandButton15 = True
CommandButton15.Enabled = False
CommandButton3.Enabled = False
CommandButton6.Enabled = False
CommandButton4.Enabled = False
CommandButton1.Enabled = True
'aufheben von Set
Set wrdDoc = Nothing
Set WrdApp = Nothing
End Sub
'Übertrag in Worddokument
Private Sub CommandButton6_Click()
Dim BezSpalte1 As String
Dim BezSpalte2 As String
Dim BezSpalte3 As String
Dim BezSpalte1Z1 As String
Dim BezSpalte2Z1 As String
Dim BezSpalte3Z1 As String
Dim BezSpalte1Z201 As String
Dim BezSpalte2Z201 As String
Dim BezSpalte3Z201 As String
Dim Bereich1 As String
Dim Bereich2 As String
Dim Bereich3 As String
Dim objDocument As Object 'benötigt für Word
Dim strPath As String 'benötigt für Word
Dim lRow As Long
With Selection
'Anfang Ermittlung der Spalten 1 bis 3 mit Buchstaben und Zahl "1" für erste Zeile
BezSpalte1Z1 = Split(Selection(1).Address, "$")(1) & "1" 'Spaltenbuchstabe von Spalte1
BezSpalte2Z1 = Split(Selection(2).Address, "$")(1) & "1" 'Spaltenbuchstabe von Spalte1
BezSpalte3Z1 = Split(Selection(3).Address, "$")(1) & "1" 'Spaltenbuchstabe von Spalte1
'Debug.Print BezSpalte1Z1
'Debug.Print BezSpalte2Z1
'Debug.Print BezSpalte3Z1
'Ende Ermittlung der Spalten 1 bis 3 mit Buchstaben und Zahl "1" für erste Zeile
'Anfang Ermittlung der Spalten 1 bis 3 mit Buchstaben und Zahl "201" für die letzte vorhandene Zeile
BezSpalte1Z201 = Split(Selection(1).Address, "$")(1) & "201" 'Spaltenbuchstabe von Spalte1
BezSpalte2Z201 = Split(Selection(2).Address, "$")(1) & "201" 'Spaltenbuchstabe von Spalte1
BezSpalte3Z201 = Split(Selection(3).Address, "$")(1) & "201" 'Spaltenbuchstabe von Spalte1
'Debug.Print BezSpalte1Z201
'Debug.Print BezSpalte2Z201
'Debug.Print BezSpalte3Z201
'Ende Ermittlung der Spalten 1 bis 3 mit Buchstaben und Zahl "201" für die letzte vorhandene Zeile
'Anfang Bereich der Spalten 1 bis 3 mit Buchstaben und Zahl "1" und Buchstaben für die erste vorhandene Zeile und Zahl "201" für die letzte vorhandene Zeile
Bereich1 = BezSpalte1Z1 & ":" & BezSpalte1Z201
Bereich2 = BezSpalte2Z1 & ":" & BezSpalte2Z201
Bereich3 = BezSpalte3Z1 & ":" & BezSpalte3Z201
'Debug.Print Bereich1
'Debug.Print Bereich2
'Debug.Print Bereich3
'Ende Bereich der Spalten 1 bis 3 mit Buchstaben und Zahl "1" und Buchstaben für die erste vorhandene Zeile und Zahl "201" für die letzte vorhandene Zeile
End With
If ListBox1.ListIndex = -1 Then 'And ListBox3.ListIndex = -1 And ListBox4.ListIndex = -1 And ListBox5.ListIndex = -1 Then
'MsgBox "Es wurde kein ListBox-Eintrag ausgewählt!"
Label7.Caption = "Es wurde kein ListBox-Eintrag ausgewählt!"
ElseIf ListBox1.ListIndex > -1 Then 'And ListBox3.ListIndex = -1 And ListBox4.ListIndex = -1 And ListBox5.ListIndex = -1 Then
'MsgBox "ListBox1 ausführen"
Label7.Caption = "Eintrag in Auswahlbereich für Kontoinhaber ausgewählt"
With Worksheets("Worddaten")
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'ermittele die Anzahl der Zeilen, gehe von dort nach oben
End With
'Anfang Auswahl kopieren in ListBox1
With Range("Worddaten!A2:A" & lRow)
Tag = "1"
.Cells(ListBox1.ListIndex + 1, 1).Copy
Tag = ""
End With
'Ende Auswahl kopieren in ListBox1
If TextBox2 = "" Then
Label7.Caption = "Bitte Worddatei auswählen"
Exit Sub
Else
strPath = TextBox2
End If
Set objDocument = GetObject(PathName:=strPath) 'mit Variable aus TextBox2
objDocument.Application.Run "Unformatierten_Text_einfügen" 'führt ein Makro in diesem Dokument aus
Set objDocument = Nothing
Application.CutCopyMode = False
ListBox1 = ""
CommandButton6.Enabled = False
End If
End Sub
'Hilfe für dieses Formular
Private Sub CommandButton21_Click()
UF_Hilfe.Label1.Caption = 25
UF_Hilfe.Show
' UF_Wordbrief02Basis_Hilfe.Show
End Sub
Private Sub ListBox1_Click()
If ListBox1.ListIndex = -1 Then
CommandButton6.Enabled = False
Else
CommandButton6.Enabled = True
End If
End Sub
Private Sub UserForm_Activate()
'Anfang - Userform unverschiebbar machen
Dim hMenu As LongPtr
hMenu = GetSystemMenu(FindWindow(vbNullString, Caption), 0)
If hMenu 0 Then
DeleteMenu hMenu, SC_MOVE, MF_BYCOMMAND
End If
'Ende - Userform unverschiebbar machen
End Sub
Private Sub UserForm_Initialize()
Dim wb As Workbook 'benötigt für ThisWorkbook
Dim wksH As Worksheet 'benötigt für Worksheets
Dim wksWd As Worksheet 'benötigt für Worksheets
Dim namensber As Name 'benötigt für ListBox2
Dim iRow As Integer 'benötigt für ComboBox1
Dim wks As Worksheet 'benötigt für ComboBox1
Dim i As Long
'Anfang Bildschirmgroesse
Application.WindowState = xlMaximized
With Me
.Height = Application.Height
.Width = Application.Width
End With
'Ende Bildschirmgroesse
Set wb = ThisWorkbook 'benötigt für Worksheets
Set wksH = wb.Sheets("Hilfstabelle") 'benötigt für Textboxes
Set wksWd = wb.Sheets("Worddaten") 'benötigt für Textboxes
'Anfang listet die Wordbrief_Basisvorlagen im aktuellen Workbook in Tabelle Worddaten Spalte AF auf
Call Word_Vorlagen_Laufend_auflisten
'Ende listet die Wordbrief_Basisvorlagen im aktuellen Workbook in Tabelle Worddaten Spalte AF auf
If IsEmpty(wksWd.Cells(2, 34)) Then
Label7.Font.Size = 12
Label7.Caption = "bitte neue Wordvorlage erstellen" _
& vbLf & "und dieses Formular beenden"
ElseIf Not IsEmpty(wksWd.Cells(2, 34)) Then
Label7.Font.Size = 12
Label7.Caption = "bitte Word-Briefdokument auswählen"
'Anfang Befüllen ComboBox1 mit Worddokumenten
With wksWd
ComboBox1.Clear
ComboBox1.ColumnCount = 1
ComboBox1.ColumnWidths = "3,5cm"
For i = 2 To .Cells(.Rows.Count, 34).End(xlUp).Row
If .Cells(i, 34) Like "*.dotm*" Then
ComboBox1.AddItem .Cells(i, 34)
ComboBox1.List(ComboBox1.ListCount - 1, 0) = .Cells(i, 34)
End If
Next i
End With
Set wb = Nothing: Set wksWd = Nothing
'Ende - befüllen ListBox2
End If
CommandButton6.Enabled = False
ListBox1.Enabled = False
CommandButton4.Enabled = False
CommandButton12.Enabled = False
CommandButton3.Enabled = False
End Sub
'von HWH geändert erforderlich für deaktivieren von Schliesskreuz
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode 1 Then Cancel = 1
End Sub
Der Code in der Dokumentenvorlage:
in ThisDocuments:
Option Explicit
Private WithEvents App As Word.Application
'Initialisieren anlässlich des Erstellens eines neuen Dokuments
Private Sub Document_New()
If App Is Nothing Then
Set App = ThisDocument.Application
End If
End Sub
Private Sub AutoOpen()
Call pfadAktualisieren
End Sub
Private Sub App_DocumentBeforeClose(ByVal Doc As Document, Cancel As Boolean)
'ActiveDocument.SelectContentControlsByTag("Pflichtfeld").Item(1).ShowingPlaceholderText
'nur aktiv werden, wenn das aktuelle Dokument auf derjenigen Vorlage beruht, in dem dieses Makro steht
If Doc.AttachedTemplate ThisDocument.AttachedTemplate Then Exit Sub
If ActiveDocument.SelectContentControlsByTag("Pflichtfeld").Item(1).ShowingPlaceholderText Then
Call Document_New
MsgBox "Du schließt hier nix, bevor du nicht das Pflichtfeld ausgefüllt hast!"
Cancel = True
ElseIf Not ActiveDocument.SelectContentControlsByTag("Pflichtfeld").Item(1).ShowingPlaceholderText Then
Call Document_New
If ActiveDocument.SelectContentControlsByTag("Pflichtfeld").Item(1).Range.Text = "Test" Then
MsgBox "Das Pflichtfeld ist ausgefüllt - Test - schliessen nicht möglich" _
& vbLf & "Bitte mit Excel-Formular - Button ""gewählte Worddatei schliessen"" beenden!"
'MsgBox ActiveDocument.SelectContentControlsByTag("Pflichtfeld").Item(1).Range.Text
Doc.Saved = False
Cancel = True
ElseIf ActiveDocument.SelectContentControlsByTag("Pflichtfeld").Item(1).Range.Text = "Test1" Then
'MsgBox "Das Pflichtfeld ist ausgefüllt - Test1 - schliessen möglich!"
Doc.Saved = True
'Cancel = True
ElseIf ActiveDocument.SelectContentControlsByTag("Pflichtfeld").Item(1).Range.Text = "1" Then
'MsgBox "Das Pflichtfeld ist ausgefüllt - Test1 - schliessen möglich!"
Doc.Saved = False
Cancel = False
End If
End If
End Sub
in Modul1:
Option Explicit
'Achtung!
'Das Makro: "pfadAktualisieren" funktioniert nur, wenn das Worddokument im gleichen Ordner ist wie die verbundene Excel-Datei
'Das Makro bezieht den Pfad der Datei aus dem gleichen Ordner wie die Excel-Datei
'!!!!Achtung eingebaut Pfad und Dateiname geändert!!!!
'funktioniert - eingebaut in ThisDocument - "Sub AutoOpen"
Sub pfadAktualisieren()
Dim aktuellerpfad As String, alterpfad As String
Dim DocWD As Document
Dim DokWD As Document
Dim anfang, ende
Dim aktuellerpfad2 As String, alterpfad2 As String
Dim ext, x, srcFile As String, d As String 'benötigt zum Finden des Namen der Excel-Datei
Dim aktEDatEnd As String 'benötigt zum Finden des Namen der Excel-Datei
Dim gefundenerWert As String 'benötigt zum Finden des Namen der Excel-Datei
'Abteilung aktueller Pfad------------------------------------------------------------------------------------------------
'Das soeben geöffnete Dokument zum Objekt machen, mit dem weitergearbeitet wird
Set DocWD = ActiveDocument
Set DokWD = ThisDocument
'aktuellen Pfad in der Variable aktuellerpfad merken (pathSeparator ist hier der abschließende Backslash)
' aktuellerpfad = DocWD.Path & Application.PathSeparator
aktuellerpfad = DokWD.Path & Application.PathSeparator
'aktuellerpfad = Replace(aktuellerpfad, "", "") '
'Backslashes verdoppeln, damit der Pfad so vorliegt wie im Exel-Link-Feld
aktuellerpfad = Replace(aktuellerpfad, "\", "\\") '
'Debug.Print aktuellerpfad
'Kontrolle:
'MsgBox "Der aktuelle Pfad lautet: " & aktuellerpfad
'Anfang Finden des Namen der Excel-Datei im Ordner 02
ext = Array("*.xls", "*.xlsm", "*.xlsx")
For Each x In ext
d = Dir(aktuellerpfad & x)
aktEDatEnd = VBA.Right(d, 5)
'Debug.Print aktEDatEnd
If aktEDatEnd = ".xlsm" Then
gefundenerWert = d
'Debug.Print gefundenerWert
Exit For
End If
Next
'Ende Finden des Namen der Excel-Datei im Ordner 02
'Abteilung alter Pfad--------------------------------------------------------------------------------------------------------------------------------------
With DocWD
'Feldcode-Ansicht einschalten
.ActiveWindow.View.ShowFieldCodes = True
'Kompletten Inhalt des ersten oder hier: einzigen Feldes,
'das in der Textmarke steckt, auslesen und in der Variable alterpfad ablegen
alterpfad = .Bookmarks("Suchen_PfadDateiname").Range.Fields(1).Code
'Feld Teil extrahieren, der den Dateipfad enthält:
.Bookmarks("Suchen_PfadDateiname").Range.Fields(1).Select
'anfang ist die Stelle, an der der erste Doppelpunkt gefunden wird, vermindert um 1 Zeichen,
'damit der Pfad beim Laufwerksbuchstaben beginnt
anfang = Selection.Start + InStr(alterpfad, ":") - 1
'ende ist dort, wo der letzte doppelte Backslash gefunden wird, vermehrt um 2 Zeichen
'damit die Backslashes dazugehören
ende = Selection.Start + InStrRev(alterpfad, ".xlsm") + 5
'den so ermittelten Bereich markieren
.Range(anfang, ende).Select
'Debug.Print Selection
alterpfad2 = Selection
'Debug.Print alterpfad2
aktuellerpfad2 = aktuellerpfad & gefundenerWert
'Debug.Print aktuellerpfad2
'Anfang - Prüfung ob aktueller Pfad mit dem alten Pfad identisch ist
If aktuellerpfad2 = alterpfad2 Then
'MsgBox "beide Pfade sind identisch"
'Feldcode-Ansicht ausschalten
.ActiveWindow.View.ShowFieldCodes = False
Call AlleFelderAktualisieren
Call Tabelle_markieren_Bezug_ersetzen
Call ersten_Eintrag_markieren
Exit Sub
Else
'MsgBox "beide Pfade sind nicht identisch"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = alterpfad2 'alter Pfad
.Replacement.Text = aktuellerpfad2 'neuer Pfad
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Application.DisplayAlerts = 0 'die Meldung, ob nochmals gesucht werden soll wird hiermit abgeschaltet
Selection.Find.Execute Replace:=wdReplaceAll
.ActiveWindow.View.ShowFieldCodes = False
End If
'Ende - Prüfung ob aktueller Pfad mit dem alten Pfad identisch ist
End With
'Vollzugsmeldung:MsgBox "Das Feld enthält jetzt den aktuellen Pfad."
Call AlleFelderAktualisieren
Call Tabelle_markieren_Bezug_ersetzen
Call ersten_Eintrag_markieren
End Sub
'ersetzt durch: Unformatierten_Text_einfügen
'wird ausgeführt in Userform5 Commandbutton6
Sub Inhalte_einfuegen()
Selection.PasteExcelTable True, True, True
ActiveDocument.Save
End Sub
Sub Unformatierten_Text_einfügen()
Selection.PasteSpecial Link:=True, DataType:=wdPasteText, Placement:= _
wdInLine, DisplayAsIcon:=False
ActiveDocument.Save
End Sub
'fügt Sondertext ein ohne Verknüpfung
Sub SonderText_einfügen()
Selection.PasteSpecial Link:=False, DataType:=wdPasteText, Placement:= _
wdInLine, DisplayAsIcon:=False
End Sub
'wird ausgeführt in Userform5 Commandbutton3
Sub Curser_nach_rechts()
Selection.MoveRight Unit:=wdWord, Count:=1
End Sub
'Bild einfügen mit Variabler aus Excel funktioniert - existiert aber in Userform5 Commandbutton3 als direkte Eingabe
Sub Bild_einfügen()
Dim xlsApp As Excel.Application
Dim xlsFile As Excel.Workbook
Dim xlsArbeitsDatei As Excel.Workbook
Dim xlrange As Excel.Range
Dim getobjeckts As Object
Dim FName As String
Dim xlsName As Excel.Range
Dim xlwrkbk As Excel.Workbook
Dim xlsheet As Excel.Worksheet
Set xlsApp = GetObject(, "Excel.Application")
Set xlwrkbk = xlsApp.ActiveWorkbook
Set xlsheet = xlwrkbk.Sheets("Worddaten")
Set xlrange = xlsheet.Range("B8")
Set xlsName = xlsheet.Range("B6")
Selection.InlineShapes.AddPicture FileName:= _
xlsName, _
LinkToFile:=False, SaveWithDocument:=True
Set xlsApp = Nothing
Set xlwrkbk = Nothing
Set xlsheet = Nothing
Set xlrange = Nothing
Set xlsName = Nothing
End Sub
'wird ausgeführt in ThisDocument - Makro: Sub Document_New
Sub AlleFelderAktualisieren()
Dim rngDoc As Range
Dim oDoc As Document
Set oDoc = ActiveDocument
For Each rngDoc In oDoc.StoryRanges
rngDoc.Fields.Update
While Not (rngDoc.NextStoryRange Is Nothing)
Set rngDoc = rngDoc.NextStoryRange
rngDoc.Fields.Update
Wend
Next rngDoc
End Sub
'wird ausgeführt in ThisDocument - Makro: Sub Document_New
Sub Tabelle_markieren_Bezug_ersetzen()
Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "#Bezug!"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.MoveRight Unit:=wdCharacter, Count:=2
End Sub
Sub ersten_Eintrag_markieren()
ActiveDocument.Range(0, 0).Select '(springt zum Dokumentanfang)
End Sub
Sub Umwandeln_Mergeformat_zu_Charformat()
'Anfang Umwandlung von Mergeformat in Charformat
ActiveWindow.View.ShowFieldCodes = True 'Word-VBA öffnen
Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "\* mergeformat"
.Replacement.Text = "\* charformat"
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
ActiveWindow.View.ShowFieldCodes = False 'Word-VBA schliessen
'Anfang Umwandlung von Mergeformat in Charformat
End Sub
Ich hoffe, dass euch eine passende Lösung einfällt. Danke
Gruss
Peter