내 워드 매크로에서 두 번째 단어를 찾지 못했습니다.

Question

":"문자가있는 행이 있으면 txt 파일 내부에서 찾기 위해 Microsoft Word에서 VBA 스크립트를 만들려고합니다. 이것이 사실이라면, 나는이 줄을 쪼개서이 정보를 주 파일에있는 테이블에 삽입하고 싶다. 이 objetive 위해, 나는이 정보를 얻으려면 모두 라인을 통해 가고 싶습니다.

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

포함하는 첫 번째 줄 ":"3 호선을 Mails.txt에

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 

그리고 Mails.txt 파일은 다음을 포함 :이를 위해

,이 코드가 , 찾을 수 있지만 두 번째 줄, Mails.txt 5 번째 줄을 찾을 수 없습니다.

왜 이런 현상이 발생합니까? 어떻게 해결할 수 있습니까?

Answer 1

FileSystemObject를 통해 파일을 읽고 Selection을 사용하지 않는 버전입니다. 내가 나를 위해 작동하지 않는 라인 (스타일 이름, 사용자 정의 함수)을 주석 처리했다는 점에 유의하십시오. 또한 두 가지 스타일을 테이블에 적용합니다. 처음에는 다른 스타일을 적용합니다. 하나 골라주세요. 당신이 다음 찾기를 실행하기 전에 ;-)

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