Question

我已经编写了一些代码来执行以下操作：

当用户在编写电子邮件时单击“发送”检查附件类型.doc，.docx，.pdf然后提示用户询问是否是提交，如果用户单击“否”，则发送电子邮件并且过程结束。但是，如果用户单击“是”，则代码将连接到MS SQL并插入用户名，收件人电子邮件地址和时间戳，然后发送电子邮件。

到目前为止，代码正常用于此目的，但Outlook最近开始崩溃并重新启动，现在它指出ADD-IN问题使用加载项检测到问题并且已禁用（VBA for Outlook）。 / p>

非常感谢任何帮助识别代码中的弱点。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim Atmt As attachment
Dim FileName As String
Dim i As Integer
Dim strPrompt As String
Dim vError As Variant
Dim sErrors As String

i = 0

For Each Atmt In Item.Attachments
Debug.Print Atmt.FileName

If (UCase(Right(Atmt.FileName, 4)) = UCase("docx")) Or _
   (UCase(Right(Atmt.FileName, 3)) = UCase("pdf")) Or _
   (UCase(Right(Atmt.FileName, 3)) = UCase("doc")) Then

i = i + 1

End If


Next Atmt

    If i > 0 Then

    strPrompt = "You have attached a document. Is this a CV Submission?"

        If MsgBox(strPrompt, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check for Attachment") = vbNo Then
            Cancel = False

        Else:

              Dim myNamespace As Outlook.NameSpace
              Dim mail As MailItem
              Dim recip As Outlook.Recipient
              Dim recips  As Outlook.Recipients
              Dim pa      As Outlook.PropertyAccessor
              Dim conn As ADODB.Connection
              Dim rs As ADODB.Recordset
              Dim sConnString As String

              Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"


              ' Create the connection string.
              sConnString = "Provider=SQLOLEDB;Data Source=WIN-NBST3PHVFV4\ECLIPSE;" & _
                            "Initial Catalog=OBlive;" & _
                            "User ID=outlook;Password=0Zzy007;"

              ' Create the Connection and Recordset objects.
             Set conn = New ADODB.Connection
             Set rs = New ADODB.Recordset
             Set myNamespace = Application.GetNamespace("MAPI")
             Set recips = Item.Recipients

             For Each recip In recips
             Set pa = recip.PropertyAccessor
             Next

             ' Open the connection and execute.
             conn.Open sConnString
             Set rs = conn.Execute("INSERT INTO dbo.Submissions (CV_Sent, Consultant, Timestamp, Recipient) VALUES ( '1','" & myNamespace.CurrentUser & "', CURRENT_TIMESTAMP, '" & pa.GetProperty(PR_SMTP_ADDRESS) & "' )")
             ' Clean up
             If CBool(conn.State And adStateOpen) Then conn.Close
             Set conn = Nothing
             Set rs = Nothing

        End If

    End If

End Sub

Answer 1

我不确定你的问题是什么，但我可以批评你的代码：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    Dim Atmt As attachment
    Dim FileName As String
    Dim i As Integer
    Dim strPrompt As String
    Dim vError As Variant
    Dim sErrors As String

    i = 0

    For Each Atmt In Item.Attachments
                                     ' <====== YOU SHOULD BE INDENTING BLOCKS LIKE THIS
        FileName = Atmt.FileName     ' <====== CACHE THIS VALUE - YOU DECLARED IT!
        Debug.Print FileName

        ' <==== This pattern deserved to become a function, HasFileExtension()
        ' UCase(Right(Atmt.FileName, 4)) = UCase("docx")

        If HasFileExtension(FileName, "docx") Or HasFileExtension(FileName, "pdf") Or HasExtension(FileName, "doc") Then
            i = i + 1
        End If

    Next Atmt

    If i > 0 Then

        strPrompt = "You have attached a document. Is this a CV Submission?"
        ' <===== TABBING WENT WEIRD HERE
        If MsgBox(strPrompt, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check for Attachment") = vbNo Then
            Cancel = False
        Else ' <=== UNECESSARY COLON WAS HERE

            ' <============== IT IS GENERALLY A GOOD IDEA TO PUT ALL DECLARATIONS AT THE START OF A PROCEDURE
            Dim myNamespace As Outlook.NameSpace
            Dim mail As MailItem
            Dim recip As Outlook.Recipient
            Dim recips  As Outlook.Recipients
            Dim pa      As Outlook.PropertyAccessor
            Dim conn As ADODB.Connection
            'Dim rs As ADODB.Recordset     ' <===== NOT USED NOW
            Dim sConnString As String

            Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

            ' Create the connection string.
            sConnString = "Provider=SQLOLEDB;Data Source=WIN-NBST3PHVFV4\ECLIPSE;" & _
                          "Initial Catalog=OBlive;" & _
                          "User ID=outlook;Password=0Zzy007;"

            ' Create the Connection and Recordset objects.
            Set conn = New ADODB.Connection
            'Set rs = New ADODB.Recordset     <====== NO NEED TO SET THIS
            Set myNamespace = Application.GetNamespace("MAPI")

            Set recips = Item.Recipients

            ' <==== This chunk iterates through all the recipents, and retrieves the PropertyAccessor object of each. However, only the last value of "pa" is used by the end of the loop. Maybe you only want the last recipient? In which case, you would be better off doing:
            ' Set pa = recips(recips.Count).PropertyAccessor
            ' <==== I guess that this works ok for one recipient, but fails for multiple recipients.
            For Each recip In recips
                 Set pa = recip.PropertyAccessor
            Next

            ' Open the connection and execute.
            conn.Open sConnString
            ' <===== REMOVED "Set rs = ". You are not using rs.
            conn.Execute "INSERT INTO dbo.Submissions (CV_Sent, Consultant, Timestamp, Recipient) VALUES ( '1','" & myNamespace.CurrentUser & "', CURRENT_TIMESTAMP, '" & pa.GetProperty(PR_SMTP_ADDRESS) & "' )"
            ' Clean up
            If CBool(conn.State And adStateOpen) Then conn.Close
            Set conn = Nothing
            'Set rs = Nothing 
        End If

    End If

End Sub

Function HasFileExtension(ByRef sFileName As String, ByRef sFileExtension As String) As Boolean

    ' <==== To be sure, you must include a dot before the file extension when comparing.
    HasFileExtension = ( LCase$(Right$(sFileName, Len(sFileName) + 1)) = ("." & LCase$(sFileExtension)) )

End Function

Outlook VBA代码弱点

1 个答案: