Option Compare Database
Function ShiftPass(Sp As Boolean)
Const DB_Boolean As Long = 1
ChangeProperty "AllowBypassKey", DB_Boolean, Sp
'-------------- disable bypasskey
'ChangeProperty "AllowBypassKey", DB_Boolean, true
End Function
Function ChangeProperty(strPropName As String, varPropType As Variant, varPropvalue As Variant) As Integer
Dim prp As Variant
Const conPropNotFoundError = 3270
On Error GoTo Change_Err
CurrentProject.Properties(strPropName) = varPropvalue
ChangeProperty = True
Change_Bye:
Exit Function
Change_Err:
If Err = conPropNotFoundError Then ' Property not found.
CurrentProject.Properties.Add strPropName, varPropvalue
Resume Next
Else
' Unknown error.
ChangeProperty = False
Resume Change_Bye
End If
End Function
Sub MakeAdpConnectionless()
'斷開當前adp的連接
If Application.CurrentProject.BaseConnectionString <> "" Then
Application.CurrentProject.CloseConnection '關閉連接
Application.CurrentProject.OpenConnection '將連接設定為無
End If
End Sub
Public Function sCreateConnection(ByVal UDLFileName As String) As String
'********************************************************************
'本函數在adp中檢查連接,如果沒有,將通過輸入參數建立連接
'
'輸入:
' udlfilename: 通用數據連接文件名
'輸出:
' 連接狀態
'
'********************************************************************
On Error GoTo sCreateConnectionTrap:
Dim sConnectionString As String
' If Application.CurrentProject.BaseConnectionString = "" Then
'表示adp處於無連接狀態中
sConnectionString = GetConnectionStringFromUDL(CurrentProject.Path & "\" & UDLFileName)
Application.CurrentProject.OpenConnection sConnectionString
sCreateConnection = "創建了使用 udl 文件 (" & UDLFileName & ") 連接到數據庫的連接!"
' Else '連接已存在
' sCreateConnection = "已經存在數據庫連接!"
' End If
sCreateConnectionExit:
Exit Function
sCreateConnectionTrap:
sCreateConnection = Err.Description
Resume sCreateConnectionExit
End Function
Public Function GetConnectionStringFromUDL(ByVal UDLFileName As String) As String
Dim TextLine As String
Open UDLFileName For Input As #3 ' 開啟檔案。
Do While Not EOF(3) ' 執行迴圈直到檔尾為止。
Line Input #3, TextLine ' 讀入一行資料並將之指定給變數。
Loop
Dim temps As String
temps = Decrypt(TextLine, 5)
GetConnectionStringFromUDL = temps
Close #3 ' 關閉檔案。
End Function
Function Encrypt(SStr As String, TagNum As Byte) As String
If TagNum > 5 Then TagNum = 5
If SStr <> "" Then
Dim temps, temps1 As String, i, j As Integer
For i = 1 To Len(SStr)
j = Asc(MID(SStr, i, 1))
If (j <> 10) And (j <> 13) And (j <> 32) Then
temps1 = Chr(Asc(MID(SStr, i, 1)) + TagNum)
Else
temps1 = Chr(Asc(MID(SStr, i, 1)))
End If
temps = temps & temps1
Next i
Encrypt = temps
End If
End Function
Function Decrypt(SStr As String, TagNum As Byte) As String
If TagNum > 5 Then TagNum = 5
If SStr <> "" Then
Dim temps, temps1 As String, i, j As Integer
For i = 1 To Len(SStr)
j = Asc(MID(SStr, i, 1))
If (j <> 10) And (j <> 13) And (j <> 32) Then
temps1 = Chr(Asc(MID(SStr, i, 1)) - TagNum)
Else
temps1 = Chr(Asc(MID(SStr, i, 1)))
End If
temps = temps & temps1
Next i
Decrypt = temps
End If
End Function
====================================To Use
Private Sub Form_Load()
'DoCmd.RunCommand acCmdAppMinimize
'DoCmd.Restore
SetAct hwnd
ChangeProperty "AppIcon", DB_Text, CurrentProject.Path & "\icons\App.ico"
ChangeProperty "StartupShowDBWindow", DB_Boolean, False
CurrentProject.Properties("UseAppIconForFrmRpt") = True
Application.RefreshTitleBar
MakeAdpConnectionless
' sCreateConnection "tsmis.udl"
End Sub
