提取汉字第一个拼音字母或五笔第一个字根问题

Question

我想达到这样一个效果:当我输入汉字时可以根据我事先的设定,自动显示此汉字的第一个拼音字母或五笔第一个字根,如当我选择拼音时,如果我输入"你是谁",则可以显示"NSS".请问这个效果如何实现?请给个实际例子说明,谢谢!

Answer 1

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, "")
           sChar = UCase(Left(sChar, 1))
         End If
         
        End If
      End If
     End If
     GetChineseSpell = GetChineseSpell & sChar
   Next j
 Else
   
 
 End If
  
End If
End FunctionPrivate Sub Command1_Click()
MsgBox GetChineseSpell("你是谁")
End Sub

Answer 2

判断拼音首个字母的代码我有，是利用ASCII码判断的，原理很简单，很容易看懂：）
//定义首字拼音过程Public Function py(mystr As String) As String
If Asc(mystr) < 0 Then
    If Asc(Left(mystr, 1)) < Asc("啊") Then
    py = "0"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("啊") And Asc(Left(mystr, 1)) < Asc("芭") Then
    py = "A"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("芭") And Asc(Left(mystr, 1)) < Asc("擦") Then
    py = "B"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("擦") And Asc(Left(mystr, 1)) < Asc("搭") Then
    py = "C"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("搭") And Asc(Left(mystr, 1)) < Asc("蛾") Then
    py = "D"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("蛾") And Asc(Left(mystr, 1)) < Asc("发") Then
    py = "E"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("发") And Asc(Left(mystr, 1)) < Asc("噶") Then
    py = "F"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("噶") And Asc(Left(mystr, 1)) < Asc("哈") Then
    py = "G"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("哈") And Asc(Left(mystr, 1)) < Asc("击") Then
    py = "H"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("击") And Asc(Left(mystr, 1)) < Asc("喀") Then
    py = "J"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("喀") And Asc(Left(mystr, 1)) < Asc("垃") Then
    py = "K"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("垃") And Asc(Left(mystr, 1)) < Asc("妈") Then
    py = "L"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("妈") And Asc(Left(mystr, 1)) < Asc("拿") Then
    py = "M"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("拿") And Asc(Left(mystr, 1)) < Asc("哦") Then
    py = "N"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("哦") And Asc(Left(mystr, 1)) < Asc("啪") Then
    py = "O"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("啪") And Asc(Left(mystr, 1)) < Asc("期") Then
    py = "P"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("期") And Asc(Left(mystr, 1)) < Asc("然") Then
    py = "Q"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("然") And Asc(Left(mystr, 1)) < Asc("撒") Then
    py = "R"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("撒") And Asc(Left(mystr, 1)) < Asc("塌") Then
    py = "S"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("塌") And Asc(Left(mystr, 1)) < Asc("挖") Then
    py = "T"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("挖") And Asc(Left(mystr, 1)) < Asc("昔") Then
    py = "W"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("昔") And Asc(Left(mystr, 1)) < Asc("压") Then
    py = "X"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("压") And Asc(Left(mystr, 1)) < Asc("匝") Then
    py = "Y"
    Exit Function
End If
If Asc(Left(mystr, 1)) >= Asc("匝") Then
    py = "Z"
    Exit Function
End If
Else
    If UCase(mystr) <= "Z" And UCase(mystr) >= "A" Then
        py = UCase(Left(mystr, 1))
        Else
            py = mystr
        End If
    End If
End Function//调用过程.TEXT1输入，LABEL1显示Private Sub command1_click()
    Dim a As Integer
    Label1.Caption = ""
    a = Len(Text1.Text)
    For i = 1 To a
        Label1.Caption = Label1.Caption & py(Mid(Text1.Text, i, 1)) 
    Next i
End Sub