frmbase_main.frm

医院管理方面的例子

            PicSplitter.Left = Me.Width - SglSplitLimit
        Else
            PicSplitter.Left = SglPos
        End If
    End If
End Sub

Private Sub ImgSplitter_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    ProcSizeControls PicSplitter.Left
    PicSplitter.Visible = False
    MbMoving = False
End Sub

Private Sub insystem_Click()
    Unload Me
    Call Main
End Sub

Private Sub test_Click()
    'FrmJhmy_Et_Card.Show
    'FrmSys_BaseData_Province.Show
    'FrmJhmy_Kcgl_Yprk.Show
    'FrmJhmy_Mlwh_Sjjg.Show 1
    'FrmYpgl_Mlwh_Ypml.Show 1
    'FrmJhmy_Et_Jz.Show 1
End Sub

Private Sub ToolbarMain_ButtonClick(ByVal Button As MSComctlLib.Button)
    
    TreeMain.SetFocus
    Select Case Trim(Button.Key)
        Case "fist"
            If TreeMain.Nodes.Count = 0 Then Screen.MousePointer = 0: Exit Sub
            TreeMain.SelectedItem = TreeMain.SelectedItem.FirstSibling
            TreeMain.SelectedItem.FirstSibling.Expanded = True
        Case "forward"
            If TreeMain.Nodes.Count = 0 Then Screen.MousePointer = 0: Exit Sub
            If TreeMain.SelectedItem.Parent Is Nothing Then
                'If Not (TreeMain.SelectedItem Is Nothing) Then TreeMain.SelectedItem = TreeMain.SelectedItem.Previous
            Else
                TreeMain.SelectedItem = TreeMain.SelectedItem.Parent
                TreeMain.SelectedItem.Expanded = False
            End If
        Case "next"
            If TreeMain.Nodes.Count = 0 Then Screen.MousePointer = 0: Exit Sub
            If TreeMain.SelectedItem.Child Is Nothing Then
                'If Not (TreeMain.SelectedItem Is Nothing) Then TreeMain.SelectedItem = TreeMain.SelectedItem.Next
            Else
                TreeMain.SelectedItem = TreeMain.SelectedItem.Child
                TreeMain.SelectedItem.Expanded = True
            End If
        Case "last"
            If TreeMain.Nodes.Count = 0 Then Screen.MousePointer = 0: Exit Sub
            TreeMain.SelectedItem = TreeMain.SelectedItem.LastSibling
            TreeMain.SelectedItem.LastSibling.Expanded = True
        Case "refresh"
            Call ProcTreeAddItem
        Case "exit"
            If MsgBox("确定退出系统吗?", vbQuestion + vbYesNo + vbDefaultButton2, "") = vbYes Then
                Unload Me
                End
            End If
    End Select
    Screen.MousePointer = 0
End Sub

Private Sub TreeMain_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then Call TreeMain_NodeClick(TreeMain.SelectedItem)
End Sub
Private Sub TreeMain_NodeClick(ByVal Node As MSComctlLib.Node)
    Call ProcTreeSelItem(Mid(Trim(Node.Key), 2, Len(Trim(Node.Key))))
End Sub

Private Sub Form_Load()
    Call ProcTreeAddItem
    StatusBarMain.SimpleText = "  " & "操作员编号:" & PStrUserID & "  " & "操作员姓名:" & PStrUserName & "  " & "进入系统时间:" & Format(Now, "yyyy年mm月dd日hh时mm分")
    TreeMain.Width = 2000
End Sub

Private Sub Form_Resize()
    ProcSizeControls ImgSplitter.Left
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim CnnDB As cls_base_cnndb.ClassCnnDB
    Set CnnDB = New cls_base_cnndb.ClassCnnDB
    CnnDB.FunDbClose PcnnHisDb
End Sub

Private Sub ProcTreeAddItem()

    Dim Node_a      As Node
    Dim Node_b      As Node
    Dim Node_c      As Node
    Dim Node_d      As Node

    TreeMain.Nodes.Clear
    TreeMain.Style = 7
    TreeMain.LineStyle = tvwRootLines
    
    Dim AdoRs_a As ADODb.Recordset
    Set AdoRs_a = New ADODb.Recordset
    AdoRs_a.Open "SELECT zxtbm,zxtmc,zxttp FROM aqgl_xtzxt WHERE zxtjb='a' AND zxtbm_gs='0000000000' AND zxtbm IN (SELECT zxtbm FROM aqgl_yhqx WHERE UserID='" + PStrUserID + "') ORDER BY zxtbm ", PcnnHisDb, adOpenDynamic
   
    Do While Not AdoRs_a.EOF
    
        Set Node_a = TreeMain.Nodes.Add(, , "a" & Trim(AdoRs_a.Fields(0)), AdoRs_a.Fields(1), IIf(IsNull(Trim(AdoRs_a.Fields(2))), "default", Trim(AdoRs_a.Fields(2))))
        Node_a.Tag = Trim(AdoRs_a.Fields(0))
        
        '----------------------------------------b-------------------------------
        Dim AdoRs_b As ADODb.Recordset
        Set AdoRs_b = New ADODb.Recordset
        AdoRs_b.Open "SELECT zxtbm,zxtmc,zxttp FROM aqgl_xtzxt WHERE zxtjb='b' AND zxtbm_gs='" + Trim(AdoRs_a.Fields(0)) + "' AND zxtbm IN (SELECT zxtbm FROM aqgl_yhqx WHERE UserID='" + PStrUserID + "') ORDER BY zxtbm ", PcnnHisDb, adOpenDynamic
        Do While Not AdoRs_b.EOF
        
            Set Node_b = TreeMain.Nodes.Add("a" & Trim(AdoRs_a.Fields(0)), 4, "b" + Trim(AdoRs_b.Fields(0)), Trim(AdoRs_b.Fields(1)), IIf(IsNull(Trim(AdoRs_b.Fields(2))), "default", Trim(AdoRs_b.Fields(2))))
            Node_b.Tag = Trim(AdoRs_b.Fields(0))
            
            '------------------------------------c-------------------------------
            Dim AdoRs_c As ADODb.Recordset
            Set AdoRs_c = New ADODb.Recordset
            AdoRs_c.Open "SELECT zxtbm,zxtmc,zxttp FROM aqgl_xtzxt WHERE zxtjb='c' AND zxtbm_gs='" + Trim(AdoRs_b.Fields(0)) + "' AND zxtbm IN (SELECT zxtbm FROM aqgl_yhqx WHERE UserID='" + PStrUserID + "') ORDER BY zxtbm ", PcnnHisDb, adOpenDynamic
            
            Do While Not AdoRs_c.EOF
            
                Set Node_c = TreeMain.Nodes.Add("b" & Trim(AdoRs_b.Fields(0)), 4, "c" + Trim(AdoRs_c.Fields(0)), Trim(AdoRs_c.Fields(1)), IIf(IsNull(Trim(AdoRs_c.Fields(2))), "default", Trim(AdoRs_c.Fields(2))))
                Node_c.Tag = Trim(AdoRs_c.Fields(0))
                
                '--------------------------------d-------------------------------
                Dim AdoRs_d As ADODb.Recordset
                Set AdoRs_d = New ADODb.Recordset
                AdoRs_d.Open "SELECT zxtbm,zxtmc,zxttp FROM aqgl_xtzxt WHERE zxtjb='d' AND zxtbm_gs='" + Trim(AdoRs_c.Fields(0)) + "' AND zxtbm IN (SELECT zxtbm FROM aqgl_yhqx WHERE UserID='" + PStrUserID + "') ORDER BY zxtbm ", PcnnHisDb, adOpenDynamic
                Do While Not AdoRs_d.EOF
                    Set Node_d = TreeMain.Nodes.Add("c" & Trim(AdoRs_c.Fields(0)), 4, "d" + Trim(AdoRs_d.Fields(0)), Trim(AdoRs_d.Fields(1)), IIf(IsNull(Trim(AdoRs_d.Fields(2))), "default", Trim(AdoRs_d.Fields(2))))
                    Node_d.Tag = Trim(AdoRs_d.Fields(0))
                    AdoRs_d.MoveNext
                Loop
                AdoRs_d.Close: Set AdoRs_d = Nothing
                AdoRs_c.MoveNext
            Loop
            AdoRs_c.Close: Set AdoRs_c = Nothing
            AdoRs_b.MoveNext
        Loop
        AdoRs_b.Close: Set AdoRs_b = Nothing
        AdoRs_a.MoveNext
    Loop
    AdoRs_a.Close: Set AdoRs_a = Nothing
'    Unload FrmBase_Wait
'    FrmBase_Main.Show
End Sub

Private Sub ProcSizeControls(SingTmp As Single)
    If Me.Width < 2000 Or Me.Height < 2000 Then Exit Sub
    If SingTmp < 1500 Then SingTmp = 1500
    If SingTmp > (Me.Width - 1500) Then SingTmp = Me.Width - 2000
    TreeMain.Top = PicMain.Top
    TreeMain.Left = 0
    TreeMain.Height = Me.Height - 950 - PicMain.Top
    TreeMain.Width = 2500 'SingTmp
    ImgSplitter.Left = SingTmp
    PicMain.Width = Me.Width - (TreeMain.Width + 180)
    ImgSplitter.Top = TreeMain.Top
    ImgSplitter.Height = TreeMain.Height
    PicMain.Refresh
End Sub

Private Sub ProcTreeSelItem(StrNodeKey As String)

    If TreeMain.SelectedItem Is Nothing Then Exit Sub
    

    Select Case StrNodeKey
'        Case "0101"       '个人健康档案
'            Dim ClsJkda As cls_jkda.ClassJkda
'            Set ClsJkda = New cls_jkda.ClassJkda
'            ClsJkda.FunGetShowFrmJkda_Gyxx PcnnHisDb
'            Set ClsJkda = Nothing
'
'        Case "0103"         '家庭健康档案
'            Dim ClsJkdaHome As cls_jkda.ClassJkda
'            Set ClsJkdaHome = New cls_jkda.ClassJkda
'            ClsJkdaHome.FunGetShowFrmJkda_Home PcnnHisDb
'            Set ClsJkdaHome = Nothing
        
        '========================================================
        '=====================儿童保健===========================
        '========================================================
'        Case "0201"          '儿童保健
'            Dim ClsBaseList    As cls_etbj.ClassEtbj
'            Set ClsBaseList = New cls_etbj.ClassEtbj
'            ClsBaseList.PropUserID = PStrUserID
'            ClsBaseList.PropUserName = PStrUserName
'            ClsBaseList.FunShowFrmEb_Zz_Prt_00 PcnnHisDb
'            Set ClsBaseList = Nothing
'
'        Case "0203"          '新生儿访视
'            Dim ClsEtbjTj    As cls_etbj.ClassEtbj
'            Set ClsEtbjTj = New cls_etbj.ClassEtbj
'            ClsEtbjTj.PropUserID = PStrUserID
'            ClsEtbjTj.PropUserName = PStrUserName
'            ClsEtbjTj.FunShowFrmEb_Tj PcnnHisDb
'            Set ClsEtbjTj = Nothing
'
'        '------------报表统计-----------
'        Case "020401"
'            Dim ClsPrt_1    As cls_etbj.ClassEtbj
'            Set ClsPrt_1 = New cls_etbj.ClassEtbj
'            ClsPrt_1.PropUserID = PStrUserID
'            ClsPrt_1.PropUserName = PStrUserName
'            ClsPrt_1.FunShowFrmEb_Zz_Prt_01 PcnnHisDb
'            Set ClsPrt_1 = Nothing
'
'        Case "020402"
'            Dim ClsPrt_2    As cls_etbj.ClassEtbj
'            Set ClsPrt_2 = New cls_etbj.ClassEtbj
'            ClsPrt_2.PropUserID = PStrUserID
'            ClsPrt_2.PropUserName = PStrUserName
'            ClsPrt_2.FunShowFrmEb_Zz_Prt_02 PcnnHisDb
'            Set ClsPrt_2 = Nothing
'
'        Case "020403"
'            Dim ClsPrt_3    As cls_etbj.ClassEtbj
'            Set ClsPrt_3 = New cls_etbj.ClassEtbj
'            ClsPrt_3.PropUserID = PStrUserID
'            ClsPrt_3.PropUserName = PStrUserName
'            ClsPrt_3.FunShowFrmEb_Zz_Prt_03 PcnnHisDb
'            Set ClsPrt_3 = Nothing
'
'        Case "020404"
'            Dim ClsPrt_4    As cls_etbj.ClassEtbj
'            Set ClsPrt_4 = New cls_etbj.ClassEtbj
'            ClsPrt_4.PropUserID = PStrUserID
'            ClsPrt_4.PropUserName = PStrUserName
'            ClsPrt_4.FunShowFrmEb_Zz_Prt_04 PcnnHisDb
'            Set ClsPrt_4 = Nothing
'
'        Case "020405"
'            Dim ClsPrt_5    As cls_etbj.ClassEtbj
'            Set ClsPrt_5 = New cls_etbj.ClassEtbj
'            ClsPrt_5.PropUserID = PStrUserID
'            ClsPrt_5.PropUserName = PStrUserName
'            ClsPrt_5.FunShowFrmEb_Zz_Prt_05 PcnnHisDb
'            Set ClsPrt_5 = Nothing
'
'        Case "020406"
'            Dim ClsPrt_6    As cls_etbj.ClassEtbj
'            Set ClsPrt_6 = New cls_etbj.ClassEtbj
'            ClsPrt_6.PropUserID = PStrUserID
'            ClsPrt_6.PropUserName = PStrUserName
'            ClsPrt_6.FunShowFrmEb_Zz_Prt_06 PcnnHisDb
'            Set ClsPrt_6 = Nothing
'
'        '========================================================
'        '=====================计划免疫===========================
'        '========================================================
'        '------------日常业务-----------
'        Case "030101"        '卡片登记
'            Dim ClsJhmyKpdj    As cls_jhmy.ClassJhmy
'            Set ClsJhmyKpdj = New cls_jhmy.ClassJhmy
'            ClsJhmyKpdj.PropUserID = PStrUserID
'            ClsJhmyKpdj.PropUserName = PStrUserName
'            ClsJhmyKpdj.FunShowFrmJhmy_Et_Card PcnnHisDb
'            Set ClsJhmyKpdj = Nothing
'
'        Case "030102"        '儿童接种
'            Dim ClsJhmyEtjz    As cls_jhmy.ClassJhmy
'            Set ClsJhmyEtjz = New cls_jhmy.ClassJhmy
'            ClsJhmyEtjz.PropUserID = PStrUserID
'            ClsJhmyEtjz.PropUserName = PStrUserName
'            ClsJhmyEtjz.FunShowFrmJhmy_Et_jz PcnnHisDb
'            Set ClsJhmyEtjz = Nothing
'
'        Case "030103"        '预约接种
'            Dim ClsJhmyYyjz    As cls_jhmy.ClassJhmy
'            Set ClsJhmyYyjz = New cls_jhmy.ClassJhmy
'            ClsJhmyYyjz.PropUserID = PStrUserID
'            ClsJhmyYyjz.PropUserName = PStrUserName
'            ClsJhmyYyjz.FunShowFrmJhmy_Et_Yy PcnnHisDb
'            Set ClsJhmyYyjz = Nothing
'
'        Case "030104"        '预约结果
'            Dim ClsJhmyYyjzJg    As cls_jhmy.ClassJhmy
'            Set ClsJhmyYyjzJg = New cls_jhmy.ClassJhmy
'            ClsJhmyYyjzJg.PropUserID = PStrUserID
'            ClsJhmyYyjzJg.PropUserName = PStrUserName
'            ClsJhmyYyjzJg.FunShowFrmJhmy_Et_Yyjg PcnnHisDb
'            Set ClsJhmyYyjzJg = Nothing
'
'        '------------库存管理-----------
'        Case "030201"        '疫苗入库
'            Dim ClsJhmyKcrk    As cls_jhmy.ClassJhmy
'            Set ClsJhmyKcrk = New cls_jhmy.ClassJhmy
'            ClsJhmyKcrk.PropUserID = PStrUserID