listset.cls

金算盘软件代码

    End With
    
    CopyListField (lngListID)
    mvarListID = lngListID
    EditUpdate
    rstList.Close
End Sub

'Copy All ListField
Private Sub CopyListField(lngListID As Long)
  Dim strSql As String
  Dim rstSource As rdoResultset, rstDesc As rdoResultset
  Dim fldListField As rdoColumn
     
     strSql = "Select * from ViewField Where " & _
              "(ViewField.blnIsChoose=1 or ViewField.blnIsFixed=1 Or " & _
              "Viewfield.blnIsMust=1 Or ViewField.blnIsPrep=1)" & _
              "And lngViewId = " & mvarViewID
     
     Set rstSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
     
     strSql = "Select * from Listfield Where lngListId=" & lngListID
     Set rstDesc = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
     
     With rstSource
         Do While Not .EOF
            rstDesc.AddNew
                rstDesc!lngListID = lngListID
                rstDesc!strListFieldDesc = rstSource!strViewFieldDesc
                rstDesc!bytsort = 0
                rstDesc!lngViewFieldID = rstSource!lngViewFieldID
                rstDesc!lngListFieldID = GetNewID("ListField")
            rstDesc.Update
            .MoveNext
         Loop
     End With
     rstSource.Close
     rstDesc.Close
End Sub

'保存列表修改结果
Public Sub SaveList()
  Dim strSql As String, strOrder As String
  Dim rstChoosed As rdoResultset
  
   On Error GoTo ErrHandle
   strSql = "Select lngListID,lngOperatorID,lngViewID from List Where " & _
            "List.lngViewID=" & mvarViewID & " And List.lngOperatorID=" & gclsBase.OperatorID
   strOrder = " Order By lngOperatorID,lngViewID"
   
   Set rstChoosed = gclsBase.BaseDB.OpenResultset(strSql & strOrder, rdOpenStatic)
   
   If rstChoosed.EOF Then
      mblnFirstUse = True
   Else
      mblnFirstUse = False
      mvarListID = rstChoosed.rdoColumns("lngListID")
   End If
    
    If mblnFirstUse Then
        AddList
        mblnFirstUse = False
    Else
        EditUpdate
    End If
    Exit Sub
ErrHandle:
End Sub

'更新用户自定义列表的修改
Private Sub EditUpdate()
  Dim strSql As String
  Dim rstListField As rdoResultset
  Dim intCount As Integer
  
  'Set All Choosed Flag to False
  strSql = "UPDATE ListField Set blnIsChoosed=0 WHERE lngListID =" & mvarListID
    
  gclsBase.ExecSQL strSql
  
  'Save Now Choosed Field
  For intCount = 1 To mvarColumns
      strSql = "Update ListField" & " Set lngListFieldNO=" & intCount & ",strListFieldDesc='" & mvarColumnDesc(intCount) & _
                        "',lngDisplayWidth=" & mvarColumnWidth(intCount) & ",bytSort=" & mvarColumnOrderType(intCount) & _
                        ",blnIsChoosed=1 Where lngListId=" & mvarListID & " And lngViewFieldId=" & mvarColumnFieldID(intCount)
      gclsBase.ExecSQL strSql
  Next intCount
End Sub

'取当前列表设置
Private Function GetListSet(ByVal ListViewID As Long) 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 edtErrReturn As ErrDealType
   
   On Error GoTo ErrHandle
'   Debug.Print "ListsetA1: " & Timer
   strCondVersion = " And (Mod(ViewField.bytVersion, " & gVersionType * 2 & ")>=" & gVersionType & ")"
   
   If gclsBase.AccountSys = "3" Or gclsBase.AccountSys = "4" Then
      strCondVersion = strCondVersion & " And blnNotHospital=0"
   End If
   
   strSql = "Select * from ViewField,List,ListField Where ViewField.lngViewFieldID=listField.lngViewFieldID " & _
            "And List.lngListID=ListField.lngListID And List.lngViewID=" & ListViewID & " And ListField.blnIsChoosed=1 " & strCondVersion
   strCond = " And List.lngOperatorID=" & gclsBase.OperatorID
   strOrder = " Order By lngListFieldNO"
'    Debug.Print "ListsetA1-01: " & Timer
   Set rstChoosed = gclsBase.BaseDB.OpenResultset(strSql & strCond & strOrder, rdOpenStatic)
'    Debug.Print "ListsetA1-02: " & Timer
   If rstChoosed.EOF Then
      mblnFirstUse = True
      
      strSql = "Select * from View1,ViewField Where View1.lngViewID=" & ListViewID & _
               " And View1.lngViewId=ViewField.lngViewId And (ViewField.blnIsFixed=1 Or Viewfield.blnIsMust=1" & _
               " Or ViewField.blnIsPrep=1)" & strCondVersion
      strOrder = " Order By lngViewFieldNO"
      Set rstChoosed = gclsBase.BaseDB.OpenResultset(strSql & strOrder, rdOpenStatic)
   Else
      mblnFirstUse = False
   End If
   With rstChoosed
       If .EOF Then
          GetListSet = ""
          Exit Function
       End If
       .MoveLast
       .MoveFirst
       
       Columns = .RowCount
       If Not mblnFirstUse Then
          mvarListID = .rdoColumns("lngListID")
       Else
          mvarListID = 0
       End If
       mvarFixColumns = 0
       mvarMustColumns = 0
'        Debug.Print "ListsetA1-1: " & Timer
       For intCount = 1 To .RowCount
            If mblnFirstUse Then
                 mvarColumnDesc(intCount) = !strViewFieldDesc
                 mvarColumnFieldID(intCount) = !lngViewFieldID
                 lngWidth = Utility.GetDisplayWidth(!strViewFieldDesc, !bytFieldSize)
                 mvarColumnOrderType(intCount) = IIf(IsNull(!bytPrepOrder), 0, !bytPrepOrder)
            Else
                 mvarColumnDesc(intCount) = !strListFieldDesc
                 mvarColumnFieldID(intCount) = .rdoColumns("lngViewFieldID")
                 lngWidth = !lngDisplayWidth
                 mvarColumnOrderType(intCount) = !bytsort
            End If
            
            mvarColumnFieldName(intCount) = !strFieldName
            mvarColumnWidth(intCount) = lngWidth
            mvarColumnIsFix(intCount) = !blnIsFixed
            mvarColumnIsMust(intCount) = !blnIsMust
            mvarFieldDec(intCount) = !bytFieldDec
            mvarColumnGroup(intCount) = !strGroup
            mbytFormat(intCount) = IIf(IsNull(!bytFormat), 0, !bytFormat)
            mblnNotZero(intCount) = !blnNotZero
            If !blnIsFixed Then
                 mvarFixColumns = mvarFixColumns + 1
            End If
            If !blnIsMust Then
                 mvarMustColumns = mvarMustColumns + 1
            End If
            mvarColumnIsFind(intCount) = !blnIsFind
            mvarColumnFieldType(intCount) = !strFieldType
            mvarColumnFieldSize(intCount) = !bytFieldSize
            mvarColumnCombine(intCount) = IIf(IsNull(!strCombine), "", !strCombine)
            
            .MoveNext
       Next intCount
   End With
   Dim strVarTemp As String
'    Debug.Print "ListsetA2: " & Timer
   mvarSelect = GetSelect
'    Debug.Print "ListsetA3: " & Timer
   strVarTemp = GetWhere
'    Debug.Print "ListsetA4: " & Timer
   'mstrWhereInFrom = mvarWhere
   If Trim(strVarTemp) <> "" And Trim(mstrWhereInFrom) <> "" Then
        mvarWhere = mstrWhereInFrom & " And " & strVarTemp
   ElseIf Trim(mstrWhereInFrom) = "" And Trim(strVarTemp) <> "" Then
        mvarWhere = strVarTemp
   ElseIf Trim(mstrWhereInFrom) <> "" And Trim(strVarTemp) = "" Then
        mvarWhere = mstrWhereInFrom
   ElseIf Trim(mstrWhereInFrom) = "" And Trim(strVarTemp) = "" Then
        mvarWhere = ""
   End If
'    Debug.Print "ListsetA5: " & Timer
   rstChoosed.Close
   Exit Function
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    If edtErrReturn = edtResume Then
         Resume
    End If
    GetListSet = False
End Function

'显示栏目设置窗口
Public Function ShowListSet(ByVal ListViewID As Long, Optional ChangeName As Boolean = True) As Boolean
   'Dim strPureWhere As String
   If mvarViewID = 0 Then
       ViewId = ListViewID
   End If
   ShowListSet = frmListSet.SetList(Me, ChangeName)
   If ShowListSet Then
      mvarSelect = GetSelect
      'mvarWhere = GetWhere
      GetWhere
      mvarWhere = IIf(Trim(mstrPureWhere) <> "" And Trim(mstrWhereInFrom) <> "", _
                mstrWhereInFrom & " and " & mstrPureWhere, IIf(Trim(mstrPureWhere) <> "", _
                Trim(mstrPureWhere), "") & IIf(Trim(mstrWhereInFrom) <> "", Trim(mstrWhereInFrom), ""))
   End If
End Function

'取 SELECT 子句
Public Function GetSelect() As String
  Dim intCount As Integer
  Dim strSelect As String, strFieldFat As String
  Dim rstViewField As rdoResultset
  Dim strQuanFat As String, strPriceFat As String, strRateFat As String, strName As String
  Dim strNatureFat As String, strCurrFat As String
  Dim blnSum As Boolean
  
  '显示格式 0=其他 1=数量 2=单价 3=原币 4=汇率 5=本币 6=日期
     
     strPriceFat = Replace(Utility.GetFormatString(gclsBase.PriceDec), "#", "9")
     strQuanFat = Replace(Utility.GetFormatString(gclsBase.QuantityDec), "#", "9")
     strNatureFat = Replace(Utility.GetFormatString(gclsBase.NaturalCurDec), "#", "9")
     For intCount = 1 To mvarColumns
        strName = mvarColumnFieldName(intCount)
        strFieldFat = ""
        blnSum = False
        If InStr(1, UCase(strName), "SUM") <> 0 Or InStr(1, UCase(strName), "FIRST") <> 0 _
            Or InStr(1, UCase(strName), "LAST") <> 0 Or InStr(1, UCase(strName), "MAX") <> 0 _
            Or InStr(1, UCase(strName), "MIN") <> 0 Then
            blnSum = True
        End If
        Select Case mbytFormat(intCount)
           Case 1
              'strFieldFat = "'" & strQuanFat & "'"
           Case 2
              'strFieldFat = "'" & strPriceFat & "'"
           Case 3
              If blnSum Then
                 strFieldFat = "'999,999,999,999,990.' || String1(min(" & mstrCurTable & ".bytCurrencyDec),'0')"
              Else
                 strFieldFat = "'999,999,999,999,990.' || String1(" & mstrCurTable & ".bytCurrencyDec,'0')"
              End If
           Case 4
              If blnSum Then
                 strFieldFat = "'999,999,999,999,990.' || String1(min(" & mstrCurTable & ".bytRateDec),'0')"
              Else
                 strFieldFat = "'999,999,999,999,990.' || String1(" & mstrCurTable & ".bytRateDec,'0')"
              End If
           Case 5
              If mblnFormatNum Then
                 strFieldFat = "'" & strNatureFat & "'"
              Else
                 strFieldFat = ""
              End If
           Case 6
'              strFieldFat = "'RRRR-MM-DD'"
           Case 9
              strFieldFat = "'" & Replace(Utility.GetFormatString(mvarFieldDec(intCount)), "#", "9") & "'"
        End Select
        '格式化
        If mblnFormatCell Then
            If strFieldFat <> "" And mvarColumnDesc(intCount) <> "实际支付" Then
               If mbytFormat(intCount) = 6 Then
                    strFieldFat = strName
                Else
                    strFieldFat = "ltrim(To_char(" & strName & "," & strFieldFat & "))"
                End If
            Else
               strFieldFat = strName
            End If
            If mblnNotZero(intCount) Then
               strFieldFat = "decode(sign(" & strName & "),0,''," & strFieldFat & ")"
            End If
        Else
            strFieldFat = strName
        End If
        If mvarColumnDesc(intCount) <> "实际支付" Then
            If strSelect = "" Then
                strSelect = strFieldFat & " As " & """" & mvarColumnDesc(intCount) & """"
            Else
                strSelect = strSelect & "," & strFieldFat & " As " & """" & mvarColumnDesc(intCount) & """"
            End If
        Else
            If strSelect = "" Then
                strSelect = strFieldFat
            Else
                strSelect = strSelect & "," & strFieldFat
            End If
        End If
     Next intCount
     GetSelect = strSelect
End Function

Private Function GetWhere() As String
    mstrPureWhere = Filter.GetInitWhere(mvarListID, 1, , , , , mstrHaving)
    GetWhere = mstrPureWhere
End Function

Public Sub RefreshWhere()
    mstrPureWhere = Filter.GetInitWhere(mvarListID, 1, , , , , mstrHaving)
    mvarWhere = IIf(Trim(mstrPureWhere) <> "" And Trim(mstrWhereInFrom) <> "", _
                mstrWhereInFrom & " and " & mstrPureWhere, IIf(Trim(mstrPureWhere) <> "", _
                Trim(mstrPureWhere), "") & IIf(Trim(mstrWhereInFrom) <> "", Trim(mstrWhereInFrom), ""))
End Sub
'交换列
Public Sub ExChangeColumn(ByVal One As Integer, Another As Integer)
   Dim varTemp As Variant
        
        varTemp = mvarColumnWidth(One)
        mvarColumnWidth(One) = mvarColumnWidth(Another)
        mvarColumnWidth(Another) = varTemp
        
        varTemp = mvarColumnOrderType(One)
        mvarColumnOrderType(One) = mvarColumnOrderType(Another)
        mvarColumnOrderType(Another) = varTemp
        
        varTemp = mvarColumnIsFix(One)
        mvarColumnIsFix(One) = mvarColumnIsFix(Another)
        mvarColumnIsFix(Another) = varTemp
        
        varTemp = mvarColumnIsFind(One)
        mvarColumnIsFind(One) = mvarColumnIsFind(Another)
        mvarColumnIsFind(Another) = varTemp
        
        varTemp = mvarColumnFieldID(One)
        mvarColumnFieldID(One) = mvarColumnFieldID(Another)
        mvarColumnFieldID(Another) = varTemp
        
        varTemp = mvarColumnFieldName(One)
        mvarColumnFieldName(One) = mvarColumnFieldName(Another)
        mvarColumnFieldName(Another) = varTemp
        
        varTemp = mvarColumnDesc(One)
        mvarColumnDesc(One) = mvarColumnDesc(Another)
        mvarColumnDesc(Another) = varTemp
        
        varTemp = mvarColumnFieldType(One)
        mvarColumnFieldType(One) = mvarColumnFieldType(Another)
        mvarColumnFieldType(Another) = varTemp
        
        varTemp = mvarColumnFieldSize(One)
        mvarColumnFieldSize(One) = mvarColumnFieldSize(Another)
        mvarColumnFieldSize(Another) = varTemp
        
        varTemp = mvarColumnCombine(One)
        mvarColumnCombine(One) = mvarColumnCombine(Another)
        mvarColumnCombine(Another) = varTemp
        
End Sub

Private Sub Class_Initialize()
    mblnReadOnly = True
    mblnFormatNum = True
    mblnFormatCell = True
End Sub