mdlgzcommon.bas

一个售饭系统的消费数据分析系统

Attribute VB_Name = "mdlGzCommon"
'******************************************************
'    功  能  : 公共函数的说明
'    时  间  : 1999年11月2日--1999年12月8日
'    作  者  : 高智
'    地  址  : 深圳达实自动化公司
'
'******************************************************

Option Explicit


'***********************************
'         数据库路径及名称：公用变量
'***********************************
Public GstrDatabasePath As String
Public GstrDatabaseName As String
Public GstrDatabasePathName As String
Public cnnString As String
'Public envEatery.cnnCurrentDB As New ADODB.Connection
'Public envEatery.cnnMain As New ADODB.Connection

'***********************************
'         初始化数据库连接及其它全局变量
'***********************************
Sub connectDB()
Dim rstSysSet As ADODB.Recordset
Dim strSQL As String
Dim intYesNo As Integer
Dim GstrCnn As String
Dim strPWD As String

On Error GoTo ErrorHandler

    GstrDatabasePath = GetSetting("ConsumeSystem", "DatabaseSetting", "GstrDatabasePath")
    GstrDatabaseName = "DasIcCard.mdb"
    GstrDatabasePathName = GstrDatabasePath & GstrDatabaseName
    cnnString = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & GstrDatabasePathName & ";Jet OLEDB:Database Password=123321"
    envEatery.cnnCurrentDB.Open cnnString ', "admin", "123321"
    If envEatery.cnnCurrentDB.State = adStateClosed Then
        MsgBox "无法连接到数据库 DasIcCard.mdb ！" & vbCrLf & vbCrLf & _
            "提示：如果通过网络访问，首先检查网络是否正常，" & vbCrLf & _
            "          数据库是否“完全”共享；" & vbCrLf & _
            "      如果使用本机数据库，首先检查是否更改过密码" & vbCrLf & _
            "          或者设为只读文件。" & vbCrLf & vbCrLf & _
            "请运行新程序连接到数据库 DasIcCard.mdb"
        End
    End If
    Debug.Print envEatery.cnnCurrentDB.ConnectionString
    
    
'    GstrCnn = GetSetting("ConsumeSystem", "DatabaseSetting", "GstrCnn", "")
'    strPWD = GetSetting("ConsumeSystem", "DatabaseSetting", "GstrPwd", "")
'    GstrCnn = GstrCnn & DeCrypt(strPWD, "147")
'    envEatery.cnnCurrentDB.ConnectionString = GstrCnn
'    Debug.Print envEatery.cnnCurrentDB.ConnectionString
'    envEatery.cnnCurrentDB.Open       '找开DasIcCard数据库
'    Debug.Print envEatery.cnnCurrentDB.ConnectionString
'    If envEatery.cnnCurrentDB.State = adStateClosed Then
'      envEatery.cnnCurrentDB.ConnectionString = GstrCnn
'      Debug.Print envEatery.cnnCurrentDB.ConnectionString
'      envEatery.cnnCurrentDB.Open       '找开DasIcCard数据库
'      Do While envEatery.cnnCurrentDB.State = adStateClosed Or GstrCnn = ""
'        GstrDatabaseName = "DasIcCard"
''        frmODBCLogon.Show 1
'        If GstrCnn = "" Then   '是否连接
''          OdbcConnectSuccess = False
''          Unload Me
'          Exit Sub
'        Else
''          OdbcConnectSuccess = True
'          Call SaveSetting("ConsumeSystem", "DatabaseSetting", "GstrCnn", GstrCnn)
'        End If
'        strPWD = GetSetting("ConsumeSystem", "DatabaseSetting", "GstrPwd", "")
'        GstrCnn = GstrCnn & DeCrypt(strPWD, "147")
'        envEatery.cnnCurrentDB.ConnectionString = GstrCnn
'        envEatery.cnnCurrentDB.Open       '找开DasIcCard数据库
'      Loop
''      If envEatery.cnnCurrentDB.State = adStateClosed Then
''            OdbcConnectSuccess = False
''      Else
''            OdbcConnectSuccess = True
''      End If
'    Else
''      OdbcConnectSuccess = True
'    End If
'
    
    
    
    
'    cnnString = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & GstrDatabasePathName & ";Jet OLEDB:Database"
'    cnnString = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & App.Path & "\temp.mdb;Jet OLEDB:Database"
'    envEatery.cnnDTempDB.Open cnnString ', "admin", "123321"
'
'    Do While envEatery.cnnDTempDB.State = adStateClosed
'        If envEatery.cnnDTempDB.State = adStateOpen Then envEatery.cnnDTempDB.Close
'        intYesNo = MsgBox("提示：如果通过网络访问，首先检查网络是否正常，" & vbCrLf & _
'            "          数据库是否“完全”共享；" & vbCrLf & _
'            "      如果使用本机数据库，首先检查是否更改过密码" & vbCrLf & _
'            "          或者设为只读文件。" & vbCrLf & vbCrLf & _
'            "选择“是”继续；" & vbCrLf & "选择“否”退出。", _
'            vbYesNo + vbDefaultButton1 + vbInformation, _
'            "请查找数据库 temp.mdb")
'        If intYesNo = vbNo Then End
'        ChangeConnection
'        cnnString = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & GstrDatabasePathName & ";Jet OLEDB:Database Password=123321"
'        envEatery.cnnDTempDB.Open cnnString ', "admin", "123321"
'    Loop
    
'    strSQL = "SELECT * FROM cSysSet"
'    Set rstSysSet = envEatery.cnnCurrentDB.Execute(strSQL)
    
'    If rstSysSet.EOF = False Then
'        If rstSysSet.Fields("CommPassWord") = "88888888" Then
'        Else
'            MsgBox "系统已经升级或初始化！", vbOKOnly + vbCritical, App.Title
'            End
'        End If
'    Else
'        MsgBox "没有系统设置信息！", vbOKOnly + vbCritical, App.Title
'        End
'    End If
    
    
    cnnString = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & App.Path & "\temp.mdb;Jet OLEDB:Database"
    envEatery.cnnDTempDB.Open cnnString ', "admin", "123321"

    Do While envEatery.cnnDTempDB.State = adStateClosed
        If envEatery.cnnDTempDB.State = adStateOpen Then envEatery.cnnDTempDB.Close
        intYesNo = MsgBox("提示：如果通过网络访问，首先检查网络是否正常，" & vbCrLf & _
            "          数据库是否“完全”共享；" & vbCrLf & _
            "      如果使用本机数据库，首先检查是否更改过密码" & vbCrLf & _
            "          或者设为只读文件。" & vbCrLf & vbCrLf & _
            "选择“是”继续；" & vbCrLf & "选择“否”退出。", _
            vbYesNo + vbDefaultButton1 + vbInformation, _
            "请查找数据库 temp.mdb")
        If intYesNo = vbNo Then End
        ChangeConnection
        cnnString = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & GstrDatabasePathName & ";Jet OLEDB:Database Password=123321"
        envEatery.cnnDTempDB.Open cnnString ', "admin", "123321"
    Loop
    
    
    

Exit Sub
ErrorHandler:
    MsgBox Err.Number & Err.Description
    Resume Next
End Sub

'***********************************
'         公用子过程：改变数据库连接
'***********************************
Public Sub ChangeConnection()
Dim strOldPath As String
On Error GoTo ExitSub

    AnalyseConsumedata.dlgdb.CancelError = True
    strOldPath = CurDir
    AnalyseConsumedata.dlgdb.InitDir = App.Path
    AnalyseConsumedata.dlgdb.DialogTitle = "请选择数据库文件"
    AnalyseConsumedata.dlgdb.Filter = "mdb|*.mdb"
    AnalyseConsumedata.dlgdb.ShowOpen
    GstrDatabasePath = CurDir
    If Right(GstrDatabasePath, 1) <> "\" Then GstrDatabasePath = GstrDatabasePath & "\"
    GstrDatabasePathName = AnalyseConsumedata.dlgdb.FileName
    GstrDatabaseName = AnalyseConsumedata.dlgdb.FileTitle
    ChDir strOldPath
    Exit Sub
    
ExitSub:
    MsgBox "没有选择数据库档案，程序将退出！", vbExclamation
    End
End Sub
'***********************************
'         函数入口地址
'***********************************
Sub Main()
    If App.PrevInstance Then
        MsgBox "程序已经运行！", vbOKOnly + vbInformation
        End
    End If
    
    connectDB
    
    AnalyseConsumedata.Show
End Sub


'
'Public Const VBLabel As Long = 0
'Public Const VBText As Long = 1
'Public Const VBFrame As Long = 2
'Public Const VBOptionButton As Long = 3
'Public Const VBPictureBox As Long = 4
'Public Sub Transparent(frmParent As Form, ByVal flag As Long, Optional ByVal bkcolor As Long)
'  Dim ctrl As Control
'  Select Case flag
    '  Case VBLabel
    '    For Each ctrl In frmParent.Controls
    '        If TypeOf ctrl Is VB.Label Then ctrl.BackStyle = bkcolor
    '    Next ctrl
    '  Case VBText
    '    For Each ctrl In frmParent.Controls
    '       If TypeOf ctrl Is VB.TextBox Then ctrl.BackColor = bkcolor
    '     Next ctrl
    '  Case VBFrame
    '    For Each ctrl In frmParent.Controls
    '        If TypeOf ctrl Is VB.Frame Then ctrl.BackColor = bkcolor
    '    Next ctrl
    '  Case VBOptionButton
    '    For Each ctrl In frmParent.Controls
    '        If TypeOf ctrl Is VB.OptionButton Then ctrl.BackColor = bkcolor
    '    Next ctrl
    '  Case VBPictureBox
    '    For Each ctrl In frmParent.Controls
    '        If TypeOf ctrl Is VB.PictureBox Then ctrl.BackColor = bkcolor
    '    Next ctrl
    '  Case Else
'  End Select
'End Sub

'***************
'
'字符解密
'lq add 2001.2.6
'
'**************
Public Function DeCrypt(texti As String, salasana As String) As String
Dim G As Integer
Dim T As Long
Dim TT As Long
Dim X1 As Double
Dim sana As Integer
Dim DeCrypted As String

For T = 1 To Len(salasana)
    sana = Asc(Mid(salasana, T, 1))
    X1 = X1 + sana
Next T
X1 = Int((X1 * 0.1) / 6)
salasana = X1
G = 0
For TT = 1 To Len(texti)
    sana = Asc(Mid(texti, TT, 1))
    G = G + 1
    If G = 6 Then G = 0
    X1 = 0
    If G = 0 Then X1 = sana + (salasana - 2)
    If G = 1 Then X1 = sana - (salasana - 5)
    If G = 2 Then X1 = sana + (salasana - 4)
    If G = 3 Then X1 = sana - (salasana - 2)
    If G = 4 Then X1 = sana + (salasana - 3)
    If G = 5 Then X1 = sana - (salasana - 5)
    X1 = X1 - G
    DeCrypted = DeCrypted & Chr(X1)
Next TT
DeCrypt = DeCrypted
End Function

'把intParentID的所有子机构显示在树中
'Public Sub GetDepartment(intParentID As Integer, tvwDepartment As MSComctlLib.TreeView)
Public Sub GetDepartment(intParentID As Integer, tvwDepartment As MSComctlLib.TreeView)
Dim strSQL As String
Dim rstNodeDept As ADODB.Recordset
    
On Error GoTo ErrorHandler

    strSQL = "select DepartmentID,Title from cDepartment "
    strSQL = strSQL & "WHERE ParentID=" & intParentID
    Set rstNodeDept = envEatery.cnnCurrentDB.Execute(strSQL)
    Do While rstNodeDept.EOF = False
        strSQL = "D" & rstNodeDept("DepartmentID")
        If intParentID = 0 Then
            Call tvwDepartment.Nodes.Add(, , strSQL, Trim(rstNodeDept("Title"))) '"TopDepartmentClose", "TopDepartmentOpen")
'            Call tvwDepartment.Nodes.Add(, , strSQL, Trim(rstNodeDept("Title")), 1, 3) '"TopDepartmentClose", "TopDepartmentOpen")
        Else
            Call tvwDepartment.Nodes.Add("D" & intParentID, tvwChild, strSQL, Trim(rstNodeDept("Title"))) '"DepartmentClose", "DepartmentOpen")
'            Call tvwDepartment.Nodes.Add("D" & intParentID, tvwChild, strSQL, Trim(rstNodeDept("Title")), 4, 2) '"DepartmentClose", "DepartmentOpen")
        End If
        Call GetDepartment(rstNodeDept("DepartmentID"), tvwDepartment)
        rstNodeDept.MoveNext
    Loop
    rstNodeDept.Close
    
Exit Sub

ErrorHandler:
    
    Select Case Err.Number   ' Evaluate error number.
        Case 0
            '
        Case Else
            MsgBox "错误" & Err.Number & "：" & Err.Description, , App.Title
            'Resume
'            ctlErrorLog "mdlCtlGzComn", "GetDepartment", Err.Number, Err.Description
    End Select
End Sub




Public Sub RefreshTreeview(tvwDepartment As MSComctlLib.TreeView)
'Public Sub RefreshTreeview(tvwDepartment As MSComctlLib.TreeView)
Dim i As Integer

On Error GoTo ErrorHandler

    tvwDepartment.Nodes.Clear
    
    Call GetDepartment(0, tvwDepartment)

    For i = 1 To tvwDepartment.Nodes.Count
        tvwDepartment.Nodes(i).Expanded = True
    Next i
 
    tvwDepartment.LineStyle = tvwRootLines
    tvwDepartment.Style = tvwTreelinesPlusMinusPictureText
    tvwDepartment.LabelEdit = tvwManual
    
Exit Sub

ErrorHandler:
    
    Select Case Err.Number   ' Evaluate error number.
        Case 0
            '
        Case Else
            MsgBox "错误" & Err.Number & "：" & Err.Description, , App.Title
'            ctlErrorLog "mdlCtlGzComn", "RefreshTreeview", Err.Number, Err.Description
    End Select
End Sub