crossset.cls

金算盘软件代码

    Else
        GetFormat = ""
    End If
End Function
'对字段格式化
Private Function FormatFieldName(ByVal strDesc As String, ByVal strColName As String, ByVal strColValue As String, ByVal strFieldValue As String, Optional ByVal bytTo_Char As Byte = 0, Optional ByVal dblSum As Double = 1, Optional ByVal dblTax As Double = 1) As String
Dim intLen As Integer
Dim strTo_Char As String
Dim strTemp As String
    If mvarViewID = 1213 Then   '强生：地区销售交叉表
        Select Case strDesc
        Case "客户数"
            strTemp = "Sum(Decode(" & strColName & ",'" & strColValue & "',1,0))"
        Case "含税金额", "不含税金额"
            intLen = gclsBase.NaturalCurDec
            If intLen > 0 Then
                strTo_Char = "999999999990." & String(intLen, "0")
            Else
                strTo_Char = "999999999999"
            End If
            strTemp = "Ltrim(To_Char(Sum(Decode(" & strColName & ",'" & strColValue & "'," & strFieldValue & ",0)),'" & strTo_Char & "'))"
        Case "占含税总额百分比%"
            strTemp = "Ltrim(To_Char(Sum(Decode(" & strColName & ",'" & strColValue & "'," & strFieldValue & ",0))/" & dblTax & "*100,'99999990.00'))"
        Case "占不含税总额百分比%"
            strTemp = "Ltrim(To_Char(Sum(Decode(" & strColName & ",'" & strColValue & "'," & strFieldValue & ",0))/" & dblSum & "*100,'99999990.00'))"
        Case Else
        End Select
    Else
        Select Case bytTo_Char
        Case 0, 1      '缺省
            strTemp = "Sum(Decode(" & strColName & ",'" & strColValue & "'," & strFieldValue & ",0))"
        Case 2       '单价
            intLen = gclsBase.PriceDec
            If intLen > 0 Then
                strTo_Char = "99999999990." & String(intLen, "0")
            Else
                strTo_Char = "99999999999"
            End If
            strTemp = "Ltrim(To_Char(Sum(Decode(" & strColName & ",'" & strColValue & "'," & strFieldValue & ",0)),'" & strTo_Char & "'))"
        Case 3       '原币
            strTemp = "Ltrim(Decode(Sign(Max(Currencys.bytCurrencyDec)),1,To_Char(Sum(Decode(" & strColName & ",'" & strColValue & "'," & strFieldValue & ",0)),'999999999990.'|| String1(Max(Currencys.bytCurrencyDec),'0')),To_Char(Sum(Decode(" & strColName & ",'" & strColValue & "'," & strFieldValue & ",0)),'999999999999')))"
        Case 4       '汇率
            strTemp = "Ltrim(Decode(Sign(Max(Currencys.bytCurrencyDec)),1,To_Char(Sum(Decode(" & strColName & ",'" & strColValue & "'," & strFieldValue & ",0)),'999999999990.'|| String1(Max(Currencys.bytCurrencyDec),'0')),To_Char(Sum(Decode(" & strColName & ",'" & strColValue & "'," & strFieldValue & ",0)),'999999999999')))"
        Case 5       '本币
            intLen = gclsBase.NaturalCurDec
            If intLen > 0 Then
                strTo_Char = "999999999990." & String(intLen, "0")
            Else
                strTo_Char = "999999999999"
            End If
            strTemp = "Ltrim(To_Char(Sum(Decode(" & strColName & ",'" & strColValue & "'," & strFieldValue & ",0)),'" & strTo_Char & "'))"
        Case Else
            strTemp = "Sum(Decode(" & strColName & ",'" & strColValue & "'," & strFieldValue & ",0))"
        End Select
    End If
    FormatFieldName = strTemp
End Function

'保存类到数据库
'保存交叉表修改结果
Public Function SaveCross(Optional blnSaveAs As Boolean = False) As Boolean
    On Error GoTo clsErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    
    If blnSaveAs Then
        AddReport
        mvarReportPrep = 2
    Else
        EditUpdate
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCross = True
    Exit Function
clsErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
    SaveCross = False
End Function
'按用户ID重新保存一份标准表
Private Sub AddReport()
  Dim rstReport As rdoResultset
  Dim strSql As String
  Dim lngReportID As Long
   
'    On Error GoTo ErrHandle
'    If mvarSaveErr Then Exit Sub
'    gclsBase.BaseDB.BeginTrans
    
    '关闭表触发器
    strSql = "Alter Table Report Disable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
    
    mvarPrintSetID = StandardReport.GetPrintSetupID(3, mvarReportID)
    strSql = "Select * From Report"
    Set rstReport = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
    With rstReport
       .AddNew
          lngReportID = BillPublic.GetNewID("Report")
          !lngViewId = mvarViewID
          !bytGroup = mvarGroupNo
          !strReportName = mvarReportName
          !lngOperatorID = gclsBase.OperatorID
          !bytPrep = 2
          !bytWizard = 4
          !lngParentId = mvarParentID
          !intLevel = mvarLevel + 1
          !strDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
          !blnIsDetail = 1
          !blnIsRowTotal = 0
          !blnIsColTotal = 0
          !bytRowTotalMethod = 0
          !bytColTotalMethod = 0
          !strExtraCond = IIf(mvarReportCond = "", " ", mvarReportCond)
          !lngPrintSetupID = mvarPrintSetID
          !lngReportID = lngReportID
       .Update
    End With
    
    '打开表触发器
    strSql = "Alter Table Report Enable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
'    gclsBase.BaseDB.CommitTrans
    
    Set rstReport = Nothing
    CopyReportField (lngReportID)
    mvarReportID = lngReportID
    EditUpdate
'    Exit Sub
'
'ErrHandle:
'    gclsBase.BaseDB.RollBacktrans
'    Set rstReport = Nothing
'    Utility.ShowMsg frmMain.hwnd, Err.Description, vbCritical + vbOKOnly, App.title
'    mvarSaveErr = True
End Sub

'复制所有报表字段
Private Sub CopyReportField(ByVal lngReportID As Long)
  Dim strSql As String
  Dim intCount As Integer, intLoc As Integer
  Dim rstSource As rdoResultset, rstDesc As rdoResultset
  Dim lngFieldID As Long
  Dim fldReportField As rdoColumn
  Dim colFieldID As Collection
     
'     On Error GoTo ErrHandle
'     If mvarSaveErr Then Exit Sub
'     gclsBase.BaseDB.BeginTrans
     
     Set colFieldID = New Collection
     For intCount = 0 To UBound(mvarReportFieldID)
        If mvarReportFieldID(intCount) > 0 Then
            colFieldID.Add intCount + 1, CStr(mvarReportFieldID(intCount))
        End If
     Next intCount
     
     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)
     
     '关闭表触发器
    strSql = "Alter Table ReportField Disable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
    
     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
                         lngFieldID = BillPublic.GetNewID("ReportField")
                         rstDesc.rdoColumns(fldReportField.Name).Value = lngFieldID
                         On Error Resume Next
                         intLoc = -1
                         intLoc = colFieldID(CStr(fldReportField.Value))
                         If intLoc > 0 Then
                            mvarReportFieldID(intLoc - 1) = lngFieldID
                         End If
                         On Error GoTo 0
                     End If
                End If
            Next
            rstDesc.Update
            .MoveNext
         Loop
     End With
     '打开表触发器
    strSql = "Alter Table ReportField Enable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
'     gclsBase.BaseDB.CommitTrans
     Set rstSource = Nothing
     Set rstDesc = Nothing
'     Exit Sub
'
'ErrHandle:
'    gclsBase.BaseDB.RollBacktrans
'    Set rstSource = Nothing
'    Set rstDesc = Nothing
'    Utility.ShowMsg frmMain.hwnd, Err.Description, vbCritical + vbOKOnly, App.title
'    mvarSaveErr = True
End Sub

'更新用户自定义交叉表的修改
Private Sub EditUpdate()
  Dim strSql As String
  Dim intCount As Integer, intLoc As Integer, intNumber As Integer
'  Dim rstsave As rdoResultset
  
'  On Error GoTo ErrHandle
'  If mvarSaveErr Then Exit Sub
'  gclsBase.BaseDB.BeginTrans
     
  '更新报表
  strSql = "UPDATE Report Set " _
            & "intTitleWidth=" & mvarTitleWidth & ",intTitleHeight=" & mvarTitleHeight & ",intTitleTop=" & mvarTitleTop & ",intTitleLeft=" & mvarTitleLeft & ",intTitleAlign=" & mvarTitleAlign _
            & ",intCondWidth=" & mvarCondWidth & ",intCondHeight=" & mvarCondHeight & ",intCondTop=" & mvarCondTop & ",intCondLeft=" & mvarCondLeft & ",intCondAlign=" & mvarCondAlign & ",bytCondShow=" & mvarCondShow _
            & ",strReportName='" & mvarReportName & "',bytVersion=" & mvarVersion _
            & ",intGridTop=" & mvarGridTop & ",lngCrossDefWidth=" & mvarDefWidth & ",blnIsIncludeTotal=1,bytWizard=4" _
            & ",blnIsRowTotal=" & mvarIsRowSum & ",blnIsColTotal=" & mvarIsColSum & ",lngPageFieldID=" & mvarBudgetID _
            & ",bytRowTotalMethod=" & mvarRowTotalMethod & ",bytColTotalMethod=" & mvarColTotalMethod _
            & " WHERE lngReportID =" & mvarReportID
  gclsBase.ExecSQL strSql
    
  '初始化报表字段
  strSql = "UPDATE ReportField Set blnIsChoosed=0 ,bytReportFieldType=0 ,bytSort=0,intSortNO=0," & _
            "bytCodeShow=2,dblDistance=0 ,lngReportFieldNO=0  WHERE lngReportID =" & mvarReportID
  gclsBase.ExecSQL strSql
  
  intNumber = 1
  '更新报表列表框字段
  For intLoc = 0 To mvarListColumns - 1
      intCount = mvarListLoc(intLoc)
      strSql = "UPDATE ReportField Set strReportFieldDesc='" & mvarColumnDesc(intCount) _
            & "',bytReportFieldType=6 ,bytCodeShow=" & mvarCodeName(intCount) _
            & ",lngReportFieldNO=" & intNumber & ",lngDisplayWidth=" & mvarColumnWidth(intCount) _
            & ",lngDisplayHeight=" & mvarColumnHeight(intCount) & ",lngDisplayTop=" & mvarColumnTop(intCount) _
            & ",lngDisplayLeft=" & mvarColumnLeft(intCount) & ",intAlign=" & mvarColumnAlign(intCount) _
            & " Where lngReportId= " & mvarReportID & " And lngViewFieldId=" & mvarColumnID(intCount)
      gclsBase.ExecSQL strSql
      intNumber = intNumber + 1
  Next intLoc
  '更新报表已选字段
  For intLoc = 0 To mvarChoosedColumns - 1
      intCount = mvarChoosedLoc(intLoc)
      If mvarColumnStyle(intCount) = 0 Then
            strSql = "UPDATE ReportField Set strReportFieldDesc='" & mvarColumnDesc(intCount) _
                  & "',bytReportFieldType=0" _
                  & ",lngReportFieldNO=" & intNumber & ",lngDisplayWidth=" & mvarColumnWidth(intCount) _
                  & ",blnIsChoosed=1 " _
                  & " Where lngReportId= " & mvarReportID & " And lngViewFieldId=" & mvarColumnID(intCount)
            gclsBase.ExecSQL strSql
            intNumber = intNumber + 1
      End If
  Next intLoc
  '更新报表交叉字段
  For intLoc = 0 To mvarRowColumns - 1
        intCount = mvarRowLoc(intLoc)
        strSql = "UPDATE ReportField Set strReportFieldDesc='" & mvarColumnDesc(intCount) _
              & "',bytReportFieldType=3" _
              & ",lngReportFieldNO=" & intNumber & ",lngDisplayWidth=" & mvarColumnWidth(intCount) _
              & ",blnIsChoosed=1 " _
              & " Where lngReportId= " & mvarReportID & " And lngViewFieldId=" & mvarColumnID(intCount)
        gclsBase.ExecSQL strSql
        intNumber = intNumber + 1
  Next intLoc
  For intLoc = 0 To mvarColColumns - 1
        intCount = mvarColLoc(intLoc)
        strSql = "UPDATE ReportField Set strReportFieldDesc='" & mvarColumnDesc(intCount) _
              & "',bytReportFieldType=4" _
              & ",lngReportFieldNO=" & intNumber & ",lngDisplayWidth=" & mvarColumnWidth(intCount) _
              & ",blnIsChoosed=1 " _
              & " Where lngReportId= " & mvarReportID & " And lngViewFieldId=" & mvarColumnID(intCount)
        gclsBase.ExecSQL strSql
        intNumber = intNumber + 1
  Next intLoc
  For intLoc = 0 To mvarDataColumns - 1
        intCount = mvarDataLoc(intLoc)
        strSql = "UPDATE ReportField Set strReportFieldDesc='" & mvarColumnDesc(intCount) _
              & "',bytReportFieldType=8" _
              & ",lngReportFieldNO=" & intNumber & ",lngDisplayWidth=" & mvarColumnWidth(intCount) _
              & ",blnIsChoosed=1 " _
              & " Where lngReportId= " & mvarReportID & " And lngViewFieldId=" & mvarColumnID(intCount)
        gclsBase.ExecSQL strSql
        intNumber = intNumber + 1
  Next intLoc
'  gclsBase.BaseDB.CommitTrans
'  Exit Sub
'
'ErrHandle:
'    gclsBase.BaseDB.RollBacktrans
'    Utility.ShowMsg frmMain.hwnd, Err.Description, vbCritical + vbOKOnly, App.title
'    mvarSaveErr = True
End Sub
'Private Sub EditSql(sql As String)
'Dim strBegin As String, strEnd As String, strStop As String
'    strBegin = "1990-01-01"
'    strEnd = "2030-12-31"
'    strStop = "2030-12-31"
'
'    Select Case mvarViewID
'    Case 462, 466         '预测报表
'        sql = strReplace(sql, "YCTS", "1")
'    Case 648, 649, 650, 1114, 1115, 1116      '注册日期
'        sql = strReplace(sql, "ZCRQ", Format(gclsBase.BaseDate, "YYYY-MM-DD"))
'        sql = strReplace(sql, "JSRQ", strEnd)
'    Case 520                     '滞销稽查
'        sql = strReplace(sql, "ZTRQ", Format(gclsBase.BeginDate, "YYYY-MM-DD"))
'        sql = strReplace(sql, "JZRQ", strStop)
'    Case 779, 780, 781, 782      '购销稽查
'         sql = strReplace(sql, "JZRQ", strStop)
'    Case 754, 774, 775 '固定资产清单
''         StandardReport.GetBasePeriods strTemp
'         sql = strReplace(sql, "KJQJS", "12")
'    Case 763
'        sql = strReplace(sql, "ZTRQ", strBegin)
'        sql = strReplace(sql, "JZRQ", strEnd)
'    Case Else
'    End Select
'End Sub
Public Function ShowWizard(Optional ByVal lngReportID As Long, Optional lngParentId As Long, _
       Optional intParentLevel As Integer, Optional clsStandard As StandardReportSet = Nothing, Optional clsWizardFormCond As FormCond = Nothing, Optional blnIsNew As Boolean = True) As Boolean
   Dim clsFormCond  As FormCond
   Dim clsFormStandard  As CrossSet
   Dim blnStandard As Boolean
   
    If mvarReportID = 0 Then
        GetReportSet lngReportID
    End If
    If mvarParentID = 0 Then
        mvarParentID = lngParentId
        mvarLevel = intParentLevel
    End If
    If clsWizardFormCond Is Nothing Then
        Set clsFormCond = New FormCond
    Else
        Set clsFormCond = clsWizardFormCond
    End If
    If clsStandard Is Nothing Then
        Set clsFormStandard = New FormCond
    Else
        Set clsFormStandard = clsStandard
    End If
    blnStandard = False
    ShowWizard = frmStandard.SetStandard(blnStandard, clsFormCond, clsFormStandard, Me)
    
    If ShowWizard And blnIsNew Then
       '由向导新生成了一张帐表(还未存到数据库)
        Report.ShowStandardReport 0, 0, clsFormStandard, Me, clsFormCond
    End If
    Set clsFormCond = Nothing
    Set clsFormStandard = Nothing
End Function

Private Sub Class_Terminate()
    Erase marrCol
    
    Erase mvarColumnID()
    Erase mvarReportFieldID()
    Erase mvarColumnDesc()
    Erase mvarColumnWidth()
    Erase mvarColumnHeight()
    Erase mvarColumnLeft()
    Erase mvarColumnTop()
    Erase mvarColumnAlign()
    Erase mvarColumnChoosed()
    Erase mvarColumnStyle()
    Erase mvarTableName()
    Erase mvarFieldDesc()
    Erase mvarFieldName()
    Erase mvarFieldType()
    Erase mvarFieldHead()
    Erase mvarColumnNO()
    Erase mvarCodeName()
    Erase mvarColumnFormat()
    
    Erase mvarChoosedID()
    Erase mvarChoosedLoc()
    Erase mvarListID()
    Erase mvarListLoc()
    Erase mvarRowFieldID()
    Erase mvarRowLoc()
    Erase mvarColFieldID()
    Erase mvarColLoc()
    Erase mvarDataFieldID()
    Erase mvarDataLoc()
End Sub