copy line from body of email to subject line

do mail merge, what the problem with that?
check the steps here http://www.statelibraryofiowa.org/ld/q-s/silo/e-mail/outlook/email-merge

in your database file, a olumn should be set for person, another column for his program. then in mail merge spesify in subjet <<program-name>> and in the message: dear <<person>>

How are the emails currently being sent?

In the VBS that adds the attachment, have you tried adjusting the subject there?  Not sure if that is allowed but since you are already updating the outgoing email there before it sends I would give it a try, the additional VBS code would be just a line or two.

---

»bp

Bill,
I don't know how do adjust the VBS - that is what I am hoping to to get some assistance with.   The program name is in the same spot on each email and it is the only thing on that line.  Looks like this

"Calvin
We have taken a look at you design for the

Transmorger

and we have decided that it is too dangerous for mass production.  Please cease all work.

Sincerely,
Acme Industries"

So I  want to get the line with the name of the program  (Transmorger) in the subject line

Thanks

Share the VBA that does the attachment and we can make suggestions on how to add this.

---

»bp

here it is:::


SubOutlookMailMergeAttachment

Sub SubOutlookMailMergeAttachment            
      ' Script version
      strProgamName = "Outlook Mail Merge Attachment (v1.1.9 Beta)"
      strProgamVersion = "Outlook Mail Merge Attachment (v1.1.9 Beta)"      
      
      ' Set manual line-breaks in message box texts for windoes versions < 6.
      strBoxCr = vbCrLf
      On Error Resume Next
      Set SystemSet = GetObject("winmgmts:").InstancesOf ("Win32_OperatingSystem")       
      For each System in SystemSet                         
            If System.Version >= 6 Then            
                  strBoxCr = ""
            End If
            sWindowsVersion = System.Caption
      Next
      On Error Goto 0
            
      ' Welcome dialog
      strDialog = "This script adds an attachment to all the emails that are currently in the Microsoft Office Outlook outbox. " & strBoxCr & _
          "The script is tested with Microsoft Outlook 2003, 2007, 2010 and 2013." & vbCrLf & _
            "" & vbCrLf & _
            "Usage:" & vbCrLf & _
            "1.  Create your mail merge and be sure the messages are kept in the outbox (Work Offline)." & vbCrLf & _
            "2.  Execute (Double-Click) 'Outlook Mail Merge Attachment.vbs',"  & vbCrLf & _
            "2a.  select the attachment(s)," & vbCrLf & _
            "2b.  the scripts now adds the selected file to all the emails in the outbox." & vbCrLf & _
            "3.   Send the emails by working Online." & vbCrLf & _
            "" & vbCrLf & _                  
            "The emails are send by passing keystrokes. Please do not touch the keyboard or mouse while in " & strBoxCr & _
            "process." & vbCrLf & _            
            "" & vbCrLf & _
            "Do you want to continiue?" & vbCrLf & _            
            "" & vbCrLf & _            
            "" & vbCrLf & _
          "http://omma.sourceforge.net" & vbCrLf & _      
          "westerveld@users.sourceforge.net" & vbCrLf & _                  
            "" & vbCrLf & _                  
            "Copyright (C) 2006-2013 Wouter Westerveld" & vbCrLf & _
            "This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without "  & strBoxCr & _
            "even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the "  & strBoxCr & _
            "GNU General Public License for more details."

      '''''''''''''''''''''''''''''''''''''''''''''''
      ' Initialize, load objects, check
      '''''''''''''''''''''''''''''''''''''''''''''''

    If MsgBox(strDialog, vbOKCancel + vbInformation, strProgamName) = vbCancel Then
        ' fout  
          Exit Sub                  
    End If    
       
    ' Outlook and Word Constants
    intFolderOutbox = 4
    msoFileDialogOpen = 1
   
   
    ' Load requied objects
    Set WshShell = WScript.CreateObject("WScript.Shell")      ' Windows Shell
    Set ObjWord = CreateObject("Word.Application")      ' File Open dialog    
    Set ObjOlApp = CreateObject("Outlook.Application")      ' Outlook
    Set ns = ObjOlApp.GetNamespace("MAPI")                  ' Outlook
    Set box = ns.GetDefaultFolder(intFolderOutbox)          ' Outlook                           
         
    ' Check if we can detect problems in the outlook configuration
    sProblems = ""   
    sBuild = Left(ObjOlApp.Version, InStr(1, ObjOlApp.Version, ".") + 1)
   
    ' check spelling check just before sending
    On Error Resume Next
    r = WshShell.RegRead("HKCU\Software\Microsoft\Office\" & sBuild & "\Outlook\Options\Spelling\Check")    
    If Not(Err) And (r = 1) Then
          sProblems = sProblems & _          
          "Your Outlook spell check is configured such that it gives a pop-up box when sending emails. Please disable " & strBoxCr & _
          "the 'Always check spelling before sending' option in your Outlook. (ErrorCode = 101)" & vbCrLf &vbCrLf
    End If
    On Error Goto 0
   
      ' For outlook 2000, 2002, 2003
      If sBuild = "9.0" Or sBuild = "10.0" Or sBuild = "11.0" Then
      
          ' Check for word as email editor.
          On Error Resume Next
            intEditorPrefs = WshShell.RegRead("HKCU\Software\Microsoft\Office\" & sBuild & "\Outlook\Options\Mail\EditorPreference")            
            If Not(Err) Then
                  If intEditorPrefs = 131073 Or intEditorPrefs = 196609 Or intEditorPrefs = 65537 Then
                        ' HTML = 131072, HTML & Word To Edit = 131073, Rich Text = 196610, Rich Text & Word To Edit = 196609, Plain Text = 65536, Plain Text & Word To Edit = 65537                  
                        sProblems = sProblems & _                  
                        "Your Outlook is configured to use Word as email editor. Please change this to the internal outlook editor in " & strBoxCr & _
                        "your outlook settings. (ErrorCode = 102)" & vbCrLf &vbCrLf                        
                  End If
            End If            
            On Error Goto 0
      End If

      If sProblems <> "" Then                            
            sProblems = "The OMMA script detected settings in your Outlook settings that need to be changed for the software to work." & vbCrLf & vbCrLf & sProblems
            MsgBox       sProblems, vbExclamation, strProgamName                  
            'fout
            Exit Sub
      End If

       
    ' Check if there are messages
    If box.Items.Count = 0 Then
        MsgBox "There are no messages in the Outbox.", vbExclamation, strProgamName          
             ' fout
       Exit Sub
    End If
   
    ' Give a warning if there already is an attachment
    If box.Items(1).Attachments.Count > 0 Then
        If MsgBox("The first email in your outbox has already " & box.Items(1).Attachments.Count & " attachment(s). Do you want to continue?", vbOKCancel + vbQuestion, strProgamName) = vbCancel Then
            ' fout  
                Exit Sub            
        End If
    End If
       
   
       
    '''''''''''''''''''''''''''''''''''''''''''''''
    ' Ask user for Filenames, add atachment, and
    ' Add attachment and save email
    '''''''''''''''''''''''''''''''''''''''''''''''    
       
       
    ' Ask user to open a file
    ' Select the attachment filename
   
      ObjWord.ChangeFileOpenDirectory(CreateObject("Wscript.Shell").SpecialFolders("Desktop"))      
      ObjWord.FileDialog(msoFileDialogOpen).Title = "Attach file(s)..."
      ObjWord.FileDialog(msoFileDialogOpen).AllowMultiSelect = True
      
      
      okEscape = False      
      If ObjWord.FileDialog(1).Show = -1 Then
            If ObjWord.FileDialog(1).SelectedItems.Count > 0 Then            
                  okEscape = True
            End If
      End If
      
      If Not okEscape Then
            ObjWord.Quit
            MsgBox "Cancel was pressed, no attachments where added.", vbExclamation, strProgamName
            Exit Sub         
      End If
      
    WScript.Sleep(800)              
       
    ' Add the attachment to each email
    For Each Item In box.Items        
          For Each objFile in ObjWord.FileDialog(1).SelectedItems
              Item.Attachments.Add(objFile)  
        Next            
        Item.Save
    Next

      ObjWord.Quit
       
       '''''''''''''''''''''''''''''''''''''''''''''''
       ' Send the emails using keystrokes
       '''''''''''''''''''''''''''''''''''''''''''''''
       
    For i = 1 to box.Items.Count
       
        ' Wait 5 extra seconds after 50 emails
        If (i Mod 50) = 0 Then
                WScript.Sleep(5000)          
        End If
       
        ' Open email
        Set objItem = box.Items(i)
            Set objInspector = objItem.GetInspector
            objInspector.Activate            
            WshShell.AppActivate(objInspector.Caption)            
            objInspector.Activate
      
            ' wait upto 10 seconds until the window has focus            
            okEscape = False
            For j = 1 To 100
                  WScript.Sleep(100)
                  If (objInspector Is ObjOlApp.ActiveWindow) Then
                        okEscape = True
                        Exit For
                  End      If
            Next
            If Not(okEscape) Then                                      
              MsgBox "Internal error while opening email in outbox. Please read the how-to and the troubleshooting sections in the " & strBoxCr & "documentation. (ErrorCode = 103)", vbError, strProgamName
             ' fout
             Exit Sub                  
            End If
            
            ' send te email by typing ALT+S
            WshShell.SendKeys("%S")
                                    
            ' wait upto 10 seconds for the sending to complete
            okEscape = False
            For j = 1 To 100
                  WScript.Sleep(100)
                  boolSent = False
                  On Error Resume Next
                  boolSent = objItem.Sent
                  If Err Then
                        boolSent = True
                  End      If
                  On Error Goto 0
                  If boolSent Then
                        okEscape = True
                        Exit For
                  End      If
            Next                                    
            If Not(okEscape) Then                              
                  ' Error                         
              MsgBox "Internal error while sending email. Perhaps the email window was not activated. Please read the how-to and " & strBoxCr & "the troubleshooting sections in the documentation. (ErrorCode = 104)", vbExclamation, strProgamName
             ' fout
             Exit Sub                                    
            End If
            
            
      
    Next
 
    ' Finished    
    strDialog = "Successfully added the attachment to " & box.Items.Count & " emails." & vbCrLf & vbCrLf & _          
          "OMMA is free software, please let the author know whether OMMA worked properly. " &strBoxCr & _
          "Did you already fill the feedback form?" & vbCrLf & vbCrLf & _
          "Answer 'No' will open the feedback form in your browser."  & vbCrLf & _  
          "Answer 'Yes' just exit the script."
          
    If MsgBox(strDialog, vbYesNo + vbInformation, strProgamName) = vbNo Then
            WshShell.Run "http://omma.sourceforge.net/feedback.php?worksok=yes&verOmma=" & escape(strProgamVersion) & "&verWindows=" & escape(sWindowsVersion) & "&verOutlook=" & escape(sBuild)
    End If        
   
End Sub