采用VBA把Outlook联系人保存到Sql Server的联系表中

我采用Access Project建立了以Access为前端,Sql Server为后台的销售统计数据库，在Sql Server上创建了名为“theContacts”的联系人数据表。使用中发现分布在各个前端电脑里的Outlook联系人资源没有得到利用，采用Access窗体逐个录入联系人费时费力，为此我在Outlook里采用宏，通过以下代码就可以把选定的联系人上传到Sql Server的“theContacts"表中。

 

代码运行时，Outlook与Sql Server销售统计数据库采用ADO连接。

 

为了方便理解，我在代码里仅仅描述了如何保存或更新“theContacts"表中的“姓”和“名”字段，实际编程中，把其他字段名称添加到代码中的Sql语句里即可使用。

 

Option Explicit

Private ins As Outlook.Inspector
Private itm As Object
Private con As Outlook.ContactItem
Private cnn As ADODB.Connection
Private rst As ADODB.Recordset
Private sqlContact As String
Private cnnString As String
Private intContactID As Integer

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Public Sub SaveContactToSqlserver()
   
On Error GoTo ErrorHandler
   
    Set ins = Application.ActiveInspector
    Set itm = ins.CurrentItem
   
    Select Case itm.Class '判断是否选定对象是否为联系人
   
        Case Is <> olContact
       
            MsgBox "您选定的内容不是联系人信息! 点击[确定]退出.", vbInformation, "您选定的内容不是联系人信息!"
            GoTo ErrorHandlerExit
            'Could add more error-trapping to determine if the mail message uses a
            'specific custom form, or has specific data in one or more fields
  
        Case Else
       
            If Not itm.Saved Then '判断选定联系人信息是否已保存在本地Outlook
           
                If MsgBox("联系人:" & "[" & itm.LastName & itm.FirstName & "]" & "的信息已更改!" & "确定要保存吗?" & vbCrLf & vbCrLf & "点击[是]保存;点击[否]放弃.", vbInformation + vbYesNo) = vbYes Then
                    itm.Save '点"确定"保存更改到本地Outlook
'                    Call UpLoadContact '调用UpLoadContact上传选定联系人信息到服务器
                Else
                    GoTo ErrorHandlerExit
                End If
               
            End If
               
            Call UpLoadContact '调用UpLoadContact上传选定联系人信息到服务器
           
    End Select
   
    Set ins = Nothing
    Set itm = Nothing

ErrorHandlerExit:
    Exit Sub

ErrorHandler:
   
    MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
        Resume ErrorHandlerExit

End Sub

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Private Sub UpLoadContact()

On Error GoTo ErrorHandler

    Set ins = Application.ActiveInspector
    Set itm = ins.CurrentItem
        
        Set con = itm
       
        '采用ADO连接数据库
        Set cnn = New ADODB.Connection
        cnnString = "Provider = SQLOLEDB.1;Data Source = [服务器名称];Initial Catalog = [数据库名称];User ID =sa;Password =;"
        cnn.Open cnnString
       
        sqlContact = "select ContactID from tblcontacts where lastname='" & con.LastName & "'and firstname='" & con.FirstName & "';"
        Set rst = New ADODB.Recordset
        rst.Open sqlContact, cnn, adOpenDynamic, adLockReadOnly
               
            '查询服务器中是否已有记录
            If rst.BOF And rst.EOF Then
           
                '如服务器中无记录,将选定的联系人信息上传到服务器
                cnn.Execute "Insert into tblContacts (Title,FirstName,MiddleName,LastName) values ('" & con.Title & "','" & con.FirstName & "','" & con.MiddleName & "','" & con.LastName & "')"
                MsgBox "联系人:" & "[" & con.LastName & con.FirstName & "]" & "的信息已上传至服务器!", vbInformation
               
            Else
           
                '如已有记录,则让用户选择覆盖还是放弃
                intContactID = rst!ContactID
                Debug.Print intContactID
                    If MsgBox("联系人:" & "[" & con.LastName & con.FirstName & "]" & "的信息已存在!" & vbCrLf & vbCrLf & "点击[确定]覆盖,点击[取消]退出.", vbOKCancel + vbExclamation) = vbOK Then
                        cnn.Execute "Update tblcontacts set lastname='" & con.LastName & "',firstname='" & con.FirstName & "'where ContactID='" & intContactID & "';" '更新服务器记录
                        MsgBox "联系人:" & "[" & con.LastName & con.FirstName & "]" & "的信息已更新!", vbInformation
                    Else
                        GoTo ErrorHandlerExit
                    End If
           
            End If
        rst.Close
        Set rst = Nothing
        cnn.Close
        Set cnn = Nothing
       
ErrorHandlerExit:
    Exit Sub

ErrorHandler:
   
    MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
        Resume ErrorHandlerExit

End Sub