[RESOLVED] VB Macro to Email Current Page in Word

Hello All

I am trying to write a macro for MS Word that would:

Look at each page of a word doc and find an email address on that page then
Send the page as an attached file to the email address.

Why: I work for a small City in Florida and we have our time cards in Word format.
The Template we use each week is a Word Doc with a Excel sheet Object in it.

We use the template to do a mail merge every two weeks to create the new time cards.
Then we print them and send to the employees. About half of the city employees
Work with computers and would like to fill out the time card inside the word doc.

The hope is that the users will be able to fill out the time card and email it back to
the payroll people.

So I need your help.

I have found some code examples on the web to email a word doc to a fixed address.

What I need help with is:

Code that would loop thru each page of the word doc and collect the email address from that page
And then send only that page as an attachment to that email address. Then loop to the next page.

Or for you to let me know that this is not do-able.

Thanks for your Help

this is feasible, all you have to do is create a function that will search for email inside your document...this is not so complicated..

i don't think you can send the page alone you have to extract it and save it to another document and send it...

I have this much code so far.

Does anyone have code for saving the current page in word to a new Doc ?

Code to send the current Doc as email Attachment

Thanks

VB Code:

Sub ETimeCard()
'
' ETimeCard Macro
' Macro created 2/23/2006 
'
 
 
 
    Dim template As String
    Dim WordApp As Word.Application
    Dim WordDoc As Word.Document
    Dim WordTemp As Word.Document
    Set WordDoc = ActiveDocument
    Dim docPath As String
    Dim intTimes As Integer
    Dim strLetter As String
    Dim strUser As String
    Dim strStatus As String
    Dim docPageCount As Integer
    Dim msg1 As Integer
    Dim msg2 As String
    Dim EMAddress As String
   
   
    
    MaxPages = Selection.Information(wdNumberOfPagesInDocument)
    
        For i = 1 To MaxPages
            msg1 = i
            MsgBox msg1
        
            Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Count:=i, Name:=""
            ActiveDocument.Bookmarks("\page").Select
            
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            
            With Selection.Find
            .Text = "\[*\]"
            .Replacement.Text = ""
            .MatchWildcards = True
            .Forward = True
            .Wrap = wdFindStop
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .Forward = True
            End With
            
            Selection.Find.Execute '    Replace:=wdReplaceAll
            
            EMAddress = Mid$(Selection, 2, Len(Selection) - 2) & vbNewLine
            
            'If Selection.Words.Count <= 10 And _
                Selection.Type <> wdSelectionIP Then
            'MsgBox "The selection contains " & Selection.Words.Count _
                & " words."
            'End If
            
            
        'MsgBox EMAddress
        'Options.SendMailAttach = True
        'ActiveDocument.SendMail
 
        
        Next
 
End Sub

Here is the Final Code I worked out and the Time Card Doc

VB Code:

Sub ETimeCard()
'
' ETimeCard Macro
' Macro created 2/23/2006 by CH
'
'You must load the Outlook Library located under Tools - References in the Visual Basic Editor
'You must Create a Folder named "C:\Temp\Time Cards\" to store the Word Doc in (see code below)
'You will get a 5 sec delay for each Email, this is done by Outlook as Spam Protection
 
 
    Dim template As String
    Dim WordApp As Word.Application
    Dim WordDoc As Word.Document
    Dim WordTemp As Word.Document
    Set WordDoc = ActiveDocument
    Dim docPath As String
    Dim intTimes As Integer
    Dim strLetter As String
    Dim strUser As String
    Dim strStatus As String
    Dim docPageCount As Integer
    Dim msg1 As Integer
    Dim msg2 As String
    Dim EMAddress As String
    Dim BodyText As String
   
    
   
    Dim bStarted As Boolean
    Dim oOutlookApp As Outlook.Application
    Dim oItem As Outlook.MailItem
 
   
    
    MaxPages = Selection.Information(wdNumberOfPagesInDocument)
    
        For i = 1 To MaxPages
            'msg1 = i
            'MsgBox msg1
        
            Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Count:=i, Name:=""
            ActiveDocument.Bookmarks("\page").Select
                      
            '***********************************
            Selection.Copy
            Documents.Add template:= _
            "C:\Documents and Settings\cherbold.CNSB\Application Data\Microsoft\Templates\Normal.dot" _
            , NewTemplate:=False, DocumentType:=0
            Selection.Paste
            
            ActiveDocument.SaveAs ("C:\Temp\Time Cards\TimeCard.doc")
            ActiveDocument.Close
            
            '***********************************
                      
            
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            
            With Selection.Find
            .Text = "\[*\]"
            .Replacement.Text = ""
            .MatchWildcards = True
            .Forward = True
            .Wrap = wdFindStop
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .Forward = True
            End With
            
            Selection.Find.Execute '    Replace:=wdReplaceAll
            
            EMAddress = Mid$(Selection, 2, Len(Selection) - 2) & vbNewLine
            
            'If Selection.Words.Count <= 10 And _
                Selection.Type <> wdSelectionIP Then
            'MsgBox "The selection contains " & Selection.Words.Count _
                & " words."
            'End If
            
            
            'MsgBox EMAddress
          
       '*****************************************************
       
        'On Error Resume Next
  
        
        
        Set oOutlookApp = GetObject(, "Outlook.Application")
        If Err <> 0 Then
            Set oOutlookApp = CreateObject("Outlook.Application")
            bStarted = True
        End If
        
        Set oItem = oOutlookApp.CreateItem(olMailItem)
        
        With oItem
            .To = EMAddress
            .Subject = "Time Card"
        '.Body = "Your text Here"
            'Add the document as an attachment, you can use the .displayname property
            'to set the description that's used in the message
            'ActiveDocument.FullName , Type:=olByValue, _DisplayName:="Document as attachment"
            .Attachments.Add Source:="C:\Temp\Time Cards\TimeCard.doc"
            .Send
        End With
        
        
        
 
        '**********************************************************
       
       
 
        Next
 
Set oItem = Nothing
Set oOutlookApp = Nothing
End Sub