form1.frm

这是本人几年前写的一个导医院His数据的小程序。

VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "查门诊过去处方库主细目对不上"
   ClientHeight    =   7515
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7995
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   7515
   ScaleWidth      =   7995
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.ListBox ll 
      Height          =   2220
      Left            =   210
      TabIndex        =   11
      Top             =   5100
      Width           =   7755
   End
   Begin VB.CommandButton Command1 
      Caption         =   "OK"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   26.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   765
      Left            =   6870
      TabIndex        =   3
      Top             =   60
      Width           =   1095
   End
   Begin VB.ListBox l1 
      Height          =   4200
      Left            =   30
      TabIndex        =   1
      Top             =   870
      Width           =   7935
   End
   Begin VB.ListBox l2 
      Height          =   4200
      Left            =   4020
      TabIndex        =   2
      Top             =   870
      Width           =   3945
   End
   Begin VB.Label Label9 
      Caption         =   "主细目相差金额大于一数据"
      Height          =   2295
      Left            =   30
      TabIndex        =   12
      Top             =   5130
      Width           =   225
   End
   Begin VB.Label Label8 
      Caption         =   "细目数据"
      Height          =   255
      Left            =   4050
      TabIndex        =   10
      Top             =   660
      Width           =   975
   End
   Begin VB.Label Label7 
      Caption         =   "主目数据"
      Height          =   225
      Left            =   30
      TabIndex        =   9
      Top             =   660
      Width           =   1155
   End
   Begin VB.Label Label6 
      Height          =   255
      Left            =   1740
      TabIndex        =   8
      Top             =   30
      Width           =   1755
   End
   Begin VB.Label Label5 
      Caption         =   "共有记录数:"
      Height          =   315
      Left            =   30
      TabIndex        =   7
      Top             =   30
      Width           =   1605
   End
   Begin VB.Label Label4 
      Height          =   375
      Left            =   5070
      TabIndex        =   4
      Top             =   360
      Width           =   825
   End
   Begin VB.Label Label3 
      Caption         =   "主细目差额:"
      Height          =   405
      Left            =   4050
      TabIndex        =   6
      Top             =   360
      Width           =   1035
   End
   Begin VB.Label Label2 
      Height          =   405
      Left            =   1740
      TabIndex        =   0
      Top             =   360
      Width           =   1665
   End
   Begin VB.Label Label1 
      Caption         =   "当前正在处理条数："
      Height          =   315
      Left            =   30
      TabIndex        =   5
      Top             =   360
      Width           =   1695
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public Sdate As String
Public Edate As String

Private Sub Command1_Click()
Dim rs1 As New ADODB.Recordset
Dim rs2 As New ADODB.Recordset
Dim sql1 As String
Dim sql2 As String
Dim rs3 As New ADODB.Recordset
Dim I As Double
Dim NumX As Currency
Dim CE As Currency
Screen.MousePointer = vbHourglass
On Error Resume Next
Conn.Execute "drop table aaaaaa"
Conn.Execute "drop table aaaaaa_zm"
Conn.Execute "drop table aaaaaa_xm"
On Error GoTo 0
Conn.Execute "select distinct 处方号 into aaaaaa from mz_cfk_gq where 收款标记<>0 and 日结日期>='" & Sdate & " 00:00:00' and 日结日期<='" & Edate & " 23:59:59'"
If rs1.State = adStateOpen Then rs1.Close
If rs2.State = adStateOpen Then rs2.Close
rs1.CursorLocation = adUseClient
rs2.CursorLocation = adUseClient
sql1 = "select 处方号,sum(处方金额) as 金额 into aaaaaa_zm from mz_cfk_gq where 处方号 in(select 处方号 from aaaaaa) and 日结日期>='" & Sdate & " 00:00:00' and 日结日期<='" & Edate & " 23:59:59' group by 处方号 order by 处方号"
sql2 = "select 处方号,sum(单价*数量*剂数) as 金额 into aaaaaa_xm from mz_cfk_gq_xm where 处方号 in(select 处方号 from aaaaaa) and 日结日期>='" & Sdate & " 00:00:01' and 日结日期<='" & Edate & " 23:59:59' group by 处方号 order by 处方号"
Conn.Execute sql1
Conn.Execute sql2
sql1 = "select * from aaaaaa_zm order by 处方号"
sql2 = "select * from aaaaaa_xm order by 处方号"
rs1.Open sql1, Conn
rs2.Open sql2, Conn
If rs1.EOF Or rs2.EOF Then Screen.MousePointer = vbDefault: Exit Sub
rs1.MoveLast: rs2.MoveLast
rs1.MoveFirst: rs2.MoveFirst

Label6.Caption = rs2.RecordCount
ll.AddItem "处方号" & String(2, vbTab) & "主目数据" & vbTab & "细目数据"
l1.AddItem "主目处方号" & String(10, " ") & "主目数据" & String(10, " ") & "细目处方号" & String(10, " ") & "细目数据" & String(8, " ")
Do While Not rs1.EOF
    If rs3.State = adStateOpen Then rs3.Close
    rs3.CursorLocation = adUseClient
    sql1 = "select * from aaaaaa_xm where 处方号='" & rs1![处方号] & "'"
    rs3.Open sql1, Conn, adOpenForwardOnly, adLockReadOnly, adCmdText
    If rs3.EOF And rs3.BOF Then
        l1.AddItem rs1![处方号] & "    " & rs1![金额]
        l2.AddItem " "
    Else
        If CCur(rs1![金额]) <> CCur(rs3![金额]) Then
            l1.AddItem rs1![处方号] & String(20 - Len(rs1![处方号]), " ") & rs1![金额] & String(18 - Len(rs1![金额]), "  ") & rs3![处方号] & String(20 - Len(rs3![处方号]), " ") & rs3![金额] & String(16 - Len(rs3![金额]), " ")
            'l2.AddItem rs3![处方号] & "   " & rs3![金额]
            CE = (CCur(rs1![金额]) - CCur(rs3![金额]))
            If Abs(CE) >= 1 Then
                ll.AddItem rs1![处方号] & vbTab & rs1![金额] & vbTab & rs3![金额]
            End If
            NumX = NumX + CE
        End If
    End If
    Label4.Caption = NumX
    I = I + 1
    Label3.Caption = I
    DoEvents
    rs1.MoveNext
Loop
On Error Resume Next
Conn.Execute "drop table aaaaaa"
Conn.Execute "drop table aaaaaa_zm"
Conn.Execute "drop table aaaaaa_xm"
On Error GoTo 0
If rs1.State = adStateOpen Then rs1.Close
If rs2.State = adStateOpen Then rs2.Close
If rs3.State = adStateOpen Then rs3.Close
Set rs2 = Nothing
Set rs1 = Nothing
Set rs3 = Nothing
Screen.MousePointer = vbDefault
End Sub