怎样在VB里得到关于一个汉字的拼音全码（急）？

Question

很多以前的贴子都不能SHOW出来了，论坛是挺“嗖”的

Answer 1

你需要一个汉字码表啊  a    kbsk
......

Answer 2

各位也不用找了！哥们直接贴出来得了！'用于实现汉字与拼音转换的类模块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 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 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 Sub
Public 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 GetAllOfPy(ByVal sString As String) As String
On Error GoTo GetAllOfPyErr
    Dim lStrLen As Long
    Dim i As Long
    Dim sChar As String
    Dim bChar() As Byte    If MSPYInstalled Then
        lStrLen = Len(sString)
        GetAllOfPy = ""
        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
                GetAllOfPy = GetAllOfPy & sChar
            Next i
        End If
    Else
        GetAllOfPy = sString
    End If
    Exit Function
GetAllOfPyErr:
    GetAllOfPy = sString
End FunctionPrivate Sub Class_Initialize()
    Init
End Sub

Answer 3

[名称]           由汉字获取拼音[语言种类]       Visual Basic[类别一]         自定义函数[类别二]         文本/文件处理[类别三]         空[数据来源]       未知[保存时间]       2002-05-15[关键字一]       汉字[关键字二]       拼音[关键字三]       空[内容简介]       空[源代码内容]Option Explicit
Private Const IME_ESC_MAX_KEY = &H1005
Private Const IME_ESC_IME_NAME = &H1006
Private Const GCL_REVERSECONVERSION = &H2
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 IsDBCSLeadByte Lib "kernel32" (ByVal bTestChar As Byte) As Long
Public Function GetChineseSpell(Chinese As String, Optional Delimiter As String = " ", Optional
IMEName As String = "微软拼音输入法", Optional BufferSize As Long = 255) As String
If VBA.Len(VBA.Trim(Chinese)) > 0 Then
 Dim i As Long
 Dim s As String
 s = VBA.Space(BufferSize)
 Dim IMEInstalled As Boolean
 Dim j As Long
 Dim a() As Long
 ReDim a(BufferSize) As Long
 j = GetKeyboardLayoutList(BufferSize, a(LBound(a)))
 
  
 For i = LBound(a) To LBound(a) + j - 1
   If ImmEscape(a(i), 0, IME_ESC_IME_NAME, ByVal s) Then
     If VBA.Trim(IMEName) = VBA.Replace(VBA.Trim(s), VBA.Chr(0), "") Then
      IMEInstalled = True
      Exit For
     End If
   End If
 Next i
 If IMEInstalled Then
   'Stop
   Chinese = VBA.Trim(Chinese)
   Dim sChar As String
   Dim Buffer0() As Byte
   'Dim Buffer() As Byte
   Dim bBuffer0() As Byte
   Dim bBuffer() As Byte
   Dim k As Long
   Dim l As Long
   Dim m As Long
   For j = 0 To VBA.Len(Chinese) - 1
     sChar = VBA.Mid(Chinese, j + 1, 1)
     Buffer0 = VBA.StrConv(sChar, vbFromUnicode)
     If IsDBCSLeadByte(Buffer0(0)) Then
      k = ImmEscape(a(i), 0, IME_ESC_MAX_KEY, Null)
      If k Then
        l = ImmGetConversionList(a(i), 0, sChar, 0, 0, GCL_REVERSECONVERSION)
        If l Then
         s = VBA.Space(BufferSize)
         If ImmGetConversionList(a(i), 0, sChar, ByVal s, l, GCL_REVERSECONVERSION) Then
           
           bBuffer0 = VBA.StrConv(s, vbFromUnicode)
           ReDim bBuffer(k * 2 - 1)
           For m = bBuffer0(24) To bBuffer0(24) + k * 2 - 1
             bBuffer(m - bBuffer0(24)) = bBuffer0(m)
           Next m
           sChar = VBA.Trim(VBA.StrConv(bBuffer, vbUnicode))
           If VBA.InStr(sChar, vbNullChar) Then
            sChar = VBA.Trim(VBA.Left(sChar, VBA.InStr(sChar, vbNullChar) - 1))
           End If
           sChar = VBA.Left(sChar, VBA.Len(sChar) - 1) & VBA.IIf(j < VBA.Len(Chinese) - 1, Delimiter, "")
           
         End If
         
        End If
      End If
     End If
     GetChineseSpell = GetChineseSpell & sChar
   Next j
 Else
   
 
 End If
  
End If
End Function
Private Sub Command1_Click()
VBA.MsgBox GetChineseSpell("我是") 
End Sub
     以上代码保存于： SourceCode Explorer(源代码数据库)
           复制时间： 2002-11-18 17:32
           软件版本： 1.0.754
           软件作者： Shawls
           个人主页： Http://Shawls.Yeah.Net
             E-Mail： [email protected]
                 QQ： 9181729

Answer 4

win2000下运行很好，但win98下得不到拼音，请高手解答

Answer 5

'可是以下代码在win98下运行却得不到拼音代码呀Option Explicit
Private Const IME_ESC_MAX_KEY = &H1005
Private Const IME_ESC_IME_NAME = &H1006
Private Const GCL_REVERSECONVERSION = &H2
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 IsDBCSLeadByte Lib "kernel32" (ByVal bTestChar As Byte) As Long
Public Function GetChineseSpell(Chinese As String, Optional Delimiter As String = " ", Optional IMEName As String = "微软拼音输入法", Optional BufferSize As Long = 255) As String
If Len(Trim(Chinese)) > 0 Then
 Dim i As Long
 Dim s As String
 s = Space(BufferSize)
 Dim IMEInstalled As Boolean
 Dim j As Long
 Dim a() As Long
 ReDim a(BufferSize) As Long
 j = GetKeyboardLayoutList(BufferSize, a(LBound(a)))
 
  
 For i = LBound(a) To LBound(a) + j - 1
   If ImmEscape(a(i), 0, IME_ESC_IME_NAME, ByVal s) Then
     If Trim(IMEName) = Replace(Trim(s), Chr(0), "") Then
      IMEInstalled = True
      Exit For
     End If
   End If
 Next i
 If IMEInstalled Then
   'Stop
   Chinese = Trim(Chinese)
   Dim sChar As String
   Dim Buffer0() As Byte
   'Dim Buffer() As Byte
   Dim bBuffer0() As Byte
   Dim bBuffer() As Byte
   Dim k As Long
   Dim l As Long
   Dim m As Long
   For j = 0 To Len(Chinese) - 1
     sChar = Mid(Chinese, j + 1, 1)
     Buffer0 = StrConv(sChar, vbFromUnicode)
     If IsDBCSLeadByte(Buffer0(0)) Then
      k = ImmEscape(a(i), 0, IME_ESC_MAX_KEY, Null)
      If k Then
        l = ImmGetConversionList(a(i), 0, sChar, 0, 0, GCL_REVERSECONVERSION)
        If l Then
         s = Space(BufferSize)
         If ImmGetConversionList(a(i), 0, sChar, ByVal s, l, GCL_REVERSECONVERSION) Then
           
           bBuffer0 = StrConv(s, vbFromUnicode)
           ReDim bBuffer(k * 2 - 1)
           For m = bBuffer0(24) To bBuffer0(24) + k * 2 - 1
             bBuffer(m - bBuffer0(24)) = bBuffer0(m)
           Next m
           sChar = Trim(StrConv(bBuffer, vbUnicode))
           If InStr(sChar, vbNullChar) Then
            sChar = Trim(Left(sChar, InStr(sChar, vbNullChar) - 1))
           End If
           sChar = Left(sChar, Len(sChar) - 1) & IIf(j < Len(Chinese) - 1, Delimiter, "")
           
         End If
         
        End If
      End If
     End If
     GetChineseSpell = GetChineseSpell & sChar
   Next j
 Else
   
 
 End If
  
End If
End FunctionPrivate Sub Command1_Click()
Dim s$s = "我是涞璎"
MsgBox s & ":" & GetChineseSpell(s)
End Sub'可是以上代码在win98下运行却得不到拼音代码呀

Answer 6

http://www.ourfly.com/download/download.aspx
汉字转拼音的程序(源码)

Answer 7

好面熟，好象是CSDN的2002年年初杂志上发表的。

Answer 8

噢，前提是微软拼音输入法，但win98下没有这个输入法

Answer 9

“涞璎”这样的汉字怎样在win98中得到拼音首字母“LY”呢？   急呀