module.bas

独一无二的数据库编程例程

Attribute VB_Name = "Module"
Option Explicit
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 GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long
Private Declare Function IsDBCSLeadByte Lib "kernel32" (ByVal bTestChar As Byte) 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 Const IME_ESC_MAX_KEY = &H1005
Private Const IME_ESC_IME_NAME = &H1006
Private Const GCL_REVERSECONVERSION = &H2
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Const SW_SHOW = 5
Public ADD_NEW As Boolean

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
    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 = Trim(Left(sChar, Len(sChar) - 1) & IIf(j < Len(Chinese) - 1, Delimiter, ""))
            End If
          End If
        End If
      End If
      GetChineseSpell = GetChineseSpell & sChar
    Next j
  End If
End If
End Function