阡陌暮的部落格

Dim MyWs As Workspace
Dim MyDB As Database
Dim WordTab As Recordset

Set MyWs = DBEngine.CreateWorkspace″″ ″Admin″ ″″ dbUseJet
Set MyDB = MyWs.OpenDatabase数据库名称 False False
Set WordTab = MyDB.OpenRecordset″表名″ dbOpenDynaset

Dim LocCnn1 As ADODB.Connection
Dim LocRst1 As ADODB.Recordset

Set LocCnn1 = New ADODB.Connection
LocCnn1.Open ″Provider=Microsoft.Jet.OLEDB.4.0User ID=Admin″ & _
″Data Source=″ & App.Path & ″\数据库名称.mdb″& _
″Mode=Share Deny NoneExtended Properties=''Persist Security Info=False″ & _
″Jet OLEDBDatabase Password='asp561rbc'″

Set LocRst1 = New ADODB.Recordset　
LocRst1.CursorType = adOpenKeyset
LocRst1.LockType = adLockOptimistic
LocRst1.Open ″SELECT  FROM 表名″ LocCnn1adCmdText

Function RStr(Str As String) As String
For i = Len(Str) To 1 Step -1
   RStr = RStr & Mid(Str, i, 1)
Next
End Function

Dim TempPsdString As String
Dim tem(3) As String
Private Sub Command1_Click()
Dim i As Integer
Dim TmpStr As String
List1.Clear
Open Text3 & "pwd.txt" For Output As #1
   Print ""
Close #1
For i = 0 To Text2 - 1
   TmpStr = GetStr(Text1)
   List1.AddItem TmpStr
   Open Text3 & "pwd.txt" For Append As #1
       Print #1, TmpStr
   Close #1
   Form1.Caption = "密码生成器" & "--已完成" & Int(i / (Text2 - 1) * 100) & "%"
Next
If MsgBox("已生成" & Text2 & "个" & Text1 & "字符的密码" & vbCr & "是否打开密码文件查看?", vbYesNo + vbInformation, "任务完成") = vbYes Then Shell "notepad.exe " & Text3 & "pwd.txt"
Form1.Caption = "密码生成器"
End Sub

Function GetStr(Index As Integer) As String
   If Index < 1 Then Exit Function
   Dim i As Integer
   Dim TmpStr As String
   For i = 1 To Index
      Randomize
      TmpStr = Mid(TempPsdString, Int(Len(TempPsdString) * Rnd) + 1, 1)
      GetStr = GetStr + CStr(TmpStr)
   Next
End Function

Private Sub Form_Load()
Text3 = App.Path
If Right(Text3, 1) <> "\" Then Text3 = Text3 & "\"
Text3 = App.Path
If Right(Text3, 1) <> "\" Then Text3 = Text3 & "\"
tem(0) = "0123456789"
tem(1) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
tem(2) = "abcdefghijklmnopqrstuvwxyz"
tem(3) = "~!@#$%^&*()_+[]:,.<>?/*-"
TempPsdString = tem(0) + tem(1) + tem(2) + tem(3)
End Sub

Private Sub Check1_Click(Index As Integer)
TempPsdString = ""
For i = 0 To 3
   If Check1(i).Value = 1 Then TempPsdString = TempPsdString & tem(i)
Next
If TempPsdString = "" Then MsgBox "必须选择一项！": Check1(Index).Value = 1
End Sub

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