阡陌暮的部落格

Public connSTR As String  '定义一个公用变量

Public Function CData() '连接数据库,
On Error GoTo errEnd
dbName = App.Path
If Right(dbName, 1) <> "\" Then dbName = dbName + "\"
dbName = dbName + "Data.mdb"
connSTR = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbName & ";Persist Security Info=False"
Exit Sub
errEnd:
   MsgBox err.Description, vbOKOnly + vbExclamation, "打开数据库出错"
End Function

'汉字转拼音
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
[separator]
   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
'汉字转拼音完

Private Sub Text1_Change()'text1l输入时在label1中即时显示拼音
 If Option1.Value = True Then
    Label1.Caption = ""
    Dim a As Integer
    a = Len(Text1.Text)
    For i = 1 To a
        Label1.Caption = Label1.Caption & py(Mid(Text1.Text, i, 1))
    Next i
 End If
End Sub

Private Sub Command1_Click()'按command1后在label1显示拼音
 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

'窗体透明代码开始
Public Const WS_EX_LAYERED = &H80000
Public Const GWL_EXSTYLE = (-20)
Public Const LWA_ALPHA = &H2
Public Const LWA_COLORKEY = &H1
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
'窗体透明代码结束

   Dim rtn As Long
   rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
   rtn = rtn Or WS_EX_LAYERED
   SetWindowLong hwnd, GWL_EXSTYLE, rtn
   SetLayeredWindowAttributes hwnd, 0, 255, LWA_ALPHA

'窗体位于最上层代码开始
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_SHOWWINDOW = &H40
Public Const FLAGS = &H2 Or &H1
'窗体位于最上层代码结束

Dim retvalue As Long
retvalue = SetWindowPos(Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS)'取消最上层
retvalue = SetWindowPos(Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)'设置为最上层