展望VBA代码弱点

Question

我已经写了一些代码瓶坯如下：

当用户点击发送，同时组成了附件类型.DOC电子邮件检查，.DOCX，.PDF然后提示用户询问是否是如果用户点击否，则发送电子邮件并且过程结束。但是，如果用户单击是，则代码将连接到MS SQL并插入用户名，收件人电子邮件地址和时间戳，然后发送电子邮件。

到目前为止，代码可以正常工作，但Outlook最近开始崩溃并重新启动，现在它声明添加问题使用加载项检测到问题，并且已禁用它（Outlook的VBA）。

任何帮助确定代码中的弱点将非常感激。

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