Mein Word-Makro findet das zweite Wort nicht

Question

Ich möchte ein VBA-Skript in Microsoft Word erstellen, um innerhalb einer TXT-Datei zu finden, wenn eine Zeile mit ":" Zeichen vorhanden ist. Wenn das wahr ist, möchte ich diese Zeile bekommen, sie teilen und diese Information in eine Tabelle einfügen, die sich in der Hauptdatei befindet. Um dieses Ziel zu erreichen, möchte ich alle gefundenen Zeilen durchlaufen, um diese Informationen zu erhalten.

Dazu habe ich diesen Code:

Dim arrNames 
    Dim cont As Integer 

    cont = 0 

    strPath = ActiveDocument.name 
    Documents.Open path & "Mails.txt" 
    strPath2 = ActiveDocument.name 

    With Selection.Find 
     .Text = ":" 
     Do While .Execute(Forward:=True, Format:=True) = True 

      Selection.Find.Execute FindText:=(":") 
      Selection.Expand wdLine 

      arrNames = Split(Selection.Text, ":") 

      Documents(strPath).Activate 

      If cont = 0 Then 

       Call gestOSINT("Pwd") 

       Selection.Find.Execute FindText:=("[Pwd]") 

       ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:= _ 
        3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _ 
        wdAutoFitFixed 
       With Selection.Tables(1) 
        If .Style <> "Tabla con cuadrícula" Then 
         .Style = "Tabla con cuadrícula" 
        End If 
        .ApplyStyleHeadingRows = True 
        .ApplyStyleLastRow = False 
        .ApplyStyleFirstColumn = True 
        .ApplyStyleLastColumn = False 
        .ApplyStyleRowBands = True 
        .ApplyStyleColumnBands = False 
       End With 
       Set tblNew = Selection.Tables(1) 

       tblNew.Style = "Tabla de lista 1 clara - Énfasis 1" 
       Selection.TypeText Text:="Correo electrónico" 
       Selection.MoveRight Unit:=wdCell 
       Selection.TypeText Text:="Tipo de filtrado" 
       Selection.MoveRight Unit:=wdCell 
       Selection.TypeText Text:="Plataforma" 
      End If 



      Set rowNew = tblNew.Rows.Add 

      rowNew.Cells(1).Range.Text = arrNames(0) 
      rowNew.Cells(2).Range.Text = arrNames(1) 
      rowNew.Cells(3).Range.Text = arrNames(2) 

      cont = cont + 1 
      Documents(strPath2).Activate 
      Selection.Text = arrNames(0) & vbCrLf 


      Selection.MoveDown Unit:=wdLine, Count:=1 
      Selection.Collapse wdCollapseEnd 


     Loop 
    End With 



    Documents(strPath2).Activate 
    ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges 
    Documents(strPath).Activate 

    If cont = 0 Then 
     pwdMails = False 
    Else 
     pwdMails = True 
    End If 

Und Mails.txt Datei folgendes enthalten:

mail@mail.com 
mail2@mail.com 
mail3@mail.com:word1:word2 
mail4@mail.com 
mail5@mail.com:word3:word4 

Die erste Zeile, die enthalten ":", Zeile 3 in Mails.txt , wurde gefunden, aber die zweite Zeile, Zeile 5 in Mails.txt, wurde nicht gefunden.

Warum passiert das? Wie kann ich es reparieren?

Answer 1

Hier ist eine Version, die die Datei über FileSystemObject liest und vermeidet, Selection zu verwenden. Bitte beachten Sie, dass ich Zeilen auskommentiert habe, die für mich nicht funktionieren (Stilnamen, benutzerdefinierte Funktionen). Außerdem: Sie wenden zwei Stile auf die Tabelle an, zuerst den einen und dann den anderen. Bitte wählen Sie einen aus.

;-)

Const ForReading = 1 
Dim arrNames 
Dim cont As Integer 
Dim fso, MyFile, FileName, TextLine, tblNew As Table, newRow As Row 

Set fso = CreateObject("Scripting.FileSystemObject") 

cont = 0 

If cont = 0 Then 

    'Call gestOSINT("Pwd") 

    'Selection.Find.Execute FindText:=("[Pwd]") 

    Set tblNew = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=1, NumColumns:= _ 
     3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _ 
     wdAutoFitFixed) 
    With tblNew 
'  If .Style <> "Tabla con cuadrícula" Then 
'   .Style = "Tabla con cuadrícula" 
'  End If 
     .ApplyStyleHeadingRows = True 
     .ApplyStyleLastRow = False 
     .ApplyStyleFirstColumn = True 
     .ApplyStyleLastColumn = False 
     .ApplyStyleRowBands = True 
     .ApplyStyleColumnBands = False 
'  .Style = "Tabla de lista 1 clara - Énfasis 1" 
    End With 

    With tblNew.Rows(1) 
     .Cells(1).Range.text = "Correo electrónico" 
     .Cells(2).Range.text = "Tipo de filtrado" 
     .Cells(3).Range.text = "Plataforma" 
    End With 
End If 

FileName = path & "Mails.txt" 

Set MyFile = fso.OpenTextFile(FileName, ForReading) 

Do While MyFile.AtEndOfStream <> True 
    TextLine = MyFile.ReadLine 
    If InStr(1, TextLine, ":") > 0 Then 
     arrNames = VBA.split(TextLine, ":") 
     Set rowNew = tblNew.Rows.Add 

     rowNew.Cells(1).Range.text = arrNames(0) 
     rowNew.Cells(2).Range.text = arrNames(1) 
     rowNew.Cells(3).Range.text = arrNames(2) 
    End If 
Loop 
MyFile.Close 

If cont = 0 Then 
    pwdMails = False 
Else 
    pwdMails = True 
End If