Question

我正在尝试向多人发送电子邮件。但它应该选择的电子邮件地址是基于已登录的用户。我该怎么做？我有一个表格，其中有5列电子邮件ID。根据谁登录，代码应该选择该人并向该行中的所有人发送电子邮件。

我如何实现这一目标？我知道如何在excel中进行但访问我不太了解。我正在粘贴我知道的代码和hv尝试过的代码。

＆＃13;

Sub Mail_ActiveSheet()
       
    Dim OutApp As Object
    Dim Outmail As Object
    Dim sTo As String
    Dim sCC As String
    Dim lastrow, i As Integer
    Dim sub1, sub2, sub3, body1 As Variant
    Dim emailid, cc1, cc2, cc3, cc4, subj, attch, Sourcewb, Outnail, Soucrwb As Object
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    ThisWorkbook.Activate
'Code for Email sheet creation
    Call EMAILSHEET_DATA
'Code for emailing schedular to the associates
    Worksheets("Email_List").Select
    lastrow = ThisWorkbook.Worksheets("Email_List").Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastrow
            Set emailid = Worksheets("Email_List").Range("C" & i)
            sTo = emailid
        Set cc1 = Worksheets("Email_List").Range("D" & i)
        'Set cc2 = Worksheets("Email_List").Range("E" & i)
        'body1 = Worksheets("Email_List").Range("a" & i)
        sCC = cc1 '& ";" & cc2
        subj1 = Worksheets("Email_List").Range("F" & i).Value
        subj2 = Worksheets("Email_List").Range("G" & i).Value
        subj3 = Worksheets("Email_List").Range("H" & i).Value
        subj = "Your Schedule for " & subj1 & subj2 & subj3
        ActiveWorkbook.Activate
        Set Sourcewb = ActiveWorkbook
        Set OutApp = CreateObject("Outlook.Application")
        Set Outmail = OutApp.CreateItem(0)
        On Error Resume Next
        With Outmail
            .To = sTo
            .CC = sCC
            '.BCC=Sbcc
            .Subject = subj
            .Body = "Hello " & Worksheets("Email_List").Range("a" & i).Value & "," & vbCrLf & vbCrLf & subj & "." _
            & vbCrLf & vbCrLf & Worksheets("Email_List").Range("i" & i).Value _
            & vbCrLf & Worksheets("Email_List").Range("j" & i).Value _
            & vbCrLf & Worksheets("Email_List").Range("k" & i).Value _
            & vbCrLf & Worksheets("Email_List").Range("l" & i).Value _
            & vbCrLf & Worksheets("Email_List").Range("m" & i).Value _
            & vbCrLf & Worksheets("Email_List").Range("n" & i).Value _
            & vbCrLf & Worksheets("Email_List").Range("o" & i).Value _
            & vbCrLf & vbCrLf & "Note: Please report any scheduling conflicts or errors to your Supervisor." _
            & vbCrLf & vbCrLf & "Thank You," & vbCrLf & "gmail.com Management"
            .Send
        End With
        On Error GoTo 0
        Set Outmail = Nothing
        Set OutApp = Nothing
        'ActiveWorkbook.Close False
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Application.DisplayAlerts = True
    Next i
    ThisWorkbook.Activate
    MsgBox ("Thank You! The Schedules have been sent to all the associates.")
End Sub

'DATA FOR EMAIL SHEET
Sub EMAILSHEET_DATA()
    Worksheets("Email_list").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Worksheets("Schedules").Select
    Range("B15").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Email_List").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Associate_Info!R1C1:R270C7,4,0)"
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Associate_Info!R1C1:R270C7,3,0)"
    Range("D2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Associate_Info!R1C1:R270C7,4,0)"
    Range("E2").Select
    'ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],Associate_Info!C[-4]:C[-1],4,0)"
    ActiveCell.FormulaR1C1 = "Information not available"
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "=Schedules!R12C5"
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "  to  "
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "=Schedules!R12C17"
    Range("I2").Select
    ActiveCell.FormulaR1C1 = _
        "=TEXT(Schedules!R12C5,""MM/DD/YY"") & "" , "" & Schedules!R13C5 & "" , "" & Schedules!R[13]C[-4] &  "" - "" & Schedules!R[13]C[-3]"
    Range("J2").Select
    ActiveCell.FormulaR1C1 = _
        "=TEXT(Schedules!R12C7,""MM/DD/YY"")  & "" , "" & Schedules!R13C7 & "" , "" & Schedules!R[13]C[-3] &  "" - "" & Schedules!R[13]C[-2]"
    Range("K2").Select
    ActiveCell.FormulaR1C1 = _
        "=TEXT(Schedules!R12C9,""MM/DD/YY"")  & "" , "" & Schedules!R13C9 & "" , "" & Schedules!R[13]C[-2] &  "" - "" & Schedules!R[13]C[-1]"
    Range("L2").Select
    ActiveCell.FormulaR1C1 = _
        "=TEXT(Schedules!R12C11,""MM/DD/YY"")  & "" , "" & Schedules!R13C11 & "" , "" & Schedules!R[13]C[-1] &  "" - "" & Schedules!R[13]C[0]"
    Range("M2").Select
    ActiveCell.FormulaR1C1 = _
        "=TEXT(Schedules!R12C13,""MM/DD/YY"")  & "" , "" & Schedules!R13C13 & "" , "" & Schedules!R[13]C &  "" - "" & Schedules!R[13]C[1]"
    Range("N2").Select
    ActiveCell.FormulaR1C1 = _
        "=TEXT(Schedules!R12C15,""MM/DD/YY"")  & "" , "" & Schedules!R13C15 & "" , "" & Schedules!R[13]C[1] &  "" - "" & Schedules!R[13]C[2]"
    Range("O2").Select
    ActiveCell.FormulaR1C1 = _
        "=TEXT(Schedules!R12C17,""MM/DD/YY"")  & "" , "" & Schedules!R13C17 & "" , "" & Schedules!R[13]C[2] &  "" - "" & Schedules!R[13]C[3]"
    Range("O2").Select
    Selection.End(xlToLeft).Select
    Range("B2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Range("A2").Select
    lastrow = Cells(2, 1).End(xlDown).Row
    'Range("B2:O" & lastrow).Select
    Range("b3:o" & lastrow).Select
    'Range("B3:B571").Select
    'Range("B571").Activate
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.End(xlUp).Select
    Range("B2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.End(xlUp).Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$O$291").AutoFilter Field:=2, Criteria1:="#N/A"
    Rows("6:6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    Selection.AutoFilter
    Range("A1").Select
    ActiveWorkbook.Save
End Sub

＆＃13;

Public Sub EmailList()
'late Binding
Dim olApp As Object
Dim olemail As Object
Dim strbody As String

'creating new outlook instance
Set olApp = CreateObject("Outlook.Application")
Set olemail = olApp.CreateItem(0)

strbody = "<html> <body> Hi " & Me.FullName & " <br/> <br/> Your leaves have been saved.  <br/> Start Date: " & Me.Text8 & " <br/> End Date: " & Me.Text10 & " <br/> <br/> Regards <br/> Walmart.com Management "

Set olApp = CreateObject("Outlook.Application")
Set olemail = olApp.CreateItem(0)
With olemail
.BodyFormat = 2
.Display
.htmlBody = strbody
.to = "reetika.choudhary@gmail.com"
.Subject = "Leaves Applied"

.Send
DoCmd.SetWarnings WarningsOff

End With

End Sub

＆＃13;

excel代码如下：

任何帮助将受到高度赞赏！提前谢谢。

Answer 1

您可以在Windows系统上使用Environ("USERNAME")从环境变量中提取用户名：

Sub SO()

    Dim username As String

    username = Environ("USERNAME")

    MsgBox username & " is currently logged on."

End Sub

访问动态电子邮件地址选择

1 个答案: