frmcustom.frm

来自「本系统可用于医院和专业体检中心的健康体检管理」· FRM 代码 · 共 1,655 行 · 第 1/4 页

    Dim rsReport As ADODB.Recordset
    Dim strFormat As String
    Dim arrFormat
    Dim i As Integer
    Dim ctl As Control
    
    Me.MousePointer = vbHourglass
    menuOperation = Modify
    
    '清除掉控件上原有显示内容
    picChild.Refresh
    
    '标签
    For i = 1 To txtCaption.UBound
        txtCaption(i).Visible = False
    Next
    '动态文本
    For i = 1 To txtAuto.UBound
        txtAuto(i).Visible = False
    Next
    '线条
    For i = 1 To linLine.UBound
        linLine(i).Visible = False
    Next
    '图片
    For i = 1 To picPhoto.UBound
        picPhoto(i).Visible = False
    Next
    
    If (cmbReport.ListCount < 1) Or (cmbReport.ListIndex < 0) Then
        cmdDelete.Enabled = False
        cmdModify.Enabled = False
        cmdSave.Enabled = False
        picChild.Visible = False
        chkShowGrid.Enabled = False
        
        fsbHorizontal.Enabled = False
        fsbVertical.Enabled = False
        fraContainer.Enabled = False
        GoTo ExitLab
    Else
        cmdDelete.Enabled = True
        cmdModify.Enabled = True
        cmdSave.Enabled = True
        picChild.Visible = True
        chkShowGrid.Enabled = True
        
        fsbHorizontal.Enabled = True
        fsbVertical.Enabled = True
        fraContainer.Enabled = True
    End If
    
    picChild.ScaleMode = vbMillimeters
    
'*******************20040415封闭  闻*********************************
'    picChild.Width = 210
'    picChild.Height = 297
'*******************20040415封闭完  闻*******************************

'*******************20040415添加  闻*********************************
    '根据报表纸型设置picChild的长度和宽度
    strSQL = "select * from Report_MC where BBID='" _
            & LongToString(cmbReport.ItemData(cmbReport.ListIndex), 5) & "'"
    Set rsReport = New ADODB.Recordset
    rsReport.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    Select Case rsReport("BBZX")
        Case "A4"
            picChild.Width = 210
            picChild.Height = 297
        Case "B5"
            picChild.Width = 182
            picChild.Height = 257
        Case "A3"
            picChild.Width = 297
            picChild.Height = 420
        Case "16K"
            picChild.Width = 184
            picChild.Height = 260
    End Select
'*******************20040415添加完  闻*********************************
    
    SetScrollBar
    
'    '根据报表名称获取其拼音缩写
'    strSQL = "select ReportPYSX from SET_REPORT" _
'            & " where ReportName='" & cmbReport.Text & "'"
'    Set rsReport = New ADODB.Recordset
'    rsReport.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'    If rsReport.RecordCount > 0 Then
'        strPYSX = rsReport(0)
'        rsReport.Close
'    Else
'        GoTo ExitLab
'    End If
    
    mintLine = 0
    mintText = 0
    mintAuto = 0
    mintPhoto = 0

    '获取报表结构
    strSQL = "select * from REPORT_DT" _
            & " where BBID='" & LongToString(cmbReport.ItemData(cmbReport.ListIndex), 5) & "'" _
            & " order by ReportIndex"
    Set rsReport = New ADODB.Recordset
    rsReport.Open strSQL, GCon, adOpenStatic, adLockOptimistic
On Error Resume Next '关闭错误陷阱
    If rsReport.RecordCount > 0 Then
        rsReport.MoveFirst
        Do
            '绘制报表
            If rsReport("ReportType") = WLine Then
                '画线
'                picChild.Line (rsReport("ReportLeft"), rsReport("ReportTop"))-(rsReport("ReportWidth"), rsReport("ReportHeight"))
                
                Load linLine(rsReport("ReportIndex"))
                Set linLine(rsReport("ReportIndex")).Container = picChild
                
                With linLine(rsReport("ReportIndex"))
                    .X1 = rsReport("ReportLeft")
                    .Y1 = rsReport("ReportTop")
                    .X2 = rsReport("ReportWidth")
                    .Y2 = rsReport("ReportHeight")
                    .Visible = True
                End With
                
                If rsReport("ReportIndex") > mintLine Then
                    mintLine = rsReport("ReportIndex")
                End If
            ElseIf rsReport("ReportType") = WText Then
                '静态文本
                strFormat = rsReport("ReportFormat")
                arrFormat = Split(strFormat, ",")
                
                With txtCaption(rsReport("ReportIndex"))
                    Load txtCaption(rsReport("ReportIndex"))
                    Set txtCaption(rsReport("ReportIndex")).Container = picChild
                    
                    .Move rsReport("ReportLeft"), rsReport("ReportTop"), rsReport("ReportWidth"), rsReport("ReportHeight")
                    
                    .FontName = arrFormat(0)
                    .FontSize = arrFormat(1)
                    .FontBold = arrFormat(2)
                    .FontItalic = arrFormat(3)
                    .FontUnderline = arrFormat(4)
                    .Alignment = arrFormat(5)
                    
                    .Text = rsReport("ReportText")
                    
                    '设置拉伸风格
                    SetResize .hWnd, Me.hWnd
                    
                    .Visible = True
                End With
                
                If rsReport("ReportIndex") > mintText Then
                    mintText = rsReport("ReportIndex")
                End If
            ElseIf rsReport("ReportType") = WAuto Then
                '动态文本
                strFormat = rsReport("ReportFormat")
                arrFormat = Split(strFormat, ",")
                
                With txtAuto(rsReport("ReportIndex"))
                    Load txtAuto(rsReport("ReportIndex"))
                    Set txtAuto(rsReport("ReportIndex")).Container = picChild
                    
                    .Move rsReport("ReportLeft"), rsReport("ReportTop"), rsReport("ReportWidth"), rsReport("ReportHeight")
                    
                    .FontName = arrFormat(0)
                    .FontSize = arrFormat(1)
                    .FontBold = arrFormat(2)
                    .FontItalic = arrFormat(3)
                    .FontUnderline = arrFormat(4)
                    .Alignment = arrFormat(5)
                    
                    .Text = rsReport("ReportText")
                    .Tag = rsReport("ReportRelation")
                    
                    '设置拉伸风格
                    SetResize .hWnd, Me.hWnd
                    
                    .Visible = True
                End With
                
                If rsReport("ReportIndex") > mintAuto Then
                    mintAuto = rsReport("ReportIndex")
                End If
            ElseIf rsReport("ReportType") = WPhoto Then
                '图片
                Load picPhoto(rsReport("ReportIndex"))
                    
                With picPhoto(rsReport("ReportIndex"))
                    Set .Container = picChild
                    
                    .Move rsReport("ReportLeft"), rsReport("ReportTop"), rsReport("ReportWidth"), rsReport("ReportHeight")
                    
                    If rsReport("ReportIndex") > mintPhoto Then
                        mintPhoto = rsReport("ReportIndex")
                    End If
                    
                    '检查是否有图片
                    If Not (IsNull(rsReport("ReportPhoto"))) Then
                        If Dir(mstrTempFile) <> "" Then Kill mstrTempFile
                        ReadDB rsReport("ReportPhoto"), mstrTempFile
                        Set .PICTURE = LoadPicture(mstrTempFile)
                    End If
                    
                    '设置拉伸风格
                    SetResize .hWnd, Me.hWnd
                    picPhoto_Resize rsReport("ReportIndex")
                    
                    .Visible = True
                End With
            End If
            
            rsReport.MoveNext
        Loop Until rsReport.EOF
        rsReport.Close
        
        
        picChild.ScaleMode = vbPixels
        
        For Each ctl In Me
            If TypeOf ctl Is Line Then
                Set aLine = ctl
                Call SetRegion
            End If
        Next
    End If
    
    cmdSave.Enabled = False
    
    mstrName = cmbReport.Text
    mstrBBID = LongToString(cmbReport.ItemData(cmbReport.ListIndex), 5)
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
    picChild.ScaleMode = vbPixels
End Sub

Private Sub cmdAdd_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim i As Integer
    Dim strRet As String
    
    '***********************************************************
    '版本控制
    '***********************************************************
    Select Case genuVersion
        Case WLB
            '
        Case ZYB
        
        Case BZB
            If cmbReport.ListCount >= 4 Then
                MsgBox "您使用的是标准版，只能设置4张体检报表！", vbInformation, "提示"
                Exit Sub
            End If
        Case PJB
            If cmbReport.ListCount >= 2 Then
                MsgBox "您使用的是普及版，只能设置2张体检报表！", vbInformation, "提示"
                Exit Sub
            End If
    End Select
    '***********************************************************
    '***********************************************************
    
    
    strRet = dlgReport.ShowReport(Add)
    Set dlgReport = Nothing
    '
    If strRet = "" Then Exit Sub
    
    '获取刚添加的报表的信息
    strSQL = "select * from REPORT_MC" _
            & " where BBID='" & strRet & "'"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    
    cmbReport.AddItem rsTemp("BBMC")
    cmbReport.ItemData(cmbReport.NewIndex) = strRet
    cmbReport.ListIndex = cmbReport.NewIndex
    rsTemp.Close
    
    picChild.Visible = True
    chkShowGrid.Enabled = True
    menuOperation = Add
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmdDelete_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim cmd As ADODB.Command
    Dim rsTemp As ADODB.Recordset
    Dim strBBID As String
    Dim intIndex As Integer
    
    If cmbReport.ListCount < 1 Then Exit Sub
    
    If MsgBox("该操作不可恢复！" & vbCrLf & "确实要删除报表“" & cmbReport.Text & "”吗？" _
            , vbQuestion + vbYesNo + vbDefaultButton2, "小心") = vbNo Then Exit Sub
    
    strBBID = LongToString(cmbReport.ItemData(cmbReport.ListIndex), 5)
    '删除报表结构
    strSQL = "delete from REPORT_DT" _
            & " where BBID='" & strBBID & "'"
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    cmd.CommandText = strSQL
    cmd.Execute
    
    '删除报表名称
    strSQL = "delete from REPORT_MC" _
            & " where BBID='" & strBBID & "'"
    cmd.CommandText = strSQL
    cmd.Execute
    
    '最后删除在组合表里的记录
    strSQL = "delete from REPORT_ZHDT" _
            & " where BBID='" & strBBID & "'"
    cmd.CommandText = strSQL
    cmd.Execute
    
    intIndex = cmbReport.ListIndex
    cmbReport.RemoveItem intIndex
    If cmbReport.ListCount = 0 Then
        cmbReport_Click
    ElseIf intIndex = 0 Then
        cmbReport.ListIndex = 0
    Else
        cmbReport.ListIndex = intIndex - 1
    End If
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdModify_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim i As Integer
    Dim strRet As String
    
    strRet = dlgReport.ShowReport(Modify, LongToString(cmbReport.ItemData(cmbReport.ListIndex), 5))
    Set dlgReport = Nothing
    '
    If strRet = "" Then Exit Sub
    
    '获取刚添加的报表的信息
    strSQL = "select * from REPORT_MC" _
            & " where BBID='" & strRet & "'"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    
    cmbReport.List(cmbReport.ListIndex) = rsTemp("BBMC")
    cmbReport.ItemData(cmbReport.ListIndex) = strRet
    
    cmbReport_Click
    
    picChild.Visible = True
    chkShowGrid.Enabled = True
    menuOperation = Modify
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim objControl As Object
    Dim strTable As String
    Dim strFormat As String
    Dim strBBID As String
    Dim strSQL As String
    Dim cmd As ADODB.Command
    Dim rsTemp As ADODB.Recordset
    Dim blnPhoto As Boolean '标识是否当前处理的是否图片
    
    Me.MousePointer = vbHourglass
    
    '****************************************************************
    '                       保存时以毫米为单位
    '****************************************************************
    picChild.ScaleMode = vbMillimeters
    
    strTable = "REPORT_DT"
    '报表编号
    strBBID = LongToString(cmbReport.ItemData(cmbReport.ListIndex), 5)
    
    '首先清除原来的记录