Word Userform - Suchfeld für Worddateien - Ergebnisausgabe in Listbox

 
Option Explicit
' Ordner für die Text-Vorlagen  

Const DOCFOLDER = "C:\vbaTest\Bestelltexte"  

Dim BoEnter As Boolean
Dim m_appExcel As Excel.Application
Dim m_wbkExcel As Excel.Workbook
Dim m_wksExcel As Excel.Worksheet
Dim m_rngExcel As Excel.Range
Dim m_rngCell As Range
Dim m_strFirstAddress As String
Dim m_Suchwort As String
Dim m_LiefName As String
Dim m_LiefAnschrift As String
Dim m_LiefLand As String
Dim m_LiefPLZ As String
Dim m_LiefOrt As String
Dim m_Bereich As Range
Dim m_rngDoc As Range
Dim m_oDoc As Document
Dim m_LT As String

Private Sub UserForm_Initialize()
Dim DatumHeute As String
DatumHeute = Format(Date, "dd.mm.yyyy")  
BestelldatenWord.BestDatum = DatumHeute
End Sub

Private Sub BestelldatenWord_Activate()
lbResults.Clear
LiefSuche.SetFocus
End Sub

Private Sub LiefSuche_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Set m_appExcel = Excel.Application
Set m_wbkExcel = Excel.Workbooks.Open("C:\vbaTest\Lieferanten.xlsx")  
Set m_wksExcel = Excel.Worksheets("Lieferanten")  
Set m_rngExcel = m_wksExcel.UsedRange
   
m_Suchwort = ("*" & BestelldatenWord.LiefSuche.Value & "*")  
BestelldatenWord.LiefListBox.Clear
With m_wksExcel.Range("F:F")  
Set m_rngExcel = .Find(m_Suchwort, LookIn:=xlValues, lookat:=xlWhole)
If Not m_rngExcel Is Nothing Then
m_strFirstAddress = m_rngExcel.Address

Do
With BestelldatenWord.LiefListBox
.ColumnCount = 1
.AddItem
.List(.ListCount - 1, 0) = m_rngExcel.Text                   'LieferantenName  
.List(.ListCount - 1, 1) = m_rngExcel.Offset(0, 5).Value     'LiefAnschrift  
.List(.ListCount - 1, 2) = m_rngExcel.Offset(0, 1).Value     'LiefLand  
.List(.ListCount - 1, 3) = m_rngExcel.Offset(0, 6).Value     'LiefPLZ  
.List(.ListCount - 1, 4) = m_rngExcel.Offset(0, 7).Value     'LiefOrt  
.ColumnWidths = "8cm"  
End With

Set m_rngExcel = .FindNext(m_rngExcel)
Loop While Not m_rngExcel Is Nothing And m_rngExcel.Address <> m_strFirstAddress
Else
End If
End With

m_wbkExcel.Close False
m_appExcel.Quit
Set m_appExcel = Nothing
End Sub
Private Sub LiefListBox_Click()
Set m_appExcel = Excel.Application
Set m_wbkExcel = Excel.Workbooks.Open("C:\vbaTest\Lieferanten.xlsx")  
Set m_wksExcel = Excel.Worksheets("Lieferanten")  
Set m_rngExcel = m_wksExcel.UsedRange

Dim LiefKontakt As Worksheet
Dim EndeLiefKontakt As Integer
Dim I As Integer
Dim ZahlBed As String

m_LiefName = LiefListBox.List(LiefListBox.ListIndex, 0)
m_LiefAnschrift = LiefListBox.List(LiefListBox.ListIndex, 1)
m_LiefLand = LiefListBox.List(LiefListBox.ListIndex, 2)
m_LiefPLZ = LiefListBox.List(LiefListBox.ListIndex, 3)
m_LiefOrt = LiefListBox.List(LiefListBox.ListIndex, 4)

BestelldatenWord.LiefName = m_LiefName
BestelldatenWord.LiefAnschrift = m_LiefAnschrift
BestelldatenWord.LiefLand = m_LiefLand
BestelldatenWord.LiefPLZ = m_LiefPLZ
BestelldatenWord.LiefOrt = m_LiefOrt

m_wbkExcel.Close False
m_appExcel.Quit
Set m_appExcel = Nothing
End Sub

Private Sub SendenAnWord_Click()
Set m_Bereich = ActiveDocument.Bookmarks("LiefName").Range  
m_Bereich.Text = m_LiefName
ActiveDocument.Bookmarks.Add Name:="LiefName", Range:=m_Bereich  

Set m_Bereich = ActiveDocument.Bookmarks("LiefAnschrift").Range  
m_Bereich.Text = m_LiefAnschrift
ActiveDocument.Bookmarks.Add Name:="LiefAnschrift", Range:=m_Bereich  

Set m_Bereich = ActiveDocument.Bookmarks("LiefLand").Range  
m_Bereich.Text = m_LiefLand
ActiveDocument.Bookmarks.Add Name:="LiefLand", Range:=m_Bereich  

Set m_Bereich = ActiveDocument.Bookmarks("LiefPLZ").Range  
m_Bereich.Text = m_LiefPLZ
ActiveDocument.Bookmarks.Add Name:="LiefPLZ", Range:=m_Bereich  

Set m_Bereich = ActiveDocument.Bookmarks("LiefOrt").Range  
m_Bereich.Text = m_LiefOrt
ActiveDocument.Bookmarks.Add Name:="LiefOrt", Range:=m_Bereich  

Set m_Bereich = ActiveDocument.Bookmarks("BestDatum").Range  
m_Bereich.Text = BestelldatenWord.BestDatum
ActiveDocument.Bookmarks.Add Name:="BestDatum", Range:=m_Bereich  

Set m_Bereich = ActiveDocument.Bookmarks("LT").Range  
m_Bereich.Text = BestelldatenWord.LT
ActiveDocument.Bookmarks.Add Name:="LT", Range:=m_Bereich  

BestelltextEinfügen

Me.Hide
AlleFldAktualisieren
End Sub

Sub BestelltextEinfügen()
If lbResults.ListIndex <> -1 Then
Dim objWord As Word.Application
Dim strDocPath As String
Dim docBestellung As Document
Dim docBestelltext As Document

Dim strBMName   As String   'Textmarkenname  
Dim rngBMRange  As Range    'Textmarkenbereich  
  
Dim strBMText   As String   'Textmarken-Text  
strBMName = "Bestelltext1"  'Textmarkenname  

' Pfad der aktuell markierten Zeile aus der zweiten unsichtbaren Spalte holen  
strDocPath = lbResults.List(lbResults.ListIndex, 1)
        
Set docBestelltext = Documents.Open(strDocPath)
docBestelltext.Content.Copy
docBestelltext.Close True

With ActiveDocument 'docBestellung 'ActiveDocument  
If .Bookmarks.Exists(strBMName) Then
'Verweis auf den Textmarkenbereich setzen  
Set rngBMRange = .Bookmarks(strBMName).Range
'Der Textmarke den Text zuweisen  
rngBMRange.Paste
'Textmarke neu definieren  
.Bookmarks.Add Name:=strBMName, Range:=rngBMRange
End If
End With
End If
End Sub

Private Sub txtSearch_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim doc As Document, fso As Object, file As Object, found As Boolean
'Inhalt der Listbox löschen  
lbResults.Clear
Set fso = CreateObject("Scripting.FileSystemObject")  
For Each file In fso.GetFolder(DOCFOLDER).Files
' nur docx Dokumente durchsuchen  
If fso.GetExtensionName(file.Path) = "docx" Then  
If InStr(1, file.Name, txtSearch.Text, vbTextCompare) Then
found = True
'Wurde ein Treffer gefunden füge den Namen ohne Extension zur Listbox hinzu  
lbResults.AddItem fso.GetBaseName(file.Name)
'Speichere den Pfad der Datei in einer zweiten Spalte der Listbox die in der Eigenschaft die Breite '0' bekommen sollte damit sie nicht sichtbar ist  
lbResults.List(lbResults.ListCount - 1, 1) = file.Path
End If
End If
Next
If Not found Then
MsgBox "Kein Dokument mit dem Suchwort gefunden"  
End If
End Sub

Public Sub AlleFldAktualisieren()
Set m_oDoc = ActiveDocument
For Each m_rngDoc In m_oDoc.StoryRanges
m_rngDoc.Fields.Update
While Not (m_rngDoc.NextStoryRange Is Nothing)
Set m_rngDoc = m_rngDoc.NextStoryRange
m_rngDoc.Fields.Update
Wend
Next m_rngDoc
ActiveDocument.Bookmarks("LiefName").Select  
End Sub

Sub SpeichernMitBestellnummer()
Dim objWord As Word.Application
Dim Briefbestellung As Document
Dim dialogs As FileDialog

m_PfadBestellung = "C:\vbaTest\Bestellungen\Bestellung1.docx"  

Set dialogs = Application.FileDialog(msoFileDialogSaveAs)
With dialogs
.InitialView = msoFileDialogViewList
.InitialFileName = m_PfadBestellung
.FilterIndex = 0
.Show
End With
End Sub

ActiveDocument.Shapes(1).TextFrame.TextRange.Select
With dialogs(wdDialogFileSaveAs)
.Name = "C:\vbaTest\Bestellung1.docx"  
.Show
End With

Sub ListAddins()
   Dim MyAddin As COMAddIn
   Dim i As Integer, msg As String

   For Each MyAddin In Application.COMAddIns
      msg = msg & MyAddin.Description & " - " & MyAddin.ProgID & vbCrLf  
   Next
   MsgBox msg
End Sub