如何得到一个汉字的声调？

JeanLaw 2004-07-15 08:53:43

如何得到一个汉字的拼音声调？就是一声、二声，平仄的那个声调。

...全文

660 8 打赏收藏转发到动态举报

写回复

用AI写文章

8 条回复

切换为时间正序

请发表友善的回复…

发表回复

ryuginka 2004-07-15

打赏
举报

JeanLaw 2004-07-15

打赏
举报

JeanLaw 2004-07-15

打赏
举报

厉害,终于解决了.

hxh2004 2004-07-15

打赏
举报

强,
虽然我没有仔细看,但是还是佩服佩服

northwolves 2004-07-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(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("《》，。/？、][{}“”‘’；：！·〈〉「」『』｜〖〗【】（）［］｛｝…—.,""'';:?/\!", 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()
MsgBox GetChineseSpell("人", 0) & vbCrLf & GetChineseSpell("人", 1) & vbCrLf & GetChineseSpell("人", 2) ' right(GetChineseSpell("人", 0),1)为声调
End Sub