7,763
社区成员
发帖
与我相关
我的任务
分享有没有实现这种功能的软件？如果自己写的话，该怎么做啊？
就是能提取汉字拼音头个字母的软件，比如：
重庆 CQ
福州 FZ
北京故宫 BJGG
我是解放军 WSJFJ
重庆 CQ
福州 FZ
北京故宫 BJGG
我是解放军 WSJFJ
...全文
请发表友善的回复…
发表回复
啊维 2004-04-14
- 打赏
- 举报
楼主:马桶在WC里啊
mmcgzs 2004-04-14
- 打赏
- 举报
大家不要抢，都有分。
不要误会，我也是来抢分的。
楼上的正确。
楼主给分吧
不要误会，我也是来抢分的。
楼上的正确。
楼主给分吧
高高兴兴的晶晶 2004-04-13
- 打赏
- 举报
袁飞站点
http://www.jxsks.com/yuanfei/main/firstpage.asp
★ 袁飞汉字拼音互查控件 1.2 版 2002-5-15 20:44:04 452 185.80 K(包含演示程序)
袁飞汉字拼音互查控件 1.2 版!
新增功能:
1、添加取汉字之“常用拼音”功能。
2、添加取汉字之“拼音首码”功能。
3、改进算法，大大压缩身躯！(1.0 版控件为2.78M, 1.2 版仅 428K)
http://www.jxsks.com/yuanfei/main/firstpage.asp
★ 袁飞汉字拼音互查控件 1.2 版 2002-5-15 20:44:04 452 185.80 K(包含演示程序)
袁飞汉字拼音互查控件 1.2 版!
新增功能:
1、添加取汉字之“常用拼音”功能。
2、添加取汉字之“拼音首码”功能。
3、改进算法，大大压缩身躯！(1.0 版控件为2.78M, 1.2 版仅 428K)
northwolves 2004-04-13
- 打赏
- 举报
'不考虑多音字，可以用这个小函数：
Function pinyin(ByVal x As String) As String
Const hanzi = "啊芭擦搭蛾发噶哈击喀垃妈拿哦啪期然撒塌挖昔压匝座ABCDEFGHJKLMNOPQRSTWXYZZ"
Dim i As Long, j As Long, a() As String
ReDim a(1 To Len(x))
For i = 1 To Len(x)
a(i) = Mid(x, i, 1)
Next
For i = 1 To Len(x)
If a(i) = "座" Then a(i) = "Z"
For j = 1 To 23
If Asc(a(i)) >= Asc(Mid(hanzi, j, 1)) And Asc(a(i)) < Asc(Mid(hanzi, j + 1, 1)) Then a(i) = Mid(hanzi, 24 + j, 1)
Next
Next
pinyin = UCase(Join(a, ""))
Erase a
End Function
Private Sub Command1_Click()
MsgBox pinyin("重庆")
MsgBox pinyin("福州")
MsgBox pinyin("北京故宫")
MsgBox pinyin("我是解放军")
End Sub
Function pinyin(ByVal x As String) As String
Const hanzi = "啊芭擦搭蛾发噶哈击喀垃妈拿哦啪期然撒塌挖昔压匝座ABCDEFGHJKLMNOPQRSTWXYZZ"
Dim i As Long, j As Long, a() As String
ReDim a(1 To Len(x))
For i = 1 To Len(x)
a(i) = Mid(x, i, 1)
Next
For i = 1 To Len(x)
If a(i) = "座" Then a(i) = "Z"
For j = 1 To 23
If Asc(a(i)) >= Asc(Mid(hanzi, j, 1)) And Asc(a(i)) < Asc(Mid(hanzi, j + 1, 1)) Then a(i) = Mid(hanzi, 24 + j, 1)
Next
Next
pinyin = UCase(Join(a, ""))
Erase a
End Function
Private Sub Command1_Click()
MsgBox pinyin("重庆")
MsgBox pinyin("福州")
MsgBox pinyin("北京故宫")
MsgBox pinyin("我是解放军")
End Sub
liuyanghe111 2004-04-13
- 打赏
- 举报
如果是多音字，就要注意了，我建议你下载一个袁飞拼音控件
icecanal 2004-04-13
- 打赏
- 举报
也可用数据库的方法,我自己作了一个GBK字库的汉字拼音笔划的数据库
ukyoxh 2004-04-13
- 打赏
- 举报
给你一段代码
新建立一个模块,把下面的代码粘贴进去
Option Explicit
Public Const CB_SHOWDROPDOWN = &H14F
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
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
Dim temp 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
If GetChineseSpell <> "" Then
temp = Mid(GetChineseSpell, 1, 1)
For i = 1 To Len(GetChineseSpell)
If Mid(GetChineseSpell, i, 1) = " " Then
temp = temp + Mid(GetChineseSpell, i + 1, 1)
End If
Next
End If
GetChineseSpell = temp
End Function
'使用例子
'注意,系统必须安装微软拼音输入法
dim s as string
s=GetChineseSpell("重庆")
新建立一个模块,把下面的代码粘贴进去
Option Explicit
Public Const CB_SHOWDROPDOWN = &H14F
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
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
Dim temp 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
If GetChineseSpell <> "" Then
temp = Mid(GetChineseSpell, 1, 1)
For i = 1 To Len(GetChineseSpell)
If Mid(GetChineseSpell, i, 1) = " " Then
temp = temp + Mid(GetChineseSpell, i + 1, 1)
End If
Next
End If
GetChineseSpell = temp
End Function
'使用例子
'注意,系统必须安装微软拼音输入法
dim s as string
s=GetChineseSpell("重庆")
