mdldatabase.bas

本系统可用于医院和专业体检中心的健康体检管理

Attribute VB_Name = "mdlDatabase"
Option Explicit

'**************************************************************
'**************************************************************
'************************  作    者：吴明远     ****************
'************************  功能简介：读写数据库  ***************
'************************  开发时间：2003-8    ****************
'**************************************************************
'**************************************************************

Public g_blnReLogin As Boolean '是否重新登录
Public gstrConString As String
Public rs As ADODB.Recordset
Public GCon As ADODB.Connection             '全局连接变量
Public DatabaseName As String               '数据库名
Public Const DatabaseDir = "Data\"          '数据存放路径
Public Const TemplateDir = "Config\Template\"   '报表模板存放路径
Public Const TJResultToText = "TJResultToText.txt" '报表输出模板
Public Const GuiderConfig = "GuiderConfig.ini"
Public Const NoRecord = 3021
Public Const PasswordDepth = -15
Public Const EXPRESSIONHEADER = "W"
Public Const SPY_FILE = "micro-spy.wmy"
Public Const HEADER = "W" '在各种数字关键字前面作为首字符（数字不能作为首字符）
Public Const PHOTO_FIELD = "_Photograph"
Public Const BookMarkSeparator = "A"
Public Const VARCHAR_TO_FLOAT_ERROR = -2147217913
'导出报表中的模板常量
Public Const Hospital = "&HOSPITAL"
Public Const ExportTime = "&EXPORTTIME"
Public Const HEALTHID = "&HEALTHID"
Public Const name = "&NAME"
Public Const SEX = "&SEX"
Public Const TJRQ = "&TJRQ"
Public Const AFFIRM = "A"

Public TempTable As String '考虑到多个用户同时使用临时表，所以每个用户的临时表名设置不同
Public g_intZJModifyDays As Integer

'******************20040328加入 闻********************************
Public gstrConStringLis As String         'Lis数据库的全局连接串
Public GConLis As ADODB.Connection        'Lis数据库的全局连接变量
Public Const LisDatabaseName = "Lis"      'Lis数据库名
'******************20040328加入完 闻******************************

Public Type Manager
    SystemXTGL As String  '系统管理人员
    SystemZJYS As String  '总检医生
    SysTemCJYS As String  '超级医生
    SystemKSYS As String  '科室医生
    SystemDJRY As String  '登记人员
    SystemZR As String    '主任
    SystemLRY As String   '录入员
    
End Type
Public GManager As Manager

'定义个人基本信息
Public Type PersonInfo
    PersonName As String
    FZID As Integer
    PersonSex As String
    PersonAge As Integer
    PersonJTDH As String
    PersonBGDH As String
    PersonYDDH As String
End Type

Public Type Coordinate
    x As Single
    y As Single
    Width As Single
    Height As Single
    IsUse As Boolean
End Type

Public Enum OpenDirection
    WRITEFILE = 0
    READFILE = 1
End Enum

Public Enum FromTable
    AFFIRM_TABLE = 0
    NOTAFFIRM_TABLE = 1
End Enum

Public Const WLine As Integer = 0       '线条
Public Const WText As Integer = 1       '静态文本
Public Const WAuto As Integer = 2       '动态文本
Public Const WPhoto As Integer = 3       '图片

Public Const WKShi As Integer = 0 '科室
Public Const WDX As Integer = 1 '大项
Public Const WXX As Integer = 2 '小项
Public Const WTJRQ As Integer = 3 '体检日期
Public Const WDate As Integer = 4 '打印日期
Public Const WDoctor As Integer = 5 '体检医生
Public Const WXJie As Integer = 6 '科室小结
Public Const WJYi As Integer = 7 '科室建议

Public Const WHealthID As Integer = 8 '档案号
Public Const WName As Integer = 9 '姓名
Public Const WSN As Integer = 10 '体检序号
Public Const WSex As Integer = 11 '性别
Public Const WDWei As Integer = 12 '单位
Public Const WPhone As Integer = 13 '联系电话
Public Const WZJJLun As Integer = 14 '总检结论
Public Const WZJJYi As Integer = 15 '总检建议
Public Const WSFZH As Integer = 16   '身份证号
Public Const WAge As Integer = 17   '年龄
Public Const WTJTC As Integer = 18   '体检套餐
Public Const WCXM As Integer = 19    '查询码

Public Enum Report
    CUSTOMREPORT = 0 '用户定制的报表
    UNIVERSALREPORT = 1 '通用报表
End Enum

Public Enum MBLX '模板类型
    GEREN = 0
    TUANTI = 1
End Enum

Public Type FontType
    FontName As String
    FontSize As Double
    FontBold As Boolean
    FontItalic As Boolean
    FontUnderline As Boolean
    Alignment As Integer
    Multiline As Boolean
End Type

'操作
Public Enum OperationType
    Add = 0
    Modify = 1
End Enum
Public Enum JBType
   AddJB = 0
   ModifyJB = 1
End Enum
Public Enum JYType
  AddJY = 0
  ModifyJY = 1
End Enum
'日志
Public Enum LogType
    OperationLog = 0
    ErrorLog = 1
End Enum

'录入模式
Public Enum InputMode
    CENTRALIZE_INPUT = 0
    WORKSTATION_INPUT = 1
End Enum

Public Sub InitManager()
    With GManager
        .SystemXTGL = "01"
        .SysTemCJYS = "02"
        .SystemKSYS = "03"
        .SystemLRY = "04"
        
'        .SystemZJYS = "03"
'        .SystemDJRY = "05"
'        .SystemZR = "06"
        
    End With
End Sub

'处理Select语句中的单引号--去单引号
Public Function CheckString(ByVal s As String) As String
    Dim intPosition As Integer
    intPosition = InStr(s, "'")
    
    While intPosition > 0
        s = Mid(s, 1, intPosition - 1) & Mid(s, intPosition + 1)
        intPosition = InStr(s, "'")
    Wend
    
    CheckString = s
End Function

'关闭数据库连接对象
Public Sub DisConnectDatabase(ByRef con As ADODB.Connection)
On Error Resume Next
    Dim Status
    
    If con Is Nothing Then
        GoTo ExitLab
    Else
        If con.State = adStateOpen Then
            con.Close
        End If
        Set con = Nothing
    End If
    
    GoTo ExitLab
ExitLab:
    '
End Sub

'连接数据库
'参数1：欲连接的对象
'参数2：游标类型。可选。默认为客户端游标
Public Function ConnectDatabase(ByRef con As ADODB.Connection, _
        Optional ByVal adCursorType As CursorLocationEnum = adUseClient) As Boolean
On Error GoTo ErrTrap
    Dim strMsg As String
    Dim strStatus
    Screen.MousePointer = vbArrowHourglass
    
    '检查连接对象是否存在
    If con Is Nothing Then
        Set con = New ADODB.Connection
    End If
    '初始化
    ConnectDatabase = False
    con.ConnectionString = gstrConString
    con.CursorLocation = adCursorType
    con.Open
    
    ConnectDatabase = True  '成功连接数据库
    Screen.MousePointer = vbDefault
    Exit Function
ErrTrap:
    Screen.MousePointer = vbDefault
    strStatus = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg strStatus
    
    strMsg = "无法连接数据库，请检查是否存在以下原因：" & vbCrLf _
                & vbCrLf & "*Microsoft SQL Server尚未运行" _
                & vbCrLf & "*ODBC配置文件被损坏" _
                & vbCrLf & "*ODBC连接被删除或数据源被移动" _
                & vbCrLf & "*数据库被人为损坏" _
                & vbCrLf & vbCrLf & "请联系系统管理员！"
    strStatus = SetError(Err.Number, strMsg, Err.Source)
    ErrMsg strStatus
End Function

'确保建立了数据库连接
Public Function CheckConnection(ByRef con As ADODB.Connection) As Boolean
On Error GoTo ErrMsg
    Dim Msg As String
    
    CheckConnection = False '假设连接未建立
    
    If Not (con Is Nothing) Then '说明开始时已连接上
        If con.State <> adStateOpen Then
            If ConnectDatabase(con) = False Then Exit Function
        End If
    
    Else '一开始时就未未连接上
        '再尝试一次
        If ConnectDatabase(con) = False Then
            Exit Function
        End If
    End If
    
    CheckConnection = True '连接已建立
    Exit Function
ErrMsg:
    '
End Function

'加密
Public Function Incode(ByVal strPassward As String) As String
    Dim i As Integer
    Dim n As Integer

    Incode = ""
    For i = 1 To Len(Trim(strPassward))
        If i Mod 2 = 0 Then
            n = Asc(Mid(strPassward, i, 1)) + 4 + i
        Else
            n = Asc(Mid(strPassward, i, 1)) - 2 - i
        End If
        If n < Asc("A") Then
            n = Asc(Mid(strPassward, i, 1)) + 3 + i
        ElseIf n > Asc("Z") And n < Asc("a") Then
            n = Asc(Mid(strPassward, i, 1))
        ElseIf n > Asc("z") Then
            n = Asc(Mid(strPassward, i, 1)) - 1 - i
        End If
        Incode = Incode & Chr(n)
    Next i
    Incode = Trim(Incode)
End Function

'Purpose:   Add log
Public Sub AddLog(ByVal OperationManagerOrErrNumber, ByVal strDescription As String, ByVal enuLog As LogType, Optional strSource)
On Error Resume Next
    Dim Status
    Dim strSQL As String
    
    Select Case enuLog
        Case OperationLog
            strSQL = "insert into OperationLog values('" _
                    & OperationManagerOrErrNumber & "','" _
                    & strDescription & "','" & Date & " " & Time & "')"
        Case ErrorLog
            strSQL = "insert into ErrorLog values('" _
                    & OperationManagerOrErrNumber & "','" & strDescription _
                    & "','" & strSource & "','" & Date & " " & Time & "')"
    End Select
    
    Status = Execute(strSQL)
End Sub

'（函数GetRows和Execute的错误处理机制很好，通常情况下，我们去掉其中的CheckStatus就OK了！）
'创建一个标准执行模块，命名modErrorMgt，添加如下处理出错的函数：
Public Function NoError()
    'Define local ErrorType
    Dim pError(2)

    'Assign no error
    pError(0) = 0
    pError(1) = ""
    pError(2) = ""
   
    'Return the ErrorType
    NoError = pError
End Function

Public Function SetError(ErrNumber As Long, ErrDescription As String, ErrSource As String)
'This function will return a variant array of three elements
'set to the passed parameters
    'Define local ErrorType
    Dim pError(2)
 
    'Assign error
    pError(0) = ErrNumber
    pError(1) = ErrDescription
    pError(2) = ErrSource
   
    'Return the ErrorType
    SetError = pError
End Function

Public Function ErrTrue(Status) As Boolean
    'First check to make sure Status is an array
    If IsArray(Status) Then
        'Then make sure first elements is numeric
        If IsNumeric(Status(0)) Then
            If Status(0) <> 0 Then
                'an error occurred
                ErrTrue = True
            End If
        End If
    End If
End Function

'以下代码判断结果集的维数，若为1，则产生了错误，若为2，则正确
Public Function Dimensions(VariantArray) As Integer
'Determine the number of dimensions for a Variant array

    'handle all errors locally
    On Error GoTo Dimensions_Err
    
    'define local variables
    Dim Ctr As Integer
    Dim TestVal As Long
    
    Do
        'loop and increment counter
        Ctr = Ctr + 1
        'test then upper bound of the dimension
        TestVal = UBound(VariantArray, Ctr)
    Loop
    
Dimensions_Cont:
    'all done
    Exit Function
    
Dimensions_Err:
    'When an error occurs we have exceeded the number of
    'dimensions in our variant array by one. The true number
    'of dimensions is the counter less one.
    Dimensions = Ctr - 1
    
    'Reset then Err object and exit the function
    Resume Dimensions_Cont
End Function