求助！请问一下怎么得到汉字的首字母？

Public Function GetPY(A1 As String) As String
If Asc(A1) < 0 Then
'四个特殊字
    If A1 = "噢" Then
        GetPY = "O"
        Exit Function
    End If
    If A1 = "杞" Then
        GetPY = "Q"
        Exit Function
    End If
    If A1 = "嘌" Then
        GetPY = "P"
        Exit Function
    End If
    If A1 = "呤" Then
        GetPY = "L"
        Exit Function
    End If
'正常汉字
    If Asc(A1) < Asc("啊") Then
        GetPY = "0"
        Exit Function
    End If
    If Asc(A1) >= Asc("啊") And Asc(A1) < Asc("芭") Then
        GetPY = "A"
        Exit Function
    End If
    If Asc(A1) >= Asc("芭") And Asc(A1) < Asc("擦") Then
        GetPY = "B"
        Exit Function
    End If
    If Asc(A1) >= Asc("擦") And Asc(A1) < Asc("搭") Then
        GetPY = "C"
        Exit Function
    End If
    If Asc(A1) >= Asc("搭") And Asc(A1) < Asc("蛾") Then
        GetPY = "D"
        Exit Function
    End If
    If Asc(A1) >= Asc("蛾") And Asc(A1) < Asc("发") Then
        GetPY = "E"
        Exit Function
    End If
    If Asc(A1) >= Asc("发") And Asc(A1) < Asc("噶") Then
        GetPY = "F"
        Exit Function
    End If
    If Asc(A1) >= Asc("噶") And Asc(A1) < Asc("哈") Then
        GetPY = "G"
        Exit Function
    End If
    If Asc(A1) >= Asc("哈") And Asc(A1) < Asc("击") Then
        GetPY = "H"
        Exit Function
    End If
    If Asc(A1) >= Asc("击") And Asc(A1) < Asc("喀") Then
        GetPY = "J"
        Exit Function
    End If
    If Asc(A1) >= Asc("喀") And Asc(A1) < Asc("垃") Then
        GetPY = "K"
        Exit Function
    End If
    If Asc(A1) >= Asc("垃") And Asc(A1) < Asc("妈") Then
        GetPY = "L"
        Exit Function
    End If
    If Asc(A1) >= Asc("妈") And Asc(A1) < Asc("拿") Then
        GetPY = "M"
        Exit Function
    End If
    If Asc(A1) >= Asc("拿") And Asc(A1) < Asc("哦") Then
        GetPY = "N"
        Exit Function
    End If
    If Asc(A1) >= Asc("哦") And Asc(A1) < Asc("啪") Then
        GetPY = "O"
        Exit Function
    End If
    If Asc(A1) >= Asc("啪") And Asc(A1) < Asc("期") Then
        GetPY = "P"
        Exit Function
    End If
    If Asc(A1) >= Asc("期") And Asc(A1) < Asc("然") Then
        GetPY = "Q"
        Exit Function
    End If
    If Asc(A1) >= Asc("然") And Asc(A1) < Asc("撒") Then
        GetPY = "R"
        Exit Function
    End If
    If Asc(A1) >= Asc("撒") And Asc(A1) < Asc("塌") Then
        GetPY = "S"
        Exit Function
    End If
    If Asc(A1) >= Asc("塌") And Asc(A1) < Asc("挖") Then
        GetPY = "T"
        Exit Function
    End If
    If Asc(A1) >= Asc("挖") And Asc(A1) < Asc("昔") Then
        GetPY = "W"
        Exit Function
    End If
    If Asc(A1) >= Asc("昔") And Asc(A1) < Asc("压") Then
        GetPY = "X"
        Exit Function
    End If
    If Asc(A1) >= Asc("压") And Asc(A1) < Asc("匝") Then
        GetPY = "Y"
        Exit Function
    End If
    If Asc(A1) >= Asc("匝") Then
        GetPY = "Z"
        Exit Function
    End If
Else
'英文和数字
    If UCase(A1) <= "Z" And UCase(A1) >= "A" Then
        GetPY = UCase(A1)
    ElseIf A1 <= "9" And A1 >= "0" Then
        GetPY = A1
    Else
        GetPY = "0"
    End If
End If
End Function

Function pinyin(ByVal x As String) As String
Dim i As Integer
Const hanzi = "啊芭擦搭蛾发噶哈击喀垃妈拿哦啪期然撒塌挖昔压匝座ABCDEFGHJKLMNOPQRSTWXYZZ"
If x = "座" Then pinyin = "Z"
For i = 1 To 23
If Asc(x) >= Asc(Mid(hanzi, i, 1)) And Asc(x) < Asc(Mid(hanzi, i + 1, 1)) Then pinyin = Mid(hanzi, 24 + i, 1)
Next
End FunctionFunction py(ByVal x As String) As String
Dim i As Integer
For i = 1 To Len(x)
If Mid(x, i, 1) <> " " And Asc(Mid(x, i, 1)) < 0 Then py = py & pinyin(Mid(x, i, 1))
Next
py = UCase(py)
End FunctionPrivate Sub Command1_Click()
MsgBox py("中国软件")
End Sub

'一个得到拼音的模块
'先建立一个模块,然后在过程中直接调用该函数就可以得到拼音了
'使用方法
dim s as string
s= GetChineseSpell("你好")
'结果  s="nh"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 LongPrivate 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

FFFFB0A1
   ↓
FFFFB0FE       A
   ↓
FFFFB1FE       B
   ↓
FFFFB2FE       C
   ↓
FFFFB3FE       D
   ↓
FFFFB4FE       E
   ↓
FFFFB5FE       F......依次类推。前边是汉字的16进制格式。

    $B0A1..$B0C4 : result := 'A';
    $B0C5..$B2C0 : result := 'B';
    $B2C1..$B4ED : result := 'C';
    $B4EE..$B6E9 : result := 'D';
    $B6EA..$B7A1 : result := 'E';
    $B7A2..$B8C0 : result := 'F';
    $B8C1..$B9FD : result := 'G';
    $B9FE..$BBF6 : result := 'H';
    $BBF7..$BFA5 : result := 'J';
    $BFA6..$C0AB : result := 'K';
    $C0AC..$C2E7 : result := 'L';
    $C2E8..$C4C2 : result := 'M';
    $C4C3..$C5B5 : result := 'N';
    $C5B6..$C5BD : result := 'O';
    $C5BE..$C6D9 : result := 'P';
    $C6DA..$C8BA : result := 'Q';
    $C8BB..$C8F5 : result := 'R';
    $C8F6..$CBF9 : result := 'S';
    $CBFA..$CDD9 : result := 'T';
    $CDDA..$CEF3 : result := 'W';
    $CEF4..$D188 : result := 'X';
    $D1B9..$D4D0 : result := 'Y';
    $D4D1..$D7F9 : result := 'Z';

Dim Str As String, TempStr As String
Dim i As Integer
Str = Text1.Text
TempStr = ""
length = Len(Str)
For i = 1 To length
    Select Case Asc(Str)
        Case &HB0A1 To &HB0C4: ch = "a"
        Case &HB0C5 To &HB2C0: ch = "b"
        Case &HB2C1 To &HB4ED: ch = "c"
        Case &HB4EE To &HB6E9: ch = "d"
        Case &HB6EA To &HB7A1: ch = "e"
        Case &HB7A2 To &HB8C0: ch = "f"
        Case &HB8C1 To &HB9FD: ch = "g"
        Case &HB9FE To &HBBF6: ch = "h"
        Case &HBBF7 To &HBFA5: ch = "j"
        Case &HBFA6 To &HC0AB: ch = "k"
        Case &HC0AC To &HC2E7: ch = "l"
        Case &HC2E8 To &HC4C2: ch = "m"
        Case &HC4C3 To &HC5B5: ch = "n"
        Case &HC5B6 To &HC5BD: ch = "o"
        Case &HC5BE To &HC6D9: ch = "p"
        Case &HC6DA To &HC8BA: ch = "q"
        Case &HC8BB To &HC8F5: ch = "r"
        Case &HC8F6 To &HCBF9: ch = "s"
        Case &HCBFA To &HCDD9: ch = "t"
        Case &HCDDA To &HCEF3: ch = "w"
        Case &HCEF4 To &HD188: ch = "x"
        Case &HD1B9 To &HD4D0: ch = "y"
        Case &HD4D1 To &HD7F9: ch = "z"
    Case Else
        ch = Left(Str, 1)
    End Select
    TempStr = TempStr + ch
    Str = Mid(Str, 2, Len(Str))
Next
Text2.Text = TempStr

调试易

求助！请问一下怎么得到汉字的首字母？

解决方案 »