📄 frmyh_djwh.frm

📁 一个用VB写的财务软件源码
💻 FRM
📖 第 1 页 / 共 2 页
字号:
上一页 12

Private Sub SetTextVisible(ByVal b As Boolean)
txtEdit.Visible = False
cboJsfs.Visible = False
If mFg.Row >= mFg.FixedRows Then
    Select Case mFg.Col
    Case 5
        cboJsfs.Visible = b
        If Trim$(cboJsfs.text) <> Trim$(mFg.TextMatrix(mFg.Row, mFg.Col)) And b = False Then
            mFg.TextMatrix(mFg.Row, mFg.Col) = Trim$(cboJsfs.text)
            cboJsfs.ListIndex = -1
            mFg.CellBackColor = vbYellow
        End If
        If cboJsfs.Visible = True Then
            cboJsfs.SetFocus
        End If
    Case 6
        txtEdit.Visible = b
        If Trim$(txtEdit.text) <> Trim$(mFg.TextMatrix(mFg.Row, mFg.Col)) And b = False Then
            mFg.TextMatrix(mFg.Row, mFg.Col) = Trim$(txtEdit.text)
            txtEdit.text = ""
            mFg.CellBackColor = vbYellow
        End If
        If txtEdit.Visible = True Then
            txtEdit.SetFocus
        End If
    Case 7
        txtEdit.Visible = b
        If Trim$(txtEdit.text) <> Trim$(mFg.TextMatrix(mFg.Row, mFg.Col)) And b = False Then
            If IsDate(Trim$(txtEdit.text)) = True Then
                If Format(Trim$(txtEdit.text), "yyyy-MM-dd") <= Format(mFg.TextMatrix(mFg.Row, 2), "yyyy-MM-dd") Then
                    mFg.TextMatrix(mFg.Row, mFg.Col) = Trim$(txtEdit.text)
                End If
            End If
            txtEdit.text = ""
            mFg.CellBackColor = vbYellow
        End If
        If txtEdit.Visible = True Then
            txtEdit.SetFocus
        End If
    End Select
End If
End Sub

Private Sub MoveText()
If bEnableEnterCell = False Then Exit Sub
    With mFg
        
        If .CellLeft > 0 And .CellTop > 0 Then
            Select Case .Col
            Case 7
                txtEdit.Move .Left + .CellLeft, .Top + .CellTop, .cellWidth, .cellHeight
                txtEdit.text = .TextMatrix(.Row, .Col)
            Case 6
                txtEdit.Move .Left + .CellLeft, .Top + .CellTop, .cellWidth, .cellHeight
                txtEdit.text = .TextMatrix(.Row, .Col)
            Case 5
                cboJsfs.Move .Left + .CellLeft, .Top + .CellTop, .cellWidth
                On Error GoTo Err:
                cboJsfs.text = .TextMatrix(.Row, .Col)
                If 1 = 2 Then
Err:                   cboJsfs.ListIndex = -1
                End If
                On Error GoTo 0
            End Select
            SetTextVisible True
        Else
            SetTextVisible False
        End If
    End With
End Sub


Private Sub mFg_EnterCell()
If bEnableEnterCell = False Then Exit Sub
If mFg.Col = 6 Or mFg.Col = 5 Or mFg.Col = 7 Then
    MoveText
Else
    SetTextVisible False
End If
End Sub

Private Sub mFg_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    If mFg.Col = mFg.Cols - 1 Then
        If mFg.Row >= mFg.Rows - 1 Then
        Else
            mFg.Row = mFg.Row + 1
        End If
        mFg.Col = 1
    Else
        mFg.Col = mFg.Col + 1
    End If
End If
End Sub

Private Sub mFg_LeaveCell()
If bEnableEnterCell = False Then Exit Sub
SetTextVisible False
End Sub

Private Sub mfg_Scroll()
With mFg
    If .ColIsVisible(.Col) And .ColPos(.Col) + .ColWidth(.Col) <= .Width And .RowPos(.Row) + .RowHeight(.Row) <= .Height And .RowIsVisible(.Row) Then
        mFg_EnterCell
    Else
        mFg_LeaveCell
    End If
End With
End Sub

Private Sub mnuFileExit_Click()
Unload Me
End Sub

Public Sub ShowResult()
FillMfg MakeSql
End Sub

Public Function MakeSql() As String
Dim sWhere As String
MakeSql = "Select Pzrq,Pzzl,Pzbh,yhdz_jsfscode,yhdz_jsfs,yhdz_bill,Yhdz_Date,pzzy,hl,wb,je,fx,jlhm from tZW_Pzsj" + m_sYear
Select Case g_FLAT
Case "ORACLE"
    sWhere = " where pzrq<=to_date('" + m_sToDate + "','yyyy-mm-dd') and pzrq>=to_date('" + m_sFromDate + "','yyyy-mm-dd') and kmdm like '" + m_sSubjectCode + "%' and kjqj>=1 and kjqj<=12"
Case "SQL"
    sWhere = " where pzrq<='" + m_sToDate + "' and pzrq>='" + m_sFromDate + "' and kmdm like '" + m_sSubjectCode + "%' and kjqj>=1 and kjqj<=12"
End Select
MakeSql = MakeSql + sWhere + " order by Pzrq,Pzzl,Pzbh,jlhm"
End Function

'''''
'填充mfg
Public Sub FillMfg(ByVal sSQL As String)
Dim rSt As New Recordset
Dim s As String
Dim i As Integer
Dim iRow As Integer
Dim d As Double
Dim sPzrq As String
Dim sPzzy As String
rSt.CursorLocation = adUseClient
rSt.Open sSQL, glo.cnnMain, adOpenKeyset, adLockPessimistic

mFg.Rows = mFg.FixedRows + rSt.RecordCount
iRow = 1
While rSt.EOF = False
    With mFg
        mFg.RowHeight(iRow) = 315
        .TextMatrix(iRow + mFg.FixedRows - 1, 0) = FormatToString(rSt.Fields("jlhm").value)
        .TextMatrix(iRow + mFg.FixedRows - 1, 1) = CStr(iRow)
        If Trim$(sPzrq) = FormatToString(rSt.Fields("Pzrq").value) Then
            sPzrq = sPzrq + " "
        Else
            sPzrq = FormatToString(rSt.Fields("Pzrq").value)
        End If
        .TextMatrix(iRow + mFg.FixedRows - 1, 2) = sPzrq
        
        .TextMatrix(iRow + mFg.FixedRows - 1, 3) = FormatToString(rSt.Fields("Pzzl").value)
        .TextMatrix(iRow + mFg.FixedRows - 1, 4) = FormatToString(rSt.Fields("Pzbh").value)
        If Trim$(FormatToString(rSt.Fields("Yhdz_jsfsCode").value)) <> "" And Trim$(FormatToString(rSt.Fields("Yhdz_jsfsCode").value)) <> "" Then
            .TextMatrix(iRow + mFg.FixedRows - 1, 5) = Trim$(FormatToString(rSt.Fields("Yhdz_jsfsCode").value)) + "=" + Trim$(FormatToString(rSt.Fields("Yhdz_jsfs").value))
        Else
            .TextMatrix(iRow + mFg.FixedRows - 1, 5) = ""
        End If
        .TextMatrix(iRow + mFg.FixedRows - 1, 6) = FormatToString(rSt.Fields("Yhdz_bill").value)
        If .TextMatrix(iRow + mFg.FixedRows - 2, 7) <> FormatToString(rSt.Fields("Yhdz_Date").value) Then
            .TextMatrix(iRow + mFg.FixedRows - 1, 7) = FormatToString(rSt.Fields("Yhdz_Date").value)
        Else
            .TextMatrix(iRow + mFg.FixedRows - 1, 7) = FormatToString(rSt.Fields("Yhdz_Date").value) + " "
        End If
        If sPzzy = FormatToString(rSt.Fields("Pzzy").value) Then
            sPzzy = sPzzy + " "
        Else
            sPzzy = FormatToString(rSt.Fields("Pzzy").value)
        End If
        .TextMatrix(iRow + mFg.FixedRows - 1, 8) = sPzzy
        Select Case cboStyle.text
        Case "金额式"
            d = FormatToDouble(rSt.Fields("Je").value)
            If Abs(d) > 0.0005 Then
                If Left$(rSt.Fields("fx").value, 1) = "借" Then
                    .TextMatrix(iRow + mFg.FixedRows - 1, 9) = Format(d, "#,###0.00")
                    If .TextMatrix(iRow + mFg.FixedRows - 1, 9) = .TextMatrix(iRow + mFg.FixedRows - 2, 9) Then
                        .TextMatrix(iRow + mFg.FixedRows - 1, 9) = .TextMatrix(iRow + mFg.FixedRows - 1, 9) + vbLf
                    End If
                Else
                    .TextMatrix(iRow + mFg.FixedRows - 1, 10) = Format(d, "#,###0.00")
                    If .TextMatrix(iRow + mFg.FixedRows - 1, 10) = .TextMatrix(iRow + mFg.FixedRows - 2, 10) Then
                        .TextMatrix(iRow + mFg.FixedRows - 1, 10) = .TextMatrix(iRow + mFg.FixedRows - 1, 10) + vbLf
                        
                    End If
                End If
            End If
        Case "外币金额式"
            '汇率
            d = FormatToDouble(rSt.Fields("Hl").value)
            If Abs(d) > 0.000000005 Then
                .TextMatrix(iRow + mFg.FixedRows - 1, 9) = Format(d, "#,###0.0000")
                If .TextMatrix(iRow + mFg.FixedRows - 1, 9) = .TextMatrix(iRow + mFg.FixedRows - 2, 9) Then
                    .TextMatrix(iRow + mFg.FixedRows - 1, 9) = .TextMatrix(iRow + mFg.FixedRows - 1, 9) + vbLf
                End If
            Else
                .TextMatrix(iRow + mFg.FixedRows - 1, 9) = ""
                If .TextMatrix(iRow + mFg.FixedRows - 1, 9) = .TextMatrix(iRow + mFg.FixedRows - 2, 9) Then
                    .TextMatrix(iRow + mFg.FixedRows - 1, 9) = .TextMatrix(iRow + mFg.FixedRows - 1, 9) + vbLf
                End If
            End If
            '金额，外币
            d = FormatToDouble(rSt.Fields("Wb").value)
            If Abs(d) > 0.0005 Then
                If Left$(rSt.Fields("fx").value, 1) = "借" Then
                    .TextMatrix(iRow + mFg.FixedRows - 1, 10) = Format(d, "#,###0.00")
                    If .TextMatrix(iRow + mFg.FixedRows - 1, 10) = .TextMatrix(iRow + mFg.FixedRows - 2, 10) Then
                        .TextMatrix(iRow + mFg.FixedRows - 1, 10) = .TextMatrix(iRow + mFg.FixedRows - 1, 10) + vbLf
                    End If
                    .TextMatrix(iRow + mFg.FixedRows - 1, 12) = ""
                    If .TextMatrix(iRow + mFg.FixedRows - 1, 12) = .TextMatrix(iRow + mFg.FixedRows - 2, 12) Then
                        .TextMatrix(iRow + mFg.FixedRows - 1, 12) = .TextMatrix(iRow + mFg.FixedRows - 1, 12) + vbLf
                    End If
                Else
                    .TextMatrix(iRow + mFg.FixedRows - 1, 10) = ""
                    If .TextMatrix(iRow + mFg.FixedRows - 1, 10) = .TextMatrix(iRow + mFg.FixedRows - 2, 10) Then
                        .TextMatrix(iRow + mFg.FixedRows - 1, 10) = .TextMatrix(iRow + mFg.FixedRows - 1, 10) + vbLf
                    End If
                    .TextMatrix(iRow + mFg.FixedRows - 1, 12) = Format(d, "#,###0.00")
                    If .TextMatrix(iRow + mFg.FixedRows - 1, 12) = .TextMatrix(iRow + mFg.FixedRows - 2, 12) Then
                        .TextMatrix(iRow + mFg.FixedRows - 1, 12) = .TextMatrix(iRow + mFg.FixedRows - 1, 12) + vbLf
                    End If
                End If
            Else
                .TextMatrix(iRow + mFg.FixedRows - 1, 10) = ""
                If .TextMatrix(iRow + mFg.FixedRows - 1, 10) = .TextMatrix(iRow + mFg.FixedRows - 2, 10) Then
                    .TextMatrix(iRow + mFg.FixedRows - 1, 10) = .TextMatrix(iRow + mFg.FixedRows - 1, 10) + vbLf
                End If
                .TextMatrix(iRow + mFg.FixedRows - 1, 12) = ""
                If .TextMatrix(iRow + mFg.FixedRows - 1, 12) = .TextMatrix(iRow + mFg.FixedRows - 2, 12) Then
                    .TextMatrix(iRow + mFg.FixedRows - 1, 12) = .TextMatrix(iRow + mFg.FixedRows - 1, 12) + vbLf
                End If
            End If
            d = FormatToDouble(rSt.Fields("Je").value)
            If Abs(d) > 0.0005 Then
                If Left$(rSt.Fields("fx").value, 1) = "借" Then
                    .TextMatrix(iRow + mFg.FixedRows - 1, 11) = Format(d, "#,###0.00")
                    If .TextMatrix(iRow + mFg.FixedRows - 1, 11) = .TextMatrix(iRow + mFg.FixedRows - 2, 11) Then
                        .TextMatrix(iRow + mFg.FixedRows - 1, 11) = .TextMatrix(iRow + mFg.FixedRows - 1, 11) + vbLf
                    End If
                    .TextMatrix(iRow + mFg.FixedRows - 1, 13) = ""
                    If .TextMatrix(iRow + mFg.FixedRows - 1, 13) = .TextMatrix(iRow + mFg.FixedRows - 2, 13) Then
                        .TextMatrix(iRow + mFg.FixedRows - 1, 13) = .TextMatrix(iRow + mFg.FixedRows - 1, 13) + vbLf
                    End If
                Else
                    .TextMatrix(iRow + mFg.FixedRows - 1, 11) = ""
                    If .TextMatrix(iRow + mFg.FixedRows - 1, 11) = .TextMatrix(iRow + mFg.FixedRows - 2, 11) Then
                        .TextMatrix(iRow + mFg.FixedRows - 1, 11) = .TextMatrix(iRow + mFg.FixedRows - 1, 11) + vbLf
                    End If
                    .TextMatrix(iRow + mFg.FixedRows - 1, 13) = Format(d, "#,###0.00")
                    If .TextMatrix(iRow + mFg.FixedRows - 1, 13) = .TextMatrix(iRow + mFg.FixedRows - 2, 13) Then
                        .TextMatrix(iRow + mFg.FixedRows - 1, 13) = .TextMatrix(iRow + mFg.FixedRows - 1, 13) + vbLf
                    End If
                End If
            Else
                .TextMatrix(iRow + mFg.FixedRows - 1, 11) = ""
                If .TextMatrix(iRow + mFg.FixedRows - 1, 11) = .TextMatrix(iRow + mFg.FixedRows - 2, 11) Then
                    .TextMatrix(iRow + mFg.FixedRows - 1, 11) = .TextMatrix(iRow + mFg.FixedRows - 1, 11) + vbLf
                End If
                .TextMatrix(iRow + mFg.FixedRows - 1, 13) = ""
                If .TextMatrix(iRow + mFg.FixedRows - 1, 13) = .TextMatrix(iRow + mFg.FixedRows - 2, 13) Then
                    .TextMatrix(iRow + mFg.FixedRows - 1, 13) = .TextMatrix(iRow + mFg.FixedRows - 1, 13) + vbLf
                End If
            End If
        End Select
    End With
    mFg.MergeRow(iRow + mFg.FixedRows - 1) = False
    iRow = iRow + 1
    rSt.MoveNext
Wend
rSt.Close
End Sub

Private Sub mnuFileFind_Click()
'
Dim i As Integer
Dim j As Integer
Dim dat As Date
Dim dDate As Date
Dim sNumber As String
Dim sJsfs As String
frmYH_DjwhFind.Show 1
If frmYH_DjwhFind.Ok Then
    dDate = frmYH_DjwhFind.dTp.value
    sNumber = Trim$(frmYH_DjwhFind.txtDj)
    sJsfs = Trim$(frmYH_DjwhFind.cboJsfs.text)
    Unload frmYH_DjwhFind
    For i = mFg.FixedRows To mFg.Rows - 1
        dat = Format(mFg.TextMatrix(i, 2), "yyyy-MM-dd")
        If dat = dDate Then
            If mFg.TextMatrix(i, 5) = sJsfs Then
                If mFg.TextMatrix(i, 6) Like sNumber + "*" Then
                    mFg.Row = i
                    Exit For
                End If
            End If
        End If
    Next
Else
    Unload frmYH_DjwhFind
End If
End Sub

Private Sub mnuFileSave_Click()
'
Dim oldcol As Integer
Dim OldRow As Integer
Dim iCol As Integer
Dim i As Integer
Dim j As Integer
Dim cmd As New ADODB.Command
Dim pBill As ADODB.Parameter
Dim pJsfsCode As ADODB.Parameter
Dim pJsfsName As ADODB.Parameter
Dim pDate As ADODB.Parameter

Dim pKjqj As ADODB.Parameter
Dim pPzzl As ADODB.Parameter
Dim pPzbh As ADODB.Parameter
Dim pJlhm As ADODB.Parameter
Dim bColorChange As Boolean
oldcol = mFg.Col
OldRow = mFg.Row
bEnableEnterCell = False
cmd.ActiveConnection = glo.cnnMain
cmd.CommandText = "Update tZW_Pzsj" + m_sYear + " set yhdz_bill=?,yhdz_jsfscode=?,yhdz_jsfs=?,yhdz_Date=? where kjqj=? and pzzl=? and pzbh=? and jlhm=?"
Set pBill = cmd.CreateParameter("Bill", adVarChar, adParamInput, 12)
cmd.Parameters.Append pBill
Set pJsfsCode = cmd.CreateParameter("JsfsCode", adVarChar, adParamInput, 3)
cmd.Parameters.Append pJsfsCode
Set pJsfsName = cmd.CreateParameter("JsfsName", adVarChar, adParamInput, 12)
cmd.Parameters.Append pJsfsName
Set pDate = cmd.CreateParameter("Yhdz_date", adDate, adParamInput)
cmd.Parameters.Append pDate

Select Case g_FLAT
Case "ORACLE"
    Set pKjqj = cmd.CreateParameter("Kjqj", adNumeric, adParamInput)
Case "SQL"
    Set pKjqj = cmd.CreateParameter("Kjqj", adSmallInt, adParamInput)
End Select
cmd.Parameters.Append pKjqj
Set pPzzl = cmd.CreateParameter("Pzzl", adVarChar, adParamInput, 4)
cmd.Parameters.Append pPzzl
Set pPzbh = cmd.CreateParameter("Pzbh", adVarChar, adParamInput, 4)
cmd.Parameters.Append pPzbh
Select Case g_FLAT
Case "ORACLE"
    Set pJlhm = cmd.CreateParameter("Jlhm", adNumeric, adParamInput)
Case "SQL"
    Set pJlhm = cmd.CreateParameter("Jlhm", adSmallInt, adParamInput)
End Select
cmd.Parameters.Append pJlhm
cmd.Prepared = True
For i = mFg.FixedRows To mFg.Rows - 1
    mFg.Row = i
    bColorChange = False
    For iCol = 5 To 7
        mFg.Col = iCol
        If mFg.CellBackColor <> 0 Then
            bColorChange = True
        End If
    Next
    If bColorChange = True Then
        j = InStr(1, Trim$(mFg.TextMatrix(i, 5)), "=")
        If j > 0 Then
            pJsfsCode.value = Mid(Trim$(mFg.TextMatrix(i, 5)), 1, j - 1)
            pJsfsName.value = Mid(Trim$(mFg.TextMatrix(i, 5)), j + 1)
        Else
            pJsfsCode.value = Trim$(mFg.TextMatrix(i, 5))
            pJsfsName.value = ""
        End If
        pBill.value = Trim$(mFg.TextMatrix(i, 6))
        pDate.value = Format(Trim$(mFg.TextMatrix(i, 7)), "yyyy-MM-dd")
        pKjqj.value = GetPeriod(Trim$(mFg.TextMatrix(i, 2)))
        pPzzl.value = Trim$(mFg.TextMatrix(i, 3))
        pPzbh.value = Trim$(mFg.TextMatrix(i, 4))
        pJlhm.value = CInt(Trim$(mFg.TextMatrix(i, 0)))
        cmd.Execute
    End If
Next
cmd.Prepared = False
Set cmd = Nothing

ClearColorFlag
bEnableEnterCell = False
mFg.Col = oldcol
mFg.Row = OldRow
bEnableEnterCell = True
End Sub

Private Sub tbr_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "Find"
    mnuFileFind_Click
Case "Save"
    mnuFileSave_Click
Case "Help"
    SendKeys "F1"
Case "Exit"
    mnuFileExit_Click
End Select
End Sub

Private Sub txtEdit_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    mFg.Col = mFg.Col + 1
End If
End Sub
'清除标志
Private Sub ClearColorFlag()
Dim i As Integer
Dim iCol As Integer
bEnableEnterCell = False

For i = mFg.FixedRows To mFg.Rows - 1
    For iCol = 5 To 7
        mFg.Col = iCol
        mFg.Row = i
        mFg.CellBackColor = 0
    Next
Next
bEnableEnterCell = True
End Sub
上一页 12
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -