VB的文本资料,需要时有帮助

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(ByVal CHINESE As String, Optional PYTYPE As Integer = 0, Optional Delimiter As String = " ") As String

If Len(Trim(CHINESE)) > 0 Then
 Dim i As Long
 Dim s As String
 s = Space(255)
 Dim IMEInstalled As Boolean
 Dim j As Long
 Dim a() As Long
 
 ReDim a(255) As Long
 j = GetKeyboardLayoutList(255, 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("微软拼音输入法") = Replace(Trim(s), Chr(0), "") Then
      IMEInstalled = True
      Exit For
     End If
   End If
 Next i
 If IMEInstalled Then
   CHINESE = Trim(CHINESE)
   Dim sChar As String
   Dim Buffer0() 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)
   '  If Not InStr("·￡??￡/￡??￠][{}?°?±???ˉ￡?￡o￡??¤?′?μ???1?o??￡ü????????￡¨￡?￡?￡Y￡?￡y?-?a.,""'';:?/\!", sChar) > 0 Then
     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(255)
         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
          End If
         End If
         
        End If
      End If
    ' End If
     GetChineseSpell = GetChineseSpell & Switch(PYTYPE = 0, sChar, PYTYPE = 1, Left(sChar, Len(sChar) - 1), PYTYPE = 2, UCase(Left(sChar, 1))) & IIf(PYTYPE = 2, "", Delimiter)  ''返回全拼
     Next j
 Else ''没安装“微软拼音输入法”，返回一个空格
    GetChineseSpell = " "
 End If
Else
 GetChineseSpell = "" ''输入为空字符串
End If
End Function

Private Sub Command1_Click()
Const x As String = "中华人民共和国"
MsgBox "全拼+声调：" & GetChineseSpell(x, 0) & vbCrLf & "全拼：" & GetChineseSpell(x, 1) & vbCrLf & "拼音首字母" & GetChineseSpell(x, 2), 0, x
End Sub