frmreg.frm

建立数据库连接的加密字符串

      Begin VB.CommandButton Command1 
         Caption         =   "&S"
         Height          =   435
         Index           =   2
         Left            =   3360
         TabIndex        =   5
         Top             =   240
         Width           =   255
      End
      Begin VB.TextBox Text1 
         BackColor       =   &H80000018&
         BeginProperty Font 
            Name            =   "Arial"
            Size            =   12
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   390
         IMEMode         =   3  'DISABLE
         Index           =   4
         Left            =   1575
         TabIndex        =   6
         Top             =   240
         Width           =   1770
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "数据目录"
         BeginProperty Font 
            Name            =   "Arial"
            Size            =   12
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   270
         Index           =   5
         Left            =   540
         TabIndex        =   18
         Top             =   300
         Width           =   1185
      End
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "说明:用于设计各种类型的数据连接"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   240
      TabIndex        =   16
      Top             =   3240
      Width           =   3255
   End
End
Attribute VB_Name = "FrmReg"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'GetDirectory
Private Declare Function GetSystemDirectory Lib "KERNEL32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Dim oCn As New ADODB.Connection
Dim DBpath As String

Private Sub Check1_Click()
If Check1.Value = 1 Then
    Text1(4).Enabled = False
    Command1(2).Enabled = False
    
Else
    Text1(4).Enabled = True
    Command1(2).Enabled = True
End If
End Sub

Private Sub Combo1_Click()
If Combo1.ListIndex > 1 Then
    Frame2.Visible = True
Else
    Frame2.Visible = False
End If
End Sub

Private Sub Combo1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then SendKeys "{tab}"
End Sub

Private Sub Command1_Click(Index As Integer)
Select Case Index
    Case 0
        If LtestCON = True Then SetReg
        
    Case 1
        Unload Me
    Case 2
        SetPath
End Select
End Sub

Private Sub Command1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
If KeyCode = 27 Then SendKeys "+{tab}"
End Sub

Private Sub Form_Load()
Combo1.ListIndex = 0
GetReg
End Sub


Private Sub Text1_GotFocus(Index As Integer)
Text1(Index).SelStart = 0
Text1(Index).SelLength = Len(Text1(Index).text)
End Sub

Private Sub Text1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
If KeyCode = 27 Then SendKeys "+{tab}"
End Sub

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 Then SendKeys "{tab}"
End Sub


Private Function SetTxt(text As String, key As String) As String
    Dim textchar As String * 1
    Dim keychar As String * 1
    Dim wb As Integer
    Dim fj As String
    Dim i As Integer
    For i = 1 To Len(text)
        textchar = Mid(text, i, 1)
        keychar = Mid(key, (i Mod Len(key) + 1), 1)
        wb = Asc(textchar) Xor Asc(keychar)
        SetTxt = SetTxt & Chr(wb)
    Next
End Function


Private Sub SetReg(Optional MLBz As String = "0")
Dim fso As New FileSystemObject, Path As String * 255, ReturnLength As Long, oFhdc, cContent As String, cFile As String
Dim RegTXT   As String

'If MsgBox("是否确认保存当前注册信息？", vbQuestion + vbYesNo, "保存") = vbNo Then Exit Sub
If MLBz = "0" Then    '当前目录
    'ReturnLength = App.Path
    cFile = Trim(App.Path) & "\LHXT_REG.txt"
Else
    ReturnLength = GetSystemDirectory(Path, Len(Path))
    cFile = Mid(Path, 1, ReturnLength) & "\LHXT_REG.txt"
End If

Set oFhdc = fso.OpenTextFile(cFile, ForWriting, True)
RegTXT = Trim(FrmReg.Combo1.text) & "," & Trim(FrmReg.Text1(0).text) & "," & Trim(FrmReg.Text1(1).text & "," & Trim(FrmReg.Text1(2).text) & "," & Trim(FrmReg.Text1(3).text)) & "," & Trim(FrmReg.Text1(4).text)

oFhdc.Write SetTxt(RegTXT, "1")
oFhdc.Close
Unload Me
End Sub

Private Sub GetReg(Optional MLBz As String = "0")

Dim fso As New FileSystemObject, Path As String * 255, ReturnLength As Long, cFile As String, oFhdc, cContent As String

If MLBz = "0" Then    '当前目录
    'ReturnLength = App.Path
    cFile = Trim(App.Path) & "\LHXT_REG.txt"
Else
    ReturnLength = GetSystemDirectory(Path, Len(Path))
    cFile = Mid(Path, 1, ReturnLength) & "\lhxt_reg.txt"
End If

cContent = ""
If fso.FileExists(cFile) Then
    Set oFhdc = fso.OpenTextFile(cFile, ForReading, False)
    cContent = Trim(oFhdc.ReadAll)
    oFhdc.Close
Else
    Exit Sub
End If
cContent = SetTxt(Trim(cContent), "1")

Combo1.text = GetVlu(cContent, 1)
Text1(0) = GetVlu(cContent, 2)
Text1(1) = GetVlu(cContent, 3)
Text1(2) = GetVlu(cContent, 4)
Text1(3) = GetVlu(cContent, 5)
Text1(4) = GetVlu(cContent, 6)
End Sub


Private Function GetVlu(Ss As String, ii As Integer)
'从字符串中截取内容，和MYHELP连用
Dim jj As Integer, p1 As Integer, p2 As Integer
GetVlu = ""
jj = 0
p1 = 0 + 1
p2 = InStr(1, Ss, ",")
If p2 = 0 Then p2 = Len(Ss) + 1

Do While jj < ii And p1 <= Len(Ss)
    GetVlu = Trim(Mid(Ss, p1, p2 - p1))
    p1 = p2 + 1
    p2 = InStr(p1, Ss, ",")
    If p2 = 0 Then p2 = Len(Ss) + 1
    jj = jj + 1
Loop
If ii > jj Then GetVlu = ""

End Function


Private Function LtestCON() As Boolean
Dim oCnStr As String, cType As String
On Error Resume Next
LtestCON = False
cType = Trim(Combo1.text)
Select Case UCase(cType)
    Case "SYBASE"
        oCnStr = "Provider=Sybase.ASEOLEDBProvider.2;Initial Catalog=" & Trim(Text1(1)) & ";User ID=" & Trim(Text1(2)) & ";Password=" & Trim(Text1(3)) & ";Data Source=" & Trim(Text1(0)) & ";Persist Security Info=False"
    Case "MSSQL"
        oCnStr = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=" & Trim(Text1(2)) & ";pwd=" & Trim(Text1(3)) & ";Initial Catalog=" & Trim(Text1(1)) & ";Data Source=" & Trim(Text1(0))
    Case "ACCESS"
        oCnStr = "DBQ=" & Trim(Text1(4)) & Trim(Text1(1)) & ".mdb;Driver={Microsoft Access Driver (*.mdb)};DriverId=25;FIL=MS Access;SafeTransactions=0;Threads=3;PWD=" & Trim(Text1(3)) & ";UID=admin;UserCommitSync=Yes;"
    Case "DBF"
        oCnStr = "Driver={Microsoft FoxPro VFP Driver (*.dbf)};UID=;PWD=;SourceDB=" & Trim(Text1(4)) & ";SourceType=DBF;Exclusive=No;BackgroundFetch=Yes;Collate=Machine;Null=Yes;Deleted=Yes;"
End Select
Set oCn = Nothing
oCn.CursorLocation = adUseClient
oCn.Open oCnStr

If oCn.State = 1 Then
    MsgBox "测试连接成功!", vbInformation, "连接"
    LtestCON = True
Else
    MsgBox "连接错误!  " & Err.Description, vbCritical, "连接"
    LtestCON = False
End If
On Error GoTo 0
End Function

Private Sub SetPath(Optional LX As Integer = 1)

CommonDialog1.CancelError = True
On Error Resume Next
CommonDialog1.Flags = cdlOFNHideReadOnly
CommonDialog1.Filter = "All Files (*.*)|*.*|DBF Files(*.dbf)|*.dbf|MDB Files(*.mdb)|*.mdb|"
CommonDialog1.FilterIndex = LX
CommonDialog1.ShowOpen
Text1(4).text = Mid(CommonDialog1.FileName, 1, (InStr(1, CommonDialog1.FileName, CommonDialog1.FileTitle) - 1))
ErrHandler:
' 用户按了“取消”按钮
On Error GoTo 0

End Sub