Help with VBA EMAIL - Subject line won't change

[diabloxx]

I have a macro that a number of people here have helped me with over the last few months, I have been able to adapt it to many different scenarios but this one.

Basically the code will open a directory, loop through and create an email for each spreadsheet found. what I'd like to do is have the subject line change to the value of cell "S2" in each spreadsheet. the problem I have is it only opens the first spreadsheet and all subsequent emails have the same subject line.


I’m attaching the code below. I can't imagine it being difficult change, I just don't know where I’m going wrong.

Thanks In Advance!

James</SPAN></SPAN>

Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function
Sub EXPIRED_EMAIL()
    
        Dim OutApp As Object
        Dim OutMail As Object
        Dim strMyFolder As String
        Dim strFile As String
        Dim strBody As String
        Dim strSubject As String
        Dim SigString As String
        Dim Signature As String
        Dim MyDate As String
        Dim MyDay As String
        Dim MyMonth As String
        Dim MyYear As String
        Dim Phone As String
        
         MyYear = Year(Date)
         MyMonth = Month(Date)
         If Month(Date) < 10 Then LastMonth = "0" & Month(Date)
         MyDay = Day(Date)
         If Day(Date) < 10 Then MyDay = "0" & Day(Date)
         MyDate = MyYear & "-" & MyMonth & "-" & MyDay
         
        
     
        
        
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Please select a folder..."
            .InitialFileName = Application.DefaultFilePath & "\" 'change the default folder accordingly
            .Show
            If .SelectedItems.Count > 0 Then
                strMyFolder = .SelectedItems(1) & "\"
            Else
                Exit Sub
            End If
        End With
        
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
        
        Set OutApp = CreateObject("Outlook.Application")
        
        SigString = "C:\Documents and Settings\" & Environ("username") & _
            "\Application Data\Microsoft\Signatures\MySig.HTM" 'Change the filename for the signature accordingly
        
        If Dir(SigString) <> "" Then
                Signature = GetBoiler(SigString)
        End If
        
    
    'SigString = "C:\Users\" & Environ("username") & _
     "\AppData\Roaming\Microsoft\Signatures\James.txt"
     
        If Signature <> "" Then
            Phone = Mid(Signature, InStr(1, Signature, "651"), 12)
        End If
        
        strBody = "If this item expires please segregate it to ensure there is no chance of implanting after UBD by you or any colleagues." & "<br><br>" & _
                  "Thank you!"
        strFile = ""
        strFile = Dir(strMyFolder & "*.xlsx") 'change the file extension acccordingly
        
        
        Do While Len(strFile) > 0
        
            Set OutMail = OutApp.CreateItem(0)
            
            'strSubject = Mid(strFile, 1, InStr(1, strFile, ".") - 1)
          
         
            On Error Resume Next
            With OutMail
                .SentOnBehalfOfName = ""
                .To
                .CC = ""
                .BCC = ""
                .Subject = Sheets(1).Range("s2").Value
                .HTMLBody = strBody & vbNewLine & vbNewLine
                '.Attachments.Add strMyFolder & strFile
                .Display
                '.Send
            End With
            On Error GoTo 0
            
            strFile = Dir
            
        Loop
     
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
     
        Set OutMail = Nothing
        Set OutApp = Nothing
        
    End Sub

 

[montecarlo2079]

try changing the sheet name reference to Sheets(sheet1).range("s2").value


With OutMail
.SentOnBehalfOfName = ""
.To
.CC = ""
.BCC = ""
.Subject = Sheets(1).Range("s2").Value
.HTMLBody = strBody & vbNewLine & vbNewLine
'.Attachments.Add strMyFolder & strFile
.Display
'.Send
End With
On Error GoTo 0

strFile = Dir

Loop

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

[/CODE][/QUOTE]

 

[diabloxx]

i found out that the issue i was having was that i needed to have the code actually OPEN the workbook first, then i was able to extract the cel data and paste it into the email, then the code closed the workbook.

Thanks for your effort and time, i really appreciate that there is a forum like this where people are willing to help one another!

James