frmtablebook.frm

金算盘软件代码

                            'frmPrintMsg.lblCurrPage.Caption = mlngCurPage
                            SetData
                            ABook.PrintDirect
                            'Unload frmPrintMsg
                            Next i
                        Next mlngCurPage
                    Else                    '不按顺序 1 打印，起始页必须为奇数 (1,3,5)
                        For mlngCurPage = lngStartPage + IIf(lngStartPage Mod 2 = 0, 1, 0) To lngEndPage Step 2 '1,3,5
'                            SetData
                            For i = 1 To frm.GCopiesPrint
                            'Load frmPrintMsg
                            'frmPrintMsg.Show
                            'frmPrintMsg.lblCurrPage.Caption = mlngCurPage
                            SetData
                            ABook.PrintDirect
                            'Unload frmPrintMsg
                            Next i
                        Next mlngCurPage
                    End If
                        
                    If frm.GIsPrintbyPrderTwo Then          '按顺序 2 打印，起始页必须为偶数 (6,4,2)
                        For mlngCurPage = lngEndPage + IIf(lngEndPage Mod 2 = 0, 0, -1) To lngStartPage Step -2 '6,4,2
'                            SetData
                            For i = 1 To frm.GCopiesPrint
                            'Load frmPrintMsg
                            'frmPrintMsg.Show
                            'frmPrintMsg.lblCurrPage.Caption = mlngCurPage
                            SetData
                            ABook.PrintDirect
                            'Unload frmPrintMsg
                            Next i
                        Next mlngCurPage
                    Else                                '按顺序 2 打印，起始页必须为偶数 (2,4,6)
                        For mlngCurPage = lngStartPage + IIf(lngStartPage Mod 2 = 0, 0, 1) To lngEndPage Step 2 '2,4,6
'                            SetData
                            For i = 1 To frm.GCopiesPrint
                            'Load frmPrintMsg
                            'frmPrintMsg.Show
                            'frmPrintMsg.lblCurrPage.Caption = mlngCurPage
                            SetData
                            ABook.PrintDirect
                            'Unload frmPrintMsg
                            Next i
                        Next mlngCurPage
                    End If
                    
                End If '单面打印
            End If '逐份打印
        
            ABook.EndPrint
            mlngCurPage = oldPage
            SetData
        Else                '输出到文件
            Dim clsFileSever As New FileSeverClass
            If frm.GintFileType = 4 Then
                If Not clsFileSever.Saveas(frm.GStrFileName, 4, , , msgAccount, , mclsTable.ReportName, frm.GintFileIndex) Then
                    Utility.ShowMsg Me.hwnd, "文件保存不成功!", vbOKOnly + vbInformation, App.title
                End If
            Else
                If Not clsFileSever.Saveas(frm.GStrFileName, frm.GintFileType, , , msgAccount, , mclsTable.ReportName) Then
                    Utility.ShowMsg Me.hwnd, "文件保存不成功!", vbOKOnly + vbInformation, App.title
                End If
            End If
            Set clsFileSever = Nothing
        End If
    End If
    Set frm = Nothing
End Sub
Private Sub cmdSave_Click()
Dim frm As New frmReportSameName
Dim blnIsSameName As Boolean, blnIsOK As Boolean, blnErr As Boolean
Dim strName As String, strErr As String
    
    '是否有同名报表
    strName = mclsTable.ReportName
    blnErr = Report.NameIsErr(strName, strErr)
    If blnErr Then
        blnIsOK = frm.ShowInputBox("报表不能有非法字符:'" & strErr & "',请输入新的报表名!", strName, , True)
        If Not blnIsOK Then Exit Sub
    End If
    blnIsSameName = Report.ReportExist(strName, mclsTable.ParentId, mclsTable.ReportID)
    Do While blnIsSameName
       blnIsOK = frm.ShowInputBox("已有同名报表'" & strName & "'了,请输入新的报表名!", strName, , True)
       If blnIsOK Then
            blnIsSameName = Report.ReportExist(strName, mclsTable.ParentId, mclsTable.ReportID)
       Else
            Exit Sub
       End If
    Loop
    '保存
    mclsTable.ReportName = strName
    gclsBase.BaseDB.BeginTrans
    blnIsOK = mclsTable.SaveTable                                    '保存报表属性
    If blnIsOK Then
        Caption = mclsTable.ReportName          '窗体标题
        SetGridTitle mclsTable.ReportName                            '报表标题
        mclsFormCond.KeyID = mclsTable.ReportID
        mclsFormCond.UpdateCond                                      '保存报表条件
        gclsBase.BaseDB.CommitTrans
        ABook.Refresh
        gclsSys.SendMessage Me.hwnd, msgReport
        mblnChanged = False
    Else
        gclsBase.BaseDB.RollbackTrans
        Utility.ShowMsg Me.hwnd, "数据库冲突,请重新保存报表", vbOKOnly + vbInformation, App.title
    End If
    Set frm = Nothing
End Sub

Private Sub cmdSaveAs_Click()
Dim frm As New frmReportSameName
Dim blnIsSameName As Boolean, blnIsOK As Boolean
Dim strName As String
    
    strName = mclsTable.ReportName
    blnIsOK = frm.ShowInputBox("请输入新报表名!", strName, , True)
    If Not blnIsOK Then Set frm = Nothing: Exit Sub
    '是否有同名报表
    blnIsSameName = Report.ReportExist(strName, mclsTable.ParentId, mclsTable.ReportID, False)
    Do While blnIsSameName
       blnIsOK = frm.ShowInputBox("已有同名报表'" & strName & "'了,请输入新的报表名!", strName, , True)
       If blnIsOK Then
            blnIsSameName = Report.ReportExist(strName, mclsTable.ParentId, mclsTable.ReportID, False)
       Else
            Set frm = Nothing
            Exit Sub
       End If
    Loop
    '保存
    mclsTable.ReportName = strName
    gclsBase.BaseDB.BeginTrans
    blnIsOK = mclsTable.SaveTable(True)                              '保存报表属性
    If blnIsOK Then
        Caption = mclsTable.ReportName           '窗体标题
        mclsTable.TitleWidth = 0
        SetGridTitle mclsTable.ReportName                            '报表标题
        mclsFormCond.KeyID = mclsTable.ReportID
        mclsFormCond.UpdateCond                                      '保存报表条件
        gclsBase.BaseDB.CommitTrans
        '设置报表打印ID
        clsFset.UpdatePrintSetupID mclsTable.ReportID, clsFset.GetPrintSetupID(8)
        ABook.Refresh
        gclsSys.SendMessage Me.hwnd, msgReport
        mblnChanged = False
    Else
        gclsBase.BaseDB.RollbackTrans
        Utility.ShowMsg Me.hwnd, "数据库冲突,请重新保存报表", vbOKOnly + vbInformation, App.title
    End If
    Set frm = Nothing
End Sub

Private Sub Form_Activate()
    gclsSys.CurrFormName = Me.hwnd
    If (Me.Left + Me.Width < 0 Or Me.Left > Screen.Width) And mblnLoaded Then
        Me.Left = 300
    End If
'    Utility.LoadFormSetting Me
End Sub

Private Sub mclsMainControl_ListActivityMenu(ByVal intIndex As Integer)
    Select Case intIndex
        Case 0, 1, 2
            ABook.FCAlignment(mintFCIndex) = intIndex
        Case 4, 5, 6
            ABook.FCAlignment(mintFCIndex) = intIndex - 1
        Case 8, 9, 10
            ABook.FCAlignment(mintFCIndex) = intIndex - 2
    End Select
      '返回给类
    With mclsTable
        If mintFCIndex = 0 Then
        '处理报表标题
            .TitleAlign = ABook.FCAlignment(mintFCIndex)
        ElseIf mintFCIndex < .HeadColumns + 1 Then
        '表头栏目
            .HeadAlign(mintFCIndex - 1) = ABook.FCAlignment(mintFCIndex)
        Else
        '表尾栏目
            .TailAlign(mintFCIndex - 1 - .HeadColumns) = ABook.FCAlignment(mintFCIndex)
        End If
    End With
    mblnChanged = True
'    ABook_FreeCellChanged mintFCIndex
End Sub

Private Sub mclsMainControl_ListReportMenu(ByVal intIndex As Integer)
    Select Case intIndex
    Case 0
        cmdAccSet_Click
    Case 1
        cmdFormatSet_Click
    Case 2
    Case 3
        cmdSave_Click
    Case 4
        cmdSaveAs_Click
    Case 5
    Case 6
        CmdPrint_Click
    End Select
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'                      *             辅助支持                  *
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'刷新纪录
Private Sub RefreshData()
Dim blnPage As Boolean
    SetRecBook blnPage                             '得到记录集
    If mblnFatalErr Then
        If mblnLoaded Then mblnFatalErr = False
        Exit Sub
    End If
    If blnPage Then blnPage = DispartPage          '分页
    If blnPage Then SetData                        '填充数据
End Sub
'生成新记录集
Private Sub SetRecBook(blnSucceed As Boolean)
  Dim strSql As String, strWhere As String, strTemp As String
  Dim rstBook As rdoResultset
  
   blnSucceed = False
    '生成SQL子句
    strSql = mclsTable.GetSQLPre
    strWhere = mclsFormCond.GetCond(mstrDateCond, "日期")
    GetDateStr
    
    '单据模板特殊处理
    If mclsTable.ViewId = 37 Then
        #If conVersionType = 4 Then
            strTemp = " FormatDesignQuery.lngReceiptTypeID Not IN (6,7,9,18,19,21,17,26,29,32,45,47)"
        #ElseIf conVersionType = 8 Then
            strTemp = " FormatDesignQuery.lngReceiptTypeID Not IN (6,7,17,29,38,47,48,49,50,51,32) "
        #ElseIf conVersionType = 16 Then
            strTemp = " FormatDesignQuery.lngReceiptTypeID  IN (34,35,36,37,38,39,40,41,48,49,50,51) "
        #Else
        #End If
    End If
    If strWhere <> "" Then
        If mstrDateWhere <> "" Then strWhere = strWhere & " And " & mstrDateWhere
    Else
        If mstrDateWhere <> "" Then strWhere = mstrDateWhere
    End If
    If mclsTable.ReportCond <> "" Then
        If strWhere = "" Then
            strWhere = mclsTable.ReportCond
        Else
            strWhere = strWhere & " And " & mclsTable.ReportCond
        End If
    End If
    If strTemp <> "" Then
        If strWhere = "" Then
            strWhere = strTemp
        Else
            strWhere = strWhere & " And " & strTemp
        End If
    End If
    
    If strWhere <> "" Then strSql = strSql & " WHERE " & strWhere
    '得到记录集
    Select Case mclsTable.ViewId
    Case 672        '报警列表
        strSql = strReplace(strSql, "ZCRQ", gclsBase.BaseDate)
    Case 133        '小数位数
        strSql = strReplace(strSql, "PRICEDEC", gclsBase.PriceDec)
    Case Else
    End Select
    On Error GoTo ErrHandle
    Set rstBook = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    On Error GoTo 0
    Set Data1.Resultset = rstBook
    msgAccount.col = 0
    msgAccount.Sort = 5
    rstBook.Close
    ReSetColWidth                                  '设置列宽
    blnSucceed = True
    Exit Sub
ErrHandle:
    mblnFatalErr = True
    If mblnLoaded Then
        Utility.ShowMsg Me.hwnd, "未知错误,程序将关闭窗体!", vbExclamation + vbOKOnly, App.title
    Else
        Utility.ShowMsg Me.hwnd, "未知错误,不能打开窗体!", vbExclamation + vbOKOnly, App.title
    End If
    Unload Me
End Sub
'分页
Private Function DispartPage() As Boolean
Dim intCol As Integer, intRow As Integer
Dim intRecCount As Integer
Dim lngWidth As Long, lngFixedWidth As Long
Dim intColStart() As Integer, intColEnd() As Integer, lngColExpands As Long     '临时保存模块变量
    
    If mclsTable.GridTop = 0 Then
        SetGridTop 90
    Else
        SetGridTop mclsTable.GridTop / Screen.TwipsPerPixelY
    End If
    '页横向扩展
    mlngPageWidth = ABook.ColCount              '得到最大页宽度
    lngColExpands = 0
    ReDim intColStart(lngColExpands)
    ReDim intColEnd(lngColExpands)
    intColStart(0) = 0
    '取固定列宽度
    lngFixedWidth = 0
    For intCol = 0 To msgAccount.FixedCols - 1
        lngFixedWidth = lngFixedWidth + msgAccount.ColWidth(intCol)
        If lngFixedWidth > mlngPageWidth Then
            Utility.ShowMsg Me.hwnd, "固定列太宽!请减小列宽!", vbOKOnly + vbInformation, App.title
            DispartPage = False
            Exit Function
        End If
    Next intCol
    '算列宽
    lngWidth = lngFixedWidth
    For intCol = msgAccount.FixedCols To msgAccount.Cols - 1
        lngWidth = lngWidth + msgAccount.ColWidth(intCol) / Screen.TwipsPerPixelX
        If lngWidth > mlngPageWidth Then
            lngColExpands = lngColExpands + 1
            ReDim Preserve intColStart(lngColExpands)
            ReDim Preserve intColEnd(lngColExpands)
            lngWidth = lngFixedWidth + msgAccount.ColWidth(intCol) / Screen.TwipsPerPixelX
            intColEnd(lngColExpands - 1) = intCol - 1
            intColStart(lngColExpands) = intCol
        End If
    Next intCol
    intColEnd(lngColExpands) = intCol - 1
    mlngColExpands = lngColExpands + 1
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '页纵向扩展
    mintPageRows = GetGridheight                                '得到最大页行数
    intRecCount = msgAccount.Rows - msgAccount.FixedRows
    If mintPageRows <= msgAccount.FixedRows Then
         Utility.ShowMsg Me.hwnd, "数据行数太小,请增加行数!", vbOKOnly + vbInformation, App.title
         DispartPage = False
         cmdFormatSet_Click
         Exit Function