把下这段代码放在类模块（扩展名是cls）中，接口是GetSimpleSpell(string)获取声母和GetFullSpell(string)获取拼音。 Option Explicit Private Type t keys As Long items As String End TypePrivate d(0 To 397) As t Private dd(0 To 24) As t Private index As LongPublic Function GetFullSpell(ByVal str As String) As String '获取完整的拼音 GetFullSpell = c(str, True) End FunctionPublic Function GetSimpleSpell(ByVal str As String) As String '获取每个汉字的拼音的第一个字母 GetSimpleSpell = c(str, False) End FunctionPrivate Function c(ByVal str As String, ByVal s As Boolean) As String Dim i As Long c = "" For i = 1 To Len(str) c = c & g(Asc(Mid(str, i, 1)), s) '递归 Next End FunctionPrivate Function g(ByVal num As Integer, ByVal s As Boolean) As String Dim i As Long If num > 0 And num < 160 Then g = Chr(num) Else If num < -20319 Or num > -10247 Then g = "" Else If s Then For i = 397 To 0 Step -1 If d(i).keys <= num Then Exit For Next g = d(i).items Else For i = 24 To 0 Step -1 If dd(i).keys <= num Then Exit For Next g = dd(i).items End If End If End If End FunctionPrivate Sub HtPut(ByVal n As Long, ByVal c As String) d(index).keys = n d(index).items = c index = index + 1 End Sub Private Sub HtPutS(ByVal n As Long, ByVal c As String) dd(index).keys = n dd(index).items = c index = index + 1 End Sub (未完，见下)
这是我收的一前辈的代码，望你以后也助人为乐！ 'Form1： Option ExplicitDim aa As New Class1Private Sub Command1_Click() Text2.Text = aa.MSPYReverse(Text1.Text) End Sub
这是我收的一前辈的代码，望你以后也助人为乐！ 'Class: Option Explicit Private Const IME_ESC_MAX_KEY = &H1005 Private Const IME_ESC_IME_NAME = &H1006 Private Const GCL_REVERSECONVERSION = &H2 Private 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 Type Private 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 Long Private 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 String Dim mlMSPYIndex As Long Dim imeCount As Long
Private Sub Init() Dim i As Long Dim sName As String mlMSPYIndex = 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 Function
Public Function MSPYReverse(ByVal sString As String) As String Dim lStrLen As Long Dim i As Long Dim sChar As String Dim bChar() As Byte If 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 Long lMaxKey = ImmEscape(imeHandle(mlMSPYIndex), 0, IME_ESC_MAX_KEY, Null)
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 Long bBuffer = 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
to efei (草不含羞) : 分给 xsp(半个程序员) ，我只不过用了人家的程序，不是我自己写的。 to xsp(半个程序员) : 我收了你代码，学一下
Public Function GetPY1(a1 As String) As String '汉字转换成拼音 For i = 1 To Len(a1) Dim t1 As String t1 = Mid(a1, i, 1)'If Asc(a1) < 0 Then 't1 = Left(a1, 1) If Asc(t1) < Asc("啊") Then GetPY1 = GetPY1 + "0"End If If Asc(t1) >= Asc("啊") And Asc(t1) < Asc("芭") Then GetPY1 = GetPY1 + "A"End If If Asc(t1) >= Asc("芭") And Asc(t1) < Asc("擦") Then GetPY1 = GetPY1 + "B"End If If Asc(t1) >= Asc("擦") And Asc(t1) < Asc("搭") Then GetPY1 = GetPY1 + "C"End If If Asc(t1) >= Asc("搭") And Asc(t1) < Asc("蛾") Then GetPY1 = GetPY1 + "D"End If If Asc(t1) >= Asc("蛾") And Asc(t1) < Asc("发") Then GetPY1 = GetPY1 + "E" End If If Asc(t1) >= Asc("发") And Asc(t1) < Asc("噶") Then GetPY1 = GetPY1 + "F"End If If Asc(t1) >= Asc("噶") And Asc(t1) < Asc("哈") Then GetPY1 = GetPY1 + "G"End If If Asc(t1) >= Asc("哈") And Asc(t1) < Asc("击") Then GetPY1 = GetPY1 + "H"End If If Asc(t1) >= Asc("击") And Asc(t1) < Asc("喀") Then GetPY1 = GetPY1 + "J"End If If Asc(t1) >= Asc("喀") And Asc(t1) < Asc("垃") Then GetPY1 = GetPY1 + "K"End If If Asc(t1) >= Asc("垃") And Asc(t1) < Asc("妈") Then GetPY1 = GetPY1 + "L"End If If Asc(t1) >= Asc("妈") And Asc(t1) < Asc("拿") Then GetPY1 = GetPY1 + "M"End If If Asc(t1) >= Asc("拿") And Asc(t1) < Asc("哦") Then GetPY1 = GetPY1 + "N"End If If Asc(t1) >= Asc("哦") And Asc(t1) < Asc("啪") Then GetPY1 = GetPY1 + "O" End If If Asc(t1) >= Asc("啪") And Asc(t1) < Asc("期") Then GetPY1 = GetPY1 + "P"End If If Asc(t1) >= Asc("期") And Asc(t1) < Asc("然") Then GetPY1 = GetPY1 + "Q"End If If Asc(t1) >= Asc("然") And Asc(t1) < Asc("撒") Then GetPY1 = GetPY1 + "R"End If If Asc(t1) >= Asc("撒") And Asc(t1) < Asc("塌") Then GetPY1 = GetPY1 + "S"End If If Asc(t1) >= Asc("塌") And Asc(t1) < Asc("挖") Then GetPY1 = GetPY1 + "T"End If If Asc(t1) >= Asc("挖") And Asc(t1) < Asc("昔") Then GetPY1 = GetPY1 + "W" End If If Asc(t1) >= Asc("昔") And Asc(t1) < Asc("压") Then GetPY1 = GetPY1 + "X"End If If Asc(t1) >= Asc("压") And Asc(t1) < Asc("匝") Then GetPY1 = GetPY1 + "Y"End If If Asc(t1) >= Asc("匝") Then GetPY1 = GetPY1 + "Z"End IfNext i End Function这是我根据pb的人写的，我用vb改的
to bdxzq(思考) ： 用我收的如下 涿 涞 蠡 卅 薰 薰 垅 淞 鄱 蒿 垅 痱 癫 痫 岐 矶 苕 蜃 裘 蟑 螂 嗝 鹦 绛 Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z 是不太正确
Option Explicit
Private Type t
keys As Long
items As String
End TypePrivate d(0 To 397) As t
Private dd(0 To 24) As t
Private index As LongPublic Function GetFullSpell(ByVal str As String) As String
'获取完整的拼音
GetFullSpell = c(str, True)
End FunctionPublic Function GetSimpleSpell(ByVal str As String) As String
'获取每个汉字的拼音的第一个字母
GetSimpleSpell = c(str, False)
End FunctionPrivate Function c(ByVal str As String, ByVal s As Boolean) As String
Dim i As Long
c = ""
For i = 1 To Len(str)
c = c & g(Asc(Mid(str, i, 1)), s) '递归
Next
End FunctionPrivate Function g(ByVal num As Integer, ByVal s As Boolean) As String
Dim i As Long
If num > 0 And num < 160 Then
g = Chr(num)
Else
If num < -20319 Or num > -10247 Then
g = ""
Else
If s Then
For i = 397 To 0 Step -1
If d(i).keys <= num Then Exit For
Next
g = d(i).items
Else
For i = 24 To 0 Step -1
If dd(i).keys <= num Then Exit For
Next
g = dd(i).items
End If
End If
End If
End FunctionPrivate Sub HtPut(ByVal n As Long, ByVal c As String)
d(index).keys = n
d(index).items = c
index = index + 1
End Sub
Private Sub HtPutS(ByVal n As Long, ByVal c As String)
dd(index).keys = n
dd(index).items = c
index = index + 1
End Sub
(未完，见下)
Private Sub bs()
index = 0 Call HtPutS(-20319, "a")
Call HtPutS(-20283, "b")
Call HtPutS(-19775, "c")
Call HtPutS(-19218, "d")
Call HtPutS(-18710, "e")
Call HtPutS(-18526, "f")
Call HtPutS(-18239, "g")
Call HtPutS(-17922, "h")
Call HtPutS(-17417, "j")
Call HtPutS(-16474, "k")
Call HtPutS(-16212, "l")
Call HtPutS(-15640, "m")
Call HtPutS(-15165, "n")
Call HtPutS(-14922, "o")
Call HtPutS(-14914, "p")
Call HtPutS(-14630, "q")
Call HtPutS(-14149, "r")
Call HtPutS(-14090, "s")
Call HtPutS(-13318, "t")
Call HtPutS(-12838, "w")
Call HtPutS(-12556, "x")
Call HtPutS(-11847, "y")
Call HtPutS(-11055, "z")
Call HtPutS(-10247, "zz")
End Sub
(未完)
Private Sub Class_Initialize()
Call b
Call bs
End SubPrivate Sub b()
index = 0 Call HtPut(-20319, "a")
Call HtPut(-20317, "ai")
Call HtPut(-20304, "an")
Call HtPut(-20295, "ang")
Call HtPut(-20292, "ao")
Call HtPut(-20283, "ba")
Call HtPut(-20265, "bai")
Call HtPut(-20257, "ban")
Call HtPut(-20242, "bang")
Call HtPut(-20230, "bao")
Call HtPut(-20051, "bei")
Call HtPut(-20036, "ben")
Call HtPut(-20032, "beng")
Call HtPut(-20026, "bi")
Call HtPut(-20002, "bian")
Call HtPut(-19990, "biao")
Call HtPut(-19986, "bie")
Call HtPut(-19982, "bin")
Call HtPut(-19976, "bing")
Call HtPut(-19805, "bo")
Call HtPut(-19784, "bu")
Call HtPut(-19775, "ca")
Call HtPut(-19774, "cai")
Call HtPut(-19763, "can")
Call HtPut(-19756, "cang")
Call HtPut(-19751, "cao")
Call HtPut(-19746, "ce")
Call HtPut(-19741, "ceng")
Call HtPut(-19739, "cha")
Call HtPut(-19728, "chai")
Call HtPut(-19725, "chan")
Call HtPut(-19715, "chang")
Call HtPut(-19540, "chao")
Call HtPut(-19531, "che")
Call HtPut(-19525, "chen")
Call HtPut(-19515, "cheng")
Call HtPut(-19500, "chi")
Call HtPut(-19484, "chong")
Call HtPut(-19479, "chou")
Call HtPut(-19467, "chu")
Call HtPut(-19289, "chuai")
Call HtPut(-19288, "chuan")
Call HtPut(-19281, "chuang")
Call HtPut(-19275, "chui")
Call HtPut(-19270, "chun")
Call HtPut(-19263, "chuo")
Call HtPut(-19261, "ci")
Call HtPut(-19249, "cong")
Call HtPut(-19243, "cou")
Call HtPut(-19242, "cu")
Call HtPut(-19238, "cuan")
Call HtPut(-19235, "cui")
Call HtPut(-19227, "cun")
Call HtPut(-19224, "cuo")
Call HtPut(-19218, "da")
Call HtPut(-19212, "dai")
Call HtPut(-19038, "dan")
Call HtPut(-19023, "dang")
Call HtPut(-19018, "dao")
Call HtPut(-19006, "de")
Call HtPut(-19003, "deng")
Call HtPut(-18996, "di")
Call HtPut(-18977, "dian")
Call HtPut(-18961, "diao")
Call HtPut(-18952, "die")
Call HtPut(-18783, "ding")
Call HtPut(-18774, "diu")
Call HtPut(-18773, "dong")
Call HtPut(-18763, "dou")
Call HtPut(-18756, "du")
Call HtPut(-18741, "duan")
Call HtPut(-18735, "dui")
Call HtPut(-18731, "dun")
Call HtPut(-18722, "duo")
Call HtPut(-18710, "e")
Call HtPut(-18697, "en")
Call HtPut(-18696, "er")
Call HtPut(-18526, "fa")
Call HtPut(-18518, "fan")
Call HtPut(-18501, "fang")
Call HtPut(-18490, "fei")
Call HtPut(-18478, "fen")
Call HtPut(-18463, "feng")
Call HtPut(-18448, "fo")
Call HtPut(-18447, "fou")
Call HtPut(-18446, "fu")
Call HtPut(-18239, "ga")
Call HtPut(-18237, "gai")
Call HtPut(-18231, "gan")
Call HtPut(-18220, "gang")
Call HtPut(-18211, "gao")
Call HtPut(-18201, "ge")
Call HtPut(-18184, "gei")
Call HtPut(-18183, "gen")
Call HtPut(-18181, "geng")
Call HtPut(-18012, "gong")
Call HtPut(-17997, "gou")
Call HtPut(-17988, "gu")
Call HtPut(-17970, "gua")
Call HtPut(-17964, "guai")
Call HtPut(-17961, "guan")
Call HtPut(-17950, "guang")
Call HtPut(-17947, "gui")
Call HtPut(-17931, "gun")
Call HtPut(-17928, "guo")
Call HtPut(-17922, "ha")
Call HtPut(-17759, "hai")
Call HtPut(-17752, "han")
Call HtPut(-17733, "hang")
Call HtPut(-17730, "hao")
Call HtPut(-17721, "he")
Call HtPut(-17703, "hei")
Call HtPut(-17701, "hen")
Call HtPut(-17697, "heng")
Call HtPut(-17692, "hong")
Call HtPut(-17683, "hou")
Call HtPut(-17676, "hu")
Call HtPut(-17496, "hua")
Call HtPut(-17487, "huai")
Call HtPut(-17482, "huan")
Call HtPut(-17468, "huang")
Call HtPut(-17454, "hui")
Call HtPut(-17433, "hun")
Call HtPut(-17427, "huo")
Call HtPut(-17417, "ji")
Call HtPut(-17202, "jia")
Call HtPut(-17185, "jian")
Call HtPut(-16983, "jiang")
Call HtPut(-16970, "jiao")
Call HtPut(-16942, "jie")
Call HtPut(-16915, "jin")
Call HtPut(-16733, "jing")
Call HtPut(-16708, "jiong")
Call HtPut(-16706, "jiu")
Call HtPut(-16689, "ju")
Call HtPut(-16664, "juan")
Call HtPut(-16657, "jue")
Call HtPut(-16647, "jun")
Call HtPut(-16474, "ka")
Call HtPut(-16470, "kai")
Call HtPut(-16465, "kan")
Call HtPut(-16459, "kang")
Call HtPut(-16452, "kao")
Call HtPut(-16448, "ke")
Call HtPut(-16433, "ken")
Call HtPut(-16429, "keng")
Call HtPut(-16427, "kong")
Call HtPut(-16423, "kou")
Call HtPut(-16419, "ku")
Call HtPut(-16412, "kua")
Call HtPut(-16407, "kuai")
Call HtPut(-16403, "kuan")
Call HtPut(-16401, "kuang")
Call HtPut(-16393, "kui")
Call HtPut(-16220, "kun")
Call HtPut(-16216, "kuo")
Call HtPut(-16212, "la")
Call HtPut(-16205, "lai")
Call HtPut(-16202, "lan")
Call HtPut(-16187, "lang")
Call HtPut(-16180, "lao")
Call HtPut(-16171, "le")
Call HtPut(-16169, "lei")
Call HtPut(-16158, "leng")
Call HtPut(-16155, "li")
Call HtPut(-15959, "lia")
Call HtPut(-15958, "lian")
Call HtPut(-15944, "liang")
Call HtPut(-15933, "liao")
Call HtPut(-15920, "lie")
Call HtPut(-15915, "lin")
Call HtPut(-15903, "ling")
Call HtPut(-15889, "liu")
Call HtPut(-15878, "long")
Call HtPut(-15707, "lou")
Call HtPut(-15701, "lu")
Call HtPut(-15681, "lv")
Call HtPut(-15667, "luan")
Call HtPut(-15661, "lue")
Call HtPut(-15659, "lun")
Call HtPut(-15652, "luo")
Call HtPut(-15640, "ma")
Call HtPut(-15631, "mai")
Call HtPut(-15625, "man")
Call HtPut(-15454, "mang")
Call HtPut(-15448, "mao")
Call HtPut(-15436, "me")
Call HtPut(-15435, "mei")
Call HtPut(-15419, "men")
Call HtPut(-15416, "meng")
Call HtPut(-15408, "mi")
Call HtPut(-15394, "mian")
Call HtPut(-15385, "miao")
Call HtPut(-15377, "mie")
Call HtPut(-15375, "min")
Call HtPut(-15369, "ming")
Call HtPut(-15363, "miu")
Call HtPut(-15362, "mo")
Call HtPut(-15183, "mou")
Call HtPut(-15180, "mu")
（未完）
Call HtPut(-15165, "na")
Call HtPut(-15158, "nai")
Call HtPut(-15153, "nan")
Call HtPut(-15150, "nang")
Call HtPut(-15149, "nao")
Call HtPut(-15144, "ne")
Call HtPut(-15143, "nei")
Call HtPut(-15141, "nen")
Call HtPut(-15140, "neng")
Call HtPut(-15139, "ni")
Call HtPut(-15128, "nian")
Call HtPut(-15121, "niang")
Call HtPut(-15119, "niao")
Call HtPut(-15117, "nie")
Call HtPut(-15110, "nin")
Call HtPut(-15109, "ning")
Call HtPut(-14941, "niu")
Call HtPut(-14937, "nong")
Call HtPut(-14933, "nu")
Call HtPut(-14930, "nv")
Call HtPut(-14929, "nuan")
Call HtPut(-14928, "nue")
Call HtPut(-14926, "nuo")
Call HtPut(-14922, "o")
Call HtPut(-14921, "ou")
Call HtPut(-14914, "pa")
Call HtPut(-14908, "pai")
Call HtPut(-14902, "pan")
Call HtPut(-14894, "pang")
Call HtPut(-14889, "pao")
Call HtPut(-14882, "pei")
Call HtPut(-14873, "pen")
Call HtPut(-14871, "peng")
Call HtPut(-14857, "pi")
Call HtPut(-14678, "pian")
Call HtPut(-14674, "piao")
Call HtPut(-14670, "pie")
Call HtPut(-14668, "pin")
Call HtPut(-14663, "ping")
Call HtPut(-14654, "po")
Call HtPut(-14645, "pu")
Call HtPut(-14630, "qi")
Call HtPut(-14594, "qia")
Call HtPut(-14429, "qian")
Call HtPut(-14407, "qiang")
Call HtPut(-14399, "qiao")
Call HtPut(-14384, "qie")
Call HtPut(-14379, "qin")
Call HtPut(-14368, "qing")
Call HtPut(-14355, "qiong")
Call HtPut(-14353, "qiu")
Call HtPut(-14345, "qu")
Call HtPut(-14170, "quan")
Call HtPut(-14159, "que")
Call HtPut(-14151, "qun")
Call HtPut(-14149, "ran")
Call HtPut(-14145, "rang")
Call HtPut(-14140, "rao")
Call HtPut(-14137, "re")
Call HtPut(-14135, "ren")
Call HtPut(-14125, "reng")
Call HtPut(-14123, "ri")
Call HtPut(-14122, "rong")
Call HtPut(-14112, "rou")
Call HtPut(-14109, "ru")
Call HtPut(-14099, "ruan")
Call HtPut(-14097, "rui")
Call HtPut(-14094, "run")
Call HtPut(-14092, "ruo")
Call HtPut(-14090, "sa")
Call HtPut(-14087, "sai")
Call HtPut(-14083, "san")
Call HtPut(-13917, "sang")
Call HtPut(-13914, "sao")
Call HtPut(-13910, "se")
Call HtPut(-13907, "sen")
Call HtPut(-13906, "seng")
Call HtPut(-13905, "sha")
Call HtPut(-13896, "shai")
Call HtPut(-13894, "shan")
Call HtPut(-13878, "shang")
Call HtPut(-13870, "shao")
Call HtPut(-13859, "she")
Call HtPut(-13847, "shen")
Call HtPut(-13831, "sheng")
Call HtPut(-13658, "shi")
Call HtPut(-13611, "shou")
Call HtPut(-13601, "shu")
Call HtPut(-13406, "shua")
Call HtPut(-13404, "shuai")
Call HtPut(-13400, "shuan")
Call HtPut(-13398, "shuang")
Call HtPut(-13395, "shui")
Call HtPut(-13391, "shun")
Call HtPut(-13387, "shuo")
Call HtPut(-13383, "si")
Call HtPut(-13367, "song")
Call HtPut(-13359, "sou")
Call HtPut(-13356, "su")
Call HtPut(-13343, "suan")
Call HtPut(-13340, "sui")
Call HtPut(-13329, "sun")
Call HtPut(-13326, "suo")
Call HtPut(-13318, "ta")
Call HtPut(-13147, "tai")
Call HtPut(-13138, "tan")
Call HtPut(-13120, "tang")
Call HtPut(-13107, "tao")
Call HtPut(-13096, "te")
Call HtPut(-13095, "teng")
Call HtPut(-13091, "ti")
Call HtPut(-13076, "tian")
Call HtPut(-13068, "tiao")
Call HtPut(-13063, "tie")
Call HtPut(-13060, "ting")
Call HtPut(-12888, "tong")
Call HtPut(-12875, "tou")
Call HtPut(-12871, "tu")
Call HtPut(-12860, "tuan")
Call HtPut(-12858, "tui")
Call HtPut(-12852, "tun")
Call HtPut(-12849, "tuo")
Call HtPut(-12838, "wa")
Call HtPut(-12831, "wai")
Call HtPut(-12829, "wan")
Call HtPut(-12812, "wang")
Call HtPut(-12802, "wei")
Call HtPut(-12607, "wen")
Call HtPut(-12597, "weng")
Call HtPut(-12594, "wo")
Call HtPut(-12585, "wu")
Call HtPut(-12556, "xi")
Call HtPut(-12359, "xia")
Call HtPut(-12346, "xian")
Call HtPut(-12320, "xiang")
Call HtPut(-12300, "xiao")
Call HtPut(-12120, "xie")
Call HtPut(-12099, "xin")
Call HtPut(-12089, "xing")
Call HtPut(-12074, "xiong")
Call HtPut(-12067, "xiu")
Call HtPut(-12058, "xu")
Call HtPut(-12039, "xuan")
Call HtPut(-11867, "xue")
Call HtPut(-11861, "xun")
Call HtPut(-11847, "ya")
Call HtPut(-11831, "yan")
Call HtPut(-11798, "yang")
Call HtPut(-11781, "yao")
Call HtPut(-11604, "ye")
Call HtPut(-11589, "yi")
Call HtPut(-11536, "yin")
Call HtPut(-11358, "ying")
Call HtPut(-11340, "yo")
Call HtPut(-11339, "yong")
Call HtPut(-11324, "you")
Call HtPut(-11303, "yu")
Call HtPut(-11097, "yuan")
Call HtPut(-11077, "yue")
Call HtPut(-11067, "yun")
Call HtPut(-11055, "za")
Call HtPut(-11052, "zai")
Call HtPut(-11045, "zan")
Call HtPut(-11041, "zang")
Call HtPut(-11038, "zao")
Call HtPut(-11024, "ze")
Call HtPut(-11020, "zei")
Call HtPut(-11019, "zen")
Call HtPut(-11018, "zeng")
Call HtPut(-11014, "zha")
Call HtPut(-10838, "zhai")
Call HtPut(-10832, "zhan")
Call HtPut(-10815, "zhang")
Call HtPut(-10800, "zhao")
Call HtPut(-10790, "zhe")
Call HtPut(-10780, "zhen")
Call HtPut(-10764, "zheng")
Call HtPut(-10587, "zhi")
Call HtPut(-10544, "zhong")
Call HtPut(-10533, "zhou")
Call HtPut(-10519, "zhu")
Call HtPut(-10331, "zhua")
Call HtPut(-10329, "zhuai")
Call HtPut(-10328, "zhuan")
Call HtPut(-10322, "zhuang")
Call HtPut(-10315, "zhui")
Call HtPut(-10309, "zhun")
Call HtPut(-10307, "zhuo")
Call HtPut(-10296, "zi")
Call HtPut(-10281, "zong")
Call HtPut(-10274, "zou")
Call HtPut(-10270, "zu")
Call HtPut(-10262, "zuan")
Call HtPut(-10260, "zui")
Call HtPut(-10256, "zun")
Call HtPut(-10254, "zuo")
Call HtPut(-10247, "zz")
End Sub
'Form1：
Option ExplicitDim aa As New Class1Private Sub Command1_Click()
Text2.Text = aa.MSPYReverse(Text1.Text)
End Sub
'Class:
Option Explicit Private Const IME_ESC_MAX_KEY = &H1005
Private Const IME_ESC_IME_NAME = &H1006
Private Const GCL_REVERSECONVERSION = &H2 Private 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 Type Private 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 Long Private 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 String Dim mlMSPYIndex As Long
Dim imeCount As Long
Dim i As Long
Dim sName As String mlMSPYIndex = 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 Function
Dim lStrLen As Long
Dim i As Long
Dim sChar As String
Dim bChar() As Byte If 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 Long lMaxKey = 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 Long bBuffer = 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
分给 xsp(半个程序员) ，我只不过用了人家的程序，不是我自己写的。
to xsp(半个程序员) :
我收了你代码，学一下
For i = 1 To Len(a1)
Dim t1 As String
t1 = Mid(a1, i, 1)'If Asc(a1) < 0 Then
't1 = Left(a1, 1)
If Asc(t1) < Asc("啊") Then
GetPY1 = GetPY1 + "0"End If
If Asc(t1) >= Asc("啊") And Asc(t1) < Asc("芭") Then
GetPY1 = GetPY1 + "A"End If
If Asc(t1) >= Asc("芭") And Asc(t1) < Asc("擦") Then
GetPY1 = GetPY1 + "B"End If
If Asc(t1) >= Asc("擦") And Asc(t1) < Asc("搭") Then
GetPY1 = GetPY1 + "C"End If
If Asc(t1) >= Asc("搭") And Asc(t1) < Asc("蛾") Then
GetPY1 = GetPY1 + "D"End If
If Asc(t1) >= Asc("蛾") And Asc(t1) < Asc("发") Then
GetPY1 = GetPY1 + "E"
End If
If Asc(t1) >= Asc("发") And Asc(t1) < Asc("噶") Then
GetPY1 = GetPY1 + "F"End If
If Asc(t1) >= Asc("噶") And Asc(t1) < Asc("哈") Then
GetPY1 = GetPY1 + "G"End If
If Asc(t1) >= Asc("哈") And Asc(t1) < Asc("击") Then
GetPY1 = GetPY1 + "H"End If
If Asc(t1) >= Asc("击") And Asc(t1) < Asc("喀") Then
GetPY1 = GetPY1 + "J"End If
If Asc(t1) >= Asc("喀") And Asc(t1) < Asc("垃") Then
GetPY1 = GetPY1 + "K"End If
If Asc(t1) >= Asc("垃") And Asc(t1) < Asc("妈") Then
GetPY1 = GetPY1 + "L"End If
If Asc(t1) >= Asc("妈") And Asc(t1) < Asc("拿") Then
GetPY1 = GetPY1 + "M"End If
If Asc(t1) >= Asc("拿") And Asc(t1) < Asc("哦") Then
GetPY1 = GetPY1 + "N"End If
If Asc(t1) >= Asc("哦") And Asc(t1) < Asc("啪") Then
GetPY1 = GetPY1 + "O"
End If
If Asc(t1) >= Asc("啪") And Asc(t1) < Asc("期") Then
GetPY1 = GetPY1 + "P"End If
If Asc(t1) >= Asc("期") And Asc(t1) < Asc("然") Then
GetPY1 = GetPY1 + "Q"End If
If Asc(t1) >= Asc("然") And Asc(t1) < Asc("撒") Then
GetPY1 = GetPY1 + "R"End If
If Asc(t1) >= Asc("撒") And Asc(t1) < Asc("塌") Then
GetPY1 = GetPY1 + "S"End If
If Asc(t1) >= Asc("塌") And Asc(t1) < Asc("挖") Then
GetPY1 = GetPY1 + "T"End If
If Asc(t1) >= Asc("挖") And Asc(t1) < Asc("昔") Then
GetPY1 = GetPY1 + "W"
End If
If Asc(t1) >= Asc("昔") And Asc(t1) < Asc("压") Then
GetPY1 = GetPY1 + "X"End If
If Asc(t1) >= Asc("压") And Asc(t1) < Asc("匝") Then
GetPY1 = GetPY1 + "Y"End If
If Asc(t1) >= Asc("匝") Then
GetPY1 = GetPY1 + "Z"End IfNext i
End Function这是我根据pb的人写的，我用vb改的
用我收的如下
涿 涞 蠡 卅 薰 薰 垅 淞 鄱 蒿 垅 痱 癫 痫 岐 矶 苕 蜃 裘 蟑 螂 嗝 鹦 绛
Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z Z
是不太正确