【吹友吧独创】【treo联系人救星】outlook自动增加拼音的代码

liangl923 · 发表于 2007-11-30 17:49

呵呵，treo的联系人查找一直是我的心病，我那么多联系人难道要一个一个改拼音么！！最近对outlook的宏研究的比较多，所以，研究了1天做出了自动把firstname（名字）的汉字自动转化为拼音加入到 lastname（姓氏）字段中去。自己用了下，感觉还是比较好用的！当然这么好的东西，要与吹友吧的同仁一起分享了  哈哈哈哈

有些生字无法转化出来，显示为“%”号，但是个人感觉不多，自己稍微改动下就好了。其实由于代码比较简单，所以只能照顾到常用字。有高手也可以把代码修改下，把拼音转化的部分增强。

使用环境： outlook2007[支持vba] 其他没有试过我觉得03应该没问题
               修改vba运行权限：工具》信任中心》宏安全性》不执行宏安全性检查  {用完后再改回系统默认}

使用方法：先用treo和outlook同步
               工具》宏》vb编辑器》新建模块  拷入代码F5运行就好了

代码
Option Explicit
Sub setpinyin()
Dim myolApp As New Outlook.Application
Dim myNamespace As Outlook.NameSpace
Dim myAddresslists As Outlook.folder
Dim AddressList As Outlook.AddressList
Dim item
Dim temp1, temp2

Set myNamespace = myolApp.GetNamespace("MAPI")
Set myAddresslists = myNamespace.GetDefaultFolder(olFolderContacts)
' Set myolApp = myNamespace.GetDefaultFolder(olFolderInbox)
For Each item In myAddresslists.Items
'temp1 = item.LastName & " " & item.FirstName

If item.LastName = "" Then
         item.LastName = LCase(getpy(item.FirstName))
         item.Save
         Debug.Print item.LastName

'MsgBox item.LastName

End If

Next
End Sub

Function getpychar(char) As String
On Error Resume Next
Dim tmp As String, vs1 As String

If Asc(char) >= 0 And Asc(char) <= 127 Then
      If char >= "a" And char <= "z" Then
         getpychar = Chr(Asc(char) - 32)
      ElseIf char >= "A" And char <= "Z" Then
         getpychar = char
      Else
         '如果是空格，排除
         If Asc(char) = 32 Then
            getpychar = ""
         Else
         '
            getpychar = char
         End If
      End If
Else
      tmp = 65536 + Asc(char)
      Select Case tmp
         Case 45217 To 45252: getpychar = "A"
         Case 45253 To 45760: getpychar = "B"
         Case 45761 To 46317: getpychar = "C"
         Case 46318 To 46825: getpychar = "D"
         Case 46826 To 47009: getpychar = "E"
         Case 47010 To 47296: getpychar = "F"
         Case 47297 To 47613: getpychar = "G"
         Case 47614 To 48118: getpychar = "H"
         Case 48119 To 49061: getpychar = "J"
         Case 49062 To 49323: getpychar = "K"
         Case 49324 To 49895: getpychar = "L"
         Case 49896 To 50370: getpychar = "M"
         Case 50371 To 50613: getpychar = "N"
         Case 50614 To 50621: getpychar = "O"
         Case 50622 To 50905: getpychar = "P"
         Case 50906 To 51386: getpychar = "Q"
         Case 51387 To 51445: getpychar = "R"
         Case 51446 To 52217: getpychar = "S"
         Case 52218 To 52697: getpychar = "T"
         Case 52698 To 52979: getpychar = "W"
         Case 52980 To 53640: getpychar = "X"
         Case 53689 To 54480: getpychar = "Y"
         Case 54481 To 55289: getpychar = "Z"
         Case Else: getpychar = "%"
      End Select
End If
End Function
Function getpy(str)
Dim i As Long
For i = 1 To Len(str)
      getpy = getpy & getpychar(Mid(str, i, 1))
Next i
End Function

[ 本帖最后由 liangl923 于 2007-11-30 18:03 编辑 ]

szwgh · 发表于 2007-11-30 19:08

以前也是加拼音的，不过有了中文伴侣后还是喜欢中文伴侣，打电话，发短信，加拨ＩＰ都很方便。

zerozha · 发表于 2007-11-30 21:06

楼主钻研精神值得敬佩。

ursace · 发表于 2007-11-30 21:32

这个要支持！

cnwolf · 发表于 2007-12-1 08:40

中文伴侣也不错，不过很支持楼主的原创精神。

wing2727 · 发表于 2007-12-1 15:25

支持楼主~顶了

牛丸大神 · 发表于 2007-12-1 20:17

噢乖神人啊
顶了不管啥中文伴侣
这样的帖子就该支持

liangl923 · 发表于 2007-12-1 23:07

haha 谢谢大家支持我的第二个高亮贴哈哈

c5tg · 发表于 2008-1-23 16:44

我已经试过了，很好用，但在outlook2003里面不行，貌似是有个函数未定义，在2007里面，需要把那个palm出的outlook2007的同步补丁打上，要不然能用手机同步到电脑，但从电脑无法同步到手机。

liangl923 · 发表于 2009-3-30 10:00

又来了，准备再次使用一下呵呵

air · 发表于 2009-3-30 21:12

可不可以再出个可以反过来的啊。。。比如我要是用一段这种的拼音代码的然后不想要了再给批量消除啊

账号		自动登录	找回密码
密码			加入我们

[软硬件讨论] 【吹友吧独创】【treo联系人救星】outlook自动增加拼音的代码

评分