0

私のワークブックには5つの異なるシートがあり、5つのシートをコピーして、5つの異なるメールに貼り付ける必要があります。できればHTMLとして。

以下に記述されているコードは、Outlookに異なるシートを添付するだけです。メールの本文の下にHTMLが必要です。シートの範囲はワークブックごとに異なりますが、シート名は同じままであることに注意してください。

  Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
'BrowseForFolder was a code originally written by Ron De Bruin, I love this function!

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False

End Function

Sub SaveWorksheets()
'saves each worksheet as a separate file in a specific folder.
Dim ThisFolder As String
Dim NameOfFile As String
Dim Period As String
Dim RecipName As String

ThisFolder = BrowseForFolder()

Application.ScreenUpdating = False

Dim ws As Worksheet
Dim wsName As String
For Each ws In ActiveWorkbook.Worksheets
wsName = ws.Name

If wsName <> "Data" Then

Period = ws.Cells(4, 1).Value 'put the row and column numbers of the report date here.
RecipName = ws.Cells(1, 29).Value 'put the row and column numbers of the email address here
NameOfFile = ThisFolder & "\" & "Termination Report " & wsName & " " & Period & ".xlsx"

ws.Select
ws.Copy
ActiveWorkbook.SaveAs Filename:= _
NameOfFile, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Call EmailWorkbooks(RecipName, NameOfFile)
End If

Next ws
End Sub

Sub EmailWorkbooks(RecipName, NameOfFile)

Dim OutApp As Object
Dim OutMail As Object

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

Msg = "Attached is the xyz report for your review. Please let me know if you have any questions" & vbCrLf & vbCrLf _
& "Thanks," & vbCrLf & vbCrLf _
& "Your Name Here" & vbCrLf _
& "Your Title" & vbCrLf _
& "Your contact info"

Subj = "XYZ Report" & " " & Period

On Error Resume Next
With OutMail
.To = RecipName
'.CC =
.Subject = Subj
.Body = Msg
.Attachments.Add (NameOfFile)
.Save
End With
On Error GoTo 0

End Sub
4

1 に答える 1

0

U PublishObjects コレクションの Add メソッドを使用できます。短い例:

Sub InsertSheetContent()
  Dim onePublishObject As PublishObject
  Dim oneSheet As Worksheet
  Dim scriptingObject As Object
  Dim outlookApplication As Object
  Dim outlookMail As Object
  Dim htmlBody As String
  Dim htmlFile As String
  Dim textStream

  Set scriptingObject = CreateObject("Scripting.FileSystemObject")
  Set outlookApplication = CreateObject("Outlook.Application")

  For Each oneSheet In ThisWorkbook.Worksheets
    htmlFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name & "_" & oneSheet.Name & ".html"
    Set onePublishObject = ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
                                                            Filename:=htmlFile, _
                                                            Sheet:=oneSheet.Name, _
                                                            Source:=oneSheet.UsedRange.Address, _
                                                            HtmlType:=xlHtmlStatic, _
                                                            DivID:=oneSheet.Name)
    onePublishObject.Publish Create:=True

    Set textStream = scriptingObject.OpenTextFile(htmlFile)
    htmlBody = textStream.ReadAll

    Set outlookMail = outlookApplication.CreateItem(0)
    With outlookMail
        .htmlBody = htmlBody
        .Display
    End With
  Next oneSheet

End Sub
于 2012-12-07T08:15:13.950 に答える