VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
查看: 7277|回复: 12

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

[复制链接]
 楼主| 发表于 2008-12-10 18:01:19 | 显示全部楼层 |阅读模式
转载一篇VB妮可版主的经典汉字转拼音代码,给需要的朋友。
原文地址:http://zhidao.baidu.com/question/39190631.html?fr=qrl

  1. '模块:
  2. Option Explicit

  3. Private Const IME_ESC_MAX_KEY = &H1005
  4. Private Const IME_ESC_IME_NAME = &H1006
  5. Private Const GCL_REVERSECONVERSION = &H2
  6. Private Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long
  7. 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
  8. 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
  9. Private Declare Function IsDBCSLeadByte Lib "kernel32" (ByVal bTestChar As Byte) As Long

  10. Public Function GetChineseSpell(ByVal CHINESE As String, Optional PYTYPE As Integer = 0, Optional Delimiter As String = " ") As String

  11. If Len(Trim(CHINESE)) > 0 Then
  12. Dim i As Long
  13. Dim s As String
  14. s = Space(255)
  15. Dim IMEInstalled As Boolean
  16. Dim j As Long
  17. Dim a() As Long

  18. ReDim a(255) As Long
  19. j = GetKeyboardLayoutList(255, a(LBound(a)))

  20. For i = LBound(a) To LBound(a) + j - 1
  21. If ImmEscape(a(i), 0, IME_ESC_IME_NAME, ByVal s) Then
  22. If Trim("微软拼音输入法") = Replace(Trim(s), Chr(0), "") Then
  23. IMEInstalled = True
  24. Exit For
  25. End If
  26. End If
  27. Next i
  28. If IMEInstalled Then
  29. CHINESE = Trim(CHINESE)
  30. Dim sChar As String
  31. Dim Buffer0() As Byte
  32. Dim bBuffer0() As Byte
  33. Dim bBuffer() As Byte
  34. Dim k As Long
  35. Dim l As Long
  36. Dim m As Long
  37. For j = 0 To Len(CHINESE) - 1
  38. sChar = Mid(CHINESE, j + 1, 1)
  39. ' If Not InStr("《》,。/?、][{}“”‘’;:!?〈〉「」『』|〖〗【】()〔〕{}…--.,""'';:?/\!", sChar) > 0 Then
  40. Buffer0 = StrConv(sChar, vbFromUnicode)
  41. If IsDBCSLeadByte(Buffer0(0)) Then
  42. k = ImmEscape(a(i), 0, IME_ESC_MAX_KEY, Null)
  43. If k Then
  44. l = ImmGetConversionList(a(i), 0, sChar, 0, 0, GCL_REVERSECONVERSION)
  45. If l Then
  46. s = Space(255)
  47. If ImmGetConversionList(a(i), 0, sChar, ByVal s, l, GCL_REVERSECONVERSION) Then

  48. bBuffer0 = StrConv(s, vbFromUnicode)
  49. ReDim bBuffer(k * 2 - 1)
  50. For m = bBuffer0(24) To bBuffer0(24) + k * 2 - 1
  51. bBuffer(m - bBuffer0(24)) = bBuffer0(m)
  52. Next m
  53. sChar = Trim(StrConv(bBuffer, vbUnicode))
  54. If InStr(sChar, vbNullChar) Then
  55. sChar = Trim(Left(sChar, InStr(sChar, vbNullChar) - 1))
  56. End If
  57. End If
  58. End If

  59. End If
  60. End If
  61. ' End If
  62. GetChineseSpell = GetChineseSpell & Switch(PYTYPE = 0, sChar, PYTYPE = 1, Left(sChar, Len(sChar) - 1), PYTYPE = 2, UCase(Left(sChar, 1))) & IIf(PYTYPE = 2, "", Delimiter) ''返回全拼
  63. Next j
  64. Else ''没安装“微软拼音输入法”,返回一个空格
  65. GetChineseSpell = " "
  66. End If
  67. Else
  68. GetChineseSpell = "" ''输入为空字符串
  69. End If
  70. End Function


  71. '下面是窗体代码:
  72. Private Sub Command1_Click()
  73. Print GetChineseSpell("孢孚", 2)
  74. End Sub


  75. ==============================
  76. 注意,
  77. 1.一定要系统安装的有微软拼音输入法,不然返回的是空格..
  78. 2.模块中没有带,或是说没完全带标点的处理过程,你应该自己在程序中处理或是修改模块
  79. 3.使用方法有3个参数,0是返回带单调的全拼,1是返回完整拼音,2是返回拼音首字母..

  80. 测试通过,VB妮可.
  81. 回答者: VB妮可 - 副总裁 十级   11-8 21:43
复制代码

评分

参与人数 1威望 +3 收起 理由
gbm + 3 我很赞同

查看全部评分

发表于 2008-12-10 19:01:11 | 显示全部楼层
嗯, 不错
回复 支持 反对

使用道具 举报

发表于 2008-12-10 20:01:00 | 显示全部楼层
楼主转VB妮可的代码,她同意了吗?
如果妮妮不同意,那么她会很生气,于是后果就相当严重
回复 支持 反对

使用道具 举报

 楼主| 发表于 2008-12-10 20:09:55 | 显示全部楼层
原帖由 sgz888 于 2008-12-10 20:01 发表
楼主转VB妮可的代码,她同意了吗?
如果妮妮不同意,那么她会很生气,于是后果就相当严重



,不必担心,事先询问过VB妮可的,同意才发贴供大家学习交流的。
这段代码太经典和实用了。
回复 支持 反对

使用道具 举报

发表于 2008-12-10 22:31:28 | 显示全部楼层
原来是利用了微软拼音的API。。。
回复 支持 反对

使用道具 举报

发表于 2008-12-10 23:31:17 | 显示全部楼层
  其实,我也是转的..

评分

参与人数 1威望 +2 收起 理由
DreamonII + 2 年度十佳诚实奖

查看全部评分

回复 支持 反对

使用道具 举报

发表于 2008-12-11 11:10:16 | 显示全部楼层
虽然系统没有安装微软拼音输入法,但是还是要顶一下!
回复 支持 反对

使用道具 举报

发表于 2008-12-14 17:44:45 | 显示全部楼层
取拼音首码,原来可以这样实现!
回复 支持 反对

使用道具 举报

发表于 2008-12-14 19:37:44 | 显示全部楼层
测试有效,不过要处理一下标点符号和拼音标调的问题(将数字转换为实在的声调)
回复 支持 反对

使用道具 举报

发表于 2008-12-15 09:05:03 | 显示全部楼层
鉴定完毕,马屁贴!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2022-7-4 04:02

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表