moddatabase.bas

ERP管理系统源代码erp 管理系统源代码

Attribute VB_Name = "modDatabase"
'****************************************************************************************
' MODULE        : modDatabase
' DESCRIPTION   : 数据库模块
' CREATE        : Jack Xu 2001,10,26
' CODE          : Jack Xu 2001,10,26
' FUNCTION      : 实现数据库相关操作
' USAGE         :
' SUMMARY       :
'   一、变量、数据结构
'       1.公共变量、数据结构
'           (1)TYPE_TABLE_DESC_INFO                         数据库表和显示名关联结构
'           (2)g_BKTableSet() As TYPE_TABLE_DESC_INFO       可供导入导出的数据库表信息
'       2.私有变量、数据结构
'           (1)Const m_strTableDescList                     初始化 g_BKTableSet 用的常量
'           (2)m_tagErrInfo As TYPE_ERRORINFO               错误信息记录变量
'           (3)m_strMDFFile , m_strLDFFile                  备份文件中 MDF 和 LDF 文件的名称
'   二、函数或过程
'       1. 公共函数或过程
'           (1) 检查否存在空基础表
'               Public Function ExistEmptyBaseTable(ByVal strTableNamesSet As String) As Boolean
'           (2) 获得基本信息表对应的描述说明性文字
'               Public Function GetDescOfBaseTable(ByVal strTableName As String) As String
'           (3) 获得系统进行数据库连接时使用的用户名和密码
'               Public Function GetSysUserName() As String
'               Public Function GetSysPassword() As String
'           (4) 获得 SQL 数据库服务器系统安装目录路径
'               Public Function GetSQLServerSysPath() As String
'           (6) 修复数据库，以进行数据库备份、恢复操作
'               Private Function FixDBForBackup() As Boolean
'           (7) 备份数据库
'               Public Function BackupDataBase(ByVal strFileName As String, ByVal fFull As String) As Boolean
'           (8) 恢复数据库
'               Public Function RestoreDataBase(ByVal strFileName As String) As Boolean
'           (9) 删除数据库备份文件操作
'               Public Sub DeleteBackupFile(ByVal strFileName As String)
'           (10)初始化可供导入导出的数据库表信息
'               Public Function InitBKTableInfo() As Boolean
'       2. 私有（内部）函数或过程
'           (1) 检查数据库中一个表是否为空
'               Private Function IsTableEmpty(ByVal strTableName As String) As Boolean
'           (2) 检查数据库中一个表是否存在
'               Private Function IsTableExist(ByVal strTableName As String) As Boolean
'           (3) 在数据库中创建设备
'               Private Function CreateDBDevice(ByVal conn As adodb.Connection, _
'                                ByVal strFileName As String, _
'                                Optional ByVal strPrefix As String = "") As String
'           (4) 在数据库中删除设备
'               Private Sub DropDBDevice(ByVal conn As adodb.Connection, _
'                                ByVal strDeviceName As String, _
'                                Optional ByVal fDelfile As Boolean = False)
'           (5) 获得数据库当前连接的用户数目
'               Private Function GetDBConnectionUserNum(ByVal dbConn As adodb.Connection) As Long
'           (6)获得备份文件中 MDF 和 LDF 文件的名称
'               Private Function GetMDFAndLDFFile(ByVal strDevice As String, ByVal conn As adodb.Connection) As Boolean
'*********************************************************************************************************************************
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''
' 备份文件中 MDF 和 LDF 文件的名称
Dim m_strMDFFile As String
Dim m_strLDFFile As String

'''''''''''''''''''''''''''''''''''''''''''''''''''
' 错误信息
Dim m_tagErrInfo As TYPE_ERRORINFO

''''''''''''''''''''''''''''''''''''''''''''''''''''
' 数据库表和显示名关联结构
Public Type TYPE_TABLE_DESC_INFO
    strTableDesc    As String       ' 表的描述性名称
    strTableName    As String       ' 表名
End Type

' 可供导入导出的数据库表信息
Public g_BKTableSet() As TYPE_TABLE_DESC_INFO

'''''''''''''''''''''''''''''''''''''''''''''''''''
' 初始化 g_BKTableSet 用的常量
'Const m_strTableDescList = "省份、直辖市、自治区信息" & vbTab & "States" & "## 城市信息" & vbTab & "Cities" & "## 省份与城市关联表" & vbTab & "StateCity" & "## 公司部门" & vbTab & "Departments" _
                      & "## 地区信息" & vbTab & "Territories" & "## 产品资料" & vbTab & "Products" & "## 行业资料" & vbTab & "Industries" & "## 行业地位" & vbTab & "IndustryStatus" _
                      & "## 员工等级" & vbTab & "EmployeeClass" & "## 员工资料" & vbTab & "Employees" & "## 供应商级别信息" & vbTab & "SupplyClass" & "## 供应商类型" & vbTab & "SupplyTypes" _
                      & "## 产品类型信息" & vbTab & "ProductStyles" & "## 产品子类信息" & vbTab & "ProductSubStyles" & "## 货币资料" & vbTab & "CurrencyExchange" & "## 客户类型信息" & vbTab & "CustomerTypes" _
                      & "## 付款方式" & vbTab & "Payments" & "## 客户资料" & vbTab & "Customers" & "## 客户联系人资料" & vbTab & "Contactors" & "## 客户与联系人关联表" & vbTab & "CustomerContactor" _
                      & "## 客户电话资料" & vbTab & "CustomerPhones" & "## 订单主表" & vbTab & "OrderPrimary" & "## 订单付款细表" & vbTab & "OrderPaymentDetails" & "## 订单货品细表" & vbTab & "OrderDetails" _
                      & "## 发货单主表" & vbTab & "DeliveryPrimary" & "## 发货单细表" & vbTab & "DeliveryDetails" & "## 收款单主表" & vbTab & "GatheringPrimary" & "## 收款单细表" & vbTab & "GatheringDetails" _
                      & "## 退货单主表" & vbTab & "WithdrawPrimary" & "## 退货单细表" & vbTab & "WithdrawDetails" & "## 现结销售单主表" & vbTab & "CashSalePrimary" & "## 现结销售单细表" & vbTab & "CashSaleDetails" _
                      & "## 供应商资料" & vbTab & "Supply" & "## 供应商联系人资料" & vbTab & "Providers" & "## 供应商电话资料" & vbTab & "SupplyPhones" & "## 供应商与联系人关联表" & vbTab & "SupplyProvider" _
                      & "## 进货单主表" & vbTab & "StockPrimary" & "## 进货单货品细表" & vbTab & "StockDetails" & "## 进货单付款细表" & vbTab & "StockPaymentDetails" & "## 进货退货单主表" & vbTab & "StockWithdrawPrimary" _
                      & "## 进货退货单细表" & vbTab & "StockWithdrawDetails" & "## 总体销售计划" & vbTab & "Plannings" & "## 产品销售计划主表" & vbTab & "PlanProductPrimary" & "## 产品销售计划细表" & vbTab & "PlanProductDetails" _
                      & "## 促销情况" & vbTab & "Promotions" & "## 报价信息主表" & vbTab & "PricePrimary" & "## 报价信息细表" & vbTab & "PriceDetails" & "## 地区销售计划主表" & vbTab & "PlanTerritoryPrimary" _
                      & "## 地区销售计划细表" & vbTab & "PlanTerritoryDetails" & "## 投诉管理" & vbTab & "Complains" & "## 销售员销售计划主表" & vbTab & "PlanEmployeePrimary" & "## 销售员销售计划细表" & vbTab & "PlanEmployeeDetails" _
                      & "## 工作报告信息" & vbTab & "EmployeeReports" & "## 工作计划信息" & vbTab & "EmployeeAssigns" & "## 小组信息主表" & vbTab & "GroupPrimary" & "## 小组信息细表" & vbTab & "GroupDetails" _
                      & "## 服务线索信息" & vbTab & "ServiceClues" & "## 服务终止信息" & vbTab & "ServiceHalt" & "## 服务履行情况信息" & vbTab & "ServiceConducts" & "## 服务费用主表" & vbTab & "ServiceExpenditurePrimary" _
                      & "## 服务费用细表" & vbTab & "ServiceExpenditureDetails" & "## 服务工作安排主表" & vbTab & "ServiceArrangementPrimary" & "## 服务工作安排细表" & vbTab & "ServiceArrangementDetails" & "## 销售线索资料" & vbTab & "ClueSale" _
                      & "## 销售线索货品信息" & vbTab & "ClueSalePossible" & "## 销售线索终止资料" & vbTab & "ClueSaleHalt" _
                      & "## 销售线索任务指派主表" & vbTab & "ClueArrangementPrimary" & "## 销售线索任务指派细表" & vbTab & "ClueArrangementDetails" _
                      & "## 销售线索成果信息" & vbTab & "ClueSaleOthers" & "## 销售线索拜访计划" & vbTab & "ClueMeetPlan" _
                      & "## 销售线索拜访报告" & vbTab & "ClueMeet"
                      
Dim m_strComputerName As String
Dim m_strUserName As String
                      
'*******************************************************
'将完整文件名分解为路径名和短文件名
Public Function FilterFileName(ByVal strFullName As String, _
                                ByRef strPath As String, _
                                ByRef strFile As String) As Boolean
    On Error GoTo ERROR_EXIT
    Dim strShortFileName As String
    Dim nPos As Long
    
    If Trim(strFullName) = "" Then GoTo ERROR_EXIT
    strShortFileName = strFullName
    nPos = InStr(strShortFileName, "\")
    While nPos > 0
        strShortFileName = Right(strShortFileName, Len(strShortFileName) - nPos)
        nPos = InStr(strShortFileName, "\")
    Wend
    strPath = Left(strFullName, Len(strFullName) - Len(strShortFileName))
    strFile = strShortFileName
    
    FilterFileName = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "CheckFileNameExist"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    FilterFileName = False
End Function

'**************************************************************
' 检查否存在空基础表，系统要求在正常运行时，不能有空的基础表
' 参数说明：
'       strTableNamesSet    —— 所有需要检查的基础表的表名集合
'       返回值： True       —— 有空基础表
'                False      —— 没有空基础表
Public Function ExistEmptyBaseTable(ByVal strTableNamesSet As String) As Boolean
    On Error GoTo FULL_EXIT
    Dim strTableName() As String
    Dim i As Integer
    
'    strTableName = Split(strTableNamesSet, vbTab)
'    For i = LBound(strTableName) To UBound(strTableName)
'        If IsTableEmpty(strTableName(i)) Then GoTo FULL_EXIT
'    Next
    ExistEmptyBaseTable = False
    Exit Function
FULL_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "ExistEmptyBaseTable"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "数据库中有基础表为空。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    ExistEmptyBaseTable = True
End Function

'**************************************************************
' 检查数据库中一个表是否为空
Public Function IsTableEmpty(ByVal strTableName As String) As Boolean
    On Error GoTo ERROR_EXIT
    Dim cmd As New ADODB.Command
    Dim rs As New ADODB.Recordset
    Dim strError As String
    
    If strTableName = "" Then GoTo ERROR_EXIT
    strError = "检查一个表是否为空失败。"
    cmd.ActiveConnection = dbMyDB
    cmd.CommandText = "select TOP 1 * from " & strTableName
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If rs.State <> adStateOpen Then GoTo ERROR_EXIT
    If Not rs.RecordCount > 0 Or rs.EOF Then
        strError = "表 " & strTableName & " 为空。"
        Debug.Print strError
        GoTo ERROR_EXIT1
    End If
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    IsTableEmpty = False
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "IsTableEmpty"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "数据库中有基础表为空。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
ERROR_EXIT1:
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    IsTableEmpty = True
End Function

'**************************************************************
' 检查数据库中一个表是否存在
Private Function IsTableExist(ByVal strTableName As String) As Boolean
    On Error GoTo ERROR_EXIT
    Dim cmd As New ADODB.Command
    Dim strError As String
    
    If strTableName = "" Then GoTo ERROR_EXIT
    strError = "检查一个表是否存在失败。"
    
    With cmd
        .ActiveConnection = dbMyDB
        .CommandType = adCmdStoredProc
        .CommandText = "SPEX_IS_TABLE_EXISTS"
        .Parameters.Append .CreateParameter("RETURN_VALUE", adInteger, adParamOutput, , Null)
        .Parameters.Append .CreateParameter("TableName", adVarChar, adParamInput, 255, strTableName)
        .Execute
        If .Parameters("RETURN_VALUE").Value <> 0 Then  ' 0 表示存在
            Select Case .Parameters("RETURN_VALUE").Value
                Case 1      '不存在
                    strError = "表 " & strTableName & " 不存在。"
                Case Else    '出错
                    strError = "调用存储过程 SPEX_IS_TABLE_EXISTS 出错，返回值 " _
                            & .Parameters("RETURN_VALUE").Value & " 。"
            End Select
        End If
    End With
    
    Set cmd = Nothing
    IsTableExist = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "IsTableExist"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "数据库中有基础表为空。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    Set cmd = Nothing
    IsTableExist = False
End Function

'**************************************************************
' 获得基本信息表对应的描述说明性文字
Public Function GetDescOfBaseTable(ByVal strTableName As String) As String
    On Error GoTo ERROR_EXIT
    Dim strDesc As String
    
    If strTableName = "" Then GoTo ERROR_EXIT
    strDesc = ""
'    Select Case strTableName
'        Case "States"
'            strDesc = "省份资料" & vbTab & "客户、供应商所在的省份信息。" & vbTab & "States"
'        Case "StateCity"
'            strDesc = "城市资料" & vbTab & "客户、供应商所在的城市信息。" & vbTab & "StateCity"
'        Case "CurrencyExchange"
'            strDesc = "货币资料" & vbTab & "本系统使用的结算货币种类。" & vbTab & "CurrencyExchange"
'        Case "CustomerClass"
'            strDesc = "客户级别" & vbTab & "客户的不同贡献度定义，如A级、B级等。" & vbTab & "CustomerClass"
'        Case "CustomerTypes"
'            strDesc = "客户类型" & vbTab & "客户性质定义，如批发商、零售商、终端用户等。" & vbTab & "CustomerTypes"
'        Case "Departments"
'            strDesc = "公司部门" & vbTab & "用户企业的部门设置，如销售部，市场部等。" & vbTab & "Departments"
'        Case "EmployeeClass"
'            strDesc = "员工级别" & vbTab & "同一部门员工的等级，如新手、普通、专家等。" & vbTab & "EmployeeClass"
'        Case "Industries"
'            strDesc = "行业类别" & vbTab & "客户、供应商所属的行业，如建筑、汽车等。" & vbTab & "Industries"
'        Case "IndustryStatus"
'            strDesc = "行业地位" & vbTab & "客户、工商上在其行业中的位置，如领导者等。" & vbTab & "IndustryStatus"
'        Case "OpportunityClass"
'            strDesc = "销售机会" & vbTab & "销售线索对应的机会等级，如可能成功、还在犹豫等。" & vbTab & "OpportunityClass"
'        Case "Payments"