Sub GetOutlookList()
Application.ScreenUpdating = False
Dim myOlApp As Object, myNameSpace As Object, myFolder As Object
Dim iA As Integer
Dim c As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNameSpace("MAPI") '涴岆嘐隅迡楊
'Set myFolder = myNameSpace.GetDefaultFolder(6)'Defauld--inbox
Set myFolder = myNameSpace.pickfolder '.Folders("xxxxxx").Folders("彶璃眊") '恁寁恅璃標弇离
ActiveCell.Offset(iA, 0) = "SenderName"
ActiveCell.Offset(iA, 1) = "Subject"
ActiveCell.Offset(iA, 2) = "ConverSationTopic"
ActiveCell.Offset(iA, 3) = "ReceivedTime"
ActiveCell.Offset(iA, 4) = "To"
ActiveCell.Offset(iA, 5) = "CC"
ActiveCell.Offset(iA, 6) = "Unread"
ActiveCell.Offset(iA, 7) = "Size"
ActiveCell.Offset(iA, 8) = "Attachments.Count"
For iA = 1 To myFolder.items.Count
Set c = myFolder.items(iA) '涴跺腔MailItemㄛ撈測桶珨猾萇赽蚘璃
On Error Resume Next
ActiveCell.Offset(iA, 0) = c.SenderName
ActiveCell.Offset(iA, 1) = c.Subject
ActiveCell.Offset(iA, 2) = c.ConverSationTopic
ActiveCell.Offset(iA, 3) = c.ReceivedTime
ActiveCell.Offset(iA, 4) = c.To
ActiveCell.Offset(iA, 5) = c.CC
ActiveCell.Offset(iA, 6) = c.Unread
ActiveCell.Offset(iA, 7) = c.Size
ActiveCell.Offset(iA, 8) = c.Attachments.Count
If Err <> 0 Then Debug.Print Err.Number & Err.Description: Err = 0
On Error GoTo 0
Next iA
Set myNameSpace = Nothing
Set myOlApp = Nothing
End Sub
Sub CreateOutlookEmail(strTo As String, strSubject As String, strBody As String, Optional strCC As String = "", Optional strBCC As String = "", _
Optional strPhotoPathName As String = "", Optional strAttachmentsPathName As String = "")
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.HTMLBody = "<Html><body><font size=""3"" face=""Times New Roman""></font></body></Html>"
If strPhotoPathName <> "" Then
On Error Resume Next
.Attachments.Add strPhotoPathName '婓蜇璃笢崝樓芞弇离
If Err <> 0 Then MsgBox Err.Description & vbCr & "More likely input an incorrect file path of Photo"
On Error GoTo 0
Dim arrA As Variant
Dim strPhotoName
arrA = Split(strPhotoPathName, "/")
strPhotoName = arrA(UBound(arrA))
.HTMLBody = "<img id=""_" & strPhotoPathName & """ src=""cid:""" & strPhotoName & """"">" '嗣"瘍岆斛剕腔.
End If
On Error Resume Next
If strAttachmentsPathName <> "" Then .Attachments.Add strAttachmentsPathName '氝樓蜇璃
If Err <> 0 Then MsgBox Err.Description & vbCr & "More likely input an incorrect file path of Attachments"
On Error GoTo 0
.To = strTo
.CC = strCC
.BCC = strBCC
.Subject = strSubject
.HTMLBody = strBody & "<br>" & .HTMLBody ' & RangetoHTML(rA)
.Display 'or .Send
End With
End Sub
Sub Try_CreateOutlookEmail()
Call CreateOutlookEmail("fwpfang@sina.cn", "SubjectA", "BodyA", , , "C:\Users\A8-5600K\Desktop\FWP\VBA_learn\Temp\u222.png", "C:\Users\A8-5600K\Desktop\FWP\VBA_learn\Temp\u222.png")
End Sub
Application.ScreenUpdating = False
Dim myOlApp As Object, myNameSpace As Object, myFolder As Object
Dim iA As Integer
Dim c As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNameSpace("MAPI") '涴岆嘐隅迡楊
'Set myFolder = myNameSpace.GetDefaultFolder(6)'Defauld--inbox
Set myFolder = myNameSpace.pickfolder '.Folders("xxxxxx").Folders("彶璃眊") '恁寁恅璃標弇离
ActiveCell.Offset(iA, 0) = "SenderName"
ActiveCell.Offset(iA, 1) = "Subject"
ActiveCell.Offset(iA, 2) = "ConverSationTopic"
ActiveCell.Offset(iA, 3) = "ReceivedTime"
ActiveCell.Offset(iA, 4) = "To"
ActiveCell.Offset(iA, 5) = "CC"
ActiveCell.Offset(iA, 6) = "Unread"
ActiveCell.Offset(iA, 7) = "Size"
ActiveCell.Offset(iA, 8) = "Attachments.Count"
For iA = 1 To myFolder.items.Count
Set c = myFolder.items(iA) '涴跺腔MailItemㄛ撈測桶珨猾萇赽蚘璃
On Error Resume Next
ActiveCell.Offset(iA, 0) = c.SenderName
ActiveCell.Offset(iA, 1) = c.Subject
ActiveCell.Offset(iA, 2) = c.ConverSationTopic
ActiveCell.Offset(iA, 3) = c.ReceivedTime
ActiveCell.Offset(iA, 4) = c.To
ActiveCell.Offset(iA, 5) = c.CC
ActiveCell.Offset(iA, 6) = c.Unread
ActiveCell.Offset(iA, 7) = c.Size
ActiveCell.Offset(iA, 8) = c.Attachments.Count
If Err <> 0 Then Debug.Print Err.Number & Err.Description: Err = 0
On Error GoTo 0
Next iA
Set myNameSpace = Nothing
Set myOlApp = Nothing
End Sub
Sub CreateOutlookEmail(strTo As String, strSubject As String, strBody As String, Optional strCC As String = "", Optional strBCC As String = "", _
Optional strPhotoPathName As String = "", Optional strAttachmentsPathName As String = "")
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.HTMLBody = "<Html><body><font size=""3"" face=""Times New Roman""></font></body></Html>"
If strPhotoPathName <> "" Then
On Error Resume Next
.Attachments.Add strPhotoPathName '婓蜇璃笢崝樓芞弇离
If Err <> 0 Then MsgBox Err.Description & vbCr & "More likely input an incorrect file path of Photo"
On Error GoTo 0
Dim arrA As Variant
Dim strPhotoName
arrA = Split(strPhotoPathName, "/")
strPhotoName = arrA(UBound(arrA))
.HTMLBody = "<img id=""_" & strPhotoPathName & """ src=""cid:""" & strPhotoName & """"">" '嗣"瘍岆斛剕腔.
End If
On Error Resume Next
If strAttachmentsPathName <> "" Then .Attachments.Add strAttachmentsPathName '氝樓蜇璃
If Err <> 0 Then MsgBox Err.Description & vbCr & "More likely input an incorrect file path of Attachments"
On Error GoTo 0
.To = strTo
.CC = strCC
.BCC = strBCC
.Subject = strSubject
.HTMLBody = strBody & "<br>" & .HTMLBody ' & RangetoHTML(rA)
.Display 'or .Send
End With
End Sub
Sub Try_CreateOutlookEmail()
Call CreateOutlookEmail("fwpfang@sina.cn", "SubjectA", "BodyA", , , "C:\Users\A8-5600K\Desktop\FWP\VBA_learn\Temp\u222.png", "C:\Users\A8-5600K\Desktop\FWP\VBA_learn\Temp\u222.png")
End Sub
