取汉字拼音首字符的Function

Option Explicit '功能:取汉字拼音首字母函数 '参数:as_data 要提取的汉字 '返回:汉字拼音首字母 '时间:2006 年 05 月 29 日 '设计:李成章 Public Function f_get_py(ByVal as_data As String) As String Dim ll_pos As Long Dim ls_py As String Dim ls_pos As String For ll_pos = 1 To Len(as_data) If Mid(as_data, ll_pos, 1) > 128 Then ls_py = ls_py + hz2py(Mid(as_data, ll_pos, 1)) Else ls_py = ls_py + Mid(as_data, ll_pos, 1) End If Next f_get_py = ls_py End Function Public Function hz2py(ByVal hz As String) As String Dim str1 As String '====================================以A开头的汉字====================================== str1 = "啊阿呵吖嗄腌锕錒" str1 = str1 & "爱矮挨哎碍癌艾唉哀蔼隘埃皑呆嗌嫒瑷暧捱砹嗳锿霭乃剀呃噫奇阂乂伌僾儗凒剴叆呝啀嘊噯堨塧壒娭娾嬡嵦愛懓懝敱敳昹曖欬欸毐溰溾濭烠焥璦皚皧瞹硋磑礙絠薆藹諰譪譺賹躷醷鎄鑀閡阨阸隑靄靉餲馤騃鯦鱫鴱" str1 = str1 & "按安暗岸俺案鞍氨胺厂广庵揞犴铵桉谙鹌埯黯干盒钳顸侒儑匼厈咹唵啽垵垾堓婩媕屽峖晻洝玵痷盦盫碪罯腤荌菴萻葊蓭裺誝諳豻貋遃鉗銨錌闇陰隂隌雸鞌韽頇頞馣鮟鴳鵪鶕" str1 = str1 & "昂肮盎仰卬岇昻枊醃醠骯" str1 = str1 & "袄凹傲奥熬懊敖翱澳嚣拗媪廒骜嗷坳遨聱螯獒鏊鳌鏖岙噢棍浇厫嗸嚻囂垇墺墽奡奧媼嫯岰嶅嶴慠扷抝摮擙柪梎泑滶澆澚熝爊獓璈眑磝磽礉翶翺芺蔜蝹襖謷謸軪郩鏕镺隞驁鰲鴁鴢鷔鼇 " If InStr(1, str1, hz, vbTextCompare) >= 1 Then hz2py = "A" Exit Function End If str1 = "" '====================================以B开头的汉字======================================" str1 = "把八吧爸拔罢跋巴芭扒坝霸叭靶笆疤耙捌粑茇岜鲅钯魃菝灞伯捭杷湃萆仈叐哱哵坺垻墢壩夿妭峇弝抜抪朳柭欛炦犮玐癹皅矲笩紦罷羓胈茷蚆覇詙豝跁軷釛釟鈀颰魞鮁鮊鲃鲌鼥把八吧爸拔罢跋巴芭扒坝霸叭靶笆疤耙捌粑茇岜鲅钯魃菝灞伯捭杷湃萆仈叐哱哵坺垻墢壩夿妭峇弝抜抪朳柭欛炦犮玐癹皅矲笩紦罷羓胈茷蚆覇詙豝跁軷釛釟鈀颰魞鮁鮊鲃鲌鼥" str1 = str1 & "百白摆败柏拜佰伯稗捭呗掰扒排派薜鞴唄庍拝挀擺敗栢猈竡粨粺絔薭襬贁鞁韛" str1 = str1 & "半办班般拌搬版斑板伴扳扮瓣颁绊癍坂钣舨阪瘢分...