Membership card code

[philwinfield]

Hi have sheet that new members for a club are pasted into and then a PDF file is created from a Word template for the membership card and this is then attached to an email all automated from Excel & it saved a LOT of time!
It's stopped working and I am desperate to get it going again but have no idea what this means and I have done a fair bit of searching online:

Sub Send_emails()

Dim olApp As New Outlook.Application
Dim mItem As Outlook.MailItem  ' An Outlook Mail item
Dim msgBody As String
Set olApp = CreateObject("Outlook.Application")

On Error GoTo 0


lastRow = Range("A1").End(xlDown).Row

For r = 2 To lastRow  ' each row
      
      Debug.Print Range("E" & r)    ' email
      Debug.Print Range("A" & r)    ' membership number
      Debug.Print Range("D" & r)    ' classes
      Debug.Print Range("B" & r)     ' full name
      
      If Range("A" & r) = "" Then GoTo TheEnd
      
      Set mItem = olApp.CreateItemFromTemplate("C:\Users\philw\My Drive\Development\U3A\Membership Card Code\Welcome to Poole U3Av3.msg")   ' [COLOR=rgb(0, 168, 133)]This fails with a 58 the file is already there. What file? Can I find and delete it?[/COLOR]

 

[Michael M]

Do you get an error message ?
If not, try running it manually using F8 to step through each line and see where it stops working, then repost with ,more info.
Also, in future post ALL of the code, not just a part of it.

 

[philwinfield]

Thanks Michael,

Yes I get a file already exists message but that doesn't make any sense to me and remember this has worked for 18 months fine and saves so much time!

There are two procedures, one processes paid applications from members to create their membership cards.
A second then sends these as an attachment to each member with a welcome email.

The error is when the createItemFromTemplate method is called (search for #error here below)

Massive thanks if someone can help please

Phil

Sub Create_PDF_Files()
    Dim wApp As Word.Application
    Dim wDoc As Word.Document
    Set wApp = CreateObject("Word.Application")
    Dim filepath As String
    
    
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row ' all of column A
    For r = 2 To lastRow  ' each row
        
        If Range("A" & r) = "" Then GoTo TheEnd
        
        Set wDoc = wApp.Documents.Open("C:\Users\philw\My Drive\Development\U3A\Membership Card Code\LatestCardfor22-23v2c.doc")
        docName = Range("A" & r).Value
        wApp.Visible = True
        
        With wDoc
        
          'If .Application.Selection = Range("B" & r) = "E3104" Then
        
            .Application.Selection.Find.Text = "<<name>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Range("B" & r)
            .Application.Selection.EndOf
            
            .Application.Selection.Find.Text = "<<membernum>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Range("A" & r)
            .Application.Selection.EndOf
            
            .Application.Selection.Find.Text = "<<classes>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Range("D" & r)
            .Application.Selection.EndOf
                
            .SaveAs2 Filename:=("C:\Users\philw\My Drive\Development\U3A\Membership Card Code\PDFs\" + docName), _
            FileFormat:=wdFormatPDF, AddtoRecentFiles:=False
            
            wDoc.Close SaveChanges:=wdDoNotSaveChanges
        
          'End If
        
        End With
    Next

TheEnd:

    Debug.Print ("Done")

End Sub


Sub Send_emails()

Dim olApp As New Outlook.Application
Dim mItem As Outlook.MailItem  ' An Outlook Mail item
Dim msgBody As String
Set olApp = CreateObject("Outlook.Application")

On Error GoTo 0


lastRow = Range("A1").End(xlDown).Row

For r = 2 To lastRow  ' each row
       
      Debug.Print Range("E" & r)    ' email
      Debug.Print Range("A" & r)    ' membership number
      Debug.Print Range("D" & r)    ' classes
      Debug.Print Range("B" & r)     ' full name
      
      If Range("A" & r) = "" Then GoTo TheEnd
      
      Set mItem = olApp.CreateItemFromTemplate("C:\Users\philw\My Drive\Development\U3A\Membership Card Code\Welcome to Poole U3Av3.msg") '#error here
    
    
      
      msgBody = Replace(mItem.Body, "**member**", Range("C" & r), , , vbTextCompare)
      
      
      
      With mItem
      
       .Display
       .Attachments.Add "G:\My Drive\Development\U3A\Membership Card Code\PDFs\" & Range("A" & r) & ".pdf"
       .Attachments.Add "G:\My Drive\Development\U3A\Membership Card Code\2022 U3A Welcome Letter.pdf"
       .Body = msgBody
       .Subject = "Re: Poole U3A Application Form - " & Range("B" & r)   ' -- Re: Poole U3A Application Form - Jeff Morley
       .To = Range("E" & r) '"philwinfield@gmail.com" '
        
       .Send
      
      End With
      
TheEnd:
    
        Application.Wait (Now + TimeValue("0:00:01"))
        
        ' Release all object variables
        Set mItem = Nothing
        Set olApp = Nothing
    
  Next
   
   
Errors:
Set olApp = Nothing
Set mItem = Nothing

   
   
End Sub

 

[Michael M]

If the error occurs here, have you considered adding a number to the docname ??

 .SaveAs2 Filename:=("C:\Users\philw\My Drive\Development\U3A\Membership Card Code\PDFs\" + docName), _
            FileFormat:=wdFormatPDF, AddtoRecentFiles:=False

Maybe back here

docName = Range("A" & r).Value
docname = docname & "1"

 

[philwinfield]

If the error occurs here, have you considered adding a number to the docname ??

 .SaveAs2 Filename:=("C:\Users\philw\My Drive\Development\U3A\Membership Card Code\PDFs\" + docName), _
            FileFormat:=wdFormatPDF, AddtoRecentFiles:=False

Maybe back here

docName = Range("A" & r).Value
docname = docname & "1"

Please see the message above - the error is marked in the code with #error here