利息计算.frm

不处的管理软件包

      End
   End
   Begin ComctlLib.ImageList ImageList2 
      Left            =   0
      Top             =   0
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      MaskColor       =   12632256
      _Version        =   327682
   End
   Begin ComctlLib.ImageList ImageList1 
      Left            =   3420
      Top             =   2520
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      MaskColor       =   12632256
      _Version        =   327682
   End
End
Attribute VB_Name = "frmLxjs"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'软件著作权: 北京用友软件集团有限公司
'系统名称: 资金管理8.0
'功能说明: 利息计算

Option Explicit

Dim drag As Boolean
Dim starty As Single, endy As Single
Dim mintop As Single, maxtop As Single

Dim b_sd_null As Boolean
Dim dEday As Date, dBday As Date
Dim vBday As Variant
Dim lx As Currency

Dim aTemp As clsAllInput
Dim iCalType As Long '利息计算类型 cuidong 2001.10.11

Private Sub cmd1_Click()
    DisplayCalendar edSdate, Me.hwnd, Frame1.left, Frame1.top
    edSdate.SetFocus
End Sub

Private Sub cmd2_Click()
    DisplayCalendar edEDate, Me.hwnd, Frame1.left, Frame1.top
    edEDate.SetFocus
End Sub

Private Sub cobtype_Click()
    If cobtype.ListIndex = 0 Then
        edid(0).Text = ""
        edid(1).Text = ""
    End If
End Sub

Private Sub Command2_Click(Index As Integer)
    'cuidong 2001.10.11
    '----------------------------------
    Select Case Index
    Case 0
        iCalType = 0 '利息计算
    Case 1
        iCalType = 1 '预提利息
    End Select
    '----------------------------------
    GenLxjs
End Sub

Private Sub edAccCode_Change()
    Dim bfind As Boolean
    Dim str As String
    str = AccCodeToUnitName(edAccCode, bfind)
    edUnitName = IIf(bfind, str, "")
End Sub

Private Sub edAccCode_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 113 Then   'F2
        RefCmd1(1).RunReference
    End If
End Sub

Private Sub edEDate_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 113 Then 'F2
        DisplayCalendar edEDate, Me.hwnd, Frame1.left, Frame1.top
        edSdate.SetFocus
    End If
End Sub

Private Sub edEDate_LostFocus()
   If edEDate <> "" Then
      edEDate = ForDate(edEDate)
      If IsDate(edEDate) Then edEDate = FormatDate(edEDate)
   End If
End Sub

Private Sub edID_LostFocus(Index As Integer)
    edid(Index).Text = IIf(edid(Index) <> "", right("0000000000" & edid(Index), 10), "")
    If Index = 0 Then
        If edid(0) <> "" And edid(1) = "" Then
            edid(1) = edid(0)
        ElseIf edid(0) <> "" And edid(1) <> "" And edid(0).Text > edid(1).Text Then
            edid(1).Text = edid(0).Text
        End If
    ElseIf Index = 1 Then
        If edid(1) <> "" And edid(0) = "" Then
            edid(0) = edid(1)
        ElseIf edid(1) <> "" And edid(0) <> "" And edid(0).Text > edid(1).Text Then
            edid(0).Text = edid(1).Text
        End If
    End If
End Sub

Private Sub edSdate_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 113 Then  'F2
        DisplayCalendar edSdate, Me.hwnd, Frame1.left, Frame1.top
        edSdate.SetFocus
    End If
End Sub

Private Sub edSdate_LostFocus()
   If edSdate <> "" Then
      edSdate = ForDate(edSdate)
      If IsDate(edSdate) Then
         edSdate = FormatDate(edSdate)
      End If
   End If
End Sub

Private Sub edUnitName_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 113 Then   'F2
        RefCmd1(0).RunReference
    End If
End Sub

Private Sub edUnitName_LostFocus()
    edUnitName.Text = EntCodeToName(edUnitName.Text)
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyP
            If Shift = 2 And tlb.Buttons("Print").Enabled Then
                Gen_Key "Print"
            End If
        Case vbKeyS
            'cuidong 2001.01.15
            'If Shift = 2 And tlb.Buttons("Preview").Enabled Then
            '    Gen_Key "Preview"
            'End If
        Case vbKeyW
            If Shift = 2 And tlb.Buttons("Dataout").Enabled Then
                Gen_Key "Dataout"
            End If
        Case vbKeyF6
            If Shift = 0 And tlb.Buttons("save").Enabled Then
                Gen_Key "save"
            End If
        Case vbKeyR
            If Shift = 2 And tlb.Buttons("lxjs").Enabled Then
                Gen_Key "lxjs"
            End If
        Case vbKeyF4
            If Shift = 2 Then
                Gen_Key "exit"
            ElseIf Shift = 0 And tlb.Buttons("bill").Enabled Then
                Gen_Key "bill"
            End If
    End Select
End Sub
Private Sub Form_Load()
    Screen.MousePointer = vbHourglass
    Me.Icon = LoadResPicture(109, vbResIcon)
    ImageList_Initialize ImageList1
    ToolBar_Initialize tlb, "Print", TB_PRINT
    ToolBar_Initialize tlb, "Preview", TB_PREVIEW
    ToolBar_Initialize tlb, "Dataout", TB_DATAOUT
    ToolBar_Initialize tlb, "lxjs", TB_CALC
    ToolBar_Initialize tlb, "save", TB_SAVE
    ToolBar_Initialize tlb, "bill", TB_BILL
    ToolBar_Initialize tlb, "help", TB_HELP
    ToolBar_Initialize tlb, "exit", TB_EXIT
    Command2(0).Picture = LoadResPicture(125, vbResBitmap)
    cmd1.Picture = LoadResPicture(1108, vbResBitmap)
    cmd2.Picture = LoadResPicture(1108, vbResBitmap)
    cmd3.Picture = LoadResPicture(129, vbResBitmap)
    Grid_init
    load_data
    Screen.MousePointer = vbDefault
End Sub

Private Sub load_data()
    With cobtype
        .AddItem ""
        .AddItem Ywbhtoname("01")
        .AddItem Ywbhtoname("03")
        .AddItem Ywbhtoname("05")
        .AddItem Ywbhtoname("06")
        .AddItem Ywbhtoname("07")
        .ListIndex = 0
    End With
End Sub

Private Sub Form_Resize()
    ResizeFrmLxjs Me, Frame1, Resize1, grid, FRM_LXJS_WIDTH, FRM_LXJS_HEIGHT
    mintop = (Me.Height - Me.tlb.Height) * 0.15
    maxtop = (Me.Height - Me.tlb.Height) * 0.9
End Sub

Private Sub Form_Unload(Cancel As Integer)
    zjLogInfo.TaskExec "FD0504", 0, zjLogInfo.cIYear
    zjLogInfo.ClearError
    zjGen_arr.FD0504 = False
End Sub

Private Sub grid_DblClick()
    With grid
        If .Rows = 2 And .RowHeight(1) = 0 Then Exit Sub
        GenUnionFind .TextMatrix(.row, 2)
    End With
End Sub

Private Sub ref1_CodeSelected(Code As String)
    edUnitName = Code
End Sub

Private Sub ref2_CodeSelected(Code As String)
    edAccCode = Code
    edAccCode.SetFocus
End Sub

Private Sub GenLxjs()
  If Not Valid Then Exit Sub
  Screen.MousePointer = vbHourglass
  If edSdate = "" Then
    b_sd_null = True
  Else
    dBday = edSdate
    b_sd_null = False
  End If
  dEday = edEDate
  If cobtype.ListIndex <> 0 Then
    lxjs_mx LXJS_M_BILL
  ElseIf edAccCode <> "" Then
    lxjs_mx LXJS_M_ACC
  Else
    lxjs_mx LXJS_M_UNIT
  End If
  Screen.MousePointer = vbDefault
End Sub

Private Sub lxjs_mx(iType As LxjsMethod)
    Dim sql As String
    Dim rsl As New UfRecordset
    Dim lx As Variant
    Dim i As Integer
    
    With grid
      For i = .Rows - 1 To 2 Step -1
         .RemoveItem i
      Next i
      .Rows = 2
      .RowHeight(1) = 0
    End With
    '1、贷款单据计算
    If ReBillRs(iType, Cred_Bill, rsl) Then
        While Not rsl.EOF
            lx = lxjs_busid(rsl, Cred_Bill)
            If Not IsNull(lx) Then
                fill_grid rsl!cAccId, rsl!cCreID, edSdate, edEDate.Text, CCur(lx), 1
            End If
            rsl.MoveNext
        Wend
    End If
    '2、存款单据计算
    If ReBillRs(iType, Save_Bill, rsl) Then
        While Not rsl.EOF
            lx = lxjs_busid(rsl, Save_Bill)
            If Not IsNull(lx) Then
                fill_grid rsl!cAccId, rsl!cSavID, edSdate.Text, edEDate.Text, CCur(lx), 0
            End If
            rsl.MoveNext
        Wend
    End If
    '3、内部拆借计算
    If ReBillRs(iType, UnwDeb_Bill, rsl) Then
        While Not rsl.EOF
            lx = lxjs_busid(rsl, UnwDeb_Bill)
            If Not IsNull(lx) Then
'                fill_grid rsl!cPAccID, rsl!cUnwID, edSdate.Text, edEDate.Text, CCur(lx), 1 'Cuidong 2000.12.28
                fill_grid rsl!cPAccID, rsl!cUnwID, edSdate.Text, edEDate.Text, CCur(lx), 0  'Cuidong 2000.12.28
            End If
            rsl.MoveNext
        Wend
    End If
    '4、累积类账户计算
    If iType <> LXJS_M_BILL Then
        Dim vCde As Variant
        If ReBillRs(iType, Lj_Bill, rsl) Then
            While Not rsl.EOF
                lx = lxjs_busid(rsl, Lj_Bill, vCde)
                If Not IsNull(lx) Then
                    If iType = LXJS_M_ACC Or iType = LXJS_M_UNIT Then
                        fill_grid rsl!cAccId, "", "", edEDate.Text, CCur(lx) - CCur(vCde), 0, vCde
                    Else
                        fill_grid rsl!cAccId, "", "", edEDate.Text, CCur(lx), 0
                    End If
                End If
                rsl.MoveNext
            Wend
        End If
    End If
    If grid.Rows = 2 And grid.RowHeight(1) = 0 Then
         grid.ColWidth(6) = 0
         grid.TextMatrix(0, 5) = "利息"
         MsgBox "没有可计算的单据!", vbInformation, zjGl_Name
    End If
    CloseRS rsl
End Sub

Private Sub fill_grid(AccCode As String, busid As String, _
                      bdt As String, edt As String, lx As Currency, isf As Byte, Optional cdeLx As Variant)

Dim UnitName As String
Dim itmX As String
Dim cBusid As String

  Select Case left(busid, 2)
    Case "01"
      cBusid = Ywbhtoname("01") & "-" & mID(busid, 3)
    Case "03"
      cBusid = Ywbhtoname("03") & "-" & mID(busid, 3)
    Case "05"
      cBusid = Ywbhtoname("05") & "-" & mID(busid, 3)
    Case "06"
      cBusid = Ywbhtoname("06") & "-" & mID(busid, 3)
    Case "07"
      cBusid = Ywbhtoname("07") & "-" & mID(busid, 3)
  End Select
  
  UnitName = AccCodeToUnitName(AccCode)
       
  Dim strCde As String
  If Not IsMissing(cdeLx) Then strCde = MoneyFormat(cdeLx)
  With grid
    If .Rows = 2 And .RowHeight(1) = 0 Then '.TextMatrix(1, 0) = "" Then
      .RowHeight(1) = 260
      .TextMatrix(1, 0) = UnitName
      .TextMatrix(1, 1) = AccCode
      .TextMatrix(1, 2) = cBusid