我想得到汉字的拼音，请您指教？

Question

http://www.csdn.net/Expert/memberInfo.asp?Roomid=2&typenum=8&tabletype=now&searchKeys=拼音&author=&whichpage=1

Answer 1

http://ygyuan.go.163.com/
http://ygyuan.3322.net/
现成控件免费使用.

Answer 2

由汉字获取拼音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-06-24 20:52:16
           当前版本： 1.0.714
               作者： Shawls
           个人主页： Http://Shawls.Yeah.Net
             E-Mail： [email protected]
                 QQ： 9181729

Answer 3

返回汉字字符串汉字拼音的第一个字母一类模块中： 
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 
       以上代码来自： SourceCode Explorer(源代码数据库)
           复制时间： 2002-06-24 20:52:33
           当前版本： 1.0.714
               作者： Shawls
           个人主页： Http://Shawls.Yeah.Net
             E-Mail： [email protected]
                 QQ： 9181729
返回汉字字符串汉字拼音的第一个字母二Public 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
       以上代码来自： SourceCode Explorer(源代码数据库)
           复制时间： 2002-06-24 20:52:51
           当前版本： 1.0.714
               作者： Shawls
           个人主页： Http://Shawls.Yeah.Net
             E-Mail： [email protected]
                 QQ： 9181729

Answer 4

返回汉字字符串汉字拼音的第一个字母三
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 
  
工程1中 
Dim  aa  As  New  Class1 Private  Sub  Command1_Click() 
Text2.Text  =  aa.MSPYReverse(Text1.Text) 
End  Sub 
       以上代码来自： SourceCode Explorer(源代码数据库)
           复制时间： 2002-06-24 20:52:58
           当前版本： 1.0.714
               作者： Shawls
           个人主页： Http://Shawls.Yeah.Net
             E-Mail： [email protected]
                 QQ： 9181729
返回汉字字符串汉字拼音的第一个字母四'自定义函数，对任意输入的汉字，可以得到它的拼音的第一个字母
'函数入口为汉字串，返回值为该汉字的第一个字母
Public Function getHzPy(hzStr As String) As String
On Error Resume Next
'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 <= "D188" Then
getHzPy = "X"
ElseIf "D1B9" <= hznm And hznm <= "D4D0" Then
getHzPy = "Y"
ElseIf "D4D1" <= hznm And hznm <= "D7F9" Then
getHzPy = "Z"
Else
getHzPy = hznm
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 ("非法除数")
                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
       以上代码来自： SourceCode Explorer(源代码数据库)
           复制时间： 2002-06-24 20:53:08
           当前版本： 1.0.714
               作者： Shawls
           个人主页： Http://Shawls.Yeah.Net
             E-Mail： [email protected]
                 QQ： 9181729