module1.bas

医院管理系统已经在运行中

Attribute VB_Name = "Module1"
Public dbstr As String
Public czyxm As String
Public czylx As String
Public adoconn As ADODB.Connection
Public rs1 As ADODB.Recordset
Private Type ExlCell
    Row As Long
    Col As Long
End Type

Sub tec(sjk)
    Set adoconn = New ADODB.Connection
    adoconn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & dbstr
    Junk = sjk
    adoconn.Open
    Set rs1 = New ADODB.Recordset
    rs1.Open Junk, adoconn, adOpenStatic, adLockReadOnly, adCmdTable
    ToExcel rs1, App.Path & "\wk.xls"
    adoconn.Close
End Sub
Private Sub ToExcel(SN1 As ADODB.Recordset, strCaption As String)
    Dim oExcel    As Object
    Dim objExlSht As Object ' OLE automation object
    Dim stCell As ExlCell
    On Error GoTo Err_ToExcel
       DoEvents
        On Error Resume Next
        Set oExcel = GetObject(, "Excel.Application")
        If Err = 429 Then
            Err = 0
            Set oExcel = CreateObject("Excel.Application")
            If Err = 429 Then
                MsgBox Err & ": " & Error, vbExclamation + vbOKOnly
                Exit Sub
            End If
        End If
        oExcel.Workbooks.Add
        oExcel.Worksheets("sheet1").Name = strCaption
        Set objExlSht = oExcel.ActiveWorkbook.Sheets(1)
        stCell.Row = 1
        stCell.Col = 1
        CopyRecords SN1, objExlSht, stCell
        oExcel.Visible = True
        oExcel.Interactive = True
        If Not (objExlSht Is Nothing) Then
            Set objExlSht = Nothing
        End If
        If Not (oExcel Is Nothing) Then
            Set oExcel = Nothing
        End If
        If Not (SN1 Is Nothing) Then
            Set SN1 = Nothing
        End If
   
    
Exit_ToExcel:

    On Error GoTo 0
    Exit Sub
    
Err_ToExcel:

    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "Error: " & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, App.Title & "  -  Advisory"
            Resume Exit_ToExcel
    End Select

End Sub



Private Sub CopyRecords(RST As ADODB.Recordset, WS As Worksheet, StartingCell As ExlCell)
    Dim SomeArray() As Variant
    Dim Row         As Long
    Dim Col         As Long
    Dim Fd          As ADODB.Field
    On Error GoTo Err_CopyRecords
    If RST.EOF And RST.BOF Then Exit Sub
    RST.MoveLast
    ReDim SomeArray(RST.RecordCount + 1, RST.Fields.Count)
    Col = 0
    For Each Fd In RST.Fields
        SomeArray(0, Col) = Fd.Name
        Col = Col + 1
    Next
    RST.MoveFirst
    Recs = RST.RecordCount
    Counter = 0
    For Row = 1 To RST.RecordCount
        Counter = Counter + 1
        If Counter <= Recs Then i = (Counter / Recs) * 100
        
        For Col = 0 To RST.Fields.Count - 1
            SomeArray(Row, Col) = RST.Fields(Col).Value
            If IsNull(SomeArray(Row, Col)) Then _
            SomeArray(Row, Col) = ""
        Next
        RST.MoveNext
    Next
    WS.Range(WS.Cells(StartingCell.Row, StartingCell.Col), _
        WS.Cells(StartingCell.Row + RST.RecordCount + 1, _
        StartingCell.Col + RST.Fields.Count)).Value = SomeArray

Exit_CopyRecords:
    On Error GoTo 0
    Exit Sub
Err_CopyRecords:
    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "Error: " & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, App.Title & "  -  Advisory"
            Resume Exit_CopyRecords
    End Select
        
End Sub
Private Function changnum(num As Integer) As String
    Select Case num
    Case 0
        changnum = "零"
    Case 1
        changnum = "壹"
    Case 2
        changnum = "贰"
    Case 3
        changnum = "叁"
    Case 4
        changnum = "肆"
    Case 5
        changnum = "伍"
    Case 6
        changnum = "陆"
    Case 7
        changnum = "柒"
    Case 8
        changnum = "捌"
    Case 9
        changnum = "玖"
    End Select
End Function
Public Function changemoney(num) As String
    Dim money1 As String
    Dim tn
    Dim k1 As String
    Dim k2 As String
    Dim k3 As String

    If num = 0 Then
        changemoney = " "
        Exit Function
    End If
    If num < 0 Then
        changemoney = "负" + changemoney(Abs(num))
        Exit Function
    End If
    money1 = Trim(Str(num))
    tn = InStr(money1, ".")  '小数位置
    k1 = ""
    If tn <> 0 Then
        ST1 = Right(money1, Len(money1) - tn)
        If ST1 <> "" Then
            t1 = Left(ST1, 1)
            ST1 = Right(ST1, Len(ST1) - 1)
            If t1 <> "0" Then
                k1 = k1 + changnum(Val(t1)) + "角"
            End If
            If ST1 <> "" Then
                t1 = Left(ST1, 1)
                k1 = k1 + changnum(Val(t1)) + "分"
            End If
        End If
        ST1 = Left(money1, tn - 1)
    Else
        ST1 = money1
    End If

    k2 = ""
    If ST1 <> "" Then
        t1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        k2 = changnum(Val(t1)) + k2
    End If

    If ST1 <> "" Then
        t1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        If t1 <> "0" Then
            k2 = changnum(Val(t1)) + "拾" + k2
        Else
            If Left(k2, 1) <> "零" Then k2 = "零" + k2
        End If
    End If

    If ST1 <> "" Then
        t1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        If t1 <> "0" Then
            k2 = changnum(Val(t1)) + "佰" + k2
        Else
            If Left(k2, 1) <> "零" Then k2 = "零" + k2
        End If
    End If

    If ST1 <> "" Then
        t1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        If t1 <> "0" Then
            k2 = changnum(Val(t1)) + "仟" + k2
        Else
            If Left(k2, 1) <> "零" Then k2 = "零" + k2
        End If
    End If

    k3 = ""
    If ST1 <> "" Then
        t1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        k3 = changnum(Val(t1)) + k3
    End If


    If ST1 <> "" Then
        t1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        If t1 <> "0" Then
            k3 = changnum(Val(t1)) + "拾" + k3
        Else
            If Left(k3, 1) <> "零" Then k3 = "零" + k3
        End If
    End If

    If ST1 <> "" Then
        t1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        If t1 <> "0" Then
            k3 = changnum(Val(t1)) + "佰" + k3
        Else
            If Left(k3, 1) <> "零" Then k3 = "零" + k3
        End If
    End If

    If ST1 <> "" Then
        t1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        If t1 <> "0" Then
            k3 = changnum(Val(t1)) + "仟" + k3
        End If
    End If
    If Right(k2, 1) = "零" Then k2 = Left(k2, Len(k2) - 1)
    If Len(k3) > 0 Then
        If Right(k3, 1) = "零" Then k3 = Left(k3, Len(k3) - 1)
        k3 = k3 & "万"
    End If

    changemoney = IIf(k3 & k2 = "", k1, k3 & k2 & "元" & k1)
End Function