frmtaskfinancecharge.frm

金算盘软件代码

VERSION 5.00
Object = "{D252F124-F62C-11D1-9ABD-444553540000}#1.0#0"; "GADATE.DLL"
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Object = "{0D452EE1-E08F-101A-852E-02608C4D0BB4}#2.0#0"; "FM20.DLL"
Object = "{F6125AB1-8AB1-11CE-A77F-08002B2F4E98}#2.0#0"; "MSRDC20.OCX"
Object = "{81110CCB-022B-11D3-A348-0080C89152FF}#1.3#0"; "ORAGLIST.OCX"
Begin VB.Form frmTaskFinanceCharge 
   Caption         =   "应收计息"
   ClientHeight    =   3765
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7620
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   3765
   ScaleWidth      =   7620
   Begin MSRDC.MSRDC datAR 
      Height          =   495
      Left            =   720
      Top             =   1920
      Visible         =   0   'False
      Width           =   1635
      _ExtentX        =   2884
      _ExtentY        =   873
      _Version        =   393216
      Options         =   0
      CursorDriver    =   0
      BOFAction       =   0
      EOFAction       =   0
      RecordsetType   =   1
      LockType        =   3
      QueryType       =   0
      Prompt          =   3
      Appearance      =   1
      QueryTimeout    =   30
      RowsetSize      =   100
      LoginTimeout    =   15
      KeysetSize      =   0
      MaxRows         =   0
      ErrorThreshold  =   -1
      BatchSize       =   15
      BackColor       =   -2147483643
      ForeColor       =   -2147483640
      Enabled         =   -1  'True
      ReadOnly        =   0   'False
      Appearance      =   -1  'True
      DataSourceName  =   ""
      RecordSource    =   ""
      UserName        =   ""
      Password        =   ""
      Connect         =   ""
      LogMessages     =   ""
      Caption         =   "MSRDC1"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin GACALENDARLibCtl.Calendar cldTaskDate 
      Height          =   285
      Left            =   1050
      OleObjectBlob   =   "frmTaskFinanceCharge.frx":0000
      TabIndex        =   9
      Top             =   60
      Width           =   1575
   End
   Begin VB.CommandButton cmdOk 
      Caption         =   "参数设置(&S)"
      Height          =   350
      Index           =   6
      Left            =   6315
      TabIndex        =   6
      Tag             =   "1001"
      Top             =   2820
      Width           =   1215
   End
   Begin VB.CommandButton cmdOk 
      Caption         =   "全部取消(&U)"
      Height          =   350
      Index           =   5
      Left            =   6315
      TabIndex        =   5
      Tag             =   "1001"
      Top             =   2400
      Width           =   1215
   End
   Begin VB.CommandButton cmdOk 
      Caption         =   "条件选择(&B)"
      Height          =   350
      Index           =   4
      Left            =   6315
      TabIndex        =   4
      Tag             =   "1001"
      Top             =   2040
      Width           =   1215
   End
   Begin VB.CommandButton cmdOk 
      Caption         =   "全部选择(&M)"
      Height          =   350
      Index           =   3
      Left            =   6315
      TabIndex        =   3
      Tag             =   "1001"
      Top             =   1680
      Width           =   1215
   End
   Begin VB.CommandButton cmdOk 
      Caption         =   "应收资料(&P)"
      Height          =   350
      Index           =   2
      Left            =   6315
      TabIndex        =   2
      Tag             =   "1001"
      Top             =   1260
      Width           =   1215
   End
   Begin VB.CommandButton cmdOk 
      Height          =   350
      Index           =   1
      Left            =   6315
      Style           =   1  'Graphical
      TabIndex        =   1
      Tag             =   "1002"
      Top             =   840
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.CommandButton cmdOk 
      Height          =   350
      Index           =   0
      Left            =   6315
      Style           =   1  'Graphical
      TabIndex        =   0
      Tag             =   "1001"
      Top             =   480
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin ListRefer.ListText ltxtTemplate 
      Height          =   300
      Left            =   4425
      TabIndex        =   11
      Top             =   60
      Width           =   1815
      _ExtentX        =   3201
      _ExtentY        =   556
      BackColor       =   -2147483643
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin MSFlexGridLib.MSFlexGrid msgTask 
      Bindings        =   "frmTaskFinanceCharge.frx":0089
      Height          =   3210
      Left            =   45
      TabIndex        =   12
      Top             =   450
      Width           =   6180
      _ExtentX        =   10901
      _ExtentY        =   5662
      _Version        =   393216
      Cols            =   20
      FixedCols       =   0
      BackColorFixed  =   -2147483644
      BackColorSel    =   -2147483646
      BackColorBkg    =   16777215
      Redraw          =   -1  'True
      AllowBigSelection=   0   'False
      FocusRect       =   0
      SelectionMode   =   1
   End
   Begin VB.Label label1 
      AutoSize        =   -1  'True
      Caption         =   "单据模版(&T)"
      Height          =   180
      Index           =   1
      Left            =   3435
      TabIndex        =   10
      Top             =   120
      Width           =   990
   End
   Begin MSForms.CheckBox chkProBill 
      Height          =   345
      Left            =   6315
      TabIndex        =   7
      Top             =   3210
      Width           =   1185
      BackColor       =   -2147483633
      ForeColor       =   -2147483630
      DisplayStyle    =   4
      Size            =   "2090;609"
      Value           =   "1"
      Caption         =   "生成单据"
      FontName        =   "宋体"
      FontHeight      =   180
      FontCharSet     =   134
      FontPitchAndFamily=   34
   End
   Begin VB.Label label1 
      AutoSize        =   -1  'True
      Caption         =   "计息日期(&D)"
      Height          =   180
      Index           =   0
      Left            =   60
      TabIndex        =   8
      Top             =   120
      Width           =   990
   End
End
Attribute VB_Name = "frmTaskFinanceCharge"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   财务费用窗体
'   作者:肖宇
'   日期:1998.06.23
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

Private Const mlngFormMinWidth = 600                            '窗体最小尺寸
Private Const mlngFormMinHeight = 300
Private Const mlngLeft = 50
Private Const mlngTop = 450
Private Const mlngBottomHeight = 80

Private Const mintColCustomerID = 0
Private Const mintColCurrencyID = 1
Private Const mintColCurrencyDec = 2
Private Const mintColCheck = 3
Private mintColDate As Integer
Private mintColCustomer As Integer
Private mintColCurrency As Integer
Private mintColAmount As Integer
Private mintColInterest As Integer


Private WithEvents mclsList As Grid                            'Grid类
Attribute mclsList.VB_VarHelpID = -1
Private WithEvents mclsMainControl As MainControl   'MainControl类
Attribute mclsMainControl.VB_VarHelpID = -1
Private WithEvents mclsSubClassform As SubClass32.SubClass
Attribute mclsSubClassform.VB_VarHelpID = -1

Private Const MyViewID = 117
Private mdtmDate As Date
Private mblnExit As Boolean
Private mlngActivityID As Long
Private mblnDepartment As Boolean
Private mblnEmployee As Boolean
Private mblnClass1 As Boolean
Private mblnClass2 As Boolean

Private Type CustomerDetail
    lngCustomerID As Long
    lngCurrencyID As Long
    lngDepartmentID As Long
    lngEmployeeID As Long
    lngClassID1 As Long
    lngClassID2 As Long
    dblAmount As Double
End Type

Private marrcustomer() As CustomerDetail

'生成计提财务费用列表
Public Function GetTaskList(Optional strCond As String = "") As rdoResultset
    Dim strSql As String
    Dim strARSum As String
    
    On Error Resume Next
    '在fmd的基础上创建QueryDef对象Tasklist,并用它打开记录集
    strSql = "SELECT QARDetail.lngCustomerID,QARDetail.lngCurrencyID," _
        & "SUM(QARDetail.dblCurrAmount) As dblCurrAmount " _
        & " FROM QARDetail "
    '过期应收款
    If Not frmSetTaskPara.ByARBalance Then
        If frmSetTaskPara.ByDueDay Then
            strSql = strSql & "WHERE TO_DATE('" & cldTaskDate.Text & "','RRRR-MM-DD')-TO_DATE(strDueDate,'RRRR-MM-DD')>" & frmSetTaskPara.Days
        Else
            strSql = strSql & "WHERE TO_DATE('" & cldTaskDate.Text & "','RRRR-MM-DD')-TO_DATE(strReceiptDate,'RRRR-MM-DD')> " & frmSetTaskPara.Days
        End If
        strSql = strSql & " AND dblCurrAmount>0 "
    Else
        If frmSetTaskPara.ByDueDay Then
            strSql = strSql & "WHERE (dblCurrAmount>0 AND TO_DATE('" & cldTaskDate.Text & "','RRRR-MM-DD')-TO_DATE(strDueDate,'RRRR-MM-DD')>" & frmSetTaskPara.Days _
                & " OR dblCurrAmount<0 AND strReceiptDate<'" & cldTaskDate.Text & "') "
        Else
            strSql = strSql & "WHERE (dblCurrAmount>0 AND TO_DATE('" & cldTaskDate.Text & "','RRRR-MM-DD')-TO_DATE(strReceiptDate,'RRRR-MM-DD')>" & frmSetTaskPara.Days _
                & " OR dblCurrAmount<0 AND strReceiptDate<'" & cldTaskDate.Text & "') "
        End If
    End If
    '不计算复利
    If Not frmSetTaskPara.Duplicate Then
        strSql = strSql & " AND lngActivityTypeID<>38 "
    End If
    strSql = strSql & " GROUP BY QARDetail.lngCustomerID,QARDetail.lngCurrencyID"
    
    strARSum = "(" & strSql & ") QARSum"
    
    strSql = "SELECT QARSum.lngCustomerID,QARSum.lngCurrencyID,Currencys.bytCurrencyDec,'' As 选择," _
        & mclsList.ListSet.SelectOfSql & " " & Replace(mclsList.ListSet.FromOfSql, "[QARSUM]", strARSum) _
        & " WHERE " & mclsList.ListSet.WhereOfSql & " AND dblCurrAmount>0 AND strLastFCDate<'" & cldTaskDate.Text & "'"
    '筛选条件
    If strCond <> "" Then
        strSql = strSql & " AND (" & strCond & ")"
    End If
    Set GetTaskList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
End Function

Private Sub ResetAttribute(ByVal lngCustomerID As Long)
    Dim strSql As String
    Dim recCustomer As rdoResultset
    Dim lngARAccountID As Long
    
    mblnDepartment = False
    mblnEmployee = False
    mblnClass1 = False
    mblnClass2 = False
    strSql = "SELECT lngARAccountID FROM Customer WHERE lngCustomerID=" & lngCustomerID
    'Set recCustomer = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
    Set recCustomer = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recCustomer.EOF Then
        lngARAccountID = recCustomer!lngARAccountID
        strSql = "SELECT * FROM Account WHERE lngAccountID=" & lngARAccountID
        'Set recCustomer = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
        Set recCustomer = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recCustomer.EOF Then
            'mblnDepartment = recCustomer!blnIsDepartment
            'mblnEmployee = recCustomer!blnIsEmployee
            'mblnClass1 = recCustomer!blnIsClass1
            'mblnClass2 = recCustomer!blnIsClass2
            mblnDepartment = IIf(recCustomer!blnIsDepartment = 1, True, False)
            mblnEmployee = IIf(recCustomer!blnIsEmployee = 1, True, False)
            mblnClass1 = IIf(recCustomer!blnIsClass1 = 1, True, False)
            mblnClass2 = IIf(recCustomer!blnIsClass2 = 1, True, False)
        End If
    End If
    recCustomer.Close
    Set recCustomer = Nothing
End Sub

Private Sub AddArray(lngRow As Long, lngCustomerID As Long, lngCurrencyID As Long, lngDepartmentID As Long, _