0

我对 Excel VBA 完全陌生。我正在使用 Microsoft 2003 excel。

我的上级要求我创建一个休假管理系统，以跟踪员工的休假天数，并从那里向她、她的秘书和员工发送一封关于批准或拒绝状态的电子邮件.

我确实尝试了一些 VBA 的代码。但我不知道邮件发送功能是如何工作的？我把附件发出去吗？或者当我在代码中输入一些值时，它会自动发送整个附件？我真的迷路了，谢谢！

Sub Mail_sheets()
Dim MyArr As Variant
Dim last As Long
Dim shname As Long
Dim a As Integer
Dim Arr() As String
Dim N As Integer
Dim strdate As String
For a = 1 To 253 Step 3
    If ThisWorkbook.Sheets("mail").Cells(1, a).Value = "" Then
        Exit Sub
    End
    Application.ScreenUpdating = False
    last = ThisWorkbook.Sheets("mail").Cells(Rows.Count, _
        a).End(xlUp).Row
    N = 0
    For shname = 1 To last
        N = N + 1
        ReDim Preserve Arr(1 To N)
        Arr(N) = ThisWorkbook.Sheets("mail").Cells(shname, a).Value
    Next shname
    ThisWorkbook.Sheets(Arr).Copy
    strdate = Format(Date, "dd-mm-yy") & " " & _
        Format(Time, "h-mm-ss")
    ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name _
        & " " & strdate & ".xls"
    With ThisWorkbook.Sheets("mail")
        MyArr = .Range(.Cells(1, a + 1), .Cells(Rows.Count, _
            a + 1).End(xlUp))
    End With
    ActiveWorkbook.SendMail MyArr, ThisWorkbook.Sheets("mail").Cells(1, a + 2).Value
    ActiveWorkbook.ChangeFileAccess xlReadOnly
    Kill ActiveWorkbook.FullName
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
Next a
End Sub
4

1 回答 1

3

这是一个关于如何实现您想要的示例的示例。请根据您的实际需要进行修改。

我确实尝试了一些 VBA 的代码。但我不知道邮件发送功能是如何工作的？我把附件发出去吗？

您无需将整个工作簿作为附件发送。您可以发送一封简单的电子邮件，说明请假是被批准还是被拒绝。如果您需要支持拒绝或批准请假的原因，则可以将相关单元格粘贴到电子邮件中。请参阅此示例。

我假设您的工作表看起来像这样。

在此处输入图像描述

现在假设员工Siddharth想请假。正如我们在快照中看到的，员工有0余额。因此，请假请求将被拒绝，并将向相关人员/部门发送邮件

运行代码时，它会要求您输入员工姓名

在此处输入图像描述

然后发送相关邮件。

在此处输入图像描述

代码

Option Explicit

'~~> To Field in Email
Const strTo As String = "aaa@aaa.com"
'~~> CC field in email. If you do not want to CC then change "bbb@bbb.com" to ""
Const strCC As String = "bbb@bbb.com"

'~~> This is what goes in the body
Const strBody1 As String = "Dear XYZ,"
Const strBody2 As String = "This is in reference to leave request for employee "

Const strBodyApp As String = "The employee has sufficient leave balance and can take the leave"
Const strBodyNotApp As String = "The employee doesn't have sufficient leave balance and hence cannot take the leave"
Const strByeBye  As String = "Thanks and Regards"
Const sender As String = "ABC"

Sub Sample()
    Dim ws As Worksheet
    Dim aCell As Range
    Dim Ret
    Dim Bal As Long
    Dim Rw As Long

    Ret = Application.InputBox("Please enter the name of the employee who wants to take a leave")

    If Ret = "" Then Exit Sub

    Set ws = Sheets("Sheet3")

    Set aCell = ws.Columns(2).Find(What:=Ret, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    If Not aCell Is Nothing Then
        Bal = aCell.Offset(, 5).Value
        Rw = aCell.Row

        If Bal > 0 Then
            Approved Ret, True, Rw
        Else
            Approved Ret, False, Rw
        End If
    Else
        MsgBox "The employee " & Ret & " was not found"
    End If
End Sub

Sub Approved(EmpName, app As Boolean, lRow As Long)
    Dim msg As String
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    If app = True Then
        msg = "<p class=MsoNormal>" & strBody1 & "<o:p></o:p></p>" & vbNewLine & _
               "<p class=MsoNormal><o:p>&nbsp;</o:p></p>" & vbNewLine & _
               "<p class=MsoNormal>" & strBody2 & EmpName & ". " & strBodyApp & _
               "<span style='mso-fareast-font-family:""Times New Roman""'><o:p></o:p></span></p>"
    Else
        msg = "<p class=MsoNormal>" & strBody1 & "<o:p></o:p></p>" & vbNewLine & _
               "<p class=MsoNormal><o:p>&nbsp;</o:p></p>" & vbNewLine & _
               "<p class=MsoNormal>" & strBody2 & EmpName & ". " & strBodyNotApp & _
               "<span style='mso-fareast-font-family:""Times New Roman""'><o:p></o:p></span></p>"
    End If

    Set rng = Sheets("Sheet3").Range("A1:F1" & ",A" & lRow & ":F" & lRow)

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = strTo
        .CC = strCC
        .BCC = ""
        .Subject = "Leave Status"

        .HTMLBody = msg & _
                    RangetoHTML(rng) & _
                    "<p class=MsoNormal><span style='mso-fareast-font-family:""Times New Roman""'>" & strByeBye & "<o:p></o:p></span></p>" & _
                    "<p class=MsoNormal><span style='mso-fareast-font-family:""Times New Roman""'><o:p>&nbsp;</o:p></span></p>" & _
                    "<p class=MsoNormal><span style='mso-fareast-font-family:""Times New Roman""'>" & sender & "<o:p></o:p></span></p>"

        .Display   '.Send 'To send the email
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

'~~> Taken from http://www.rondebruin.nl/mail/folder3/mail4.htm
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    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"

    'Copy the range and create a new workbook to past the data in
    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

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

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

免责声明：由于上面的代码是一个基本的例子，我没有

1）包括错误处理（你应该）

2）使用基本的东西作为Application.ScreenUpdating

示例文件：此链接将在接下来的 7 天内有效。我已经上传了一个示例文件供您使用:)

http://wikisend.com/download/562482/Sample.xls

高温高压

于 2012-04-08T12:22:29.817 回答