关于汉字拼音声母的获取方法

lihongwu 2003-07-11 11:25:26
问题为当用户输入汉字后这样取得此汉字的拼音声母的第一字符，多谢
...全文
446 18 打赏 收藏 转发到动态 举报
写回复
用AI写文章
18 条回复
切换为时间正序
请发表友善的回复…
发表回复
一脚滑倒 2004-03-06
  • 打赏
  • 举报
 回复
你们说的程序，都不能用“烨”yue字来测试
planetike 2003-08-24
  • 打赏
  • 举报
 回复
来信,发一个带拼音库的例子给你.
planetike@tom.com
xsp 2003-08-22
  • 打赏
  • 举报
 回复
http://expert.csdn.net/Expert/topic/1613/1613627.xml?temp=.5145838
lxcc 2003-08-22
  • 打赏
  • 举报
 回复
逐个取left(GetChineseSpell("..."),1)
lxcc 2003-08-22
  • 打赏
  • 举报
 回复
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 Function

Private Sub Command1_Click()
MsgBox GetChineseSpell("程序员大本营")
End Sub
Bonnie_H 2003-08-22
  • 打赏
  • 举报
 回复
学会了，好！
xhstudio 2003-08-22
  • 打赏
  • 举报
 回复
我记得以前在的公司做过相同的程序
用的也是建立一个库，之后把要查的字去库里找
因为只要第一个字母，所以速度很快
不过也是处理不了多音字，我想这个没有什么好方法对理吧，其它的方法可能也有相同的问题
buffaloes 2003-08-22
  • 打赏
  • 举报
 回复
to boyzhang(张郎):

高，高，实在是高
boyzhang 2003-08-22
  • 打赏
  • 举报
 回复
'boyzhangpublic@163.net张郎 QQ:20437023

Public Function GetPY(strHZ As String) As String '获得单个汉字拼音的首字符
strHZ = Hex(Asc(strHZ)) '将汉字转换为其内码的十六进制字符串
Select Case strHZ
Case "B0A1" To "B0C4"
GetPY = "a"
Case "B0C5" To "B2C0"
GetPY = "b"
Case "B2C1" To "B4ED"
GetPY = "c"
Case "B4EE" To "B6E9"
GetPY = "d"
Case "B6EA" To "B7A1"
GetPY = "e"
Case "B7A2" To "B8C0"
GetPY = "f"
Case "B8C1" To "B9FD"
GetPY = "g"
Case "B9FE" To "BBF6"
GetPY = "h"
Case "BBF7" To "BFA5"
GetPY = "j"
Case "BFA6" To "C0AB"
GetPY = "k"
Case "C0AC" To "C2E7"
GetPY = "l"
Case "C2E8" To "C4C2"
GetPY = "m"
Case "C4C3" To "C5B5"
GetPY = "n"
Case "C5B6" To "C5BD"
GetPY = "o"
Case "C5BE" To "C6D9"
GetPY = "p"
Case "C6DA" To "C8BA"
GetPY = "q"
Case "C8BB" To "C8F5"
GetPY = "r"
Case "C8F6" To "CBF9"
GetPY = "s"
Case "CBFA" To "CDD9"
GetPY = "t"
Case "CDDA" To "CEF3"
GetPY = "w"
Case "CEF4" To "D188"
GetPY = "x"
Case "D189" To "D4D0"
GetPY = "y"
Case "D4D1" To "D7F9"
GetPY = "z"
Case Else
GetPY = " "
End Select
End Function

Public Function GetCode(strZF) As String '将汉字字符串转换为其拼音的首字符串
If strZF = "" Then Exit Function
Dim I As Integer, S As String
For I = 1 To Len(strZF)
S = Mid(strZF, I, 1)
GetCode = GetCode & GetPY(S)
Next I
End Function

Private Sub Command1_Click()
Command1.Caption = GetCode(Text1.Text)
End Sub
道素 2003-07-21
  • 打赏
  • 举报
 回复
针对我提到的问题,我重新写了一下,包括系统版本检查:和原来的有些不同
Option Explicit




Const GCL_CONVERSION = 1
Const GCL_REVERSECONVERSION = 2

Const VER_PLATFORM_WIN32_WINDOWS = 1
Const VER_PLATFORM_WIN32_NT = 2

Private Const IME_ESC_MAX_KEY = &H1005
Private Const IME_ESC_IME_NAME = &H1006


Type CANDIDATELIST
dwSize As Long
dwStyle As Long
dwCount As Long
dwSelection As Long
dwPageStart As Long
dwPageSize As Long
dwOffset(0) As Long
End Type

Declare Function ImmGetContext Lib "imm32" ( _
ByVal hWnd As Long _
) As Long

Declare Function ImmReleaseContext Lib "imm32" ( _
ByVal hWnd As Long, _
ByVal hIMC As Long _
) As Long

Declare Function ImmGetConversionList Lib "imm32" Alias "ImmGetConversionListW" ( _
ByVal hKL As Long, _
ByVal hIMC As Long, _
ByRef lpSrc As Byte, _
ByRef lpDst As Any, _
ByVal dwBufLen As Long, _
ByVal uFlag As Long _
) As Long

Declare Function GetKeyboardLayout Lib "user32" ( _
ByVal idThread As Long _
) As Long
Private Declare Function GetKeyboardLayoutList Lib "user32" _
(ByVal nBuff As Long, _
ByRef 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, _
ByRef lpv As Any) As Long

Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" ( _
ByRef strString As Any _
) As Long

Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion(127) As Byte
End Type

Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" ( _
ByRef VersionInfo As OSVERSIONINFO _
) As Long

Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long _
)


Public Function ReverseConversionNew(strSource As String) As String

Dim bySource() As Byte

Dim i As Integer
Dim arrKeyLayout() As Long
Dim strIME As String

Dim hIMC As Long
Dim hKL As Long
Dim lngSize As Long
Dim lngOffset As Long
Dim iKeyLayoutCount As Integer

Dim byCandiateArray() As Byte
Dim CandiateList As CANDIDATELIST

Dim byWork() As Byte
Dim lngResult As Long

Const BUFFERSIZE As Integer = 255
Dim osvi As OSVERSIONINFO

Dim isChineseIme As Boolean

If strSource = "" Then Exit Function

'OS判別
osvi.dwOSVersionInfoSize = Len(osvi)
lngResult = GetVersionEx(osvi)

If osvi.dwPlatformId = VER_PLATFORM_WIN32_NT Then
'WindowsNT系:Unicode字符集
bySource = strSource

ReDim Preserve bySource(UBound(bySource) + 2)
Else
'Windows95系
bySource = StrConv(strSource, vbFromUnicode)

ReDim Preserve bySource(UBound(bySource) + 1)
End If

hIMC = ImmGetContext(Form1.hWnd)

ReDim arrKeyLayout(BUFFERSIZE) As Long
strIME = Space(BUFFERSIZE)
iKeyLayoutCount = GetKeyboardLayoutList(BUFFERSIZE, arrKeyLayout(0))

isChineseIme = False
For i = 0 To iKeyLayoutCount - 1
If ImmEscape(arrKeyLayout(i), hIMC, IME_ESC_IME_NAME, ByVal strIME) Then
If Trim(UCase("微软拼音输入法")) = UCase(Replace(Trim(strIME), Chr(0), "")) Then
isChineseIme = True
Exit For
End If
End If
Next i

If isChineseIme = False Then Exit Function



hKL = arrKeyLayout(i)
' hKL = GetKeyboardLayout(0)

lngSize = ImmGetConversionList(hKL, hIMC, bySource(0), Null, 0, GCL_REVERSECONVERSION)

If lngSize > 0 Then

ReDim byCandiateArray(lngSize)

lngSize = ImmGetConversionList(hKL, hIMC, bySource(0), byCandiateArray(0), lngSize, _
GCL_REVERSECONVERSION)

MoveMemory CandiateList, byCandiateArray(0), Len(CandiateList)

If CandiateList.dwCount > 0 Then

lngOffset = CandiateList.dwOffset(0)

ReverseConversionNew = MidB(byCandiateArray, lngOffset + 1, _
lstrlen(byCandiateArray(lngOffset)) * 2)

End If

End If

lngResult = ImmReleaseContext(Form1.hWnd, hIMC)

End Function



dragon525 2003-07-18
  • 打赏
  • 举报
 回复
:)
赞同 ch21st(风尘鸟）!
Alicky 2003-07-18
  • 打赏
  • 举报
 回复
Attribute VB_Name = "PYModule"
Option Explicit

Function FunGetFirstLetter(StrObject As String) As String
Dim i As Integer
For i = 0 To Len(StrObject) - 1
FunGetFirstLetter = FunGetFirstLetter + GetSingleLetter(Mid(StrObject, i + 1, 1))
Next i
End Function

'以下算法只解决了一级字库,二级字库要继续找办法解决
Private Function GetSingleLetter(Str As String) As String
Dim a As Long
Dim K As Integer
a = Asc(Str)
If a < 0 Then
K = ((a + 65536) \ 256 - 160) * 100 + ((a + 65536) Mod 256) - 160 '区位码
If K >= 5249 Then
GetSingleLetter = "Z"
ElseIf K >= 4925 Then
GetSingleLetter = "Y"
ElseIf K >= 4684 Then
GetSingleLetter = "X"
ElseIf K >= 4558 Then
GetSingleLetter = "W"
ElseIf K >= 4390 Then
GetSingleLetter = "T"
ElseIf K >= 4086 Then
GetSingleLetter = "S"
ElseIf K >= 4027 Then
GetSingleLetter = "R"
ElseIf K >= 3858 Then
GetSingleLetter = "Q"
ElseIf K >= 3730 Then
GetSingleLetter = "P"
ElseIf K >= 3722 Then
GetSingleLetter = "O"
ElseIf K >= 3635 Then
GetSingleLetter = "N"
ElseIf K >= 3472 Then
GetSingleLetter = "M"
ElseIf K >= 3212 Then
GetSingleLetter = "L"
ElseIf K >= 3106 Then
GetSingleLetter = "K"
ElseIf K >= 2787 Then
GetSingleLetter = "J"
ElseIf K >= 2594 Then
GetSingleLetter = "H"
ElseIf K >= 2433 Then
GetSingleLetter = "G"
ElseIf K >= 2302 Then
GetSingleLetter = "F"
ElseIf K >= 2274 Then
GetSingleLetter = "E"
ElseIf K >= 2078 Then
GetSingleLetter = "D"
ElseIf K >= 1833 Then
GetSingleLetter = "C"
ElseIf K >= 1637 Then
GetSingleLetter = "B"
ElseIf K >= 1601 Then
GetSingleLetter = "A"
End If
Else
GetSingleLetter = Str
End If
End Function
道素 2003-07-18
  • 打赏
  • 举报
 回复
对于 dragon525的补充
这段代码在98下可以,但是在2000会有问题
把Buffer0 = VBA.StrConv(sChar, vbFromUnicode)
换成Buffer0 = sChar不需要转换
所以应该用
Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA"
( _
ByRef VersionInfo As OSVERSIONINFO _
) As Long
判断一下操作系统
qffhq 2003-07-13
  • 打赏
  • 举报
 回复
up,收藏！
netwan 2003-07-12
  • 打赏
  • 举报
 回复
强啊！收藏！
dragon525 2003-07-11
  • 打赏
  • 举报
 回复
Public Function GetPY(a1 As String) As String
Dim t1 As String
If Asc(a1) < 0 Then
t1 = Left(a1, 1)
If Asc(t1) < Asc("啊") Then
GetPY = "0"
Exit Function
End If
If Asc(t1) >= Asc("啊") And Asc(t1) < Asc("芭") Then
GetPY = "A"
Exit Function
End If
If Asc(t1) >= Asc("芭") And Asc(t1) < Asc("擦") Then
GetPY = "B"
Exit Function
End If
If Asc(t1) >= Asc("擦") And Asc(t1) < Asc("搭") Then
GetPY = "C"
Exit Function
End If
If Asc(t1) >= Asc("搭") And Asc(t1) < Asc("蛾") Then
GetPY = "D"
Exit Function
End If
If Asc(t1) >= Asc("蛾") And Asc(t1) < Asc("发") Then
GetPY = "E"
Exit Function
End If
If Asc(t1) >= Asc("发") And Asc(t1) < Asc("噶") Then
GetPY = "F"
Exit Function
End If
If Asc(t1) >= Asc("噶") And Asc(t1) < Asc("哈") Then
GetPY = "G"
Exit Function
End If
If Asc(t1) >= Asc("哈") And Asc(t1) < Asc("击") Then
GetPY = "H"
Exit Function
End If
If Asc(t1) >= Asc("击") And Asc(t1) < Asc("喀") Then
GetPY = "J"
Exit Function
End If
If Asc(t1) >= Asc("喀") And Asc(t1) < Asc("垃") Then
GetPY = "K"
Exit Function
End If
If Asc(t1) >= Asc("垃") And Asc(t1) < Asc("妈") Then
GetPY = "L"
Exit Function
End If
If Asc(t1) >= Asc("妈") And Asc(t1) < Asc("拿") Then
GetPY = "M"
Exit Function
End If
If Asc(t1) >= Asc("拿") And Asc(t1) < Asc("哦") Then
GetPY = "N"
Exit Function
End If
If Asc(t1) >= Asc("哦") And Asc(t1) < Asc("啪") Then
GetPY = "O"
Exit Function
End If
If Asc(t1) >= Asc("啪") And Asc(t1) < Asc("期") Then
GetPY = "P"
Exit Function
End If
If Asc(t1) >= Asc("期") And Asc(t1) < Asc("然") Then
GetPY = "Q"
Exit Function
End If
If Asc(t1) >= Asc("然") And Asc(t1) < Asc("撒") Then
GetPY = "R"
Exit Function
End If
If Asc(t1) >= Asc("撒") And Asc(t1) < Asc("塌") Then
GetPY = "S"
Exit Function
End If
If Asc(t1) >= Asc("塌") And Asc(t1) < Asc("挖") Then
GetPY = "T"
Exit Function
End If
If Asc(t1) >= Asc("挖") And Asc(t1) < Asc("昔") Then
GetPY = "W"
Exit Function
End If
If Asc(t1) >= Asc("昔") And Asc(t1) < Asc("压") Then
GetPY = "X"
Exit Function
End If
If Asc(t1) >= Asc("压") And Asc(t1) < Asc("匝") Then
GetPY = "Y"
Exit Function
End If
If Asc(t1) >= Asc("匝") Then
GetPY = "Z"
Exit Function
End If
Else
If UCase(a1) <= "Z" And UCase(a1) >= "A" Then
GetPY = UCase(Left(a1, 1))
Else
GetPY = "0"
End If
End If
End Function
或用这个函数最简单，但是有些生僻字可能会有误如：嘌、呤,噢、杞。
如果你只是应用于一般数据库系统。名称的拼音查询的话，用以上的函数足已。（因为通常这些生僻字不会用来命名什么东西的。 如果你的要求很高的话，可以将一些拼音特殊的生僻字单独做一个库文件（.lib)保存起来。
dragon525 2003-07-11
  • 打赏
  • 举报
 回复
1 根据输入法得到拼音
2 建立一个词典（可以是数据库等外部文件，也可以在vb中用Dictionary创建）
可以参考：http://expert.csdn.net/Expert/topic/1723/1723561.xml?temp=.9041864

根据微软拼音输入法得到拼音的例子：
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
netwan 2003-07-11
  • 打赏
  • 举报
 回复
很简单,用数据库就可以实现:
记得win98附件里面有一个程序叫做:输入法生成器
用他把拼音输入法里面好像有一个文件叫mspy.ime的文件转成文本文件.
格式好象是这样:
啊 a
吧 ba
次 ci
再用sql的数据导入导出工具把他做成数据库.
zw,py
_________
啊 a
吧 ba
次 ci

然后就可以用 select left(py,1) as firstPy from dict where zw='啊'
得到你想要的,但如果要考虑多音字这种情况就要复杂些,目前我也还没有找到解决方法.
汉字转拼音声母首字母 dll
汉字转拼音声母首字母 dll delphi
ＰＢ获取汉字拼音首字母
用ＰＢ写的获取汉字拼音首字母函数,也就是汉字拼音的声母．
一个获得汉字拼音首字母的java程序
一个获取汉字拼音首字母的java程序，简单有效。
oracle汉字转拼音 获得全拼、拼音首字母、拼音截取等
oracle汉字转拼音 获得全拼、拼音首字母、拼音截取等
delphi获取汉字拼音
delphi获取汉字拼音的源代码，可以获得汉字的完整拼音。也可以获取声母。
API

1,486

社区成员

23,279

社区内容

发帖
与我相关
我的任务
社区描述
VB API
社区管理员
  • API
加入社区
  • 近7日
  • 近30日
  • 至今

加载中

查看更多榜单
社区公告
暂无公告

试试用AI创作助手写篇文章吧

+ 用AI写文章