Как добавить условие If? - PullRequest
       2

Как добавить условие If?

0 голосов
/ 08 января 2020

Я создал программу для создания и отправки квитанций. Я справился с этим, посмотрев онлайн.

Это работает, но я бы хотел отправить квитанции, когда условие выполнено.

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

Должен ли я запускать If после создания файлов pdf или после создания объекта Outlook?

Я пробовал несколько вещей, но в большинстве моих попыток я получаю ошибку

Далее без For.

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
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...