mardi 7 janvier 2020

How to add if condition so programs only send receipts when condition is met?

I created a program to create and send receipts automatically at work instead of me sending them automatically. I'm not good at VBA and managed to create this looking aroung online. It works but I would like to add a condition in there that only sends the receipts when this condition is met

cfws.Range("N" & I).Value = "no"

I know it's a simple If but I just can't figure it out in VBA. I used to code in C++ and Java more than 15 years ago, that's why I can read the language but I don't know how to add the If here.

Do I start the If after I create the pdf files or after creating the outlook object? I'm lost. I tried several things but on most of my attempts, I get an error saying there's no For for my next.

Thank you for your help.

Option Explicit

Sub CopyToTemplate()

Dim cfws As Worksheet
Dim ctws As Worksheet
Dim lastrow As Long
Dim I As Long
Dim fileloc As String
Dim filename As String
Dim Fname As String
Dim OutlApp As Object
Dim IsCreated As Boolean
Dim Count As Integer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set cfws = Worksheets("Monthly data")
Set ctws = Worksheets("Template")

Count = 0

lastrow = cfws.Cells(cfws.Rows.Count, "B").End(xlUp).Row
fileloc = "C:\Users\dave.i\Documents\Project\Receipts\"

'This creates the receipt
For I = 2 To lastrow
    filename = "DCN #" & cfws.Range("A" & I).Value & " receipt"
    ctws.Range("C41").Value = "Sub ID " & cfws.Range("A" & I).Value
    ctws.Range("D14").Value = cfws.Range("B" & I).Value
    ctws.Range("C43").Value = cfws.Range("B" & I).Value
    ctws.Range("D13").Value = cfws.Range("C" & I).Value
    ctws.Range("C42").Value = cfws.Range("C" & I).Value
    ctws.Range("C44").Value = cfws.Range("D" & I).Value
    ctws.Range("C45").Value = cfws.Range("E" & I).Value
    ctws.Range("D15").Value = cfws.Range("D" & I).Value & ", " & cfws.Range("E" & I).Value
    ctws.Range("I45").Value = cfws.Range("F" & I).Value
    ctws.Range("I46").Value = cfws.Range("G" & I).Value
    ctws.Range("I47").Value = cfws.Range("H" & I).Value
    ctws.Range("C45").Value = cfws.Range("E" & I).Value
    ctws.Range("B51").Value = cfws.Range("I" & I).Value
    ctws.Range("H50").Value = cfws.Range("J" & I).Value
    ctws.Range("B56").Value = "Charged to " & cfws.Range("K" & I).Value & " on"
    ctws.Range("B57").Value = cfws.Range("L" & I).Value

'This names the receipt and creates it
    Fname = fileloc & filename & ".pdf"
    With ctws
        .ExportAsFixedFormat Type:=xlTypePDF, filename:=Fname

    End With

'Time to send the receipts
' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0


**'Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)

    ' Prepare e-mail
    .Subject = "Daily Commercial News receipt #" & cfws.Range("A" & I).Value
    .To = cfws.Range("M" & I).Value
    '.CC = "..." ' <-- Put email of 'copy to' recipient here
    .Body = "Hello," & vbLf & vbLf _
          & "Attached is the receipt for your monthly subscription." & vbLf & vbLf _
          & "Please do note hesitate to contact us should you have any other concerns." & vbLf & vbLf _
          & "Best Regards," & vbLf _
          & Application.UserName & vbLf _
          & "Customer Service representative" & vbLf _
          & vbLf & vbLf
    .Attachments.Add Fname

    ' Try to send
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail to " & cfws.Range("M" & I).Value & " was not sent", vbExclamation
    Else
      Count = Count + 1
    End If
    On Error GoTo 0**

End With

Next I

'Sends the number of emails sent
MsgBox Count & " E-mails successfully sent", vbInformation

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Aucun commentaire:

Enregistrer un commentaire