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

liangl923

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

! Q0 z; F7 J: l4 W: K
- Z2 j) q  _" z) X6 d/ p/ }4 H& `
有些生字无法转化出来，显示为“%”号，但是个人感觉不多，自己稍微改动下就好了。其实由于代码比较简单，所以只能照顾到常用字。有高手也可以把代码修改下，把拼音转化的部分增强。
0 |' Q5 F4 X% E) x- @+ j" H
使用环境： outlook2007[支持vba]   其他没有试过 我觉得03应该没问题
                   修改vba运行权限： 工具》信任中心》宏安全性》不执行宏安全性检查  {用完后再改回系统默认}
: T5 y0 [2 Z( b
使用方法： 先用treo和outlook同步
                  工具》宏》vb编辑器   》新建模块  拷入代码F5运行就好了  
+ @5 U: l5 \/ P# n$ O4 e9 Q. u/ C: ~# N& r

代码
Option Explicit
4 h$ }9 b8 x2 d) H# e3 NSub setpinyin()
    Dim myolApp As New Outlook.Application
% t# ]% ?: J- S" S0 o    Dim myNamespace As Outlook.NameSpace
    Dim myAddresslists As Outlook.folder
    Dim AddressList As Outlook.AddressList
9 @7 }9 P8 r1 R" u2 @    Dim item
    Dim temp1, temp2
   
2 k# p7 l: c1 x    Set myNamespace = myolApp.GetNamespace("MAPI")
    Set myAddresslists = myNamespace.GetDefaultFolder(olFolderContacts)
   ' Set myolApp = myNamespace.GetDefaultFolder(olFolderInbox)
    For Each item In myAddresslists.Items
7 i7 E, y; A" q3 F. [: t( ?   'temp1 = item.LastName & " " & item.FirstName
9 r1 b8 J% U+ x7 A6 i9 S   
   If item.LastName = "" Then
( l4 J" x1 y& b' Y" Q            item.LastName = LCase(getpy(item.FirstName))
            item.Save
            Debug.Print item.LastName
6 N2 d, z# ~) ]2 a( a            
0 l4 f3 Y! j; `! q& N   'MsgBox item.LastName
   
   End If
   
6 }' N0 G3 S4 n# U$ K    Next
7 z  C! l  b: R0 t. oEnd Sub

Function getpychar(char) As String
6 @, ~, h4 t1 |' A3 h    On Error Resume Next
    Dim tmp As String, vs1 As String
   
    If Asc(char) >= 0 And Asc(char) <= 127 Then
- h& B9 O& y  t# }8 \, D1 k        If char >= "a" And char <= "z" Then
" m+ T4 m, ?& D: b: ?( t9 a            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
3 l. |3 u: ]' y1 C2 w0 H        tmp = 65536 + Asc(char)
3 z4 j1 }. t% }        Select Case tmp
            Case 45217 To 45252: getpychar = "A"
            Case 45253 To 45760: getpychar = "B"
            Case 45761 To 46317: getpychar = "C"
' F' c. P" q+ J# @/ ]9 K5 b            Case 46318 To 46825: getpychar = "D"
! O" s7 t; z- f- r            Case 46826 To 47009: getpychar = "E"
& i9 E! k# \6 j9 |( E            Case 47010 To 47296: getpychar = "F"
            Case 47297 To 47613: getpychar = "G"
+ c" f# O- ~: H2 l            Case 47614 To 48118: getpychar = "H"
* t2 w: T( X. ^4 k5 z* `            Case 48119 To 49061: getpychar = "J"
            Case 49062 To 49323: getpychar = "K"
# x; p; }6 \/ n$ s, S            Case 49324 To 49895: getpychar = "L"
            Case 49896 To 50370: getpychar = "M"
) T4 q3 i) L4 i4 P            Case 50371 To 50613: getpychar = "N"
            Case 50614 To 50621: getpychar = "O"
            Case 50622 To 50905: getpychar = "P"
1 @& l( i' C% t1 G5 z            Case 50906 To 51386: getpychar = "Q"
" F5 ?3 F! I% U) Y8 m2 x# _            Case 51387 To 51445: getpychar = "R"
+ C' G: N+ A  V; x9 L/ b            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"
% r& H0 y, }/ E+ q7 ]            Case 54481 To 55289: getpychar = "Z"
            Case Else: getpychar = "%"
        End Select
    End If
$ q! k( Y& E) W$ N8 aEnd Function
. m5 R  I; e* k' QFunction getpy(str)
Dim i As Long
    For i = 1 To Len(str)
        getpy = getpy & getpychar(Mid(str, i, 1))
/ `$ S! q' x( n% a7 @    Next i
. x& p+ a* S: R" A5 {* d: nEnd Function
8 ]3 b; l1 D1 q" M
' W- ]4 N2 v+ ^* o1 u[ 本帖最后由 liangl923 于 2007-11-30 18:03 编辑 ]

szwgh

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

zerozha

楼主钻研精神值得敬佩。

ursace

  这个要支持！

cnwolf

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

wing2727

支持楼主~顶了

牛丸大神

噢乖 神人啊
$ a. t4 c" I* N% ^+ p) q* o$ z) W* \顶了 不管啥中文伴侣
3 y  }; H  ?5 {* b) _/ C1 @这样的帖子就该支持

liangl923

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

c5tg

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

liangl923

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

air

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