1

以下のマクロを使用して、Excelから電子メールを送信しています。電子メールの本文を処理するための「RonDeBruin」アプローチ(Function RangetoHTML(rng As Range))を含めました。ただし、関数の最後に実行時エラー( '438')が発生し、サブ(.html = rangeto html(rngtext))の次の行に移動します。コード内のすべてをチェックしましたが、必要な「Dim」などはすべて揃っていると思います。ご協力いただければ幸いです。

Sub Email_set_up()
Dim valdate As String
Dim oOApp As New Outlook.Application
Dim oOmail As Outlook.MailItem
Dim rng As Range, rngText As Range
Dim strbody As String
Dim SigString As String
Dim Signature As String
Set oOApp = CreateObject("Outlook.Application")
Set oOmail = oOApp.CreateItem(olMailItem)
valdate = Format(Sheets("E-Mail").Cells(4, 2), "mm/dd/yyyy")

SigString = Environ("appdata") & _
 "\Microsoft\Signatures\CK_Sign.txt"

If Dir(SigString) <> "" Then
    Signature = GetBoiler(SigString)
Else
    Signature = ""
End If

Set rngText = Sheets("E-Mail").Range("A18:A29")

Sheets("E-Mail").Activate
    With oOmail
        For Each c In Range(Sheets("E-Mail").Range("B6"), Sheets("E-Mail").Range("B9"))
            .Recipients.Add c
        Next
        .CC = Sheets("E-Mail").Range("B11")
        .Subject = Sheets("E-Mail").Range("B16") & valdate
        .HTML = RangetoHTML(rngText)
        .Display
    End With
End Sub

Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function

Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

With TempWB.PublishObjects.Add( _
     SourceType:=xlSourceRange, _
     Filename:=TempFile, _
     Sheet:=TempWB.Sheets(1).Name, _
     Source:=TempWB.Sheets(1).UsedRange.Address, _
     HtmlType:=xlHtmlStatic)
    .Publish (True)
End With

Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                      "align=left x:publishsource=")

TempWB.Close savechanges:=False

Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
4

1 に答える 1