初心者の少しだけＶＢＡ 2018年8月30日 名前をつけてＰＤＦ and ｅｘｃｅｌファイル メール送信に作成ファイル削除

ＰＤＦ and ｅｘｃｅｌファイル　メール送信に作成ファイル削除

実用を考えれば送信履歴にファイルが残るので作成したファイルを削除したほうがいいのではないかということで作成したファイルは削除処理を最後に行っています。

残しておいてもいいけれどとりあえず。

Rangeの処理が大変でした。いろいろオブジェクトについて処理がもっと適切にできればいいと思いますが今回は大苦戦してしまったというのが正直なところです。

とりあえず勉強になりました。

個人ごとですが、昨晩脚をつってしまいかなりいたい感じで今います。

Sub mail and Outlook()

Application.ScreenUpdating = False

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\xxxxxx\" + Range("AM2") & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

  ActiveSheet.Copy

    Application.PrintCommunication = True

    ActiveSheet.PageSetup.PrintArea = "$A$1:$AN$166"

    Application.PrintCommunication = False

    With ActiveSheet.PageSetup

        .LeftHeader = ""

        .CenterHeader = ""

        .RightHeader = ""

        .LeftFooter = ""

        .CenterFooter = ""

        .RightFooter = ""

        .LeftMargin = Application.InchesToPoints(0)

        .RightMargin = Application.InchesToPoints(0)

        .TopMargin = Application.InchesToPoints(0.590551181102362)

        .BottomMargin = Application.InchesToPoints(0.196850393700787)

        .HeaderMargin = Application.InchesToPoints(0.393700787401575)

        .FooterMargin = Application.InchesToPoints(0.196850393700787)

        .PrintHeadings = False

        .PrintGridlines = False

        .PrintComments = xlPrintNoComments

        .PrintQuality = 600

        .CenterHorizontally = True

        .CenterVertically = True

        .Orientation = xlPortrait

        .Draft = False

        .PaperSize = xlPaperA3

        .FirstPageNumber = xlAutomatic

        .Order = xlDownThenOver

        .BlackAndWhite = False

        .Zoom = False

        .FitToPagesWide = 1

        .FitToPagesTall = 1

        .PrintErrors = xlPrintErrorsDisplayed

        .OddAndEvenPagesHeaderFooter = False

        .DifferentFirstPageHeaderFooter = False

        .ScaleWithDocHeaderFooter = True

        .AlignMarginsHeaderFooter = False

        .EvenPage.LeftHeader.Text = ""

        .EvenPage.CenterHeader.Text = ""

        .EvenPage.RightHeader.Text = ""

        .EvenPage.LeftFooter.Text = ""

        .EvenPage.CenterFooter.Text = ""

        .EvenPage.RightFooter.Text = ""

        .FirstPage.LeftHeader.Text = ""

        .FirstPage.CenterHeader.Text = ""

        .FirstPage.RightHeader.Text = ""

        .FirstPage.LeftFooter.Text = ""

        .FirstPage.CenterFooter.Text = ""

        .FirstPage.RightFooter.Text = ""

    End With

    Application.PrintCommunication = True

ActiveSheet.Name = "yyyyy" & Range("AM2")

ActiveWorkbook.SaveAs Filename:="C:\xxxxxx\" + Range("AM2").Value _

        , FileFormat:=xlWorkbookDefault _

         , Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _

         CreateBackup:=False

Dim toaddress, ccaddress, bccaddress As String

Dim subject, mailBody, credit As String '

Dim outlookObj As Outlook.Application

Dim mailItemObj As Outlook.mailItem

Dim SavDir As String

Dim hidut As String

Application.ScreenUpdating = False

SavDir = "C:\xxxxxx\"

hidut = Range("AM2")

toaddress = "eee.dddddd@serew.com"

subject = Range("B2")

mailBody = Range("B2") & "ooooooooo。" & vbCrLf & "qqqqqqqq"

Set outlookObj = CreateObject("Outlook.Application")

Set mailItemObj = outlookObj.CreateItem(olMailItem)

mailItemObj.BodyFormat = 3

mailItemObj.To = toaddress

mailItemObj.cc = ccaddress

mailItemObj.BCC = bccaddress

mailItemObj.subject = subject

mailItemObj.Body = mailBody & vbCrLf & credit

Dim attached, attached2 As String

Dim myattachments As Outlook.Attachments

Set myattachments = mailItemObj.Attachments

attached = SavDir & hidut & ".pdf"

attached2 = SavDir & hidut & ".xlsx"

myattachments.Add attached

myattachments.Add attached2

'mailItemObj.Save

mailItemObj.Display

'mailItemObj.Send

Set outlookObj = Nothing

Set mailItemObj = Nothing

    ActiveWorkbook.Close

Kill SavDir & hidut & ".pdf"

Kill SavDir & hidut & ".xlsx"

Application.ScreenUpdating = True

ActiveWorkbook.Close

End Sub