切换发件人收件箱 [英] Switching the FROM Inbox
本文介绍了切换发件人收件箱的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我目前使用的代码可以生成包含收件人、抄送、密件抄送等特定字段的电子邮件，但我不确定如何切换发件人"选项.电子邮件的一部分.
I currently use a code that generates an email fine with certain fields like To, CC, BCC, but I am not sure how to switch the "FROM" part of the email automatically.
我的电子邮件在这里，但我想自动切换到另一个收件箱，
Ie my email is here, but I want to automatically switch to another inbox,
我可以在通过下拉菜单生成电子邮件时手动执行此操作，但我想知道是否有方法可以自动执行此操作.我尝试将 .From 添加到此现有代码中，但不起作用.
I can do it manually when the email is generated via the drop down, but I am wondering if there are ways to do this automatically. I Tried adding .From to this existing code but does not work.
以下是相关的代码片段:
Here are the relevant snippets of code:
Dim OLook As Object, Mitem As Object, OlAttachment As Object
Dim fso As Object
Dim remail As Range
Dim acc As Object
Set Mitem = OLook.CreateItem(0)
With Mitem
'send to:
.To = send_list
'send from:
'.From = from_list
'cc to:
.CC = cc_list
'bcc to:
.BCC = bcc_list
.From = from_list 不是受支持的属性.
有谁知道如何更改此代码以添加From"?参数正确吗?
Does anyone know how to alter this code to add the "From" parameter correctly?
完整代码
Sub Create_Email()
' Creates e-mail to send
Application.ScreenUpdating = False
Sheets("Emails Management").Select
ActiveSheet.Calculate
top_line_emails = 2 'hardcoded to row 2
max_row_emails = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row - 1 'last row
ref_title_line = Application.WorksheetFunction.Match("Email Name", Columns(1), False) 'gets title row
indexActive = Application.WorksheetFunction.Match("Active", Rows(ref_title_line), False)
indexType = Application.WorksheetFunction.Match("Type", Rows(ref_title_line), False)
indexEmailName = Application.WorksheetFunction.Match("Email Name", Rows(ref_title_line), False)
indexsubject = Application.WorksheetFunction.Match("Subject", Rows(ref_title_line), False)
indexfiles = Application.WorksheetFunction.Match("Attachments", Rows(ref_title_line), False)
indexSendTo = Application.WorksheetFunction.Match("Send To", Rows(ref_title_line), False)
indexSendFrom = Application.WorksheetFunction.Match("Send From", Rows(ref_title_line), False)
indexCC = Application.WorksheetFunction.Match("CCed", Rows(ref_title_line), False)
indexBCC = Application.WorksheetFunction.Match("BCCed", Rows(ref_title_line), False)
indexGreetings = Application.WorksheetFunction.Match("Greetings", Rows(ref_title_line), False)
indexBody = Application.WorksheetFunction.Match("Body Text", Rows(ref_title_line), False)
indexSignature = Application.WorksheetFunction.Match("Signature", Rows(ref_title_line), False)
Dim OLook As Object, Mitem As Object, OlAttachment As Object
Dim fso As Object
Dim remail As Range
Dim acc As Object
Dim oMail As Object
Set fso = CreateObject("Scripting.FileSystemObject")
user_name = Environ("Username")
ref_row = top_line_emails 'hardcoded for row 2
'finds the reports that were generated
Do While ref_row <= max_row_emails
Set OLook = CreateObject("Outlook.Application")
Set Mitem = OLook.CreateItem(0)
Set OlAttachment = Mitem.attachments
send_list = ""
from_list = ""
cc_list = ""
bcc_list = ""
attach_name = ""
whole_text = ""
Body_text = ""
If Range(ColumnNumberToLetter(indexEmailName) & ref_row).Value = "" Then 'looping down the rows, if it is blank stop generating emails.
Exit Do
End If
go_for_it = True
If go_for_it = True Then
file_name = Range(ColumnNumberToLetter(indexfiles) & ref_row).Value
send_list = Range(ColumnNumberToLetter(indexSendTo) & ref_row)
from_list = Range(ColumnNumberToLetter(indexSendFrom) & ref_row)
cc_list = Range(ColumnNumberToLetter(indexCC) & ref_row)
bcc_list = Range(ColumnNumberToLetter(indexBCC) & ref_row)
Signature = Range(ColumnNumberToLetter(indexSignature) & ref_row).Value
attachment = Range(ColumnNumberToLetter(indexfiles) & ref_row).Value 'not attaching
'On Error GoTo no_email, Gets the text of the Email
Set remail = Sheets("Emails Management").Range(ColumnNumberToLetter(indexGreetings) & ref_row)
'This section gets the text part of the email.
If remail = "" Then
greetings_text = ""
Else
greetings_text = RangetoHTML2(remail)
greetings_text = get_date_cnv(greetings_text, ref_date_email)
End If
'Body text , Meant for charts
If Range(ColumnNumberToLetter(indexBody) & ref_row).Value <> "" Then
body_full_text = Range(ColumnNumberToLetter(indexBody) & ref_row).Value
'count the number of < in the body text
graphic_count = Len(body_full_text) - Len(Replace(body_full_text, "<", ""))
For Count = 1 To graphic_count
'search the start and end of the graphic range
body_start_search = InStr(1, body_full_text, "<")
body_end_search = InStr(1, body_full_text, ">")
'if there are <> then go for it
If body_start_search <> 0 And body_end_search <> 0 Then
'isolate the text in the <>
graphic_area = RTrim(LTrim(Mid(Left(body_full_text, body_end_search), body_start_search)))
'make sure the <> is not a <br> (line break)
If graphic_area <> "" And graphic_area <> "<br>" Then
'body_text = body_text & Left(body_full_text, body_start_search - 1)
graphic_area = Replace(Replace(graphic_area, "<", ""), ">", "")
'pull out the graphic type
graphic_type_search = InStr(1, graphic_area, ",")
graphic_type = Left(graphic_area, graphic_type_search - 1)
graphic_area = RTrim(LTrim(Right(graphic_area, Len(graphic_area) - graphic_type_search)))
'pull out the tab name
graphic_tab_search = InStr(1, graphic_area, ",")
graphic_tab = Left(graphic_area, graphic_tab_search - 1)
'pull out the graphic area
graphic_rng = RTrim(LTrim(Right(graphic_area, Len(graphic_area) - graphic_tab_search)))
Select Case LCase(graphic_type)
Case "chart"
Body_text = Body_text & "<br>" & RangetoHTML(Sheets(graphic_tab).Range(graphic_rng))
Case "text"
Body_text = Body_text & "<br>" & RangetoHTML2(Sheets(graphic_tab).Range(graphic_rng))
'Need to put graph part here
End Select
If Len(body_full_text) = body_end_search Then
Exit For
End If
body_full_text = Right(body_full_text, Len(body_full_text) - body_end_search - 1)
Else
If IsEmpty(Body_text) Then
Body_text = Left(body_full_text, body_start_search - 1)
Else
If Len(body_full_text) = body_end_search Then
Exit For
End If
Body_text = Body_text & "<br>" & Left(body_full_text, body_start_search - 1)
End If
If Len(body_full_text) = body_end_search Then
Exit For
End If
body_full_text = Right(body_full_text, Len(body_full_text) - body_end_search - 1)
End If
Else
Body_text = Body_text & body_full_text & "<br>"
End If
Next Count
Body_text = Body_text & "<br>" & body_full_text
End If
Set remail = Sheets("Emails Management").Range(ColumnNumberToLetter(indexBody) & ref_row)
'signature
Set remail = Sheets("Emails Management").Range(ColumnNumberToLetter(indexSignature) & ref_row)
end_text = RangetoHTML2(remail)
'creates the whole text in email
whole_text = greetings_text & "<br>" & Body_text & "<br>" & "<br>" & end_text
'create email, but does not send
Set Mitem = OLook.CreateItem(0)
With Mitem
.SendUsingAccount = GetAccountOf("email@blah.com", OLook)
.Display
'send to:
.To = send_list
'cc to:
.CC = cc_list
'bcc to:
.BCC = bcc_list
'attaching files
On Error GoTo resume_here
If Range(ColumnNumberToLetter(indexfiles) & ref_row).Value <> "" Then
file_name = Sheets("Emails Management").Range(ColumnNumberToLetter(indexfiles) & ref_row).Value
file_count = Len(file_name) - Len(Replace(file_name, ";", "")) + 1
For Count = 1 To file_count
file_search = InStr(1, file_name, ";")
If file_search = 0 Then
attach_name = RTrim(LTrim(file_name))
Else
attach_name = RTrim(LTrim(Left(file_name, file_search - 1)))
End If
ref_date = Sheets("Start").Range("D2").Value
attach_name = get_date_cnv(attach_name, ref_date)
file_name = Right(file_name, Len(file_name) - file_search)
file_name = get_date_cnv(file_name, ref_date_email)
.attachments.Add attach_name
Next Count
End If
resume_here:
'email subject
.Subject = get_date_cnv(Range(ColumnNumberToLetter(indexsubject) & ref_row).Value, ref_date_email)
'email body
.HTMLBody = whole_text
'.HTMLBody = graphic_desc
'check names in outlook
.Recipients.ResolveAll
'display email
'.Display
'save as draft
.Save
'.Send
Application.ScreenUpdating = True
Application.ScreenUpdating = False
End With
DoEvents
End If
ref_row = ref_row + 1
Loop
Set fso = Nothing
Set OLook = Nothing
Set Mitem = Nothing
Set OlAttachment = Nothing
Exit Sub
no_email:
MsgBox ("Error creating emails: " & Err.Description)
Set fso = Nothing
Set OLook = Nothing
Set Mitem = Nothing
Set OlAttachment = Nothing
Exit Sub
End Sub
推荐答案
试试这个功能
Function GetAccountOf(sEmailAddress As String, ByRef OLook As Object) As Object
Dim oAccount As Object
Set GetAccountOf = Nothing
For Each oAccount In OLook.Session.Accounts
If oAccount = sEmailAddress Then
Set GetAccountOf = oAccount
Exit Function
End If
Next oAccount
End Function
然后您可以将 .From 行替换为:
You can then replace the .From line with:
.SendUsingAccount = GetAccountOf("emailaddress@somewhere.com", OLook)
以下评论的跟进:
如果上述方法不起作用，那么我怀疑您的前景有问题导致了这种情况.你需要想办法/问题来帮助确定问题，比如
If the above doesn't work then I suspect there's something with your outlook that is causing this. You need to think of ways/questions to help determine the problem, such as
- 您要使用的帐户是否已在 Outlook 中完全设置?
- 当您从此帐户手动发送电子邮件时，Outlook 会要求您输入密码吗?
还尝试考虑可用于缩小可能导致问题的可能性的测试代码.例如尝试运行这些子程序，看看第一个代码是否确实列出了您想要的帐户.第二个代码是否导致帐户Nothing?如果是这样，也许可以选择删除该帐户并将其重新添加到 Outlook，这可能有助于重置导致问题的某些内容.
Try also to think of test code you can use to narrow down the possibilities that may be the cause of the problem. for example try to run these subroutines and see if the first code actually lists your desired account. Does the second code result in the account being Nothing? If so, perhaps an option is to delete the account and add it again to outlook, which may help reset something that was causing the problem.
Sub ShowAllAccounts()
Dim OLook As Object
Dim oAccount As Object
Set OLook = CreateObject("Outlook.Application")
For Each oAccount In OLook.Session.Accounts
MsgBox oAccount.DisplayName
Next oAccount
End Sub
Sub DoesAccountExist()
Dim OLook As Object
Set OLook = CreateObject("Outlook.Application")
If GetAccountOf("emailaddress@somewhere.com", OLook) Is Nothing Then
MsgBox "Account doesn't exist"
End If
End Sub
尝试编写一些与此类似的其他代码，如果仍然卡住，请返回.
Try to make up some other code similar to this and please get back if you are still stuck.
编辑 2:
您需要确保在您.Display您的电子邮件之前设置SendUsingAccount属性:Outlook，如果这样有趣:)
You need to make sure you set the SendUsingAccount property before you .Display your email: Outlook if funny like that :)
试试这个:
Dim OLook As Object, Mitem As Object, OlAttachment As Object
Dim fso As Object
Dim remail As Range
Dim acc As Object
Set Mitem = OLook.CreateItem(0)
With Mitem
.SendUsingAccount = GetAccountOf("emailaddress@somewhere.com", OLook)
.Display
'send to:
.To = send_list
'send from:
'.From = from_list
'cc to:
.CC = cc_list
'bcc to:
.BCC = bcc_list
这篇关于切换发件人收件箱的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
