⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 report.bas

📁 金算盘软件代码
💻 BAS
📖 第 1 页 / 共 3 页
字号:
🔍
123 
   Dim clsCrossReport As New CrossSet
   clsCrossReport.ShowWizard lngReportID, ParentId, ParentLevel
End Sub
'显示列表向导
Public Sub ShowListWizard(ByVal lngReportID As Long, ByVal ViewId As Long, Optional ParentId As Long = 0, Optional ParentLevel As Integer = 0)
  
End Sub


'显示财务分析表向导
Public Sub ShowFinanceWizard(ByVal lngReportID As Long, ByVal ViewId As Long, Optional ParentId As Long = 0, Optional ParentLevel As Integer = 0, Optional bytGroup As Byte)
   Dim clsFinanceReport As New FinanceReportWizard
   If ReportRight(lngReportID, ViewId) Then
      clsFinanceReport.ShowReportSet lngReportID, ViewId, ParentId, ParentLevel, bytGroup
   End If
End Sub

'显示帐龄分析表向导
Public Sub ShowAgeWizard(ByVal lngReportID As Long, ByVal ViewId As Long, Optional ParentId As Long = 0, Optional ParentLevel As Integer = 0)
   Dim clsAgeReport As New Age
   clsAgeReport.ShowWizard lngReportID, ViewId, ParentId, ParentLevel
End Sub

'显示帐龄分析表向导
Public Function SetAgeWizard(ByVal clsAge As Age) As Boolean
    Dim AgeWizard As New frmAgeWizard
    SetAgeWizard = AgeWizard.SetAge(clsAge)
    
End Function

'同一目录下报表是否同名同类型
Public Function FindSameName(ByVal strName As String, ByVal intLevel As Integer, Optional ByVal lngReportID As Long, Optional ByVal intgroupNo As Integer) As Boolean
    Dim strSql As String
    Dim rstName As rdoResultset
    strSql = "SELECT * FROM Report WHERE Report.strReportName='" & strName & "' And Report.intLevel= " _
              & intLevel & " And  Report.bytGroup= " & intgroupNo & " And  Report.lngReportId <> " & lngReportID
    Set rstName = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If rstName.RowCount = 0 Then
        FindSameName = False
    Else
        FindSameName = True
    End If
    rstName.Close
End Function

'同一目录下是否存在同名报表
Public Function ReportExist(ByVal strName As String, ByVal ParentId As Long, MeID As Long, Optional ExceptSelf As Boolean = True) As Boolean
    Dim strSql As String
    Dim rstName As rdoResultset
    If ExceptSelf Then
        strSql = "SELECT * FROM Report WHERE strReportName='" & strName & "' And lngParentID=" & ParentId & _
                 " And lngReportId<>" & MeID
    Else
        strSql = "SELECT * FROM Report WHERE strReportName='" & strName & "' And lngParentID=" & ParentId
    End If
    If gclsBase.ControlAccount Then
        strSql = strSql & " And bytControl IN (0,1)"
    Else
        strSql = strSql & " And bytControl IN (0,2)"
    End If
    Set rstName = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If rstName.EOF Then
        ReportExist = False
    Else
        ReportExist = True
    End If
    rstName.Close
End Function

'取日期字段名称
Public Function GetDateField(ViewId As Long, Optional IsString As Boolean = False, Optional IsOrder As Boolean = False) As String
    Select Case ViewId
    Case 5
        If IsString Then
           GetDateField = "Voucher.strDate"
        Else
           If IsOrder Then
               GetDateField = "Voucher.strDate,Voucher.lngVoucherTypeID,Voucher.intVoucherNO"
           Else
               GetDateField = "Voucher.strDate"
           End If
        End If
    
    Case 384
        If IsString Then
           GetDateField = "Voucher.strDate"
        Else
           GetDateField = "Voucher.strDate"
        End If
    
    Case 2, 359
        If IsString Then
           GetDateField = "RQ"
        Else
           GetDateField = "RQ"
        End If
    Case 1107
        If IsString Then
           GetDateField = "ARQuery2.strDate"
        Else
           GetDateField = "ARQuery2.strDate"
        End If
    Case 1108
        If IsString Then
           GetDateField = "APQuery2.strDate"
        Else
           GetDateField = "APQuery2.strDate"
        End If
    Case 1109
        If IsString Then
           GetDateField = "BankMoney2.strDate"
        Else
           GetDateField = "BankMoney2.strDate"
        End If
    Case 4, 360
        If IsString Then
           GetDateField = "Activity.strDate"
        Else
           GetDateField = "Activity.strDate"
        End If
    
    Case 100, 174, 175, 176, 178, 590, 783, 1009, 1011, 1023, 1024, 1237
        If IsString Then
           GetDateField = "ItemActivity.strDate"
        Else
           GetDateField = "ItemActivity.strDate"
        End If
    
    Case 1016
        If IsString Then
           GetDateField = "ItemActivity.strDate"
        Else
           GetDateField = "ItemActivity.strDate"
        End If
    Case 681
        If IsString Then
           GetDateField = "RPriceDiff.strDate"
        Else
           GetDateField = "RPriceDiff.strDate"
        End If
    
    Case 598
        If IsString Then
           GetDateField = "WRFix.strDate"
        Else
           GetDateField = "WRFix.strDate"
        End If
    
    Case 632
        If IsString Then
           GetDateField = "AccountDaily.strDate"
        Else
           GetDateField = "AccountDaily.strDate"
        End If
    End Select

End Function

'取版本条件
Public Function GetVersionCond() As String
   GetVersionCond = " And Mod(ViewField.bytVersion," & gVersionType * 2 & ")>=" & gVersionType
End Function

'装载自由单元格式设计弹出菜单
Public Sub FreeCellFatSet()
    Dim intCount As Integer

    With frmMain
        For intCount = .mnuListActivityMenu.Count - 1 To 1 Step -1
            Unload .mnuListActivityMenu(intCount)
        Next
        For intCount = 1 To 10
           Load .mnuListActivityMenu(intCount)
        Next intCount
         
        .mnuListActivityMenu(0).Caption = "左对齐"
        .mnuListActivityMenu(0).Enabled = True
        .mnuListActivityMenu(0).Visible = True
        
        .mnuListActivityMenu(1).Caption = "居中对齐"
        .mnuListActivityMenu(1).Enabled = True
        .mnuListActivityMenu(1).Visible = True
        
        .mnuListActivityMenu(2).Caption = "右对齐"
        .mnuListActivityMenu(2).Enabled = True
        .mnuListActivityMenu(2).Visible = True
        
        .mnuListActivityMenu(3).Checked = False
        .mnuListActivityMenu(3).Enabled = True
        .mnuListActivityMenu(3).Caption = "-"
        .mnuListActivityMenu(3).Visible = True
        
        
        .mnuListActivityMenu(4).Caption = "顶端对齐"
        .mnuListActivityMenu(4).Enabled = True
        .mnuListActivityMenu(4).Visible = True
        
        .mnuListActivityMenu(5).Caption = "中间对齐"
        .mnuListActivityMenu(5).Enabled = True
        .mnuListActivityMenu(5).Visible = True
        
        .mnuListActivityMenu(6).Caption = "底端对齐"
        .mnuListActivityMenu(6).Enabled = True
        .mnuListActivityMenu(6).Visible = True
        
        .mnuListActivityMenu(7).Checked = False
        .mnuListActivityMenu(7).Enabled = True
        .mnuListActivityMenu(7).Caption = "-"
        .mnuListActivityMenu(7).Enabled = True
        .mnuListActivityMenu(7).Visible = True

        .mnuListActivityMenu(8).Caption = "宽度相同"
        .mnuListActivityMenu(8).Enabled = True
        .mnuListActivityMenu(8).Visible = True
        
        .mnuListActivityMenu(9).Caption = "高度相同"
        .mnuListActivityMenu(9).Enabled = True
        .mnuListActivityMenu(9).Visible = True
        
        .mnuListActivityMenu(10).Caption = "宽高都相同"
        .mnuListActivityMenu(10).Enabled = True
        .mnuListActivityMenu(10).Visible = True
        
   End With
End Sub

'在复制财务分析报表时，需要将其条件(保存于ReportCond,ReportAnalysisData中)也复制一份。
'参数：lngSourceReportID:源报表ID;lngTargetReportID,目标报表ID
Public Function CopyFinanceReport(ByVal lngSourceReportID As Long, ByVal lngTargetReportID As Long) As Boolean
    Dim strSql As String
    Dim rsSource As rdoResultset
    Dim rsTarget As rdoResultset
    Dim intCount As Integer
    On Error GoTo ErrHandler
    '复制ReportAnalysisData中的条件
    strSql = "SELECT * From ReportAnalysisData Where ReportAnalysisData.lngReportID = " & lngSourceReportID
    Set rsSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If rsSource.EOF = False Then
        rsSource.MoveLast
        rsSource.MoveFirst
        Set rsTarget = gclsBase.BaseDB.OpenResultset("Select * from ReportAnalysisData", rdOpenDynamic, 4)
        For intCount = 0 To rsSource.RowCount - 1
            With rsTarget
                .AddNew
                    !lngReportID = lngTargetReportID
                    !bytAccountType = rsSource!bytAccountType
                    !bytDataType = rsSource!bytDataType
                    !bytDataSource = rsSource!bytDataSource
                    !strBudgetName = rsSource!strBudgetName
                    !intBudgetYear = rsSource!intBudgetYear
                    !IncludeUnPosted = rsSource!IncludeUnPosted
                    !blnIsTax = rsSource!blnIsTax
                    !strBudgetObject = rsSource!strBudgetObject
                    !lngBudgetID = rsSource!lngBudgetID
                .Update
            End With
            rsSource.MoveNext
        Next
        rsSource.Close
        rsTarget.Close
    End If
    CopyFinanceReport = True
    Exit Function
ErrHandler:
    CopyFinanceReport = False
End Function
'在复制帐龄分析报表时，需要将其帐龄条件(保存于AgePeriod中)也复制一份。
'参数：lngSourceReportID:源报表ID;lngTargetReportID,目标报表ID
Public Function CopyAgeReport(ByVal lngSourceReportID As Long, ByVal lngTargetReportID As Long) As Boolean
    Dim strSql As String
    Dim rsSource As rdoResultset
    Dim rsTarget As rdoResultset
    Dim intCount As Integer
    On Error GoTo ErrHandler
    '复制AgePeriod中的条件
    strSql = "SELECT * From AgePeriod Where lngReportID = " & lngSourceReportID
    Set rsSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If rsSource.EOF = False Then
        rsSource.MoveLast
        rsSource.MoveFirst
        Set rsTarget = gclsBase.BaseDB.OpenResultset("Select * from AgePeriod", rdOpenDynamic, 4)
        For intCount = 0 To rsSource.RowCount - 1
            With rsTarget
                .AddNew
                    !lngReportID = lngTargetReportID
                    !strAgePeriodName = rsSource!strAgePeriodName
                    !intDay = rsSource!intDay
                .Update
            End With
            rsSource.MoveNext
        Next
        rsSource.Close
        rsTarget.Close
    End If
    CopyAgeReport = True
    Exit Function
ErrHandler:
    CopyAgeReport = False
End Function
'在复制报表时，需要将其条件(保存于ReportCond,ReportMultiIDCond中)也复制一份。
'参数：lngSourceReportID:源报表ID;lngTargetReportID,目标报表ID
Public Function CopyReportCond(ByVal lngSourceReportID As Long, ByVal lngTargetReportID As Long) As Boolean
    Dim strSql As String
    Dim rsSource As rdoResultset
    Dim rsTarget As rdoResultset
    Dim intCount As Integer
    On Error GoTo ErrHandler
    '复制ReportCond中的条件
    strSql = "Delete  ReportCond Where ReportCond.lngReportID = " & lngTargetReportID
    gclsBase.BaseDB.Execute strSql
    strSql = "SELECT * From ReportCond Where ReportCond.lngReportID = " & lngSourceReportID
    Set rsSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If rsSource.EOF = False Then
        rsSource.MoveLast
        rsSource.MoveFirst
        Set rsTarget = gclsBase.BaseDB.OpenResultset("Select * From ReportCond", rdOpenDynamic, 4)
        For intCount = 0 To rsSource.RowCount - 1
            With rsTarget
                .AddNew
                    !lngReportID = lngTargetReportID
                    !lngViewFieldID = rsSource!lngViewFieldID
                    !strPath = rsSource!strPath
                    !blnHavefathernode = rsSource!blnHavefathernode
                    !strStringOP = rsSource!strStringOP
                    !strString1 = rsSource!strString1
                    !strString2 = rsSource!strString2
123

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -