www.pudn.com > kelon.rar > mdt01.bas
Attribute VB_Name = "mdt01"
Option Explicit
Public UID As String
Public Cn_Des As New ADODB.Connection
Public Const FILENAME = "\lz_kelon.ini"
Public Const LocFileName = "\lz_runtime.ini"
Public iniFn As String
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
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)
Sub Main()
Dim ls As String
Dim arry As Variant
ls = Command()
If InStr(ls, "wyzshxl") > 0 Then
arry = Split(ls + ",,", ",")
UID = arry(1)
fComPort.Show
Else
MsgBox "请运行 PLogin.exe 程序", 48, "提示"
End If
End Sub
'取字符串的通用程序
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
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
Public Sub DragForm(ByVal Button As Long, ByVal vObj As Object)
If Button <> 1 Then Exit Sub
On Local Error Resume Next
Call ReleaseCapture
Call SendMessage(vObj.hwnd, &HA1, 2, 0)
End Sub