救命！帮助！help！如何得到一个汉字的第一个拼音字母？

Question

我想得到一个汉字的第一个拼音字母，比如， 爱 ，第一个字母就是 Z 
多谢了，！！！

Answer 1

Option Explicit'在窗口中加两个TEXT控件,一个输入中文,一个显示英文
Private Sub Form_Load()
    Text1.Text = "我是中国人"
End SubPrivate Sub Command1_Click()
    Text2.Text = GetPY(Text1.Text)
End Sub'获得输入名称的首字拼音
Private Function GetPY(ByVal strParmeter As String) As String
    Dim intTmp As String, i As Long
    
    For i = 1 To Len(strParmeter)
        intTmp = Asc(Mid(strParmeter, i, 1))        If intTmp < Asc("啊") Then
            GetPY = GetPY & "*"
        ElseIf intTmp >= Asc("啊") And intTmp < Asc("芭") Then
            GetPY = GetPY & "A"
        ElseIf intTmp >= Asc("芭") And intTmp < Asc("擦") Then
            GetPY = GetPY & "B"
        ElseIf intTmp >= Asc("擦") And intTmp < Asc("搭") Then
            GetPY = GetPY & "C"
        ElseIf intTmp >= Asc("搭") And intTmp < Asc("蛾") Then
            GetPY = GetPY & "D"
        ElseIf intTmp >= Asc("蛾") And intTmp < Asc("发") Then
            GetPY = GetPY & "E"
        ElseIf intTmp >= Asc("发") And intTmp < Asc("噶") Then
            GetPY = GetPY & "F"
        ElseIf intTmp >= Asc("噶") And intTmp < Asc("哈") Then
            GetPY = GetPY & "G"
        ElseIf intTmp >= Asc("哈") And intTmp < Asc("击") Then
            GetPY = GetPY & "H"
        ElseIf intTmp >= Asc("击") And intTmp < Asc("喀") Then
            GetPY = GetPY & "J"
        ElseIf intTmp >= Asc("喀") And intTmp < Asc("垃") Then
            GetPY = GetPY & "K"
        ElseIf intTmp >= Asc("垃") And intTmp < Asc("妈") Then
            GetPY = GetPY & "L"
        ElseIf intTmp >= Asc("妈") And intTmp < Asc("拿") Then
            GetPY = GetPY & "M"
        ElseIf intTmp >= Asc("拿") And intTmp < Asc("哦") Then
            GetPY = GetPY & "N"
        ElseIf intTmp >= Asc("哦") And intTmp < Asc("啪") Then
            GetPY = GetPY & "O"
        ElseIf intTmp >= Asc("啪") And intTmp < Asc("期") Then
            GetPY = GetPY & "P"
        ElseIf intTmp >= Asc("期") And intTmp < Asc("然") Then
            GetPY = GetPY & "Q"
        ElseIf intTmp >= Asc("然") And intTmp < Asc("撒") Then
            GetPY = GetPY & "R"
        ElseIf intTmp >= Asc("撒") And intTmp < Asc("塌") Then
            GetPY = GetPY & "S"
        ElseIf intTmp >= Asc("塌") And intTmp < Asc("挖") Then
            GetPY = GetPY & "T"
        ElseIf intTmp >= Asc("挖") And intTmp < Asc("昔") Then
            GetPY = GetPY & "W"
        ElseIf intTmp >= Asc("昔") And intTmp < Asc("压") Then
            GetPY = GetPY & "X"
        ElseIf intTmp >= Asc("压") And intTmp < Asc("匝") Then
            GetPY = GetPY & "Y"
        ElseIf intTmp >= Asc("匝") And intTmp < 0 Then
            GetPY = GetPY & "Z"
        ElseIf (intTmp >= 65 And intTmp <= 91) Or (intTmp >= 97 And intTmp <= 123) Then
            GetPY = GetPY & Mid(strParmeter, i, 1)
        Else
            GetPY = GetPY & "*"
        End If
    Next
End Function

Answer 2

http://pcwak.8u8.com/py.rar
一个例子

Answer 3

好贴谢谢cuizm(射天狼)我原来以为必须要用库呢

Answer 4

如果在数据库中操作，可以这样create function f_ch2py(@chn nchar(1))
returns char(1)
as
begin
declare @n int
declare @c char(1)
set @n = 63select @n = @n +1,
       @c = case chn when @chn then char(@n) else @c end
from(
 select top 27 * from (
     select chn = 
'吖' union all select
'八' union all select
'嚓' union all select
'咑' union all select
'妸' union all select
'发' union all select
'旮' union all select
'铪' union all select
'丌' union all select  --because have no 'i'
'丌' union all select
'咔' union all select
'垃' union all select
'嘸' union all select
'拏' union all select
'噢' union all select
'妑' union all select
'七' union all select
'呥' union all select
'仨' union all select
'他' union all select
'屲' union all select  --no 'u'
'屲' union all select  --no 'v'
'屲' union all select
'夕' union all select
'丫' union all select
'帀' union all select @chn) as a
order by chn COLLATE Chinese_PRC_CI_AS 
) as b
return(@c)
endgo
select dbo.f_ch2py('斌')  --B
select dbo.f_ch2py('国')  --G
select dbo.f_ch2py('人')  --R
select dbo.f_ch2py('镆')  --M
drop function f_ch2py

Answer 5

//我原来以为必须要用库呢最好用库 cuizm(射天狼)的程序只能查找1级汉字

Answer 6

http://expert.csdn.net/Expert/topic/2004/2004222.xml?temp=.0641138
查表法根据微软拼音输入法得到拼音的例子：
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 FunctionPrivate Sub Command1_Click()
VBA.MsgBox GetChineseSpell("你好")
End Sub

Answer 7

回复人： cuizm(射天狼) ( ) 信誉：100  的函数可以使用，测试成功，谢谢
 回复人： pcwak(书剑狂生[MS MVP]) ( ) 信誉：66   的那个例子很好，谢谢，很简洁 回复人： rainstormmaster(rainstormmaster) ( ) 信誉：130   的函数返回值是空的
谢谢你们

Answer 8

//rainstormmaster(rainstormmaster) ( ) 信誉：130   的函数返回值是空的你要确定系统上已经安装了微软拼音输入法（对输入法有依赖，所以我建议用码表），我在98下测试通过

Answer 9

hehe,继续学习中，rainstormmaster(rainstormmaster)方法也很好给了我一个用库的理由先

Answer 10

真是条条大道通罗马!建议使用rainstormmaster(rainstormmaster)的!
cuizm(射天狼)在1级字库可用!

Answer 11

如果要得到汉字的第一个拼音字母的话，下面的方法也不错。
一、先建立一个如下的类：cHZtoSM.cls
Option ExplicitConst ERR_RESULT$ = "?"          ' 函数的错误返回值Private mGB2312SM$
Private mLoadLibSuccess As BooleanPrivate Sub Class_Initialize()
    mGB2312SM$ = ""
    mLoadLibSuccess = False
End SubPrivate Sub Class_Terminate()
    mGB2312SM$ = ""
    mLoadLibSuccess = False
End Sub
'********************************************
'* 加载库文件 成功 LoadLibSuccess = True     *
'*           失败 LoadLibSuccess = False    *
'*                                          *
'*******************************************
Public Property Get LoadLibSuccess() As Boolean
    LoadLibSuccess = mLoadLibSuccess
End Property'********************************************
'* 方法: LoadLibFile                        *
'* 功能: 加载库文件                          *
'* 注意: 将设置加载成功标志 mLoadLibSuccess  *
'* 入口: LibFileName     库文件名            *
'********************************************
Public Sub LoadLibFile(ByVal LibFileName$)
    Dim FileNum&
    Dim tmpText$
    
    On Error GoTo ErrLoad:
    FileNum& = FreeFile
    
    Open LibFileName$ For Input As #FileNum
    
    ' 顺序读取库文件,保存到变量 mGB2312SM$ 中
    Do While Not EOF(1)
       Line Input #FileNum, tmpText$
       mGB2312SM$ = mGB2312SM$ & tmpText$
    Loop
    Close #FileNum
    
    ' 加载库文件成功
    mLoadLibSuccess = True
    
    Exit Sub
ErrLoad:
    MsgBox "加载库文件 " & LibFileName$ & " 失败！", vbExclamation, "来自类 cHZtoSM 的错误"
    mGB2312SM$ = ""
    mLoadLibSuccess = False
End Sub'**********************************************************
'*             函数: HZtoSM                               *
'*                                                        *
'* 功能: 返回字符串中第一个字符的声母                       *
'* 注意: 该函数能处理所有汉字,但需要库文件的支持             *
'* 若待处理的字符并不在库文件中,则函数将返回常数 ERR_RESULT$ *
'* 入口: Str     待处理的字符串                            *
'**********************************************************
Public Function HZtoSM$(ByVal str$)
    Dim Tmpstr$, sAscii$
    Dim lAsciiU&, lAsciiL&
    Dim fPos&
    
    ' 取出字符串中的第一个字符
    Tmpstr$ = Left(str$, 1)
    
    ' 若tmpStr长度为 0 ,则函数无返回值
    If Len(Tmpstr$) <= 0 Then Exit Function
    
    ' 返回字符型 ASCII 码
    sAscii$ = Hex(Asc(Tmpstr$))    If Len(sAscii$) <> 4 Then GoTo ErrChg:
    
    ' 取出字符高字节和低字节
    lAsciiU& = Val("&H" & Left(sAscii$, 2))
    lAsciiL& = Val("&H" & Right(sAscii$, 2))
    
    ' 公式: ( 高两位 - &H81 ) * ( 16 * 12 - 1 ) +
    '       ( 低两位 - &H40 + 1 )
    ' 即可计算出声母对应的位置
    fPos& = (lAsciiU - &H81) * 191 + (lAsciiL& - 63)
    If fPos& < 0 Or fPos& > Len(mGB2312SM) Then GoTo ErrChg:
    
    ' 在库文件查找对应的声母
    HZtoSM$ = UCase(Mid(mGB2312SM, fPos&, 1))
    If (Asc(HZtoSM$) < &H41) Or (Asc(HZtoSM$) > &H90) Then GoTo ErrChg:
    
    Exit Function
ErrChg:
    ' 函数转换错误,返回常数 ERR_RESULT
   ' HZtoSM$ = ERR_RESULT$
   HZtoSM$ = UCase(Tmpstr$)
End Function'*****************************************************
'*             函数: HZtoSMEx                        *
'*                                                   *
'* 功能: 返回字符串中每个字符的声母,由函数 HZtoSM 扩展来*
'* 入口: Str     待处理的字符串                        *
'*                                                    *
'******************************************************
Public Function HZtoSMEx$(ByVal str$)
    Dim nPos&
    
    For nPos& = 1 To Len(str$)
        HZtoSMEx$ = HZtoSMEx$ & HZtoSM(Mid(str$, nPos&, 1))
    Next nPos&
End Function

Answer 12

下载这个文件到程序目录下。
http://218.77.39.97/jingying/soft/GB2312SM.rar使用方法：
'********************************************************
'*
'*取字符串的拼音码类　如mHZtoSM.HZtoSMEx(“计算机”)="JSJ"*
'*                                                      *
'********************************************************
Public mHZtoSM As cHztoSM
    Set mHZtoSM = New cHztoSM
    mHZtoSM.LoadLibFile App.Path & "\GB2312SM.Lib"
    If Not mHZtoSM.LoadLibSuccess Then
        MsgBox "打开拼音库GB23125SM时出错，可能系统某些功能使用会不正常！", vbCritical
    End If

Answer 13

下载后还要解压缩，是一个.lib文件，放到程序目录下

Answer 14

cuizm(射天狼)  你真的厉害  你的程序我看了很长时间  明白什么意思了
你都要成为我的偶像了~~~~~~~~~~~~~~

Answer 15

'//函数入口为汉字串，返回值为该汉字的第一个字母
Public Function getHzPy(hzStr As String) As String
On Error Resume Next
'declare  variable
Dim myHzm As Integer
Dim qm As Integer
Dim wm As Integer
Dim hznm As String
If Len(hzStr) > 1 Then
    myHzm = Asc(Left(hzStr, 1))
Else
    myHzm = Asc(hzStr)
End If
If myHzm >= 0 And myHzm < 256 Then
    '字母
    getHzPy = hzStr
Else
    '汉字
    qm = (myHzm + 65536) \ 256    '取区码
    wm = (myHzm + 65536) Mod 256  '取位码
    '十进制到十六进制
    hznm = tento(qm, 16) & tento(wm, 16)
End If
If "B0A1" <= hznm And hznm <= "B0C4" Then
getHzPy = "A"
ElseIf "B0C5" <= hznm And hznm <= "B2C0" Then
getHzPy = "B"
ElseIf "B2C1" <= hznm And hznm <= "B4ED" Then
getHzPy = "C"
ElseIf "B4EE" <= hznm And hznm <= "B6E9" Then
getHzPy = "D"
ElseIf "B6EA" <= hznm And hznm <= "B7A1" Then
getHzPy = "E"
ElseIf "B7A2" <= hznm And hznm <= "B8C0" Then
getHzPy = "F"
ElseIf "B8C1" <= hznm And hznm <= "B9FD" Then
getHzPy = "G"
ElseIf "B9FE" <= hznm And hznm <= "BBF6" Then
getHzPy = "H"
ElseIf "BBF7" <= hznm And hznm <= "BFA5" Then
getHzPy = "J"
ElseIf "BFA6" <= hznm And hznm <= "C0AB" Then
getHzPy = "K"
ElseIf "C0AC" <= hznm And hznm <= "C2E7" Then
getHzPy = "L"
ElseIf "C2E8" <= hznm And hznm <= "C4C2" Then
getHzPy = "M"
ElseIf "C4C3" <= hznm And hznm <= "C5B5" Then
getHzPy = "N"
ElseIf "C5B6" <= hznm And hznm <= "C5BD" Then
getHzPy = "O"
ElseIf "C5BE" <= hznm And hznm <= "C6D9" Then
getHzPy = "P"
ElseIf "C6DA" <= hznm And hznm <= "C8BA" Then
getHzPy = "Q"
ElseIf "C8BB" <= hznm And hznm <= "C8F5" Then
getHzPy = "R"
ElseIf "C8F6" <= hznm And hznm <= "CBF9" Then
getHzPy = "S"
ElseIf "CBFA" <= hznm And hznm <= "CDD9" Then
getHzPy = "T"
ElseIf "CDDA" <= hznm And hznm <= "CEF3" Then
getHzPy = "W"
ElseIf "CEF4" <= hznm And hznm <= "D188" Then
getHzPy = "X"
ElseIf "D1B9" <= hznm And hznm <= "D4D0" Then
getHzPy = "Y"
ElseIf "D4D1" <= hznm And hznm <= "D7F9" Then
getHzPy = "Z"
Else
getHzPy = hznm
End If
End Function
'************************辅助函数，可以从十进制转换到任意进制**********************
'//入口为十进制数，要转换的进制，返回为该进制数
Public Function tento(m As Integer, n As Integer) As String
Dim q As Integer
Dim r As Integer
    tento = ""
    Dim bStr As String
    Do
    Call myDivide(m, n, q, r)
    If r > 9 Then
        bStr = Chr(55 + r)
    Else
        bStr = Str(r)
    End If
    tento = Trim(bStr) & tento
    m = q
    Loop While q <> 0
End Function'************************辅助过程，得到任意两个数的商和余数***************************
Public Sub myDivide(num1 As Integer, num2 As Integer, q As Integer, r As Integer)
    If num2 = 0 Then
        MsgBox ("非法除数")
        Exit Sub
    End If
    If num1 / num2 >= 0 Then
        q = Int(num1 / num2)
    Else
        q = Int(num1 / num2) + 1
    End If
        r = num1 Mod num2
End Sub 
Private Sub Command1_Click()
   Text2.Text = getHzPy("汉")
End Sub