banreport.cls

金算盘软件代码

          !intGridTop = mvarGridTop
          !strDate = Format(gclsBase.BaseDate, "yyyy-mm-dd")
          Set clsFormat = New ClsFormatset
          !lngPrintSetupID = GetPrintSetupID(9, mvarReportID)
          mlngPrintSetID = !lngPrintSetupID
          !lngReportID = lngReportID
          !bytVersion = gVersionType
          !lngPaperID = mlngPaperID
       .Update
    End With
    
    '打开表触发器
    strSql = "Alter Table Report Enable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
    
    CopyReportField (lngReportID)
    mvarReportID = lngReportID
    EditUpdate
End Sub

'Copy All ListField
Private Sub CopyReportField(lngReportID As Long)
  Dim strSql As String
  Dim rstSource As rdoResultset, rstDesc As rdoResultset
  Dim fldReportField As rdoColumn
     
     strSql = "Select * from ReportField Where lngReportId=" & mvarReportID
     Set rstSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
     
     strSql = "Select * from ReportField Where lngReportId=" & lngReportID
     Set rstDesc = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
     
     With rstSource
         Do While Not .EOF
            rstDesc.AddNew
            For Each fldReportField In .rdoColumns
                If UCase(fldReportField.Name) = UCase("lngReportId") Then
                    rstDesc!lngReportID = lngReportID
                Else
                     If UCase(fldReportField.Name) <> UCase("lngReportFieldId") Then
                         rstDesc.rdoColumns(fldReportField.Name).Value = fldReportField.Value
                     Else
                         rstDesc.rdoColumns(fldReportField.Name).Value = BillPublic.GetNewID("ReportField")
                     End If
                End If
            Next
            rstDesc.Update
            .MoveNext
         Loop
     End With
End Sub

'保存报表修改结果
Public Function SaveReport(Optional ByVal IsSaveAs As Boolean = False) As Boolean
    MsgForm.PleaseWait "正在保存数据，请稍候．．．"
    If mbytPrep = 0 Or IsSaveAs Then
        AddReport
        mbytPrep = 2
    Else
        EditUpdate
    End If
    SaveReport = True
    Unload MsgForm
End Function

'更新用户自定义报表的修改
Private Sub EditUpdate()
  Dim strSql As String
  Dim intCount As Integer
  
  'Update Report
  strSql = "UPDATE Report Set intGridTop=" & mvarGridTop & ",lngColType=" & mlngColType & _
           ",strReportName='" & mvarReportName & "',intTitleAlign=" & mvarHeadAlign(0) & ",bytCondShow=" & mbytCondShow & _
           ",intCondAlign=" & mlngCondAlign & ",lngPaperID=" & mlngPaperID & _
           " WHERE lngReportID =" & mvarReportID
  
  gclsBase.ExecSQL strSql
  
  
  'Set All Choosed Flag to False
  strSql = "UPDATE ReportField Set blnIsChoosed=0,blnIsHeaded=0 WHERE lngReportID =" & mvarReportID
    
  gclsBase.ExecSQL strSql
  
  'Save Now Choosed Field
  For intCount = 1 To mvarColumns
      If intCount <= mintUserCols Then
            strSql = "Update ReportField" & " Set lngReportFieldNO=" & intCount & ",strReportFieldDesc='" & mvarColumnDesc(intCount) & _
                              "',lngDisplayWidth=" & mvarColumnWidth(intCount) & _
                              ",bytSort=" & mvarColumnOrderType(intCount) & _
                              ",blnIsChoosed=1 Where lngReportId=" & mvarReportID & " And lngViewFieldId=" & mvarColumnFieldID(intCount)
      Else
            strSql = "Update ReportField" & " Set strReportFieldDesc='" & mvarColumnDesc(intCount) & _
                              "',lngDisplayWidth=" & mvarColumnWidth(intCount) & _
                              ",bytSort=" & mvarColumnOrderType(intCount) & _
                              ",blnIsChoosed=1 Where lngReportId=" & mvarReportID & " And lngViewFieldId=" & mvarColumnFieldID(intCount)
      End If
      gclsBase.ExecSQL strSql
  Next intCount
  
  'Title Position
  strSql = "Update Report" & " Set intTitleTop=" & mvarHeadTop(0) & _
         ",intTitleLeft=" & mvarHeadLeft(0) & _
         ",intTitleHeight=" & mvarHeadHeight(0) & _
         ",intTitleWidth=" & mvarHeadWidth(0) & _
         " Where lngReportId=" & mvarReportID
  gclsBase.ExecSQL strSql
  
  
  For intCount = 1 To mvarHeadFields
      strSql = "Update ReportField" & " Set blnIsHeaded=1,lngReportFieldNO=" & intCount & _
               ",lngDisplayTop=" & mvarHeadTop(intCount) & _
               ",lngDisplayLeft=" & mvarHeadLeft(intCount) & _
               ",lngDisplayHeight=" & mvarHeadHeight(intCount) & _
               ",bytCodeShow=" & mbytCodeShowType(intCount) & _
               ",lngDisplayWidth=" & mvarHeadWidth(intCount) & ",intAlign=" & mvarHeadAlign(intCount) & _
               " Where lngReportId=" & mvarReportID & " And lngViewFieldId=" & mvarHeadFieldId(intCount)
      gclsBase.ExecSQL strSql
  Next intCount
End Sub

'根据币种条件选择相关的字段
'bytCurType: 1=所有币种 2=本位币 3=具体币种
Public Function GetDataField(Optional bytCurType As Byte = 1, Optional CurID As Long = 0) As Boolean
   Dim rstChoosed As rdoResultset
   Dim strSql As String
   Dim strCond As String, strOrder As String, strCondVersion As String, strCurrencyCond As String, strCurrencyCond2 As String
   Dim intCount As Integer, lngWidth As Long
   Dim rstWidth As rdoResultset
   
   strCondVersion = GetVersionCond
        
   strCurrencyCond2 = ""
   If (mlngColType And 8) <> 0 Then
       If strCurrencyCond2 = "" Then
         strCurrencyCond2 = "(Mod(bytFormula,8 * 2) >= 8)"
       Else
         strCurrencyCond2 = strCurrencyCond2 & " Or (Mod(bytFormula,8 * 2) >= 8)"
       End If
   End If
    
   If (mlngColType And 16) <> 0 Then
       If strCurrencyCond2 = "" Then
         strCurrencyCond2 = "(Mod(bytFormula,16 * 2) >= 16)"
       Else
         strCurrencyCond2 = strCurrencyCond2 & " Or (Mod(bytFormula,16 * 2) >= 16)"
       End If
   End If
    
   If (mlngColType And 128) <> 0 Then
       If strCurrencyCond2 = "" Then
         strCurrencyCond2 = "(Mod(bytFormula,128 * 2) >= 128)"
       Else
         strCurrencyCond2 = strCurrencyCond2 & " Or (Mod(bytFormula,128 * 2) >= 128)"
       End If
   End If
    
   If (mlngColType And 32) <> 0 Then
       If strCurrencyCond2 = "" Then
         strCurrencyCond2 = "(Mod(bytFormula,32 * 2) >= 32)"
       Else
         strCurrencyCond2 = strCurrencyCond2 & " Or (Mod(bytFormula,32 * 2) >= 32)"
       End If
   End If
    
   If (mlngColType And 256) <> 0 Then
       If strCurrencyCond2 = "" Then
         strCurrencyCond2 = "(Mod(bytFormula,256 * 2) >= 256)"
       Else
         strCurrencyCond2 = strCurrencyCond2 & " Or (Mod(bytFormula,256 * 2) >= 256)"
       End If
   End If
    
   If (mlngColType And 64) <> 0 Then
       If strCurrencyCond2 = "" Then
         strCurrencyCond2 = "(Mod(bytFormula,64 * 2) >= 64)"
       Else
         strCurrencyCond2 = strCurrencyCond2 & " Or (Mod(bytFormula,64 * 2) >= 64)"
       End If
   End If
    
   strCurrencyCond = ""
   '包含数量栏
   If (mlngColType And 1) <> 0 Then
      strCurrencyCond = "(Mod(bytFormula,1 * 2) >= 1)"
   End If
    
   Select Case bytCurType
       '所有币种
       Case 1
            If strCurrencyCond = "" Then
              strCurrencyCond = "((Mod(bytFormula,2 * 2) >= 2) Or (Mod(bytFormula,4 * 2) >= 4))"
            Else
              strCurrencyCond = strCurrencyCond & " Or ((Mod(bytFormula,2 * 2) >= 2) Or (Mod(bytFormula,4 * 2) >= 4))"
            End If
       '本位币
       Case 2
            If strCurrencyCond = "" Then
              strCurrencyCond = "(Mod(bytFormula,4 * 2) >= 4)"
            Else
              strCurrencyCond = strCurrencyCond & " Or (Mod(bytFormula,4 * 2) >= 4)"
            End If
       '具体币种
       Case 3
          If CurID <> 1 Then
            If strCurrencyCond = "" Then
              strCurrencyCond = "(Mod(bytFormula,2 * 2) >= 2) And bytFormula<>122"
            Else
              strCurrencyCond = strCurrencyCond & " Or ((Mod(bytFormula,2 * 2) >= 2) And bytFormula<>122)"
            End If
          Else
            If strCurrencyCond = "" Then
              strCurrencyCond = "(Mod(bytFormula,4 * 2) >= 4)"
            Else
              strCurrencyCond = strCurrencyCond & " Or (Mod(bytFormula,4 * 2) >= 4)"
            End If
          End If
   End Select
   strCurrencyCond = " And ((" & strCurrencyCond & ") And (" & strCurrencyCond2 & ") Or bytFormula=128)"
   
   If mlngPaperID <> 0 Then
      strCondVersion = strCondVersion & " And bytFormula<>122"
   End If
   
   strSql = "Select * from ViewField,Report,ReportField Where ViewField.lngViewFieldID=ReportField.lngViewFieldID " & _
            "And Report.lngReportID=ReportField.lngReportID And Report.lngReportID=" & mvarReportID & _
            strCondVersion & strCurrencyCond
   strOrder = " Order By lngReportFieldNO"
   Set rstChoosed = gclsBase.BaseDB.OpenResultset(strSql & strOrder, rdOpenStatic)
   With rstChoosed
       If .EOF Then
          GetDataField = False
          Exit Function
       End If
       .MoveLast
       .MoveFirst
       Columns = mintUserCols
       Columns = Columns + .RowCount
       
       For intCount = Columns - .RowCount + 1 To Columns
            mstrColumnGroup(intCount) = IIf(IsNull(!strGroup), "", !strGroup)
            mvarColumnDesc(intCount) = !strReportFieldDesc
            mvarColumnFieldName(intCount) = IIf(IsNull(!strFieldName), "", !strFieldName)
            
            '?If !lngDisplayWidth = 0 Or IsNull(!lngDisplayWidth) Then(此句允许自动配置宽度)
            If IsNull(!lngDisplayWidth) Then
                lngWidth = Utility.GetDisplayWidth(!strViewFieldDesc, !bytFieldSize)
            Else
                lngWidth = !lngDisplayWidth
            End If
            mvarColumnWidth(intCount) = lngWidth
            
            mvarColumnOrderType(intCount) = !bytsort
            mvarColumnIsFix(intCount) = !blnIsFixed
            mvarColumnIsMust(intCount) = !blnIsMust
            If !blnIsFixed Then
                 mvarFixColumns = mvarFixColumns + 1
            End If
            mvarColumnIsFind(intCount) = !blnIsFind
            mblnColumnMayChoose(intCount) = .rdoColumns("blnIsChoose")
            mvarColumnFieldID(intCount) = .rdoColumns("lngViewFieldID")
            mvarColumnFieldType(intCount) = !strFieldType
            mvarColumnFieldSize(intCount) = !bytFieldSize
            mvarColumnCombine(intCount) = IIf(IsNull(!strCombine), "", !strCombine)
            
            .MoveNext
       Next intCount
   End With
  
   If mlngPaperID <> 0 Then
       strSql = "Select * From ReportOnlyData Where lngPaperID=" & mlngPaperID & " Order By lngOrder"
       Set rstWidth = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
       With rstWidth
          intCount = 1
          Do While (Not .EOF) And intCount <= UBound(mvarColumnWidth)
              mvarColumnWidth(intCount) = !lngWidth
              .MoveNext
              intCount = intCount + 1
          Loop
       End With
   End If
  
End Function

'套打纸GridTop
Public Function GetGridTop()
  Dim strSql As String
  Dim rstTop As rdoResultset
    strSql = "Select lngGridTop From ReportPaper Where lngPaperID=" & mlngPaperID
    Set rstTop = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With rstTop
       If Not .EOF Then
          GetGridTop = !lngGridTop
          mvarGridTop = !lngGridTop
       End If
    End With
End Function

'取当前帐表套打设置
Public Function GetReportTdSet() As String
   Dim rstChoosed As rdoResultset
   Dim strSql As String
   Dim strCond As String, strOrder As String, strCondVersion As String
   Dim intCount As Integer, lngWidth As Long
   Dim bytVersion As Byte
   
   strCondVersion = GetVersionCond
   
   strSql = "Select * from ViewField,Report,ReportField,ReportOnlyData Where ViewField.lngViewFieldID=ReportField.lngViewFieldID And ViewField.lngViewFieldID=ReportOnlyData.lngViewFieldID " & _
            "And Report.lngReportID=ReportField.lngReportID And Report.lngReportID=" & mvarReportID & _
             strCondVersion & " And ReportOnlyData.lngPaperID=" & mlngPaperID
   strOrder = " Order By lngOrder"