frmyh_yhdzdqc.frm

一个用VB写的财务软件源码

      End
      Begin VB.Menu mnuLine1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "退出(&X)"
      End
   End
   Begin VB.Menu mnuEdit 
      Caption         =   "编辑(&E)"
      Begin VB.Menu mnuNew 
         Caption         =   "增加"
         Shortcut        =   ^N
      End
      Begin VB.Menu mnuSave 
         Caption         =   "保存"
         Shortcut        =   ^S
      End
      Begin VB.Menu mnuCancel 
         Caption         =   "取消"
         Shortcut        =   ^C
      End
      Begin VB.Menu mnuDelete 
         Caption         =   "删除"
         Shortcut        =   ^D
      End
      Begin VB.Menu mnuLine2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFilter 
         Caption         =   "筛选"
         Shortcut        =   ^L
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
   End
End
Attribute VB_Name = "frmYH_Yhdzdqc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit


'以下一段常量用于窗体frm_print的CELL打印
'-------------------------------------------------------------
'Cell单元格对齐方式: 33 = 左对齐, 34 = 右对齐, 36 = 居中对齐;

Const ROWS_PAGE = 36                '每页行数

Const COL_START = 1                 '开始列
Const COL_RQ = 1                    '日期
Const COL_JSFS = 2                  '结算方式
Const COL_BILL_NUMBER = 3           '票号
Const COL_DEBIT_MONEY = 4           '借方金额
Const COL_CREDIT_MONEY = 5          '贷方金额
Const COL_ZY = 6                    '摘要
Const COL_END = 6

Const ROW_TITLE = 1                 '标题
Const ROW_BLANK = 2                 '空白行
Const ROW_SUBJNAME = 3              '页眉
Const ROW_HEAD1 = 4                 '页标头行
Const ROW_GRID_START = 5            '表格开始行

Const CRB_LINE = vbBlack            '表格线颜色

'缺省列宽
'CELL  1单元长度 = 3.8mm
Const ColWidth = "85,80,100,140,140,160"

Dim sEnterName As String                            '单位名称
Dim IsChangeCurrentTable As Boolean                 '是否改变当前表格中的内容
Dim frmP As frmPrint                                '通用打印窗体(CELL)
'-------------------------------------------------------------



Dim Myfrmcx As frmYH_Yhcxtj
Dim rstTemp As ADODB.Recordset
Dim adoCmd As ADODB.Command
Dim sSQL As String
Dim sSQLTemp As String
Dim i As Integer
Dim j As Integer
Dim OldRow As Integer           '当前获得焦点的单元格所在行数
Dim ErrorCol As Integer         '存放出错列
Dim NewRow As Integer           '表格移动到下一个获得焦点的单元格的行数
Dim NewCol As Integer           '表格移动到下一个获得焦点的单元格的列数
Dim CurrentRowNum As Integer    '存放新增表格行的行数
Dim IsModify As Boolean         '判断当前行的内容是否被修改
Dim IsDateModify As Boolean     '判断当前行的日期是否被修改, 用于表格自动按日期排序
Dim IsRefresh As Boolean        '当移动单元格时判断当前是否在刷新表格
Dim IsDelete As Boolean         '判断当前是否在删除状态
Dim frmH_Summ As New frmIN_Summary
Dim m_sjsfsName As String

Private Sub form_load()
    OldRow = 0
    IsModify = False
    IsDateModify = False
    IsRefresh = False
    IsDelete = False
    IsChangeCurrentTable = True
    
    Set Myfrmcx = New frmYH_Yhcxtj
    Set adoCmd = New ADODB.Command
    
    adoCmd.ActiveConnection = glo.cnnMain
    lblKmmc.Caption = frmYH_Yetjbqc.lblKmmc
    lblYhtzqye.Caption = "调整前余额：" & Format(frmYH_Yetjbqc.txtYhtzqye, "##,##0.00")
    
    Set rstTemp = New ADODB.Recordset
    rstTemp.CursorLocation = adUseClient
    
    sSQLTemp = "SELECT * FROM tZW_jsfs" & glo.sOperateYear & " WHERE bEnd =-1 order by cCode"
    rstTemp.Open sSQLTemp, glo.cnnMain, adOpenStatic, adLockReadOnly
    With rstTemp
        If Not (.EOF And .BOF) Then
            .MoveFirst
'            cboEdit.AddItem "    "
            Do Until .EOF
                cboEdit.AddItem Trim$("" & .Fields("cCode").value) & " " & Trim$("" & .Fields("cName").value)
                .MoveNext
            Loop
        Else
            MsgBox "请到初始菜单下设置结算方式！", vbInformation
        End If
    End With
    rstTemp.Close
    Set rstTemp = Nothing
  '  cboEdit.ListIndex = 0
    tbr.Buttons("save").Enabled = False
    tbr.Buttons("cancel").Enabled = False
    mnuSave.Enabled = False
    mnuCancel.Enabled = False
    Call SetHead
    
    Select Case g_FLAT
        Case "SQL"
            sSQL = "SELECT * FROM tZW_yhdzd" & glo.sOperateYear & _
                    " WHERE kmdm = '" & frmYH_Yhkmxz.Kmdm & _
                    "' AND qcbz = 1 AND hxbz = 0 AND rq < '" & _
                    Format(frmYH_Yetjbqc.dtpQyrq.value, "yyyy-mm-dd") & "' ORDER BY rq,jsfsCode,Bill"
        Case "ORACLE"
            sSQL = "SELECT * FROM tZW_yhdzd" & glo.sOperateYear & _
                    " WHERE kmdm = '" & frmYH_Yhkmxz.Kmdm & _
                    "' AND qcbz = 1 AND hxbz = 0 AND TO_CHAR(rq,'yyyy-mm-dd') < '" & _
                    Format(frmYH_Yetjbqc.dtpQyrq.value, "yyyy-mm-dd") & "' ORDER BY rq,jsfsCode,Bill"
    End Select
    Call FillGrid(sSQL)
    
    '------------------------------
    '得到当前账套的单位名称
    sEnterName = GetDWMC
    If sEnterName = "" Then
        MsgBox "缺少单位名称！", vbInformation
        Exit Sub
    End If
    
    '根据当前MSFLEXGRID表格生成CELL表格
    If IsChangeCurrentTable Then
        IsChangeCurrentTable = False
        Call DrawCellTable
    End If
    
    '------------------------------
    
    Load Myfrmcx
End Sub

'设置表头
Private Sub SetHead()
    With mfgYhdzdqc
'将表格的第一列隐藏, 第一列用于存放银行对账单表的主键id
        .ColWidth(0) = 0
        .ColWidth(1) = 1300
        .ColWidth(2) = 1500
        .ColWidth(3) = 1200
        .ColWidth(4) = 1800
        .ColWidth(5) = 1800
        .ColWidth(6) = 3000
        .ColAlignment(0) = 4
        .ColAlignment(1) = 4
        .ColAlignment(2) = 1
        .ColAlignment(3) = 4
        .ColAlignment(4) = 7
        .ColAlignment(5) = 7
        .ColAlignment(6) = 1
        .row = 0
        .RowHeight(0) = 400
        For j = 0 To .Cols - 1
            .col = j
            .CellFontSize = 11
            .CellAlignment = 4
        Next j
    End With
    cmdHelp.Height = 300
    cmdHelp.Width = 320
    dtpEdit.value = Date
End Sub

'从银行对账单表中取出期初对账单, 然后填充表格;
Private Sub FillGrid(ByVal sSQL As String)
    Dim i As Integer
    Dim j As Integer
    mfgYhdzdqc.Redraw = False
    IsRefresh = True
    Set rstTemp = New ADODB.Recordset
    rstTemp.CursorLocation = adUseClient
    With rstTemp
        .Open sSQL, glo.cnnMain, adOpenStatic, adLockReadOnly
        mfgYhdzdqc.Rows = 1
        If .RecordCount = 0 Then
            tbr.Buttons("delete").Enabled = False
            mnuDelete.Enabled = False
        Else
            .MoveFirst
            For i = 1 To .RecordCount
                If .Fields("fx").value = "借" Then
                    mfgYhdzdqc.AddItem .Fields("id").value & vbTab & _
                                        Format(.Fields("rq").value, "yyyy-mm-dd") & vbTab & _
                                        Trim$("" & .Fields("jsfsCode").value) & (" " & .Fields("jsfsname").value) & vbTab & _
                                        Trim$("" & .Fields("bill").value) & vbTab & _
                                        Format(.Fields("je").value, "##,##0.00") & vbTab & _
                                        "" & vbTab & _
                                        Trim$("" & .Fields("zy").value) & vbTab & i
                Else
                    mfgYhdzdqc.AddItem .Fields("id").value & vbTab & _
                                        Format(.Fields("rq").value, "yyyy-mm-dd") & vbTab & _
                                        Trim$("" & .Fields("jsfsCode").value) & (" " & .Fields("jsfsname").value) & vbTab & _
                                        Trim$("" & .Fields("bill").value) & vbTab & _
                                        "" & vbTab & _
                                        Format(.Fields("je").value, "##,##0.00") & vbTab & _
                                        Trim$("" & .Fields("zy").value) & vbTab & i
                End If
                If .Fields("lqbz").value > 0 Then
                    mfgYhdzdqc.row = i
                    For j = 0 To mfgYhdzdqc.Cols - 1
                        mfgYhdzdqc.col = j
                        mfgYhdzdqc.CellBackColor = &HFFFFC0
                    Next j
                End If
                .MoveNext
            Next i
        End If
    End With
    With mfgYhdzdqc
        For i = 1 To mfgYhdzdqc.Rows - 1
            .RowHeight(i) = cboEdit.Height
        Next i
        .row = 0
        .col = 0
    End With
    mfgYhdzdqc.Redraw = True
    IsRefresh = False
End Sub

Private Sub cboEdit_KeyDown(KeyCode As Integer, Shift As Integer)
    With mfgYhdzdqc
        Select Case KeyCode
            Case vbKeyLeft
                If .col > 1 Then
                    .col = .col - 1
                End If
            Case vbKeyRight
                If .col < .Cols - 1 Then
                    .col = .col + 1
                End If
            Case vbKeyReturn
                If .col < .Cols - 1 Then
                    .col = .col + 1
                End If
        End Select
    End With
End Sub


Private Sub cmdHelp_Click()
    frmH_Summ.ubSelectStatus = True
    frmH_Summ.usKmdm = frmYH_Yhkmxz.Kmdm
    frmH_Summ.Show 1, Me
    If frmH_Summ.Ok Then
        txtEdit.text = frmH_Summ.txtName
    End If
    Unload frmH_Summ
End Sub

'根据所按方向键改变表格的焦点
Private Sub dtpEdit_KeyDown(KeyCode As Integer, Shift As Integer)
   If KeyCode = 13 Then
     With mfgYhdzdqc
          dtpEdit.Visible = False
         .TextMatrix(.row, .col) = Format(dtpEdit.value, "YYYY-MM-DD")
         If .col < .Cols - 1 Then
            .col = .col + 1
         End If
        .Refresh
      End With
   End If
End Sub

'当进入新的单元格时, 判断新的单元格的行数是否于老的单元格行数不同并且老的单元格行数不等于0
'并且当前不是在表格刷新状态,
'如果是, 判断老的单元格所在行的数据是否合法,
'如果合法, 判断老的单元格所在行的数据是否被修改并且当前行不是在增加状态,
'如果条件为真, 则修改数据库中表的内容
Private Sub mfgYhdzdqc_EnterCell()
    On Error Resume Next
    With mfgYhdzdqc
        If .Visible And OldRow > 0 And .row > 0 And Not IsRefresh And Not IsDelete Then
            NewRow = .row
            If NewRow <> OldRow Then
                NewCol = .col
                If Not IsValidate Then
                    IsRefresh = True
                    .row = OldRow
                    .col = ErrorCol
                    IsRefresh = False
                    Exit Sub
                ElseIf IsModify Then
                    If NewRow < OldRow Then
                        If Not tbr.Buttons("new").Enabled Then
                            Call InsertCurrentRow
                            With tbr
                                .Buttons("print").Enabled = True