Private Const IME_ESC_MAX_KEY = &H1005
Private Const IME_ESC_IME_NAME = &H1006
Private Const GCL_REVERSECONVERSION = &H2Private Type CANDIDATELIST
dwSize As Long
dwStyle As Long
dwCount As Long
dwSelection As Long
dwPageStart As Long
dwPageSize As Long
dwOffset(1) As Long
End TypePrivate Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long
Private Declare Function ImmEscape Lib "imm32.dll" Alias "ImmEscapeA" (ByVal hkl As Long, ByVal himc As Long, ByVal un As Long, lpv As Any) As Long
Private Declare Function ImmGetConversionList Lib "imm32.dll" Alias "ImmGetConversionListA" (ByVal hkl As Long, ByVal himc As Long, ByVal lpsz As String, lpCandidateList As Any, ByVal dwBufLen As Long, ByVal uFlag As Long) As Long
'Private Declare Function ImmGetConversionList Lib "imm32.dll" Alias "ImmGetConversionListA" (ByVal hkl As Long, ByVal himc As Long, ByVal lpsz As String, lpCandidateList As CANDIDATELIST, ByVal dwBufLen As Long, ByVal uFlag As Long) As Long
Private Declare Function IsDBCSLeadByte Lib "kernel32" (ByVal bTestChar As Byte) As LongPrivate Const NUM_OF_BUFFERS = 40
Private Const MSPY = "微软拼音输入法"
Dim imeHandle(1 To NUM_OF_BUFFERS) As Long
Dim imeName(1 To NUM_OF_BUFFERS) As StringDim mlMSPYIndex As Long
Dim imeCount As LongPrivate Sub Init()
Dim i As Long
Dim sName As StringmlMSPYIndex = 0
imeCount = GetKeyboardLayoutList(NUM_OF_BUFFERS, imeHandle(1))
If imeCount Then
For i = 1 To imeCount
sName = String(255, " ")
If ImmEscape(imeHandle(i), 0, IME_ESC_IME_NAME, ByVal sName) Then
If sName <> "" Then sName = Left(sName, InStr(sName, vbNullChar) - 1)
imeName(i) = sName
If sName = MSPY Then
mlMSPYIndex = i
End If
End If
Next i
End IfEnd SubPublic Property Get MSPYInstalled() As Boolean
MSPYInstalled = IIf(mlMSPYIndex, True, False)
End PropertyPublic Property Get MSPYIndex() As Long
MSPYIndex = mlMSPYIndex
End PropertyPublic Property Get Count() As Long
Count = imeCount
End PropertyPublic Function GetHandle(ByVal lIndex As Long) As Long
If lIndex >= 1 And lIndex <= imeCount Then
GetHandle = imeHandle(lIndex)
End If
End FunctionPublic Function GetName(ByVal lIndex As Long) As String
If lIndex >= 1 And lIndex <= imeCount Then
GetName = imeName(lIndex)
End If
End FunctionPublic Function MSPYReverse(ByVal sString As String) As String
Dim lStrLen As Long
Dim i As Long
Dim sChar As String
Dim bChar() As ByteIf MSPYInstalled Then
lStrLen = Len(sString)
MSPYReverse = ""
If lStrLen Then
For i = 1 To lStrLen
sChar = Mid(sString, i, 1)
bChar = StrConv(sChar, vbFromUnicode)
If IsDBCSLeadByte(bChar(0)) Then
Dim lMaxKey As Long
Dim lGCL As LonglMaxKey = ImmEscape(imeHandle(mlMSPYIndex), 0, IME_ESC_MAX_KEY, Null)
If lMaxKey Then
Dim tCandi As CANDIDATELIST
lGCL = ImmGetConversionList(imeHandle(mlMSPYIndex), 0, sChar, 0, 0, GCL_REVERSECONVERSION)
If lGCL > 0 Then
Dim bBuffer() As Byte
Dim MaxKey As Long
Dim sBuffer As String
sBuffer = String(255, vbNullChar)
MaxKey = lMaxKey
lGCL = ImmGetConversionList(imeHandle(mlMSPYIndex), 0, sChar, ByVal sBuffer, lGCL, GCL_REVERSECONVERSION)
If lGCL > 0 Then
Dim bPY() As Byte
Dim j As LongbBuffer = StrConv(sBuffer, vbFromUnicode)ReDim bPY(MaxKey * 2 - 1)
For j = bBuffer(24) To bBuffer(24) + MaxKey * 2 - 1
bPY(j - bBuffer(24)) = bBuffer(j)
Next j
sChar = StrConv(bPY, vbUnicode)If InStr(sChar, vbNullChar) Then
sChar = Trim(Left(sChar, InStr(sChar, vbNullChar) - 1))
End If
sChar = Left(sChar, Len(sChar) - 1) & " "
End If
End If
End If
End If
MSPYReverse = MSPYReverse & sChar
Next i
End If
Else
'替代方法
MSPYReverse = GetPYStr(sString)
End If
End FunctionPrivate Sub Class_Initialize()
Init
End SubPrivate Function GetPYChar(a1 As String) As String
Dim t1 As String
If Asc(a1) < 0 Then
t1 = Left(a1, 1)
If Asc(t1) < Asc("啊") Then
GetPYChar = " "
Exit Function
End If
If Asc(t1) >= Asc("啊") And Asc(t1) < Asc("芭") Then
GetPYChar = "A"
Exit Function
End If
If Asc(t1) >= Asc("芭") And Asc(t1) < Asc("擦") Then
GetPYChar = "B"
Exit Function
End If
If Asc(t1) >= Asc("擦") And Asc(t1) < Asc("搭") Then
GetPYChar = "C"
Exit Function
End If
If Asc(t1) >= Asc("搭") And Asc(t1) < Asc("蛾") Then
GetPYChar = "D"
Exit Function
End If
If Asc(t1) >= Asc("蛾") And Asc(t1) < Asc("发") Then
GetPYChar = "E"
Exit Function
End If
If Asc(t1) >= Asc("发") And Asc(t1) < Asc("噶") Then
GetPYChar = "F"
Exit Function
End If
If Asc(t1) >= Asc("噶") And Asc(t1) < Asc("哈") Then
GetPYChar = "G"
Exit Function
End If
If Asc(t1) >= Asc("哈") And Asc(t1) < Asc("击") Then
GetPYChar = "H"
Exit Function
End If
If Asc(t1) >= Asc("击") And Asc(t1) < Asc("喀") Then
GetPYChar = "J"
Exit Function
End If
If Asc(t1) >= Asc("喀") And Asc(t1) < Asc("垃") Then
GetPYChar = "K"
Exit Function
End If
If Asc(t1) >= Asc("垃") And Asc(t1) < Asc("妈") Then
GetPYChar = "L"
Exit Function
End If
If Asc(t1) >= Asc("妈") And Asc(t1) < Asc("拿") Then
GetPYChar = "M"
Exit Function
End If
If Asc(t1) >= Asc("拿") And Asc(t1) < Asc("哦") Then
GetPYChar = "N"
Exit Function
End If
If Asc(t1) >= Asc("哦") And Asc(t1) < Asc("啪") Then
GetPYChar = "O"
Exit Function
End If
If Asc(t1) >= Asc("啪") And Asc(t1) < Asc("期") Then
GetPYChar = "P"
Exit Function
End If
If Asc(t1) >= Asc("期") And Asc(t1) < Asc("然") Then
GetPYChar = "Q"
Exit Function
End If
If Asc(t1) >= Asc("然") And Asc(t1) < Asc("撒") Then
GetPYChar = "R"
Exit Function
End If
If Asc(t1) >= Asc("撒") And Asc(t1) < Asc("塌") Then
GetPYChar = "S"
Exit Function
End If
If Asc(t1) >= Asc("塌") And Asc(t1) < Asc("挖") Then
GetPYChar = "T"
Exit Function
End If
If Asc(t1) >= Asc("挖") And Asc(t1) < Asc("昔") Then
GetPYChar = "W"
Exit Function
End If
If Asc(t1) >= Asc("昔") And Asc(t1) < Asc("压") Then
GetPYChar = "X"
Exit Function
End If
If Asc(t1) >= Asc("压") And Asc(t1) < Asc("匝") Then
GetPYChar = "Y"
Exit Function
End If
If Asc(t1) >= Asc("匝") Then
GetPYChar = "Z"
Exit Function
End If
Else
If UCase(a1) <= "Z" And UCase(a1) >= "A" Then
GetPYChar = UCase(Left(a1, 1))
Else
GetPYChar = " "
End If
End If
End FunctionPrivate Function GetPYStr(ByVal S As String) As String
Dim l As Long
Dim sOut As StringIf S <> "" Then
For l = 1 To Len(S)
sOut = sOut & GetPYChar(Mid(S, l, 1))
Next l
GetPYStr = sOut
End If
End Function
Private Const IME_ESC_IME_NAME = &H1006
Private Const GCL_REVERSECONVERSION = &H2Private Type CANDIDATELIST
dwSize As Long
dwStyle As Long
dwCount As Long
dwSelection As Long
dwPageStart As Long
dwPageSize As Long
dwOffset(1) As Long
End TypePrivate Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long
Private Declare Function ImmEscape Lib "imm32.dll" Alias "ImmEscapeA" (ByVal hkl As Long, ByVal himc As Long, ByVal un As Long, lpv As Any) As Long
Private Declare Function ImmGetConversionList Lib "imm32.dll" Alias "ImmGetConversionListA" (ByVal hkl As Long, ByVal himc As Long, ByVal lpsz As String, lpCandidateList As Any, ByVal dwBufLen As Long, ByVal uFlag As Long) As Long
'Private Declare Function ImmGetConversionList Lib "imm32.dll" Alias "ImmGetConversionListA" (ByVal hkl As Long, ByVal himc As Long, ByVal lpsz As String, lpCandidateList As CANDIDATELIST, ByVal dwBufLen As Long, ByVal uFlag As Long) As Long
Private Declare Function IsDBCSLeadByte Lib "kernel32" (ByVal bTestChar As Byte) As LongPrivate Const NUM_OF_BUFFERS = 40
Private Const MSPY = "微软拼音输入法"
Dim imeHandle(1 To NUM_OF_BUFFERS) As Long
Dim imeName(1 To NUM_OF_BUFFERS) As StringDim mlMSPYIndex As Long
Dim imeCount As LongPrivate Sub Init()
Dim i As Long
Dim sName As StringmlMSPYIndex = 0
imeCount = GetKeyboardLayoutList(NUM_OF_BUFFERS, imeHandle(1))
If imeCount Then
For i = 1 To imeCount
sName = String(255, " ")
If ImmEscape(imeHandle(i), 0, IME_ESC_IME_NAME, ByVal sName) Then
If sName <> "" Then sName = Left(sName, InStr(sName, vbNullChar) - 1)
imeName(i) = sName
If sName = MSPY Then
mlMSPYIndex = i
End If
End If
Next i
End IfEnd SubPublic Property Get MSPYInstalled() As Boolean
MSPYInstalled = IIf(mlMSPYIndex, True, False)
End PropertyPublic Property Get MSPYIndex() As Long
MSPYIndex = mlMSPYIndex
End PropertyPublic Property Get Count() As Long
Count = imeCount
End PropertyPublic Function GetHandle(ByVal lIndex As Long) As Long
If lIndex >= 1 And lIndex <= imeCount Then
GetHandle = imeHandle(lIndex)
End If
End FunctionPublic Function GetName(ByVal lIndex As Long) As String
If lIndex >= 1 And lIndex <= imeCount Then
GetName = imeName(lIndex)
End If
End FunctionPublic Function MSPYReverse(ByVal sString As String) As String
Dim lStrLen As Long
Dim i As Long
Dim sChar As String
Dim bChar() As ByteIf MSPYInstalled Then
lStrLen = Len(sString)
MSPYReverse = ""
If lStrLen Then
For i = 1 To lStrLen
sChar = Mid(sString, i, 1)
bChar = StrConv(sChar, vbFromUnicode)
If IsDBCSLeadByte(bChar(0)) Then
Dim lMaxKey As Long
Dim lGCL As LonglMaxKey = ImmEscape(imeHandle(mlMSPYIndex), 0, IME_ESC_MAX_KEY, Null)
If lMaxKey Then
Dim tCandi As CANDIDATELIST
lGCL = ImmGetConversionList(imeHandle(mlMSPYIndex), 0, sChar, 0, 0, GCL_REVERSECONVERSION)
If lGCL > 0 Then
Dim bBuffer() As Byte
Dim MaxKey As Long
Dim sBuffer As String
sBuffer = String(255, vbNullChar)
MaxKey = lMaxKey
lGCL = ImmGetConversionList(imeHandle(mlMSPYIndex), 0, sChar, ByVal sBuffer, lGCL, GCL_REVERSECONVERSION)
If lGCL > 0 Then
Dim bPY() As Byte
Dim j As LongbBuffer = StrConv(sBuffer, vbFromUnicode)ReDim bPY(MaxKey * 2 - 1)
For j = bBuffer(24) To bBuffer(24) + MaxKey * 2 - 1
bPY(j - bBuffer(24)) = bBuffer(j)
Next j
sChar = StrConv(bPY, vbUnicode)If InStr(sChar, vbNullChar) Then
sChar = Trim(Left(sChar, InStr(sChar, vbNullChar) - 1))
End If
sChar = Left(sChar, Len(sChar) - 1) & " "
End If
End If
End If
End If
MSPYReverse = MSPYReverse & sChar
Next i
End If
Else
'替代方法
MSPYReverse = GetPYStr(sString)
End If
End FunctionPrivate Sub Class_Initialize()
Init
End SubPrivate Function GetPYChar(a1 As String) As String
Dim t1 As String
If Asc(a1) < 0 Then
t1 = Left(a1, 1)
If Asc(t1) < Asc("啊") Then
GetPYChar = " "
Exit Function
End If
If Asc(t1) >= Asc("啊") And Asc(t1) < Asc("芭") Then
GetPYChar = "A"
Exit Function
End If
If Asc(t1) >= Asc("芭") And Asc(t1) < Asc("擦") Then
GetPYChar = "B"
Exit Function
End If
If Asc(t1) >= Asc("擦") And Asc(t1) < Asc("搭") Then
GetPYChar = "C"
Exit Function
End If
If Asc(t1) >= Asc("搭") And Asc(t1) < Asc("蛾") Then
GetPYChar = "D"
Exit Function
End If
If Asc(t1) >= Asc("蛾") And Asc(t1) < Asc("发") Then
GetPYChar = "E"
Exit Function
End If
If Asc(t1) >= Asc("发") And Asc(t1) < Asc("噶") Then
GetPYChar = "F"
Exit Function
End If
If Asc(t1) >= Asc("噶") And Asc(t1) < Asc("哈") Then
GetPYChar = "G"
Exit Function
End If
If Asc(t1) >= Asc("哈") And Asc(t1) < Asc("击") Then
GetPYChar = "H"
Exit Function
End If
If Asc(t1) >= Asc("击") And Asc(t1) < Asc("喀") Then
GetPYChar = "J"
Exit Function
End If
If Asc(t1) >= Asc("喀") And Asc(t1) < Asc("垃") Then
GetPYChar = "K"
Exit Function
End If
If Asc(t1) >= Asc("垃") And Asc(t1) < Asc("妈") Then
GetPYChar = "L"
Exit Function
End If
If Asc(t1) >= Asc("妈") And Asc(t1) < Asc("拿") Then
GetPYChar = "M"
Exit Function
End If
If Asc(t1) >= Asc("拿") And Asc(t1) < Asc("哦") Then
GetPYChar = "N"
Exit Function
End If
If Asc(t1) >= Asc("哦") And Asc(t1) < Asc("啪") Then
GetPYChar = "O"
Exit Function
End If
If Asc(t1) >= Asc("啪") And Asc(t1) < Asc("期") Then
GetPYChar = "P"
Exit Function
End If
If Asc(t1) >= Asc("期") And Asc(t1) < Asc("然") Then
GetPYChar = "Q"
Exit Function
End If
If Asc(t1) >= Asc("然") And Asc(t1) < Asc("撒") Then
GetPYChar = "R"
Exit Function
End If
If Asc(t1) >= Asc("撒") And Asc(t1) < Asc("塌") Then
GetPYChar = "S"
Exit Function
End If
If Asc(t1) >= Asc("塌") And Asc(t1) < Asc("挖") Then
GetPYChar = "T"
Exit Function
End If
If Asc(t1) >= Asc("挖") And Asc(t1) < Asc("昔") Then
GetPYChar = "W"
Exit Function
End If
If Asc(t1) >= Asc("昔") And Asc(t1) < Asc("压") Then
GetPYChar = "X"
Exit Function
End If
If Asc(t1) >= Asc("压") And Asc(t1) < Asc("匝") Then
GetPYChar = "Y"
Exit Function
End If
If Asc(t1) >= Asc("匝") Then
GetPYChar = "Z"
Exit Function
End If
Else
If UCase(a1) <= "Z" And UCase(a1) >= "A" Then
GetPYChar = UCase(Left(a1, 1))
Else
GetPYChar = " "
End If
End If
End FunctionPrivate Function GetPYStr(ByVal S As String) As String
Dim l As Long
Dim sOut As StringIf S <> "" Then
For l = 1 To Len(S)
sOut = sOut & GetPYChar(Mid(S, l, 1))
Next l
GetPYStr = sOut
End If
End Function
Select Case hz
Case "吖", "锕", "嗄", "锿", "捱", "嗳", "霭", "砹", "嗌", "嫒", "暧", "瑷", "桉", "庵", "谙", "鹌", "埯", "铵", "揞", "犴", "黯", "坳", "嗷", _
"廒", "獒", "遨", "聱", "螯", "鳌", "鏖", "媪", "岙", "骜", "鏊"
getpy = "A"
Case "岜", "粑", "茇", "菝", "魃", "鲅", "灞", "掰", "捭", "呗", "瘢", "癍", "阪", "坂", "钣", "舨", "浜", "蒡", "勹", "孢", "煲", "龅", "鸨", _
"葆", "褓", "趵", "陂", "鹎", "邶", "悖", "碚", "蓓", "褙", "鞴", "鐾", "贲", "锛", "畚", "坌", "嘣", "甏", "荸", "匕", "吡", "妣", "秕", "俾", _
"舭", "畀", "哔", "荜", "狴", "铋", "婢", "庳", "萆", "弼", "愎", "筚", "滗", "裨", "跸", "箅", "嬖", "篦", "薜", "濞", "髀", "璧", "襞", "砭", _
"笾", "煸", "蝙", "鳊", "窆", "匾", "碥", "褊", "弁", "忭", "汴", "苄", "缏", "飑", "髟", "骠", "瘭", "镖", "飙", "飚", "镳", "婊", "裱", "鳔", _
"蹩", "傧", "缤", "槟", "镔", "豳", "殡", "膑", "髌", "鬓", "邴", "禀", "摒", "饽", "啵", "孛", "亳", "钹", "鹁", "踣", "礴", "跛", "簸", "擘", _
"檗", "逋", "钸", "晡", "醭", "卟", "钚", "瓿", "玢", "宀", "疒"
getpy = "B"
Case "嚓", "礤", "骖", "黪", "粲", "璨", "伧", "嘈", "漕", "艚", "螬", "艹", "恻", "岑", "涔", "噌", "杈", "馇", "锸", "猹", "槎", "檫", "衩", _
"镲", "汊", "姹", "钗", "侪", "虿", "瘥", "觇", "婵", "孱", "禅", "廛", "潺", "镡", "蟾", "躔", "谄", "蒇", "冁", "忏", "羼", "伥", "娼", "菖", _
"阊", "鲳", "苌", "徜", "嫦", "昶", "惝", "氅", "怅", "鬯", "怊", "焯", "晁", "耖", "砗", "屮", "坼", "抻", "琛", "嗔", "宸", "谌", "碜", "龀", _
"榇", "谶", "柽", "蛏", "铛", "瞠", "丞", "枨", "埕", "铖", "裎", "塍", "酲", "哧", "蚩", "鸱", "眵", "笞", "嗤", "媸", "螭", "魑", "茌", "墀", _
"踟", "篪", "豉", "褫", "彳", "叱", "饬", "敕", "啻", "傺", "瘛", "忡", "茺", "舂", "憧", "艟", "铳", "瘳", "俦", "帱", "惆", "雠", "樗", "刍", _
"蜍", "蹰", "杵", "楮", "褚", "亍", "怵", "绌", "憷", "黜", "搋", "啜", "嘬", "踹", "巛", "氚", "舡", "遄", "舛", "钏", "怆", "陲", "棰", "槌", _
"蝽", "莼", "鹑", "踔", "辍", "龊", "呲", "祠", "茈", "鹚", "糍", "苁", "枞", "骢", "璁", "淙", "琮", "楱", "腠", "辏", "徂", "殂", "猝", "蔟", _
"蹙", "蹴", "汆"
getpy = "C"
Case "哒", "耷", "嗒", "褡", "妲", "怛", "笪", "靼", "鞑", "岱", "甙", "绐", "迨", "玳", "埭", "黛", "眈", "聃", "殚", "瘅", "箪", "儋", "疸", "啖", _
"萏", "澹", "裆", "谠", "凼", "宕", "砀", "菪", "叨", "忉", "氘", "纛", "锝", "噔", "簦", "戥", "嶝", "磴", "镫", "羝", "嘀", "镝", "籴", "荻", "觌", _
"氐", "诋", "邸", "坻", "柢", "砥", "骶", "娣", "谛", "棣", "睇", "碲", "嗲", "巅", "癫", "踮", "阽", "坫", "玷", "钿", "癜", "簟", "貂", "鲷", "铞", _
"垤", "瓞", "堞", "揲", "耋", "牒", "蹀", "鲽", "仃", "玎", "疔", "耵", "酊", "啶", "腚", "碇", "铥", "咚", "岽", "氡", "鸫", "垌", "峒", "胨", "胴", _
"硐", "蔸", "篼", "蚪", "窦", "嘟", "渎", "椟", "牍", "黩", "髑", "笃", "芏", "蠹", "椴", "煅", "簖", "怼", "碓", "憝", "镦", "礅", "盹", "趸", "沌", _
"炖", "砘", "咄", "裰", "铎", "踱", "哚", "缍", "沲", "卩", "亻", "赕", "铫", "町", "铤", "夂", "丶"
getpy = "D"
Case "屙", "莪", "锇", "婀", "呃", "苊", "轭", "垩", "谔", "阏", "愕", "萼", "腭", "锷", "鹗", "颚", "噩", "鳄", "蒽", "摁", "鸸", "鲕", "迩", "珥", _
"铒", "佴", "嗯", "唔", "诶"
getpy = "E"
Case "垡", "砝", "幡", "蕃", "燔", "蹯", "蘩", "畈", "梵", "邡", "枋", "钫", "鲂", "舫", "妃", "绯", "扉", "蜚", "霏", "鲱", "淝", "腓", "悱", "斐", _
"榧", "翡", "篚", "狒", "痱", "镄", "棼", "鼢", "偾", "鲼", "瀵", "沣", "砜", "葑", "酆", "唪", "俸", "缶", "呋", "趺", "麸", "稃", "跗", "凫", "孚", _
"芙", "芾", "怫", "绂", "绋", "苻", "祓", "罘", "茯", "郛", "砩", "莩", "蚨", "匐", "桴", "艴", "菔", "蜉", "幞", "蝠", "黻", "拊", "滏", "黼", "驸", _
"鲋", "赙", "蝮", "鳆", "馥", "攵", "犭"
getpy = "F"
Case "旮", "伽", "钆", "尜", "尕", "尬", "陔", "垓", "赅", "丐", "戤", "坩", "泔", "苷", "疳", "酐", "尴", "澉", "橄", "擀", "旰", "矸", "绀", "淦", _
"罡", "筻", "戆", "槔", "睾", "杲", "缟", "槁", "藁", "诰", "郜", "锆", "圪", "纥", "袼", "鬲", "嗝", "塥", "搿", "膈", "镉", "骼", "哿", "舸", "虼", _
"硌", "哏", "亘", "艮", "茛", "赓", "哽", "绠", "鲠", "肱", "蚣", "觥", "珙", "佝", "缑", "篝", "鞲", "岣", "枸", "笱", "诟", "媾", "彀", "遘", "觏", _
"轱", "鸪", "菰", "蛄", "觚", "酤", "毂", "鹘", "汩", "诂", "牯", "罟", "钴", "嘏", "臌", "瞽", "崮", "梏", "牿", "痼", "锢", "鲴", "胍", "鸹", "呱", _
"卦", "诖", "倌", "鳏", "掼", "涫", "盥", "鹳", "咣", "桄", "胱", "犷", "妫", "皈", "鲑", "宄", "庋", "匦", "晷", "簋", "刿", "炅", "鳜", "衮", "绲", _
"磙", "鲧", "呙", "埚", "崞", "聒", "蝈", "帼", "掴", "虢", "馘", "猓", "椁", "蜾", "桧", "莞", "呷"
getpy = "G"
Case "鹄", "铪", "嗨", "胲", "醢", "顸", "蚶", "鼾", "邗", "晗", "焓", "菡", "颔", "撖", "瀚", "绗", "颃", "沆", "蒿", "嚆", "薅", "蚝", "嗥", "濠", _
"昊", "皓", "颢", "灏", "诃", "嗬", "劾", "曷", "盍", "颌", "阖", "翮", "壑", "桁", "珩", "蘅", "訇", "薨", "闳", "泓", "荭", "蕻", "黉", "讧", "瘊", _
"篌", "糇", "骺", "後", "逅", "堠", "鲎", "虍", "烀", "轷", "唿", "惚", "滹", "囫", "斛", "猢", "煳", "鹕", "槲", "醐", "觳", "浒", "琥", "冱", "岵", _
"怙", "戽", "祜", "笏", "扈", "瓠", "鹱", "骅", "铧", "桦", "踝", "獾", "洹", "萑", "锾", "寰", "缳", "鬟", "奂", "浣", "逭", "漶", "鲩", "擐", "肓", _
"隍", "徨", "湟", "遑", "潢", "璜", "篁", "癀", "蟥", "鳇", "诙", "咴", "虺", "晖", "珲", "麾", "隳", "洄", "茴", "哕", "浍", "荟", "恚", "彗", "喙", _
"缋", "蕙", "蟪", "阍", "馄", "诨", "溷", "耠", "锪", "劐", "攉", "钬", "夥", "镬", "嚯", "藿", "蠖", "砉", "圜"
getpy = "H"
'case
'getpy= "i"
Case "丌", "叽", "乩", "玑", "芨", "矶", "咭", "剞", "唧", "屐", "笄", "嵇", "犄", "赍", "跻", "畿", "齑", "墼", "羁", "岌", "亟", "佶", "笈", "戢", "殛", "楫", "蒺", "瘠", "蕺", "虮", "掎", "戟", "嵴", "麂", "芰", "哜", "洎", "觊", "偈", "暨", "跽", "霁", "鲚", "稷", "鲫", "髻", "骥", "迦", "浃", "珈", "痂", "笳", "袈", "葭", "跏", "镓", "岬", "郏", "恝", "戛", "铗", "蛱", "胛", "瘕", "戋", "菅", "湔", _
"犍", "搛", "缣", "蒹", "鲣", "鹣", "鞯", "囝", "枧", "笕", "趼", "睑", "裥", "锏", "谫", "戬", "翦", "謇", "蹇", "牮", "谏", "楗", "毽", "腱", "僭", "踺", "茳", "豇", "缰", "礓", "耩", "洚", "绛", "犟", "糨", "艽", "姣", "茭", "蛟", "跤", "僬", "鲛", "鹪", "佼", "挢", "皎", "敫", "徼", "噍", "醮", "疖", "喈", "嗟", "孑", "讦", "诘", "拮", "桀", "婕", "颉", "碣", "鲒", "羯", "蚧", "骱", "钅", "矜", "衿", _
"卺", "堇", "廑", "馑", "槿", "瑾", "妗", "荩", "赆", "缙", "觐", "噤", "泾", "旌", "菁", "腈", "阱", "刭", "肼", "儆", "憬", "弪", "迳", "胫", "婧", "獍", "扃", "迥", "鸠", "赳", "阄", "啾", "鬏", "柩", "桕", "噘", "孓", "珏", "崛", "桷", "觖", "厥", "劂", "谲", "獗", "蕨", "橛", "镢", "蹶", "矍", "爝", "皲", "筠", "麇", "捃", "纟", "廴"
getpy = "J"
Case "蚵", "咔", "佧", "胩", "锎", "剀", "垲", "恺", "铠", "蒈", "锴", "忾", "龛", "戡", "侃", "莰", "阚", "瞰", "伉", "闶", "钪", "尻", "栲", "铐", "犒", "珂", "轲", "疴", "钶", "颏", "稞", "窠", "瞌", "蝌", "髁", "岢", "恪", "氪", "骒", "缂", "嗑", "溘", "锞", "裉", "铿", "倥", "崆", "箜", "芤", "眍", "叩", "筘", "蔻", "刳", "堀", "骷", "绔", "喾", "侉", "蒯", "郐", "哙", "狯", "脍", "髋", "诓", "哐", _
"诳", "夼", "邝", "圹", "纩", "贶", "悝", "逵", "馗", "喹", "揆", "暌", "睽", "蝰", "夔", "跬", "匮", "喟", "愦", "蒉", "篑", "聩", "琨", "锟", "髡", "醌", "鲲", "悃", "阃", "栝", "蛞"
getpy = "K"
Case "冫", "靓", "邋", "旯", "砬", "剌", "瘌", "崃", "徕", "涞", "铼", "赉", "睐", "濑", "癞", "籁", "岚", "褴", "斓", "镧", "榄", "漤", "罱", "啷", "莨", "稂", "锒", "螂", "阆", "蒗", "唠", "崂", "痨", "铹", "醪", "栳", "铑", "耢", "仂", "叻", "泐", "鳓", "嫘", "缧", "檑", "羸", "耒", "诔", "酹", "嘞", "塄", "愣", "骊", "喱", "鹂", "缡", "蓠", "蜊", "嫠", "鲡", "罹", "藜", "黧", "蠡", "俚", "娌", "逦", _
"锂", "澧", "醴", "鳢", "呖", "坜", "苈", "戾", "枥", "疠", "俪", "栎", "疬", "轹", "郦", "猁", "砺", "莅", "唳", "笠", "粝", "蛎", "詈", "跞", "雳", "溧", "篥", "奁", "裢", "鲢", "濂", "臁", "蠊", "琏", "裣", "蔹", "娈", "殓", "楝", "潋", "椋", "墚", "踉", "魉", "嘹"
"弩", "胬", "钕", "恧", "衄", "傩", "喏", "搦", "锘", "恁"
getpy = "N"
Case "噢", "讴", "瓯", "耦", "怄"
getpy = "O"
Case "钯", "拚", "彷", "冖", "葩", "杷", "筢", "俳", "哌", "蒎", "爿", "蹒", "蟠", "泮", "袢", "襻", "滂", "逄", "螃", "脬", "庖", "狍", "匏", "疱", "醅", "锫", "帔", "旆", "辔", "霈", "湓", "怦", "嘭", "堋", "蟛", "丕", "纰", "邳", "铍", "噼", "芘", "枇", "蚍", "郫", "陴", "埤", "罴", "蜱", "貔", "鼙", "庀", "仳", "圮", "擗", "癖", "淠", "媲", "睥", "甓", "犏", "翩", "骈", "胼", "蹁", "谝", "剽", "缥", _
"螵", "殍", "瞟", "嘌", "嫖", "氕", "丿", "苤", "姘", "嫔", "颦", "榀", "牝", "娉", "俜", "枰", "鲆", "钋", "鄱", "皤", "叵", "钷", "笸", "珀", "掊", "裒", "攴", "噗", "匍", "璞", "濮", "镤", "溥", "氆", "镨", "蹼"
getpy = "P"
Case "匚", "袷", "湫", "峤", "趄", "瞿", "桤", "萋", "嘁", "槭", "蹊", "亓", "圻", "岐", "芪", "耆", "颀", "淇", "萁", "骐", "琦", "琪", "祺", "蛴", "綦", "蜞", "蕲", "鳍", "麒", "屺", "芑", "杞", "绮", "綮", "汔", "荠", "葺", "碛", "憩", "葜", "髂", "阡", "芊", "佥", "岍", "悭", "愆", "骞", "搴", "褰", "钤", "虔", "掮", "箝", "肷", "慊", "缱", "芡", "茜", "倩", "椠", "戕", "戗", "跄", "蜣", "锖", "锵", _
"镪", "嫱", "樯", "羟", "襁", "炝", "硗", "跷", "劁", "缲", "荞", "谯", "憔", "鞒", "樵", "愀", "诮", "妾", "挈", "惬", "箧", "锲", "衾", "芩", "嗪", "溱", "噙", "檎", "螓", "锓", "吣", "揿", "圊", "蜻", "鲭", "檠", "黥", "苘", "謦", "箐", "磬", "罄", "跫", "銎", "邛", "穹", "茕", "筇", "蛩", "蚯", "楸", "鳅", "犰", "虬", "俅", "逑", "赇", "巯", "遒", "裘", "蝤", "鼽", "糗", "岖", "诎", "祛", "蛐", "麴", _
"黢", "劬", "朐", "鸲", "蕖", "磲", "璩", "蘧", "氍", "癯", "衢", "蠼", "阒", "觑", "悛", "诠", "荃", "辁", "铨", "筌", "蜷", "鬈", "畎", "绻", "悫", "阕", "阙", "逡", "郄"
getpy = "Q"
Case "蚺", "髯", "苒", "禳", "穰", "荛", "桡", "娆", "荏", "稔", "仞", "轫", "饪", "衽", "肜", "狨", "嵘", "榕", "蝾", "糅", "蹂", "鞣", "铷", "嚅", "濡", "薷", "襦", "颥", "洳", "溽", "缛", "蓐", "朊", "蕤", "芮", "枘", "蚋", "睿", "偌", "箬"
getpy = "R"
Case "灬", "杓", "丨", "凵", "葚", "仨", "卅", "飒", "脎", "噻", "毵", "糁", "馓", "搡", "磉", "颡", "缫", "臊", "鳋", "埽", "瘙", "啬", "铯", "穑", "铩", "痧", "裟", "鲨", "唼", "歃", "霎", "彡", "芟", "姗", "钐", "埏", "舢", "跚", "潸", "膻", "讪", "疝", "骟", "鄯", "嬗", "蟮", "鳝", "殇", "觞", "熵", "垧", "绱", "筲", "艄", "蛸", "劭", "潲", "猞", "畲", "佘", "厍", "滠", "麝", "诜", "哂", "矧", "谂", _
"渖", "胂", "椹", "蜃", "笙", "眚", "晟", "嵊", "蓍", "酾", "鲺", "饣", "炻", "埘", "莳", "鲥", "豕", "礻", "贳", "舐", "轼", "铈", "弑", "谥", "筮", "螫", "艏", "狩", "绶", "殳", "纾", "姝", "倏", "菽", "摅", "毹", "秫", "塾", "沭", "腧", "澍", "唰", "蟀", "闩", "涮", "孀", "氵", "妁", "铄", "嗍", "搠", "蒴", "槊", "厶", "咝", "鸶", "缌", "蛳", "厮", "锶", "澌", "汜", "兕", "姒", "祀", "泗", "驷", "俟", _
"笥", "耜", "忪", "凇", "崧", "淞", "菘", "嵩", "悚", "竦", "嗖", "溲", "馊", "飕", "锼", "螋", "叟", "嗾", "瞍", "薮", "稣", "夙", "涑", "谡", "嗉", "愫", "蔌", "觫", "簌", "狻", "荽", "眭", "睢", "濉", "谇"
getpy = "S"
Case "沓", "呔", "焘", "钭", "冂", "苕", "扌", "趿", "铊", "溻", "鳎", "闼", "遢", "榻", "骀", "邰", "炱", "跆", "鲐", "薹", "肽", "钛", "昙", "郯", "覃", "锬", "忐", "钽", "铴", "羰", "镗", "饧", "溏", "瑭", "樘", "螗", "螳", "醣", "帑", "傥", "耥", "韬", "饕", "洮", "啕", "鼗", "忑", "忒", "铽", "慝", "滕", "绨", "缇", "鹈", "醍", "倜", "悌", "逖", "裼", "畋", "阗", "忝", "殄", "掭", "佻", "祧", "笤", _
"龆", "蜩", "髫", "鲦", "窕", "粜", "萜", "餮", "莛", "婷", "葶", "蜓", "霆", "梃", "嗵", "仝", "佟", "茼", "砼", "僮", "潼", "恸", "骰", "荼", "酴", "钍", "堍", "菟", "抟", "疃", "彖", "煺", "暾", "饨", "豚", "氽", "乇", "佗", "坨", "沱", "柁", "砣", "跎", "酡", "橐", "鼍", "庹", "柝", "箨"
'getpy= "T"
'case
'getpy= "u"
'case
getpy = "V"
Case "亠", "娲", "佤", "腽", "崴", "剜", "蜿", "纨", "芄", "绾", "脘", "菀", "琬", "畹", "罔", "惘", "辋", "魍", "偎", "逶", "隈", "葳", "煨", "薇", "囗", "帏", "沩", "闱", "涠", "帷", "嵬", "炜", "玮", "洧", "娓", "诿", "隗", "猥", "痿", "艉", "韪", "鲔", "軎", "猬", "阌", "雯", "刎", "汶", "璺", "蓊", "蕹", "倭", "莴", "喔", "肟", "幄", "渥", "硪", "龌", "圬", "邬", "浯", "蜈", "鼯", "仵", "妩", "庑", "忤", "怃", "迕", "牾", "鹉", "兀", "阢", "杌", "芴", "焐", "婺", "痦", "骛", "寤", "鹜", "鋈"
getpy = "W"
Case "郇", "彐", "噱", "荨", "圩", "兮", "穸", "郗", "唏", "奚", "浠", "欷", "淅", "菥", "粞", "翕", "舾", "皙", "僖", "蜥", "嬉", "樨", "歙", "熹", "羲", "螅", "蟋", "醯", "曦", "鼷", "觋", "隰", "玺", "徙", "葸", "屣", "蓰", "禧", "饩", "阋", "舄", "禊", "狎", "柙", "硖", "遐", "瑕", "黠", "罅", "氙", "祆", "籼", "莶", "跹", "酰", "暹", "娴", "痫", "鹇", "冼", "猃", "蚬", "筅", "跣", "藓", "燹", "岘", "苋", "霰", "芗", "缃", "葙", "骧", "庠", "饷", "飨", "鲞", "蟓", "枭", "哓", "枵", "骁", "绡", "逍", "潇", "箫", "魈", "崤", "筱", "偕", _
"勰", "撷", "缬", "绁", "亵", "渫", "榍", "榭", "廨", "獬", "薤", "邂", "燮", "瀣", "躞", "昕", "歆", "馨", "鑫", "囟", "陉", "硎", "擤", "荇", "悻", "芎", "咻", "庥", "鸺", "貅", "馐", "髹", "岫", "溴", "盱", "胥", "顼", "诩", "栩", "糈", "醑", "洫", "勖", "溆", "煦", "蓿", "谖", "揎", "萱", "暄", "煊", "儇", "痃", "漩", "璇", "泫", "炫", "铉", "渲", "楦", "碹", "镟", "泶", "踅", "鳕", "谑", "埙", "窨", "獯", "薰", "曛", "醺", "峋", "恂", "洵", "浔", "荀", "鲟", "徇", "巽"
getpy = "X"
Case "肀", "剡", "桠", "伢", "岈", "琊", "睚", "痖", "迓", "垭", "娅", "砑", "氩", "揠", "恹", "胭", "崦", "菸", "湮", "腌", "鄢", "嫣", "讠", "闫", "妍", "芫", "筵", "檐", "兖", "俨", "偃", "厣", "郾", "琰", "罨", "魇", "鼹", "晏", "焱", "滟", "酽", "谳", "餍", "赝", "泱", "鞅", "炀", "徉", "烊", "蛘", "怏", "恙", "幺", "夭", "吆", "爻", "肴", "轺", "珧", "徭", "繇", "鳐", "杳", "窈", "崾", "鹞", "曜", "揶", "铘", "邺", "晔", "烨", "谒", "靥", "衤", "咿", "猗", "欹", "漪", "噫", "黟", "圯", "诒", "怡", "迤", "饴", "咦", "荑", "贻", "眙", _
"酏", "痍", "嶷", "钇", "苡", "舣", "旖", "弋", "刈", "仡", "佚", "呓", "佾", "峄", "怿", "驿", "奕", "弈", "羿", "轶", "悒", "挹", "埸", "翊", "缢", "瘗", "蜴", "熠", "镒", "劓", "殪", "薏", "翳", "癔", "镱", "懿", "洇", "氤", "铟", "喑", "堙", "垠", "狺", "鄞", "夤", "龈", "霪", "吲", "蚓", "瘾", "茚", "胤", "莺", "瑛", "嘤", "撄", "罂", "璎", "鹦", "膺", "茔", "荥", "萦", "楹", "滢", "蓥", "潆", "嬴", "瀛", "郢", "颍", "瘿", "媵", "唷", "邕", "墉", "慵", "壅", "镛", "鳙", "狳", "谀", "馀", "萸", "雩", "嵛", "揄", "腴", "瑜", "觎", "窬", "蝓", "伛", "俣", "圄", "圉", "庾", "瘐", "窳", "龉", "聿", "妪", "饫", "昱", "钰", "谕", "阈", "鹆", "煜", "蓣", "毓", "蜮", "燠", "鹬", "鬻", "鸢", "眢", "箢", "沅", "爰", "鼋", "塬", "橼", "螈", "垸", "媛", "掾", "瑗", "刖", "钺", "樾", "龠", "瀹", "纭", "芸", "昀", "氲", "狁", "殒", "郓", "恽", "愠", "韫", "熨"
getpy = "Y"
Case "辶", "酢", "喋", "阝", "咂", "拶", "甾", "崽", "糌", "簪", "昝", "趱", "錾", "瓒", "臧", "驵", "奘", "唣", "迮", "啧", "帻", "笮", "舴", "箦", "赜", "仄", "昃", "谮", "缯", "罾", "锃", "甑", "吒", "哳", "揸", "楂", "齄", "砟", "咤", "痄", "蚱", "砦", "瘵", "旃", "谵", "搌", "鄣", "嫜", "獐", "璋", "蟑", "仉", "嶂", "幛", "钊", "啁", "诏", "笊", "棹", "蜇", "辄", "谪", "摺", "磔", "赭", "褶", "柘", "鹧", "浈", "桢", "祯", "蓁", "榛", "箴", "胗", "轸", "畛", "缜", "稹", "圳", "鸩", "朕", "赈", "峥", "钲", "铮", "筝", "徵", "诤", "卮", _
"栀", "祗", "胝", "埴", "絷", "跖", "摭", "踯", "芷", "祉", "咫", "枳", "轵", "黹", "酯", "忮", "豸", "帙", "郅", "栉", "陟", "桎", "贽", "轾", "鸷", "彘", "痣", "蛭", "骘", "雉", "膣", "觯", "踬", "舯", "锺", "螽", "冢", "踵", "妯",
'//函数入口为汉字串，返回值为该汉字的第一个字母
Public Function getHzPy(hzStr As String) As String
'declare variable
Dim myHzm As Integer
Dim qm As Integer
Dim wm As Integer
Dim hznm As String
If Len(hzStr) > 1 Then
myHzm = Asc(Left(hzStr, 1))
Else
myHzm = Asc(hzStr)
End If
If myHzm >= 0 And myHzm < 256 Then
'字母
getHzPy = hzStr
Else
'汉字
qm = (myHzm + 65536) \ 256
wm = (myHzm + 65536) Mod 256
'十进制到十六进制
hznm = tento(qm, 16) & tento(wm, 16)
End If
If "B0A1" <= hznm And hznm <= "B0C4" Then
getHzPy = "A"
ElseIf "B0C5" <= hznm And hznm <= "B2C0" Then
getHzPy = "B"
ElseIf "B2C1" <= hznm And hznm <= "B4ED" Then
getHzPy = "C"
ElseIf "B4EE" <= hznm And hznm <= "B6E9" Then
getHzPy = "D"
ElseIf "B6EA" <= hznm And hznm <= "B7A1" Then
getHzPy = "E"
ElseIf "B7A2" <= hznm And hznm <= "B8C0" Then
getHzPy = "F"
ElseIf "B8C1" <= hznm And hznm <= "B9FD" Then
getHzPy = "G"
ElseIf "B9FE" <= hznm And hznm <= "BBF6" Then
getHzPy = "H"
ElseIf "BBF7" <= hznm And hznm <= "BFA5" Then
getHzPy = "J"
ElseIf "BFA6" <= hznm And hznm <= "C0AB" Then
getHzPy = "K"
ElseIf "C0AC" <= hznm And hznm <= "C2E7" Then
getHzPy = "L"
ElseIf "C2E8" <= hznm And hznm <= "C4C2" Then
getHzPy = "M"
ElseIf "C4C3" <= hznm And hznm <= "C5B5" Then
getHzPy = "N"
ElseIf "C5B6" <= hznm And hznm <= "C5BD" Then
getHzPy = "O"
ElseIf "C5BE" <= hznm And hznm <= "C6D9" Then
getHzPy = "P"
ElseIf "C6DA" <= hznm And hznm <= "C8BA" Then
getHzPy = "Q"
ElseIf "C8BB" <= hznm And hznm <= "C8F5" Then
getHzPy = "R"
ElseIf "C8F6" <= hznm And hznm <= "CBF9" Then
getHzPy = "S"
ElseIf "CBFA" <= hznm And hznm <= "CDD9" Then
getHzPy = "T"
ElseIf "CDDA" <= hznm And hznm <= "CEF3" Then
getHzPy = "W"
ElseIf "CEF4" <= hznm And hznm <= "D1B8" Then
getHzPy = "X"
ElseIf "D1B9" <= hznm And hznm <= "D4D0" Then
getHzPy = "Y"
ElseIf "D4D1" <= hznm And hznm <= "D7F9" Then
getHzPy = "Z"
Else
getHzPy = getpy(hzStr)
End If
End Function
'************************辅助函数，可以从十进制转换到任意进制**********************
'//入口为十进制数，要转换的进制，返回为该进制数
Public Function tento(m As Integer, n As Integer) As String
Dim q As Integer
Dim r As Integer
tento = ""
Dim bStr As String
Do
Call myDivide(m, n, q, r)
If r > 9 Then
bStr = Chr(55 + r)
Else
bStr = Str(r)
End If
tento = Trim(bStr) & tento
m = q
Loop While q <> 0
End Function
'************************辅助过程，得到任意两个数的商和余数***************************
Public Sub myDivide(num1 As Integer, num2 As Integer, q As Integer, r As Integer)
If num2 = 0 Then
MsgBox "非法除数", vbInformation, "信息"
Exit Sub
End If
If num1 / num2 >= 0 Then
q = Int(num1 / num2)
Else
q = Int(num1 / num2) + 1
End If
r = num1 Mod num2
End Sub
Public Function GetHzPYString(pHZ As String) As String
Dim hzpy As String
Dim hz As String
Dim HZLen As Long
Dim i As Long
HZLen = Len(pHZ)
For i = 1 To HZLen
hz = Mid(pHZ, i, 1)
If Asc(hz) >= 0 Then
hzpy = hzpy & hz
Else
hzpy = hzpy & getHzPy(hz)
End If
Next i
GetHzPYString = hzpy
End Function
对于声母，你可以分离一下，声母就那么多个，逐个分离，不过对于"xian西安"这样的可能麻烦一点。