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

liangl923

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

' }! Q$ }1 a% s% v1 ?

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

! X$ e) z2 h& V! A& ?: g, T使用环境： outlook2007[支持vba]   其他没有试过 我觉得03应该没问题
* C6 `. w7 v* K# i/ s0 Z0 g& O                   修改vba运行权限： 工具》信任中心》宏安全性》不执行宏安全性检查  {用完后再改回系统默认}

4 i# j: g3 I9 V3 W! S; P; T使用方法： 先用treo和outlook同步
                  工具》宏》vb编辑器   》新建模块  拷入代码F5运行就好了  
2 |) x5 U& ], N& r1 I

代码
/ ~/ |3 w- A5 d9 I5 h7 G' f( AOption Explicit
Sub setpinyin()
    Dim myolApp As New Outlook.Application
9 ^2 b2 |+ K$ H2 _( {* Y    Dim myNamespace As Outlook.NameSpace
; N3 f' k9 i9 G" Q& R7 b; v* _    Dim myAddresslists As Outlook.folder
9 L3 F7 y! }3 j    Dim AddressList As Outlook.AddressList
    Dim item
" m+ p, t; c2 R8 `9 a    Dim temp1, temp2
( v( Q, N0 j. e! }2 t   
& d3 l4 v8 b0 c; `( d& S2 R8 @# }    Set myNamespace = myolApp.GetNamespace("MAPI")
    Set myAddresslists = myNamespace.GetDefaultFolder(olFolderContacts)
3 n, D$ T) t6 Z1 Y   ' Set myolApp = myNamespace.GetDefaultFolder(olFolderInbox)
    For Each item In myAddresslists.Items
   'temp1 = item.LastName & " " & item.FirstName
   
# P2 h( Z( Y: b   If item.LastName = "" Then
9 l2 r5 ?9 W4 \% Z            item.LastName = LCase(getpy(item.FirstName))
, W5 i7 w) _/ o& |            item.Save
; {4 U" [; r* S            Debug.Print item.LastName
8 Y) ?- _- H! r* t7 h- O$ F            
- ]7 e' b& _8 P   'MsgBox item.LastName
- d, N6 G0 w/ A  ^   
   End If
5 q8 v/ y  ?1 [, F5 F! n   
2 t4 h) u0 X) p) L- s% ~( a    Next
End Sub

Function getpychar(char) As String
/ M1 D2 r6 k" j2 B% p/ Q    On Error Resume Next
    Dim tmp As String, vs1 As String
( V: T& t% d5 J5 b7 `8 Z7 V   
  j/ \# U- l/ S5 w    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
! ^) U) F9 O1 p  }1 Z# O            getpychar = char
# N2 w1 D* ]% s" P, u        Else
            '如果是空格，排除
  {6 r. @" _. G* a& K: k& Q1 O# C            If Asc(char) = 32 Then
9 [! F' S, J; w% L: P$ n  c) U" P               getpychar = ""
; S+ J) K3 Y1 l3 g& y            Else
( ?% b( b$ h, g) z" G- p$ z            '
/ u) H- F; W$ v2 ^' P0 Q- {                getpychar = char
            End If
        End If
4 o- e# l. B3 O( L$ ]6 J    Else
& c' r% k7 S4 }        tmp = 65536 + Asc(char)
3 U, Z0 s5 |* X+ F1 [/ m        Select Case tmp
            Case 45217 To 45252: getpychar = "A"
            Case 45253 To 45760: getpychar = "B"
. L1 q6 p) y( ]5 A" x            Case 45761 To 46317: getpychar = "C"
            Case 46318 To 46825: getpychar = "D"
# a+ O: s* A, _            Case 46826 To 47009: getpychar = "E"
9 T/ G/ \5 t5 ~            Case 47010 To 47296: getpychar = "F"
2 c  f' {$ |5 L& ]2 s* e) z            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"
4 `, |! u: Z/ i- J4 E+ L7 n            Case 50371 To 50613: getpychar = "N"
            Case 50614 To 50621: getpychar = "O"
7 ?5 S- X: c  z% {            Case 50622 To 50905: getpychar = "P"
            Case 50906 To 51386: getpychar = "Q"
            Case 51387 To 51445: getpychar = "R"
            Case 51446 To 52217: getpychar = "S"
) `8 N  ~- U. r  J$ t/ e0 R  n( ?            Case 52218 To 52697: getpychar = "T"
            Case 52698 To 52979: getpychar = "W"
            Case 52980 To 53640: getpychar = "X"
            Case 53689 To 54480: getpychar = "Y"
# q: i$ R/ _0 c0 T- h            Case 54481 To 55289: getpychar = "Z"
            Case Else: getpychar = "%"
$ l6 @. ~- V$ ~! M3 J        End Select
    End If
8 b; I, Q' `; Z5 F2 B8 XEnd Function
Function getpy(str)
Dim i As Long
# A8 e1 J) A: T3 \( }# N5 S/ @    For i = 1 To Len(str)
, t: k/ `: s  ]+ L        getpy = getpy & getpychar(Mid(str, i, 1))
    Next i
End Function
2 n& C5 M1 Q% z; j" M" S
$ a0 Y' _  ~" q( \/ V[ 本帖最后由 liangl923 于 2007-11-30 18:03 编辑 ]

szwgh

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

zerozha

楼主钻研精神值得敬佩。

ursace

  这个要支持！

cnwolf

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

wing2727

支持楼主~顶了

牛丸大神

噢乖 神人啊
顶了 不管啥中文伴侣
! J. b5 A0 G% j2 s9 X" [! Q这样的帖子就该支持

liangl923

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

c5tg

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

liangl923

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

air

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