汉字与拼音互相转化

Question

各位大虾，能不能帮忙解决这个问题呀，实现汉字和拼音的互相转化。

Answer 1

如果没有人提供源码贴出来，俺打算自己写一对这样的函数。关注中...
印象中这个问题已经讨论过并且有解决方案，就在CSDN中。

Answer 2

Dim aa As New Class1
Private Sub Command1_Click() '用到类模块
    Text2.Text = aa.MSPYReverse(Text1.Text)
End Sub
'类模块中:
  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 If
  
  End Sub
  
  Public Property Get MSPYInstalled() As Boolean
  MSPYInstalled = IIf(mlMSPYIndex, True, False)
  End Property
  
  Public Property Get MSPYIndex() As Long
  MSPYIndex = mlMSPYIndex
  End Property
  
  Public Property Get Count() As Long
  Count = imeCount
  End Property
  
  Public Function GetHandle(ByVal lIndex As Long) As Long
  If lIndex >= 1 And lIndex <= imeCount Then
  GetHandle = imeHandle(lIndex)
  End If
  End Function
  
  Public 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 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 Function
  
  Private Sub Class_Initialize()
  Init
  End Sub
  
  Private 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 Function
  
  Private Function GetPYStr(ByVal S As String) As String
  Dim l   As Long
  Dim sOut   As String
  
  If S <> "" Then
  For l = 1 To Len(S)
  sOut = sOut & GetPYChar(Mid(S, l, 1))
  Next l
  GetPYStr = sOut
  End If
  End Function

Answer 3

汉字->拼音,,
输入法生成器,,
做个数据库去查,,,拼音->汉字,,,一个音可有好多字,,没办法了,,,