frmzybssz.frm

本系统可用于医院和专业体检中心的健康体检管理

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Object = "{0B81E4A9-BE4E-4AEF-9272-33AB5B51C6FC}#1.0#0"; "XPControls.ocx"
Begin VB.Form FrmZYBSSZ 
   BackColor       =   &H00D3DABC&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "职业病史数据字典设置"
   ClientHeight    =   5340
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   8685
   Icon            =   "FrmZYBSSZ.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5340
   ScaleWidth      =   8685
   StartUpPosition =   2  '屏幕中心
   Begin VB.Frame Frame2 
      BackColor       =   &H00D3DABC&
      Caption         =   "字典内容："
      Height          =   735
      Left            =   3030
      TabIndex        =   13
      Top             =   180
      Width           =   5535
      Begin VB.TextBox TxtZDNR 
         Height          =   345
         Left            =   60
         TabIndex        =   14
         Top             =   270
         Width           =   5415
      End
   End
   Begin VB.Frame Frame3 
      BackColor       =   &H00D3DABC&
      Caption         =   "该项目现有数据模板"
      Height          =   3585
      Left            =   3000
      TabIndex        =   7
      Top             =   1620
      Width           =   5595
      Begin MSComctlLib.ListView LvwSJZD 
         Height          =   3255
         Left            =   60
         TabIndex        =   8
         Top             =   240
         Width           =   5445
         _ExtentX        =   9604
         _ExtentY        =   5741
         View            =   3
         LabelEdit       =   1
         LabelWrap       =   0   'False
         HideSelection   =   0   'False
         AllowReorder    =   -1  'True
         FullRowSelect   =   -1  'True
         GridLines       =   -1  'True
         _Version        =   393217
         ForeColor       =   -2147483640
         BackColor       =   12648384
         BorderStyle     =   1
         Appearance      =   1
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         NumItems        =   1
         BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
            Key             =   "Templates"
            Text            =   "现有数据数典"
            Object.Width           =   9703
         EndProperty
      End
   End
   Begin VB.Frame Frame1 
      BackColor       =   &H00D3DABC&
      Caption         =   "职业史和职业病史"
      Height          =   5025
      Left            =   120
      TabIndex        =   0
      Top             =   180
      Width           =   2805
      Begin VB.OptionButton OptDHMC 
         BackColor       =   &H00D3DABC&
         Caption         =   "毒害名称"
         Height          =   315
         Left            =   270
         TabIndex        =   6
         Top             =   2700
         Width           =   2355
      End
      Begin VB.OptionButton OptZYBName 
         BackColor       =   &H00D3DABC&
         Caption         =   "职业病名称"
         Height          =   315
         Left            =   270
         TabIndex        =   5
         Top             =   2220
         Width           =   2355
      End
      Begin VB.OptionButton OptFHCS 
         BackColor       =   &H00D3DABC&
         Caption         =   "防护措施"
         Height          =   315
         Left            =   270
         TabIndex        =   4
         Top             =   1740
         Width           =   2355
      End
      Begin VB.OptionButton OptYHYS 
         BackColor       =   &H00D3DABC&
         Caption         =   "有害因素"
         Height          =   315
         Left            =   270
         TabIndex        =   3
         Top             =   1260
         Width           =   2355
      End
      Begin VB.OptionButton OptGongZhong 
         BackColor       =   &H00D3DABC&
         Caption         =   "工种"
         Height          =   315
         Left            =   270
         TabIndex        =   2
         Top             =   810
         Width           =   2355
      End
      Begin VB.OptionButton OptCheJian 
         BackColor       =   &H00D3DABC&
         Caption         =   "车间"
         Height          =   315
         Left            =   270
         TabIndex        =   1
         Top             =   330
         Width           =   2355
      End
   End
   Begin XPControls.XPCommandButton cmdCancel 
      Cancel          =   -1  'True
      Height          =   375
      Left            =   7110
      TabIndex        =   9
      Top             =   1080
      Width           =   1065
      _ExtentX        =   1879
      _ExtentY        =   661
      Caption         =   "退出"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin XPControls.XPCommandButton cmdAdd 
      Height          =   375
      Left            =   3420
      TabIndex        =   10
      Top             =   1080
      Width           =   1005
      _ExtentX        =   1773
      _ExtentY        =   661
      Caption         =   "添加"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin XPControls.XPCommandButton cmdDelete 
      Height          =   375
      Left            =   5850
      TabIndex        =   11
      Top             =   1080
      Width           =   1065
      _ExtentX        =   1879
      _ExtentY        =   661
      Caption         =   "删除"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin XPControls.XPCommandButton cmdModify 
      Height          =   375
      Left            =   4620
      TabIndex        =   12
      Top             =   1080
      Width           =   1035
      _ExtentX        =   1826
      _ExtentY        =   661
      Caption         =   "修改"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
End
Attribute VB_Name = "FrmZYBSSZ"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mstrType As String            '记录当前选中的类型
Dim m_strMenu As String

Public Sub ShowForm(ByVal strMenu As String)
    m_strMenu = strMenu
    Me.Show vbModal
End Sub

Private Sub cmdAdd_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strValue As String
    Dim cmd As ADODB.Command
    Dim i As Integer
    Dim strMaxID As String
    
    Me.MousePointer = vbHourglass
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, INSERT_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    If cmdAdd.Caption = "保存" Then
        strValue = Trim(TxtZDNR.Text)
        '检查用户是否输入了模板
        If strValue = "" Then
            MsgBox "请输入数据！", vbInformation, "提示"
            GoTo ExitLab
        End If
        
        '检查该模板是否已经存在
        For i = 1 To LvwSJZD.ListItems.Count
            If LvwSJZD.ListItems(i).Text = strValue Then
                MsgBox "您输入的数据字典已经存在，请核对后重新输入！", vbInformation, "提示"
                GoTo ExitLab
            End If
        Next
        
        '校验完毕，写入内容
        strMaxID = GetMaxID("DM_ZYSZYBS", "DMID", "00001")
        strSQL = "insert into DM_ZYSZYBS(DMID,Type,Content) values('" & strMaxID & "','" _
                    & mstrType & "','" _
                    & strValue & "')"
        '写入数据库
        Set cmd = New ADODB.Command
        Set cmd.ActiveConnection = GCon
        cmd.CommandText = strSQL
        cmd.Execute
        
    '    '添加到LvwSJZD中
        LvwSJZD.ListItems.Add , "W" & strMaxID, strValue
        TxtZDNR.Text = ""
        TxtZDNR.Locked = True
        cmdAdd.Caption = "添加"
        
        GoTo ExitLab
    ElseIf cmdAdd.Caption = "添加" Then
        TxtZDNR.Locked = False
        cmdAdd.Caption = "保存"
        GoTo ExitLab
    End If
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdDelete_Click()
    Dim cmd As ADODB.Command
    Dim strSQL As String
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, DELETE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    If LvwSJZD.ListItems.Count < 1 Then Exit Sub
    If LvwSJZD.SelectedItem Is Nothing Then
        MsgBox "请选择您要删除的数据字典！", vbInformation, "提示"
        Exit Sub
    End If
    If MsgBox("您确实要删除数据字典“" & LvwSJZD.SelectedItem.Text & "”吗？", _
            vbQuestion + vbYesNo + vbDefaultButton2, "小心") = vbNo Then Exit Sub

    strSQL = "delete from DM_ZYSZYBS" _
            & " where DMID='"

    strSQL = strSQL & Mid(LvwSJZD.SelectedItem.Key, 2) & "'"
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    cmd.CommandText = strSQL
    cmd.Execute
    
    LvwSJZD.ListItems.Remove LvwSJZD.SelectedItem.Index
    LvwSJZD_Click
    
    cmdModify.Caption = "修改"
    
ExitLab:

End Sub

Private Sub cmdModify_Click()
    Dim cmd As ADODB.Command
    Dim strSQL As String
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, UPDATE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    If cmdModify.Caption = "修改" Then
        TxtZDNR.Locked = False
        cmdModify.Caption = "保存"
    Else
        If TxtZDNR.Text <> LvwSJZD.SelectedItem.Text Then
            strSQL = "Update DM_ZYSZYBS set" _
                    & " Type='" & mstrType & "'," _
                    & " Content='" & TxtZDNR.Text & "'" _
                    & " where DMID='"
            strSQL = strSQL & Mid(LvwSJZD.SelectedItem.Key, 2) & "'"
            Set cmd = New ADODB.Command
            Set cmd.ActiveConnection = GCon
            cmd.CommandText = strSQL
            cmd.Execute
            
            LvwSJZD.SelectedItem.Text = TxtZDNR.Text
            TxtZDNR.Text = ""
        End If
        cmdModify.Caption = "修改"
        TxtZDNR.Locked = True
    End If
ExitLab:
End Sub

Private Sub Form_Load()
    cmdModify.Enabled = False
    cmdDelete.Enabled = False
    TxtZDNR.Locked = True
    
End Sub

Private Sub LvwSJZD_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strXMID As String
    
    Me.MousePointer = vbHourglass
    
    If LvwSJZD.SelectedItem Is Nothing Then
        TxtZDNR.Text = ""
        GoTo ExitLab
    End If
    
    TxtZDNR.Text = LvwSJZD.SelectedItem
    TxtZDNR.Locked = True
    
    cmdModify.Enabled = True
    cmdDelete.Enabled = True
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub OptCheJian_Click()
    ShowZD ("CheJian")
    mstrType = "CheJian"
End Sub

Private Sub OptDHMC_Click()
    ShowZD ("DHMC")
    mstrType = "DHMC"
End Sub

Private Sub OptFHCS_Click()
    ShowZD ("FHCS")
    mstrType = "FHCS"
End Sub

Private Sub OptGongZhong_Click()
    ShowZD ("GongZhong")
    mstrType = "GongZhong"
End Sub

Private Sub OptYHYS_Click()
    ShowZD ("YHYS")
    mstrType = "YHYS"
End Sub

Private Sub OptZYBName_Click()
    ShowZD ("ZYBName")
    mstrType = "ZYBName"
End Sub

Private Sub ShowZD(ByVal inType As String)
    Dim rstemp As ADODB.Recordset
    Dim strSQL As String
    Dim itemX As ListItem
    
    LvwSJZD.ListItems.Clear
    
    Set rstemp = New ADODB.Recordset
    strSQL = "select * from DM_ZYSZYBS where Type='" & inType & "'"
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        Do While Not rstemp.EOF
            Set itemX = LvwSJZD.ListItems.Add(, "W" & rstemp("DMID"), rstemp("Content"))
            rstemp.MoveNext
        Loop
    End If
    Set rstemp = Nothing
End Sub