module1.bas

现在我国的多数诊所或小型医院的管理水平还停留在纸介质的基础上

Attribute VB_Name = "Module1"
Option Explicit
Public DBConnection As New ADODB.Connection     '定义一个连接
Public rec_user As New ADODB.Recordset  '对应用户
Public rec_config As New ADODB.Recordset  '对应系统配置
Public rec_med As New ADODB.Recordset  '对应药品
Public rec_gh As New ADODB.Recordset  '对应药品
Public rec_hj As New ADODB.Recordset  '对应药品
Public rec_hjt As New ADODB.Recordset  '对应药品
Public rec_hja As New ADODB.Recordset  '对应药品
Public rec_hjaa As New ADODB.Recordset  '对应药品
Public rec_hjaaa As New ADODB.Recordset  '对应药品


Public rec_b As New ADODB.Recordset  '对应图书类型


Public rec_print As New ADODB.Recordset  '对应于打印
Public rec_comm As New ADODB.Recordset '对应通用
Public rec_comm2 As New ADODB.Recordset '对应通用

Public Function ConnectDataBase() As Boolean
Dim strDataPath As String
strDataPath = App.Path
If Right(strDataPath, 1) <> "\" Then
    strDataPath = strDataPath & "\"
End If
    'On Error GoTo ConnectErr
        DBConnection.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                        "Data Source=" & strDataPath & "data\mz.mdb" & ";" & _
                                        "Persist Security Info=False"
        DBConnection.ConnectionTimeout = 30
        DBConnection.Open
        ConnectDataBase = True
        Exit Function
                                        
ConnectErr:
        ConnectDataBase = False
        MsgBox "错误代码 :" & Err.Number & vbCrLf & _
                "错误描述 :" & Err.Description, vbCritical + vbOKOnly, "连接错误"
End Function

Public Function ExcuteSql(ByVal Recordsettest As ADODB.Recordset, ByVal strSQL As String) As Boolean
    If DBConnection.State = 0 Then
    ConnectDataBase
    End If
    
    On Error GoTo ExcuteSqlError
    'Set Recordsettest = Nothing
    If Recordsettest.State = adStateOpen Then
       Recordsettest.Close
    End If
    'Recordset.CursorType = adOpenKeyset
    'Recordset.LockType = adLockOptimistic
    Call Recordsettest.Open(strSQL, DBConnection, adOpenKeyset, adLockOptimistic, -1)
    ExcuteSql = True
    Exit Function
ExcuteSqlError:
    MsgBox "错误代码:" & Err.Number & vbCrLf & _
            "错误描述:" & Err.Description, vbCritical + vbOKOnly, "错误"
    ExcuteSql = False
End Function



Public Sub GetFlexGridFirstColValue(ByVal flexGrid As MSHFlexGrid, varColValue As Variant)
    If flexGrid.Rows <= 0 Or flexGrid.Cols <= 0 Or flexGrid.Row = 0 Then
        Exit Sub
    End If
    
    
    With flexGrid
    
        If .TextMatrix(.Row, 0) <> Empty Then
            varColValue = .TextMatrix(.Row, 0)
        Else
            varColValue = Empty
        End If
    End With
    

End Sub

Public Function getID(ByVal strSQL As String)
Dim rctCmb As New ADODB.Recordset
'cmbdest.AddItem " "
If ExcuteSql(rctCmb, strSQL) = True Then
    If rctCmb.RecordCount > 0 Then
        getID = rctCmb.Fields(0)
    Else
       getID = ""
    End If
End If

If rctCmb.State <> adStateClosed Then
    rctCmb.Close
    Set rctCmb = Nothing
End If

End Function

Public Sub IniCmb(ByVal cmbdest As ComboBox, ByVal strSQL As String)
Dim rctCmb As New ADODB.Recordset
cmbdest.Clear
'cmbdest.AddItem " "
If ExcuteSql(rctCmb, strSQL) = True Then
    If rctCmb.RecordCount > 0 Then
        rctCmb.MoveFirst
        While Not rctCmb.EOF
           cmbdest.AddItem Trim(rctCmb.Fields(0))
           rctCmb.MoveNext
        Wend
        
        
    End If
End If

If rctCmb.State <> adStateClosed Then
    rctCmb.Close
    Set rctCmb = Nothing
End If
If cmbdest.ListCount > 0 Then
cmbdest.ListIndex = 0
End If
End Sub

Public Sub IniTxt(ByVal cmbdest As TextBox, ByVal strSQL As String)
Dim rctCmb As New ADODB.Recordset
'cmbdest.AddItem " "
If ExcuteSql(rctCmb, strSQL) = True Then
    If rctCmb.RecordCount > 0 Then
        rctCmb.MoveFirst
        If Not rctCmb.EOF Then
           cmbdest = rctCmb.Fields(0)
           
        End If
        
        
    End If
End If

If rctCmb.State <> adStateClosed Then
    rctCmb.Close
    Set rctCmb = Nothing
End If

End Sub