www.pudn.com > kelon.rar > mlogin.bas
Attribute VB_Name = "mlogin"
Option Explicit
Public Cn_Des As New ADODB.Connection
Public Const FILENAME = "\lz_kelon.ini"
Public Const LocFileName = "\lz_Login.ini"
Public iniFn As String
Public localFn As String
Type sf_data_pc_
网卡ID As String
IP地址 As String
机器CPU As String
NET用户 As String
End Type
Public sf_data_pc As sf_data_pc_
Type sf_data_yg_
工号 As String
姓名 As String
口令 As String
上机日期 As String
上机时间 As String
退机日期 As String
退机时间 As String
End Type
Public sf_data_yg As sf_data_yg_
Public Declare Function GetPrivateProfileString& Lib "kernel32" Alias "GetPrivateProfileStringA" ( _
ByVal lpApplicationName As String, ByVal lpKeyName As String, _
ByVal lpDefault As String, ByVal lpReturnedString As String, _
ByVal nSize As Long, ByVal lpFileName As String)
Public Declare Function WritePrivateProfileString& Lib "kernel32" Alias "WritePrivateProfileStringA" ( _
ByVal lpApplicationName As String, _
ByVal lpKeyName As String, _
ByVal lpString As Any, _
ByVal lpFileName As String)
'取字符串的通用程序
Public Function pGetString(ByVal sfn As String, ByVal ssec As String, ByVal sKey As String) As String
pGetString = ""
Dim ss As String * 255
Dim ls As String
Dim l As Long
ss = ""
l = GetPrivateProfileString(ssec, sKey, "", ss, 250, sfn)
If l = 0 Then GoTo end_fun
pGetString = Trim(Left(ss, l))
end_fun:
End Function
Public Sub GetIniFileName()
If Dir(App.Path + FILENAME) = "" Then
iniFn = App.Path + "\res" + FILENAME
Else
iniFn = App.Path + FILENAME
End If
localFn = App.Path + "\res" + LocFileName
End Sub
Public Function MM2Text(ByVal vMM As String) As String
Dim s1 As String
s1 = vMM
Dim s10(16) As String
Dim s11(16) As Long
Dim i As Long
For i = 0 To 16
s10(i) = Mid(s1, (i * 2) + 1, 2) '取17个数
s11(i) = hex2num(s10(i)) '转换为十进制
Next
Dim s12(8) As Long
Dim s13(7) As String
For i = 0 To 16
If i > 7 Then '取0,2,4,6,8----16
s12(i - 8) = s11(i)
s12(i - 8) = 256 - s12(i - 8)
Else
s13(i) = s11(i) '取 1,3,5,7,----15
s13(i) = 256 - s13(i)
End If
Next
Dim s14(16) As Long
Dim s15(16) As String
For i = 0 To 16 '
Select Case i
Case 1, 3, 5, 7, 9, 11, 13, 15, 17
s14(i) = s13(i \ 2)
Case 0, 2, 4, 6, 8, 10, 12, 14, 16
s14(i) = s12(i \ 2)
End Select
s15(i) = Chr(s14(i))
Next
Dim s2 As String
For i = 0 To 16
s2 = s2 + s15(i)
Next
Dim s4 As Long
s4 = hex2num(Left(s2, 1))
Dim s5 As String
s5 = Right(s2, 17 - s4 - 1)
MM2Text = s5
End Function
Public Function Text2MM(ByVal vStr As String) As String
Dim s1 As String
Dim l1 As Long
s1 = vStr
l1 = Len(s1)
'define 16 bit
Dim l2 As Long
l2 = 16 - l1
Dim s2 As String
s2 = Left("1234567890abcdef", l2)
Dim s3 As String, s4 As String
s3 = Hex(l2)
s2 = s3 + s2 + s1
Dim i As Long
Dim s10(16) As Long, s11(16) As Long
For i = 0 To 16
s10(i) = Asc(Mid(s2, i + 1, 1))
s11(i) = 256 - s10(i)
Next
Dim s5 As String
Dim s6 As String
For i = 0 To 16 Step 2 '取0,2,4,6,8----16
s5 = Hex(s11(i))
s5 = IIf(Len(s5) = 1, "0" + s5, s5) '两位16进制数
s6 = s6 + s5
Next
Dim s7 As String
For i = 1 To 16 Step 2 '取 1,3,5,7,----15
s5 = Hex(s11(i))
s5 = IIf(Len(s5) = 1, "0" + s5, s5) '两位16进制数
s7 = s7 + s5
Next
s7 = s7 + s6 '1,3,5,7,----15 0,2,4,6,8----16
Text2MM = s7
End Function
Private Function hex2num(ByVal sHex As String) As Long
Dim s1 As String, s2 As String
Dim l1 As Long, l2 As Long
l1 = -1
l2 = -1
If Len(sHex) = 1 Then
s1 = "0"
Else
s1 = Left(sHex, 1)
End If
s2 = Right(sHex, 1)
If s1 = "a" Or s1 = "A" Then l1 = 10
If s1 = "b" Or s1 = "B" Then l1 = 11
If s1 = "c" Or s1 = "C" Then l1 = 12
If s1 = "d" Or s1 = "D" Then l1 = 13
If s1 = "e" Or s1 = "E" Then l1 = 14
If s1 = "f" Or s1 = "F" Then l1 = 15
If l1 = -1 Then l1 = Val(s1)
If s2 = "a" Or s2 = "A" Then l2 = 10
If s2 = "b" Or s2 = "B" Then l2 = 11
If s2 = "c" Or s2 = "C" Then l2 = 12
If s2 = "d" Or s2 = "D" Then l2 = 13
If s2 = "e" Or s2 = "E" Then l2 = 14
If s2 = "f" Or s2 = "F" Then l2 = 15
If l2 = -1 Then l2 = Val(s2)
hex2num = l1 * 16 + l2
End Function
Public Sub OpenODBC(ByVal vCn As ADODB.Connection, ByVal nConn As String)
Dim ConnectionString As String
Dim PWDString As String
Dim i As Long
Dim sSect As String: sSect = "local"
Dim arry As Variant
Dim Arryls As Variant
Dim NewCon As String
Dim ss As String
ss = pGetString(iniFn, sSect, "PS001")
PWDString = MM2Text(ss)
ss = pGetString(iniFn, sSect, nConn)
ConnectionString = Replace(ss, "@1@", PWDString)
On Local Error Resume Next
vCn.Close
On Local Error GoTo 0
vCn.ConnectionString = ConnectionString
vCn.Properties("Prompt") = adPromptComplete '定义：如果连接串不存在，则进行提示
vCn.Open '打开连接
If ConnectionString <> vCn.ConnectionString Then '自动取得连接
arry = Split(vCn.ConnectionString, ";") '按;分离
For i = 0 To UBound(arry) '重新组合
If InStr(arry(i), "PWD") Then
' Arry(I) = "PWD=@1@" '在这里可对口令加密后回写. 略
Arryls = Split(arry(i), "=")
PWDString = Text2MM(Arryls(1))
Call WritePrivateProfileString(sSect, "PS001", PWDString, iniFn)
arry(i) = "PWD=@1@"
End If
If i = 0 Then
NewCon = arry(i)
Else
NewCon = NewCon + ";" + arry(i)
End If
Call WritePrivateProfileString(sSect, nConn, NewCon, iniFn)
Next
End If
End Sub