basdata.bas

小型医院管理

Attribute VB_Name = "basData"

'Public Sub Main()
'    If App.PrevInstance = True Then End
'    frmMain.Show
'End Sub
Public Sub Create_Connection(Database_Type As dbType, db As String, Optional ServerName As String, Optional user As String, Optional Password As String)
    'on error goto Err_Handler
    
    Select Case Database_Type

                   
        Case 1 '-- SQL Database
            ConnectionString = "Provider=SQLOLEDB;" & _
                               "Server=" & ServerName & ";" & _
                               "Database=" & db & ";" & _
                               "UID=" & user & ";PWD=" & Password & ";"
        Case Else
            MsgBox "Incorect Database Type", vbOKOnly + vbExclamation, "Create Connection Error!"
            Exit Sub
    
    End Select
     Exit Sub
Err_Handler:
LogoError:
           Beep
           MsgBox "", vbOKOnly + vbQuestion, ""
          End
   Exit Sub
End Sub

Public Function ExecuteSQL(ByVal SQL As String) As ADODB.Recordset

    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim sTokens() As String

    'on error goto Err_Handler

    sTokens = Split(SQL)
    Set cnn = New ADODB.Connection
    cnn.Open ConnectionString

    If InStr(1, Left(UCase(SQL), 7), "INSERT") _
        Or InStr(1, Left(UCase(SQL), 7), "DELETE") _
        Or InStr(1, Left(UCase(SQL), 7), "UPDATE") Then
        cnn.Execute SQL
    Else
        Set rs = New ADODB.Recordset
        rs.Open Trim(SQL), cnn, adOpenKeyset, adLockOptimistic
        Set ExecuteSQL = rs
    End If

Exit_Execute_SQL:
    Set rs = Nothing
    Set cnn = Nothing
    Exit Function

Err_Handler:
    MsgBox Err.Number & " " & Err.Description, vbExclamation + vbOKOnly, "Execute SQL Error!"
    Resume Exit_Execute_SQL

End Function

Public Function ExecuteSP(ByVal SQL As String, Procedure_Type As spType) As ADODB.Recordset

    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset

    'on error goto Err_Handler

    Set cnn = New ADODB.Connection
    cnn.Open ConnectionString

    Select Case Procedure_Type

        Case 0
            Set rs = New ADODB.Recordset
            rs.Open Trim(SQL), cnn ', adOpenKeyset, adLockOptimistic, adCmdStoredProc
            Set ExecuteSP = rs

        Case 1, 2
            cnn.Execute SQL

    End Select

Exit_Execute_SP:
   
    Set rs = Nothing
    Set cnn = Nothing
    Exit Function

Err_Handler:
    
    fwq = 1
    Resume Exit_Execute_SP

End Function

Public Sub Load_ListView(sp As String, olv As ListView)
    Dim rsLV As New ADODB.Recordset
    Set rsLV = ExecuteSP(sp, sp_Select)
    If rsLV.EOF Then Exit Sub
    olv.ListItems.Clear
    Dim i As Integer
    LockWindowUpdate olv.hwnd
    Do Until rsLV.EOF
        Set LI = olv.ListItems.Add(, , rsLV(3).Value)
        LI.Checked = True
        For i = 4 To rsLV.Fields.Count - 1
            If IsNull(rsLV(i).Value) Then
                LI.ListSubItems.Add , , "NULL"
            Else
                If i = 5 Then
                    LI.ListSubItems.Add , , Get_ParameterDirection_Enum_Type(rsLV(i).Value) & "(" & rsLV(i).Value & ")"
                ElseIf i = 9 Then
                    LI.ListSubItems.Add , , Get_Enum_Type(rsLV(i).Value) & "(" & rsLV(i).Value & ")"
                Else
                    LI.ListSubItems.Add , , rsLV(i).Value
                End If
            End If
        Next
        rsLV.MoveNext
    Loop
    LockWindowUpdate 0&
    Adjust_Listview_Columns olv
End Sub

Public Sub Adjust_Listview_Columns(olv As ListView)
    For i = 0 To olv.ColumnHeaders.Count - 1
        SendMessage olv.hwnd, LVM_SETCOLUMNWIDTH, i, ByVal LVSCW_AUTOSIZE_USEHEADER
    Next
End Sub

Public Function Get_ParameterDirection_Enum_Type(ParameterType As Integer) As String
    Select Case ParameterType
        Case 0
            Get_ParameterDirection_Enum_Type = "adParamUnknown"
        Case 1
            Get_ParameterDirection_Enum_Type = "adParamInput"
        Case 2
            Get_ParameterDirection_Enum_Type = "adParamOutput"
        Case 3
            Get_ParameterDirection_Enum_Type = "adParamInputOutput"
        Case 4
            Get_ParameterDirection_Enum_Type = "adParamReturnValue"
    End Select
End Function
    

Public Function Get_Enum_Type(DataType As Integer) As String

    Select Case DataType
        Case 0
            Get_Enum_Type = "adEmpty"
        Case 2
            Get_Enum_Type = "adSmallInt"
        Case 3
            Get_Enum_Type = "adInteger"
        Case 4
            Get_Enum_Type = "adSingle"
        Case 5
            Get_Enum_Type = "adDouble"
        Case 6
            Get_Enum_Type = "adCurrency "
        Case 7
            Get_Enum_Type = "adDate"
        Case 8
            Get_Enum_Type = "adBSTR"
        Case 9
            Get_Enum_Type = "adIDispatch"
        Case 10
            Get_Enum_Type = "adError"
        Case 11
            Get_Enum_Type = "adBoolean"
        Case 12
            Get_Enum_Type = "adVariant"
        Case 13
            Get_Enum_Type = "adIUnknown"
        Case 14
            Get_Enum_Type = "adDecimal"
        Case 16
            Get_Enum_Type = "adTinyInt"
        Case 17
            Get_Enum_Type = "adUnsignedTinyInt"
        Case 18
            Get_Enum_Type = "adUnsignedSmallInt"
        Case 19
            Get_Enum_Type = "adUnsignedInt"
        Case 20
            Get_Enum_Type = "adBigInt"
        Case 21
            Get_Enum_Type = "adUnsignedBigInt"
        Case 64
            Get_Enum_Type = "adFileTime"
        Case 72
            Get_Enum_Type = "adGUID"
        Case 128
            Get_Enum_Type = "adBinary"
        Case 129
            Get_Enum_Type = "adChar"
        Case 130
            Get_Enum_Type = "adWChar"
        Case 131
            Get_Enum_Type = "adNumeric"
        Case 132
            Get_Enum_Type = "adUserDefined"
        Case 133
            Get_Enum_Type = "adDBDate"
        Case 134
            Get_Enum_Type = "adDBTime"
        Case 135
            Get_Enum_Type = "adDBTimeStamp"
        Case 136
            Get_Enum_Type = "adChapter"
        Case 138
            Get_Enum_Type = "adPropVariant"
        Case 139
            Get_Enum_Type = "adVarNumeric"
        Case 200
            Get_Enum_Type = "adVarChar"
        Case 201
            Get_Enum_Type = "adLongVarChar"
        Case 202
            Get_Enum_Type = "adVarWChar"
        Case 203
            Get_Enum_Type = "adLongVarWChar"
        Case 204
            Get_Enum_Type = "adVarBinary"
        Case 205
            Get_Enum_Type = "adLongVarBinary"
        Case 8192
            Get_Enum_Type = "adArray"
    End Select
End Function

Private Function Account_For_NULL(sValue As String)
    If IsNull(sValue) Then
        Account_For_NULL = "NULL"
    Else
        Account_For_NULL = Trim(sValue)
    End If
End Function

Public Function Load_Sproc() As String
    Set oRS = ExecuteSP("exec sp_helptext '" & gCurrentSproc & "'", sp_Select)
    Dim strSproc As String
    If oRS.State = adStateOpen Then
        Do Until oRS.EOF
            strSproc = strSproc & oRS("text")
            oRS.MoveNext
        Loop
        Load_Sproc = strSproc
    Else
        gCurrentSproc = ""
    End If
End Function

Public Sub Write_Command(cmd As CommandType, rtb As RichTextBox, lv As ListView)
    
    rtb.Text = ""
    
    Dim strCode As String
    Dim strParamCode As String
    Dim i As Integer
    
    strCode = vbCrLf
    
    If cmd = cmd_VB Then
        
        '-- VB Code
        
        '-- Create Connection String
        If gbCreateConnectionString = True Then
            If gbCommentCode = True Then strCode = strCode & "   '-- Create Connection String" & vbCrLf
            strCode = strCode & "   Dim " & gsConnectionString & " as String" & vbCrLf
            strCode = strCode & "   " & gsConnectionString & " = " & Chr(34) & gSQLDriver & ";" & Chr(34) & " & _" & vbCrLf
            strCode = strCode & "       " & Chr(34) & "Server=" & gCurrentServer & ";" & Chr(34) & " & _" & vbCrLf
            strCode = strCode & "       " & Chr(34) & "Database=" & gCurrentDatabase & ";" & Chr(34) & " & _" & vbCrLf
            strCode = strCode & "       " & Chr(34) & "Uid=" & gCurrentUser & ";" & Chr(34) & " & _" & vbCrLf
            strCode = strCode & "       " & Chr(34) & "Pwd=" & gCurrentPassword & ";" & Chr(34) & vbCrLf & vbCrLf
        End If