Consulting

Results 1 to 2 of 2

Thread: add a second criteria to text extraction from documents macro

  1. #1

    Arrow add a second criteria to text extraction from documents macro

    good day experts,

    I have a word macro which goes into each document with a windows folder, grabs the email addresses in that folder, and then adds that email address to a list in a new document.

    I need it to do that ASWELL as include the filename from the document that email address was extracted from next to the email address after a coma

    the VB Code is attached: Please Help me.
    Attached Files Attached Files

  2. #2
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,725
    Location
    Welcome to the forum

    Please take a minute and read the FAQs at the link in my sig

    I didn't test, but it seems you could just add the marked line

    You could also include the macro in a docm file to upload



    Option Explicit
    
    
    Sub BatchProcess()
        Dim strFilename As String
        Dim strPath As String
        Dim oDoc As Document
        Dim oNewDoc As Document
        Dim oRng As Range
        Dim hLink As Hyperlink
        Dim fDialog As FileDialog
        
        Set oNewDoc = Documents.Add
        
        Options.AutoFormatReplaceHyperlinks = True
        
        Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
        With fDialog
            .Title = "Select folder containing the documents and click OK"
            .AllowMultiSelect = False
            .InitialView = msoFileDialogViewList
            If .Show <> -1 Then
                MsgBox "Cancelled By User", , _
                       "List Folder Contents"
                Exit Sub
            End If
            strPath = fDialog.SelectedItems.Item(1)
            If Right(strPath, 1) <> "\" _
               Then strPath = strPath + "\"
        End With
        
        If Left(strPath, 1) = Chr(34) Then
            strPath = Mid(strPath, 2, Len(strPath) - 2)
        End If
        
        strFilename = Dir$(strPath & "*.doc?")
        
        While Len(strFilename) <> 0
            WordBasic.DisableAutoMacros 1
            Set oDoc = Documents.Open(strPath & strFilename)
            oDoc.Range.AutoFormat
            For Each hLink In oDoc.Hyperlinks
                If InStr(1, hLink.Address, "@") Then
                    oNewDoc.Range.InsertAfter hLink.Range & ", " & strPath & strFilename & vbCr  '   ?????????????????????????
                End If
            Next hLink
            oDoc.Close SaveChanges:=wdDoNotSaveChanges
            WordBasic.DisableAutoMacros 0
            strFilename = Dir$()
        Wend
        
        oNewDoc.Paragraphs.Last.Range.Delete
        oNewDoc.Range.Sort
        oNewDoc.Range.Find.Execute FindText:="(*^13)@", _
                                   MatchWildcards:=True, _
                                   ReplaceWith:="\1", _
                                   Replace:=wdReplaceAll
    End Sub
    Attached Files Attached Files
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •