vba -------------vba 导出word到pdf 发邮件

Posted 2020-09-26

Public Sub SendMail()
Dim objAccount As Object
Dim objApp As Object ‘Outlook.Application

‘ If Not CheckData Then
‘ Exit Sub
‘ End If
‘
‘ If MsgBox(shtMessage.Range("A1").Value, vbYesNo + vbExclamation) <> vbYes Then
‘ Exit Sub
‘ End If

Set objApp = GetObject("", "Outlook.Application")

If objApp.Session.accounts.Count > 1 Then
frmAccounts.Show vbModal
If Val(frmAccounts.lstAccounts.Tag) > 0 Then
Set objAccount = objApp.Session.accounts.Item(Val(frmAccounts.lstAccounts.Tag))
Else
Exit Sub
End If
Else
Set objAccount = objApp.Session.accounts.Item(1)
End If

Dim strPath As String
Dim objWB As Workbook

‘strPath = Environ$("TEMP") & "\test.xlsm"
‘ ThisWorkbook.SaveCopyAs strPath
Dim endRow
Dim rowindex As Integer



endRow = Sheet24.Range("a65536").End(xlUp).Row


MsgBox endRow


For rowindex = 1 To endRow

‘判断项目名称是否为空
If Sheet24.Cells(rowindex, 1) = "" Then
Exit For

End If

Dim objMailItem As Object ‘MailItem

Set objMailItem = objApp.CreateItem(0)

objMailItem.To = "[email protected]"
objMailItem.Cc = ""
objMailItem.Subject = "hello world"
objMailItem.Body = "this is a test mail"

objMailItem.Attachments.Add ExcelToWordToPdf(rowindex)

objMailItem.Display
‘objMailItem.Send

Next

‘ Dim objMailItem As Object ‘MailItem
‘
‘ Set objMailItem = objApp.CreateItem(0)
‘
‘ objMailItem.to = "[email protected]"
‘ objMailItem.Cc = ""
‘ objMailItem.Subject = "hello world"
‘ objMailItem.Body = "this is a test mail"
‘ ‘objMailItem.Attachments.Add strPath
‘
‘ objMailItem.Display
‘ ‘objMailItem.Send
‘
‘ MsgBox "Success!", vbInformation

End Sub

 

Sub TestFunc() ‘定义一个string类型的参数s

Dim s
s = "abc "
MsgBox Len(s)

MsgBox Application.ActiveWorkbook.path

‘ MsgBox ExcelToWordToPdf("我的文件") ‘返回一个字符串"返回值"
End Sub

 

 

Function ExcelToWordToPdf(rowindex As Integer)

Dim wdDoc, newPdfPath, currentPath, filename

currentPath = Application.ActiveWorkbook.path & "\"

newPdfPath = currentPath & "files\"

filename = Sheet24.Cells(rowindex, 1) & ".pdf"

Set wdDoc = CreateObject(currentPath & "template.docx") ‘打开word

wdDoc.Range.Find.Execute FindText:="{1}", ReplaceWith:="标题---test-replage", Replace:=1 ‘replace为1 替换一次，2替换所有
wdDoc.Range.Find.Execute FindText:="{2}", ReplaceWith:="test----2"


If Dir(newPdfPath) = "" Then

MkDir (newPdfPath)
End If


wdDoc.ExportAsFixedFormat newPdfPath & filename, 17 ‘ wdExportFormatPDF 是17


wdDoc.Close

Set wdDoc = Nothing
ExcelToWordToPdf = newPdfPath & filename


End Function