frmmbwh.frm

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

    '验证完毕
    
    '判断是否有选择
    If Me.lvwTemplate.SelectedItem Is Nothing Then
        MsgBox "请在左侧的列表中选择您要删除的报表模板！", vbInformation, "提示"
        Me.lvwTemplate.SetFocus
        GoTo ExitLab
    End If
    
    '确认删除
    If MsgBox("该操作不可恢复！" & vbCrLf & "您确实要删除模板“" _
            & Me.lvwTemplate.SelectedItem.Text & "”吗？", _
            vbExclamation + vbYesNo + vbDefaultButton2, _
            "警告") = vbNo Then GoTo ExitLab
    
    '记录ID号
    intMBID = CInt(Mid(Me.lvwTemplate.SelectedItem.Key, 2))
    
    '更新数据库
    strSQL = "delete from SET_BBMB" _
            & " where MBID=" & intMBID
    GCon.Execute strSQL
    
    '在左侧的列表中删除
    intIndex = lvwTemplate.SelectedItem.Index
    lvwTemplate.ListItems.Remove intIndex
    If lvwTemplate.ListItems.Count >= 1 Then
        If intIndex = 1 Then
            Set lvwTemplate.SelectedItem = lvwTemplate.ListItems(intIndex)
        Else
            Set lvwTemplate.SelectedItem = lvwTemplate.ListItems(intIndex - 1)
        End If
    End If
    
    lvwTemplate_Click
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdExportToWord_Click()
On Error Resume Next '防止用户在选择文件时单击取消，因为那样会报错
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim intMBID As Integer
    Dim strFileName As String
    
    Me.MousePointer = vbHourglass
    
    '记录模板ID
    intMBID = CInt(Val(Mid(Me.lvwTemplate.SelectedItem.Key, 2)))
    
    '获取当前选中的模板信息
    strSQL = "select MBContent from SET_BBMB" _
            & " where MBID=" & intMBID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        strFileName = GetFileName(Me.CommonDialog1, "Word文档(*.doc)|*.doc", _
                "请选择模板 " & lvwTemplate.SelectedItem.Text & " 的保存路径", _
                lvwTemplate.SelectedItem.Text, WRITEFILE)
        If strFileName = "" Then GoTo ExitLab '一旦取消则全部取消
        
        If ColumnToFile(rstemp("MBContent"), strFileName, rstemp) = True Then
            MsgBox "导出成功！", vbInformation, "提示"
        End If
        rstemp.Close
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdModify_Click()
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, UPDATE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    menuOperation = Modify
    EnableInput True
    cmdAdd.Enabled = False
    cmdDelete.Enabled = False
    cmdModify.Enabled = False
    cmdSave.Enabled = True
    cmdExportToWord.Enabled = False
ExitLab:

End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim intMBID As Integer
    Dim blnNeedCheck As Boolean
    Dim itmTemp As ListItem
    Dim enuMBLX As MBLX
    
    Me.MousePointer = vbHourglass
    
    txtMBMC.Text = Trim(txtMBMC.Text)
    '是否输入了模板名称
    If txtMBMC.Text = "" Then
        MsgBox "模板名称不能为空！请输入模板名称！", vbInformation, "提示"
        txtMBMC.SetFocus
        GoTo ExitLab
    End If
    
    '检查是否需要验证模板名称的重复性
    blnNeedCheck = False
    If menuOperation = Add Then
        blnNeedCheck = True
    ElseIf menuOperation = Modify Then
        If Me.lvwTemplate.SelectedItem.Text <> txtMBMC.Text Then
            blnNeedCheck = True
        End If
    End If
    
    '校验重复性
    If blnNeedCheck Then
        strSQL = "select Count(*) from SET_BBMB" _
                & " where MBMC='" & txtMBMC.Text & "'"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rstemp(0) >= 1 Then
            MsgBox "您输入的模板名称已经存在，请核对后重新输入！", vbInformation, "提示"
            txtMBMC.SetFocus
            GoTo ExitLab
        End If
        rstemp.Close
    End If
    
    txtFileName.Text = Trim(txtFileName.Text)
    
    If menuOperation = Modify Then
        intMBID = CInt(Mid(Me.lvwTemplate.SelectedItem.Key, 2))
        
        '修改时，如果用户设置了模板，则检查模板文件是否存在
        If txtFileName.Text <> "" Then
            If Dir(txtFileName.Text) = "" Then
                MsgBox "您选择的模板文件不存在，请核对后重新设置！", vbInformation, "提示"
                GoTo ExitLab
            End If
        End If
    Else
        '如果是添加，首先检查是否选择了模板文件
        If txtFileName.Text = "" Then
            MsgBox "请单击“选择”按钮设置模板文件！", vbInformation, "提示"
            GoTo ExitLab
        End If
        
        '模板文件是否存在
        If Dir(txtFileName.Text) = "" Then
            MsgBox "您选择的模板文件不存在，请核对后重新设置！", vbInformation, "提示"
            GoTo ExitLab
        End If
        
        '获取当前最大的ID号
        strSQL = "select Max(MBID) from SET_BBMB"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rstemp.RecordCount < 1 Then
            intMBID = 1
        ElseIf IsNull(rstemp(0)) Then
            intMBID = 1
        Else
            intMBID = rstemp(0) + 1
            rstemp.Close
        End If
        
        '首先插入一条空记录
        strSQL = "insert into SET_BBMB(MBID) values(" & intMBID & ")"
        GCon.Execute strSQL
    End If
    
    '记录模板类型
    If optGRen.Value Then
        enuMBLX = GEREN
    Else
        enuMBLX = TUANTI
    End If
    
    '更新其它字段
    strSQL = "update SET_BBMB set" _
            & " MBMC='" & txtMBMC.Text & "'" _
            & ",MBSM='" & txtMBSM.Text & "'" _
            & ",SFMR=" & IIf(optSFMR(0).Value, 1, 0) _
            & ",MBLX=" & enuMBLX _
            & " where MBID=" & intMBID
    GCon.Execute strSQL
    
    '如果当前模板设为了默认，则清除其它模板的默认设置
    If optSFMR(0).Value Then
        strSQL = "update SET_BBMB set" _
                & " SFMR=0" _
                & " where MBID<>" & intMBID _
                & " and MBLX=" & enuMBLX
        GCon.Execute strSQL
    End If
    
    '如果有模板文件，则写入数据库
    If txtFileName.Text <> "" Then
        strSQL = "select * from SET_BBMB" _
                & " where MBID=" & intMBID
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenDynamic, adLockPessimistic
        FileToColumn rstemp("MBContent"), txtFileName.Text
        rstemp.Update
        rstemp.Close
    End If
    Set rstemp = Nothing
    
    '添加到左侧的列表
    If menuOperation = Modify Then
        Me.lvwTemplate.SelectedItem.Text = txtMBMC.Text
    Else
        Set itmTemp = Me.lvwTemplate.ListItems.Add(, "W" & intMBID, txtMBMC.Text)
        Set Me.lvwTemplate.SelectedItem = itmTemp
    End If
    
    lvwTemplate_Click
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    Screen.MousePointer = vbArrowHourglass
    
    '获取已经添加的模板
    strSQL = "select MBID,MBMC from SET_BBMB order by mbmc"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        Do
            lvwTemplate.ListItems.Add , "W" & rstemp("MBID"), rstemp("MBMC")
            
            rstemp.MoveNext
        Loop Until rstemp.EOF
        rstemp.Close
        Set rstemp = Nothing
        
        '选中第一个
        Set lvwTemplate.SelectedItem = lvwTemplate.ListItems(1)
        lvwTemplate_Click
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub lvwTemplate_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim intMBID As Integer
    
    Me.MousePointer = vbHourglass
    
    EnableInput False
    txtFileName.Tag = "0"
    
    '判断是否有选择
    cmdSave.Enabled = False
    cmdExportToWord.Enabled = False
    cmdAdd.Enabled = True
    If Me.lvwTemplate.SelectedItem Is Nothing Then
        cmdDelete.Enabled = False
        cmdModify.Enabled = False
        ClearInput
        
        GoTo ExitLab
    Else
        cmdDelete.Enabled = True
        cmdModify.Enabled = True
    End If
    
    '记录模板ID
    intMBID = CInt(Val(Mid(Me.lvwTemplate.SelectedItem.Key, 2)))
    
    '获取当前选中的模板信息
    strSQL = "select MBMC,MBSM,SFMR,MBLX from SET_BBMB" _
            & " where MBID=" & intMBID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        txtMBMC.Text = rstemp("MBMC")
        txtMBSM.Text = rstemp("MBSM")
        '是否默认
        If rstemp("SFMR") = True Then
            optSFMR(0).Value = True
        Else
            optSFMR(1).Value = True
        End If
        '模板类型
        If IsNull(rstemp("MBLX")) Then
            optGRen.Value = True
        ElseIf rstemp("MBLX") = GEREN Then
            optGRen.Value = True
        Else
            optTTi.Value = True
        End If
        txtFileName.Text = ""
        cmdExportToWord.Enabled = True '允许导出模板文件
        
        rstemp.Close
        Set rstemp = Nothing
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'启用/禁用输入框
Private Sub EnableInput(ByVal blnFlag As Boolean)
    txtMBMC.Enabled = blnFlag
    txtMBSM.Enabled = blnFlag
    cmdBrowser.Enabled = blnFlag
    optSFMR(0).Enabled = blnFlag
    optSFMR(1).Enabled = blnFlag
    optGRen.Enabled = blnFlag
    optTTi.Enabled = blnFlag
End Sub

'清空输入
Private Sub ClearInput()
    txtMBMC.Text = ""
    txtMBSM.Text = ""
    txtFileName.Text = ""
End Sub

Private Sub lvwTemplate_KeyUp(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyUp, vbKeyDown
            lvwTemplate_Click
        Case Else
            '
    End Select
End Sub

Private Sub txtFileName_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Shift = vbRightButton Then
        Clipboard.Clear
    End If
End Sub

'版本控制
Private Function VersionControl() As Boolean
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    strSQL = "select Count(*) from SET_BBMB"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    
    If genuVersion = PJB Then
        If rstemp(0) >= 2 Then
            MsgBox "您目前使用的是 " & gstrVersionTitle & " ，该版本仅支持两套Word报表！" _
                & vbCrLf & "如果要使用无限制的版本，请升级到标准版、专业版或网络版！" _
                , vbExclamation, "提示"
            GoTo ExitLab
        End If
    Else
        '
    End If
    VersionControl = True
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    '
End Function