VB妮可版主的汉字转拼音（经典）

ErickYoung · 发表于 2008-12-10 18:01:19

转载一篇VB妮可版主的经典汉字转拼音代码，给需要的朋友。
原文地址：http://zhidao.baidu.com/question/39190631.html?fr=qrl

'模块:
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()
Print GetChineseSpell("孢孚", 2)
End Sub
==============================
注意,
1.一定要系统安装的有微软拼音输入法,不然返回的是空格..
2.模块中没有带,或是说没完全带标点的处理过程,你应该自己在程序中处理或是修改模块
3.使用方法有3个参数,0是返回带单调的全拼,1是返回完整拼音,2是返回拼音首字母..
测试通过,VB妮可.
回答者： VB妮可 - 副总裁十级 11-8 21:43

复制代码

iceboy · 发表于 2008-12-10 19:01:11

嗯, 不错

sgz888 · 发表于 2008-12-10 20:01:00

楼主转VB妮可的代码，她同意了吗？
如果妮妮不同意，那么她会很生气，于是后果就相当严重

ErickYoung · 发表于 2008-12-10 20:09:55

原帖由 sgz888 于 2008-12-10 20:01 发表
楼主转VB妮可的代码，她同意了吗？
如果妮妮不同意，那么她会很生气，于是后果就相当严重

，不必担心，事先询问过VB妮可的，同意才发贴供大家学习交流的。

这段代码太经典和实用了。

VBProFan · 发表于 2008-12-10 22:31:28

原来是利用了微软拼音的API。。。

VB妮可 · 发表于 2008-12-10 23:31:17

其实,我也是转的..

xthyx · 发表于 2008-12-11 11:10:16

虽然系统没有安装微软拼音输入法，但是还是要顶一下！

Jwing · 发表于 2008-12-14 17:44:45

取拼音首码,原来可以这样实现!

阳光宝宝 · 发表于 2008-12-14 19:37:44

测试有效，不过要处理一下标点符号和拼音标调的问题(将数字转换为实在的声调)

iamxiang · 发表于 2008-12-15 09:05:03

鉴定完毕，马屁贴！

		自动登录	找回密码
密码			立即注册

VBGood网站全文搜索

[转帖] VB妮可版主的汉字转拼音（经典）

评分

评分