【2008年10月22日】 可以读取 OutLook2003联系人并保存在一个文本文件中的VBA程序。当年我主要就是依靠它编写了一个桌面上的公司地址薄,除了根据人名查电话，还提供了反查的功能

 

下面的程序段（VBA）可以将Outlook中的联系人dump到文件中。如果你们公司有那种全部联系人的通讯录（全球联系人），

你可以先将全部联系人保存到你本机的联系人中，然后运行下面的程序。之后，你就可以在c:下面找到 Text.txt 。里面

包含了全部联系人名单和电话号码... ...2年之前，我就用这样的方法将全部联系人dump出来，编写Delphi程序以资源方式

引用，从而实现本地的地址簿。

程序不完善，虽然可以直接将DistroList中的写入文件中，但是不能保存Recipient的信息（组信息）。

											2008年11月22日
Private Sub copyDistroList()

On Error GoTo errHandler

    Dim myOlApp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.MAPIFolder
    Dim myDistList As Outlook.DistListItem  'source distribution list contains all contacts
    Dim myDistList1 As Outlook.DistListItem 'target distribution list containing contacts A-L
    Dim myDistList2 As Outlook.DistListItem 'target distribution list containing contacts M-Z
    Dim myFolderItems As Outlook.Items
    Dim myRcpnt As Outlook.Recipient

    Dim intIterateContactItems As Integer   'track contact items
    Dim intIterateDLMemberItems As Integer  'track distribution members
    Dim intCountContactItems As Integer     'count contact items
    Dim intCountDLMemberItems As Integer    'count distribution members within list

    Dim strSourceDistList As String         'source distro list name container
    Dim strTargetDistList1 As String        'target 1 distro list name container
    Dim strTargetDistList2 As String        'target 2 distro list name container
    Dim blnListFound As Boolean             'track if source distro list was found

     Dim objSAE      ' As Redemption.AddressEntry
     Dim myItem As Outlook.ContactItem

    strSourceDistList = "KS"          'name of source distro list
    strTargetDistList1 = "test1"        'name of target 1 distro list
    strTargetDistList2 = "test2"        'name of target 2 distro list

    'create Outlook objects
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set myFolderItems = myFolder.Items
    Set myDistList1 = myOlApp.CreateItem(olDistributionListItem)
    Set myDistList2 = myOlApp.CreateItem(olDistributionListItem)

    'intialize variables
    myDistList1.DLName = strTargetDistList1
    myDistList2.DLName = strTargetDistList2
    blnListFound = False

    Const fsoForAppend = 8
    Const PR_CELLULAR_TELEPHONE_NUMBER = &H3A1C001E

    Dim objFSO
    Dim objTextStream

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTextStream = objFSO.OpenTextFile("C:\Test.txt", fsoForAppend)
     'replace with your filename & path

    'assign the count of all contact items to variable
    intCountContactItems = myFolderItems.Count

    'iterate through all Outlook contact items until the source distro list is located
    For intIterateContactItems = 1 To intCountContactItems

        'check to see if the contact item is a distribution list type
        If TypeName(myFolderItems.Item(intIterateContactItems)) = "DistListItem" Then

            'set the myDistList object as the DistListItem
            Set myDistList = myFolderItems.Item(intIterateContactItems)

            'check to see if the distro list is correct source list
            If myDistList.DLName = strSourceDistList Then

                'assign the distro list member count to variable
                intCountDLMemberItems = myDistList.MemberCount

                'iterate through all members of the distro list
                For intIterateDLMemberItems = 1 To 2
                'intCountDLMemberItems

                    'get the member name, create the recipient, and assign to object variable
                    Set myRcpnt = myOlApp.Session.CreateRecipient(myDistList.GetMember(intIterateDLMemberItems).Address)
                    Set myItem = Application.CreateItem(olContactItem)

                    'ensure the recipient can be resolved in the Exchange director
                    myRcpnt.Resolve

                    'is recipient name resolved?
                    If myRcpnt.Resolved = True Then
                    Set objSAE = myRcpnt.AddressEntry

                            objTextStream.WriteLine myRcpnt.Name

                       myItem.FullName = myRcpnt.Name
                       myItem.Email1Address = myRcpnt.Address
                            objTextStream.WriteLine myItem.BusinessTelephoneNumber & "sss"

                       myItem.ForwardAsVcard

                       myItem.Save

                    'if recipient is not resolved then warn the user and move on to the next distro list member
                    Else
                        MsgBox "Sorry, I could not resolve the email address for " & _
                                myDistList.GetMember(intIterateDLMemberItems).Name & "." & _
                                vbCrLf & "Please write this information down and verify." & _
                                vbCrLf & "I will move on with the list.  Click okay " & _
                                "to continue.", vbOKOnly + vbCritical, "NOT RESOLVED"
                        Resume Next
                    End If

                    'Debug.Print myDistList.GetMember(intIterateDLMemberItems).Name & _
                                ", " & myDistList.GetMember(intIterateDLMemberItems).Address

                'get the next member of the distro list
                Next intIterateDLMemberItems

                'save the new distro lists
                myDistList1.Save
                myDistList2.Save
                'source distro list was found, so set variable to true
                blnListFound = True
                'since the source distro list is found, there is no need to continue with the contact items iteration
                Exit For
            End If
        End If

    'get the next item within Contacts
    Next intIterateContactItems

     'Close the file and clean up
    objTextStream.Close
    Set objTextStream = Nothing
    Set objFSO = Nothing

    'raise message box if source distro list was not found
    If blnListFound = False Then
        MsgBox "Your Source Distribution List was not found", vbOKOnly + vbInformation, "DISTRO LIST NOT FOUND"
    End If

setAllToNothing:
    'end of subroutine, so ensure all objects are emptied
    If Not myOlApp Is Nothing Then
        Set myOlApp = Nothing
    End If

    If Not myNameSpace Is Nothing Then
        Set myNameSpace = Nothing
    End If

    If Not myFolder Is Nothing Then
        Set myFolder = Nothing
    End If

    If Not myDistList Is Nothing Then
        Set myDistList = Nothing
    End If

    If Not myDistList1 Is Nothing Then
        Set myDistList1 = Nothing
    End If

    If Not myDistList2 Is Nothing Then
        Set myDistList2 = Nothing
    End If

    If Not myFolderItems Is Nothing Then
        Set myFolderItems = Nothing
    End If

    If Not myRcpnt Is Nothing Then
        Set myRcpnt = Nothing
    End If

    Exit Sub

errHandler:

    MsgBox Err.Number & " " & Err.Description, vbCritical + vbOKOnly, "ERROR"
    Resume setAllToNothing

End Sub

 

【2008年10月19日】 网站再次恢复。原来的域名 www.begin.org.cn 无法恢复，只好重新请Nihg帮我申请了新的域名：www.asdqwe.cn 貌似很奇怪的名称，也没有意义，不过你在键盘上多输入几次就知道还是很方便输入的了。转眼间，之前的页面竟然用了快3年，正好借这个机会重新做了一下网站。之前的页面是这样的。我是用的是 Free website templates 网站提供的模板。看上去非常简洁的风格，我很喜欢。网速慢的朋友浏览的速度也会很快。

网站再次恢复。原来的域名 www.begin.org.cn 无法恢复，只好重新请Nihg帮我申请了新的域名：www.asdqwe.cn 貌似很奇怪的名称，也没有意义，不过你在键盘上多输入几次就知道还是很方便输入的了。转眼间，之前的页面竟然用了快3年，正好借这个机会重新做了一下网站。之前的页面是这样的。我是用的是 Free website templates 网站提供的模板。看上去非常简洁的风格，我很喜欢。网速慢的朋友浏览的速度也会很快。

[June , 18, 2008] 最近工作很忙。因为没有登记，空间被关闭了一段时间。现在迁移到了Nihg朋友的空间中，在此表示感谢。上个月表演节目，编写了一个短剧： 《西行漫记》

西行漫记

 

（音乐）

旁白: 师徒三人前去西方取经，一天经过关村，中部，俗称中关村。

 

悟空：师傅前面有妖气，此乃凶兆！

八戒：摸自己胸部… ….

唐僧: (看八戒) 哪里哪里？

（三人走，转场）

 

白骨精：(上场)身份证 毕业证 结婚证 光盘 VCD，要不要？

八戒：(害羞表情)有片么?，有李亚鹏配音的么

白骨精：有。

八戒：（兴奋）有日本的么？

白骨精：有。

八戒：（激动）有带字幕的吗？

白骨精：(迟疑)有。

八戒：（更加激动）有李亚鹏配音的么？

白骨精：(尴尬无语)… …

 

唐僧：八戒，你又犯戒了~（一把拉过八戒，自己上前）

（严肃认真）这位施主，我们自东土大唐二来，旅途劳顿，准备买点发票回大唐报销。

白骨精：（四处张望一下）有，要多少？

唐僧：（兰花指，计算状）区区3000两而已~ 敢问施主，是机打还是手撕？我可只要机打的。

白骨精：随我而来… …

 

(悟空上场)

 

悟空：（看到白骨精，大叫）妖怪啊~ （上前，挥棒）

白骨精：叫“条子来了”。

（悟空拉着白骨精，到角落，挥棒打之）

八戒：（伸脖子）我的光盘……

唐僧：发票….

（悟空回来）

唐僧：你以为你是城管吗，怎么见人就打啊~ 不是已经答应师傅，为何还如此冥顽不化！

（悟空，生气，无语）

 

旁白：悟空一气之下，回了花果山。刚刚赶走了悟空，突然平地挂起大风（风声）

唐僧：打雷了，沙尘暴又来了。

（一个mm上场将唐僧卷走）

八戒：（喊）师傅，等一等！

唐僧：（甩头，回头一笑）用了飘柔更自信。八戒你就别追了，别误了师傅的好事。

 

八戒:（犯愁，思考状。拿出阳光服务卡，面相观众）800 Call Center。

旁白：普通话服务请按1，英语请按2。

八戒：我选1。

旁白：东北话，请按3；河南话，请按4；不需要服务：请挂机。找观音姐姐聊天，请按1277867（快速读）。

八戒：我靠，我还得再听一边？

旁白：观音117 为您服务

观音：喂，你好，观音在线。有什么需要帮助的？

八戒：姐姐，我唐僧师傅被妖精抓走了。

观音：您是我们的VIP用户，我们可以为您提供定点清除服务。

八戒：（自言自语）我还等着光盘哪。（对电话说）有其他服务么？

观音：您是我们的VIP用户，我们还可以提供上门服务。需要请按#。

旁白：（嗖）

(观音闪现，八戒下了一跳)

八戒：我靠，怎么一点声音都没有。

观音：你没有听到“嗖~”的一声么。

（观音姐姐拿出一本宝典，交给八戒）

观音：（深情）你要么？

八戒：（点头）我要~

(观音不松手)

观音：你要你就说，你不说我怎么知道，你说了我又不是不给你~

（双方用力抢，八戒忍无可忍，双手抓过）

 

旁白：此后，八戒研究MOT…….(Z.t注：我上的就是这个课，根据需要可以修改为3DB，八个要脸八个不要脸的都可以)

旁白：第一页：与练此功，必先自宫。

（八戒出门，惨叫，冲马桶的声音，转身回来）

八戒：（高叫）我悟到了（仰天长啸）大师兄终于不用被fair了

 

旁白：转眼间，八戒来到了花果山，找到了悟空。将宝典交给了悟空。

悟空：（看八戒）二师弟，怎么变白了？

八戒：大师兄，你也变胖了。

旁白: 说话间，悟空翻到了第一页。

悟空：（深情的看着八戒）二师弟辛苦了。（递给八戒一杯水）

八戒：没什么，我只是失去了一点点。以后还可以加入演艺圈（juan）。

（悟空继续看）

旁白：第二页，如不自宫，也可成功。

八戒：喷水，

吾空：MOT Moment of Tolit 师傅有救了，行动！

 

 

 

 

场景：美女给唐曾捶背。

唐僧：（对八戒）八戒你怎么来了，快跑吧，这年头你的肉比我值钱多了。

（对悟空说）悟空你也来了，我们公司离职3个月内不允许回来的。

美女：对唐僧说：先生你已经到钟了

唐僧：记得给我开发票哈。台头写上：Senovo。

悟空：师傅你身后的女人是妖精，怎么办？

唐僧：人是人她妈生的，妖是妖她妈生的，我们要有一颗仁慈的心。 让她走吧。

 

大家齐唱 Only You