Ошибка кода VBA 400, когда я пытаюсь отправить Excel в Outlook - PullRequest
0 голосов
/ 25 февраля 2020

Поэтому, когда я попытался запустить этот код, чтобы отправить свой Excel и прикрепить pdf в outlook, я столкнулся с ошибкой 400. Не слишком уверен, что здесь что-то пошло не так, был бы признателен за некоторую помощь здесь. Спасибо

Включен мой код ниже:

Sub Send_Doc()
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Set Sourcewb = ActiveWorkbook
    'Copy the sheet to a new workbook
    Sheets("xxxx").Copy
    Set Destwb = ActiveWorkbook
    Range("A4:Z10").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Daily xxx"
    Range("A4:Z10").Select
    Selection.CopyPicture xlScreen, xlBitmap
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
        With Destwb
        .SaveAs TempFilePath & TempFileName & ".pdf"
        On Error Resume Next
        With OutMail
            .To = "xxxx@xxx.com; xxx2@xxx.com"
            .CC = "xxxx3@xxx.com; xxx4@xxx.com"
            .BCC = ""
            .Subject = "Daily xxx " & Format(Now(), "dd mmm yy")
            OutMail.GetInspector.WordEditor.Range.Paste
            .Attachments.Add Destwb.FullName
            .display
        End With
    'OutMail.display
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
    'Delete the file you have send
    'Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

1 Ответ

0 голосов
/ 25 февраля 2020

Я его отредактировал, кажется, работает, но может быть сокращено.

Sub SendFxPosition()

    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range

    Set Sourcewb = ActiveWorkbook

    'ADD THIS:
    ' Select range from B instead of A so that you can type Dear Sir.... in Cell A
    Sheets("SHEET1").Range("B4:U32").ExportAsFixedFormat Type:=xlTypePDF, _
      Filename:="C:\Users\xxx\Downloads\test\DOCUMENT1.pdf", _
       Quality:= xlQualityStandard, IncludeDocProperties:=True, _
       IgnorePrintAreas:=False, OpenAfterPublish:=False
    'END

    'Copy the sheet to a new workbook:
    ' Copy from A so that when you paste into outlook you will have Dear Sir....
    Sheets("SHEET1").Copy
    Set Destwb = ActiveWorkbook

    Range("A4:U32").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    'If Temp file doesn't work for you,
    ' you can use a designated folder like the one below
    TempFilePath = "C:\Users\xxxx\Downloads\test\"
    TempFileName = "DOCUMENT1"

    Range("A4:U32").Select
    Selection.Copy

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        OutMail.GetInspector.WordEditor.Range.PasteSpecial xlPasteValuesAndNumberFormats
    End With

    With Destwb
        .SaveAs TempFilePath & TempFileName & ".xls"
        On Error Resume Next
        With OutMail         
            .To = "xxxx@xxx.com; xxxx2@xxx.com"
            .CC = ""
            .BCC = ""
            .Subject = "Daily XXX " & Format(Now(), "dd mmm yy")

            OutMail.GetInspector.WordEditor.Range.Paste

            'ADD THIS
            DestwbPDF = "C:\Users\xxxx\Downloads\test\DOCUMENT1.pdf"
            .Attachments.Add DestwbPDF
            'END           

            .display
        End With

        'OutMail.display
         On Error GoTo 0
        .Close SaveChanges:=False
    End With

    'Delete the file you have send
    'Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...