frmin_hl.frm

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

            mfg1.TextMatrix(i, 1) = ""
            mfg1.TextMatrix(i, 2) = ""
    Next i
End Sub


Private Sub tBr_ButtonMenuClick(ByVal ButtonMenu As MSComctlLib.ButtonMenu)
Select Case UCase(ButtonMenu.Key)
Dim i As Integer
Dim j As Integer
Dim gc As Integer
Dim rstCur As ADODB.Recordset

Case "PREVIEWWB"
Me.MousePointer = 11
With frmcellprint1.Cll
    Load frmcellprint1
    .OpenFile App.Path & "\CellFiles\HLWB.cll", ""
    .Clear (32)
    .SetRows tvwCur.Nodes("R").Children + 4, 0
    .SetCols 4 + 1, 0
    .MergeCells 1, 1, .GetCols(0), 1
    .SetCellString 1, 1, 0, "币种一览表"
    .SetCellAlign 1, 1, 0, 36
    .SetCellFont 1, 1, 0, .FindFontIndex("宋体", 1)
    .SetCellFontSize 1, 1, 0, 20
    .SetCellFontStyle 1, 1, 0, 2
    .SetRowHeight 1, .GetRowBestHeight(1), 1, 0
    .MergeCells 1, 2, .GetCols(0), 2
    .SetCellString 1, 2, 0, glo.sOperateYear & "年度"
    .SetCellAlign 1, 2, 0, 32 + 4
    .SetCellFontSize 1, 2, 0, 12
    .SetCellString 1, 3, 0, "币名"
    .SetColWidth 1, 100, 1, 0
    .SetCellAlign 1, 3, 0, 32 + 4
    .SetCellString 2, 3, 0, "折算方式"
    .SetColWidth 1, 170, 2, 0
    .SetCellAlign 2, 3, 0, 32 + 4
    .SetCellString 3, 3, 0, "汇率小数位"
    .SetColWidth 1, 120, 3, 0
    .SetCellAlign 3, 3, 0, 32 + 4
    .SetCellString 4, 3, 0, "外币最大误差"
    .SetColWidth 1, 170, 4, 0
    .SetCellAlign 4, 3, 0, 32 + 4
    
        Set rstCur = New ADODB.Recordset
        rstCur.CursorLocation = adUseClient
        rstCur.Open "select * from tZW_ForeignCurrency" & glo.sOperateYear, glo.cnnMain, adOpenStatic, adLockReadOnly
        If rstCur.RecordCount > 0 Then
            For i = 1 To rstCur.RecordCount
                .SetCellString 1, 3 + i, 0, Trim$("" & rstCur.Fields("cExch_Name").value)
                .SetCellAlign 1, 3 + i, 0, 33
                .SetCellString 2, 3 + i, 0, IIf(rstCur.Fields("bCAL").value = 0, "外币 / 汇率=本币", "外币 X 汇率=本币")
                .SetCellAlign 2, 3 + i, 0, 33
                .SetCellAlign 3, 3 + i, 0, 35
                .SetCellString 3, 3 + i, 0, Trim(rstCur.Fields("iDEC").value)
                .SetCellAlign 4, 3 + i, 0, 35
                .SetCellString 4, 3 + i, 0, IIf(FormatToDouble(Trim(rstCur.Fields("iDEC").value)) = 0, "1", "0." & String(FormatToDouble(Trim(rstCur.Fields("iDEC").value)), "0") & "1")
                rstCur.MoveNext
            Next i
        End If
        rstCur.Close
        Set rstCur = Nothing
    .DrawGridLine 1, 3, .GetCols(0), .GetRows(0), 0, 2, vbBlack
    .PrintSetHead "", "", "总&S页 第&P页"
    .PrintSetFoot GetEnterpriseName(""), "", "打印日期:" + glo.sOperateDate
    frmcellprint1.cllprivew
    .SaveFile App.Path & "\CellFiles\HLWB.cll", 0
    Unload frmcellprint1
End With
Me.MousePointer = 0

Case "PREVIEWHL"
If tvwCur.SelectedItem Is Nothing Then
    MsgBox "请选择币种！", vbInformation, "提示"
    Exit Sub
End If
If tvwCur.SelectedItem.Key = "R" Then
    MsgBox "请选择币种！", vbInformation, "提示"
    Exit Sub
End If
Me.MousePointer = 11
With frmcellprint1.Cll
    Load frmcellprint1
    .OpenFile App.Path & "\CellFiles\HLHL.cll", ""
    .Clear (32)
    .SetRows mfg1.Rows + 3, 0
    .SetCols mfg1.Cols + 1, 0
    .MergeCells 1, 1, .GetCols(0), 1
    .SetCellString 1, 1, 0, "固定汇率一览表"
    .SetCellAlign 1, 1, 0, 36
    .SetCellFont 1, 1, 0, .FindFontIndex("宋体", 1)
    .SetCellFontSize 1, 1, 0, 20
    .SetCellFontStyle 1, 1, 0, 2
    .SetRowHeight 1, .GetRowBestHeight(1), 1, 0
    .MergeCells 2, 2, .GetCols(0), 2
    .SetCellString 1, 2, 0, "外币：" & tvwCur.SelectedItem
    .SetCellFontSize 1, 1, 0, 12
    .SetCellAlign 1, 2, 0, 1
    .SetCellString 2, 2, 0, "             " & glo.sOperateYear & "年度"
    .SetCellAlign 2, 2, 0, 1
    
    .SetColWidth 1, mfg1.ColWidth(0) / 10, 1, 0
    .SetColWidth 1, mfg1.ColWidth(1) / 10, 2, 0
    .SetColWidth 1, mfg1.ColWidth(2) / 10, 3, 0
    For i = 0 To mfg1.Cols - 1
        For j = 0 To mfg1.Rows - 1
            If i > 0 Then
                .SetCellAlign i + 1, 3 + j, 0, 35
            End If
            .SetCellString i + 1, 3 + j, 0, mfg1.TextMatrix(j, i)
        Next j
    Next i
    .DrawGridLine 1, 3, .GetCols(0), .GetRows(0), 0, 2, vbBlack
    .PrintSetHead "", "", "总&S页 第&P页"
    .PrintSetFoot GetEnterpriseName(""), "", "打印日期:" + glo.sOperateDate
    frmcellprint1.cllprivew
    .SaveFile App.Path & "\CellFiles\HLHL.cll", 0
    Unload frmcellprint1
End With
Me.MousePointer = 0
End Select
End Sub

Private Sub tvwCur_NodeClick(ByVal Node As MSComctlLib.Node)
    tbr.Buttons("save").Tag = "" '不是增加
    If Node.Key = "R" Then
        Call InitSome("R")
        txtName.Enabled = False
        txtName.BackColor = vbButtonFace
    Else
        Call ShowOneCurrency(Node.text)
        Call InitSome("UPDATE")
        
    End If
        txtEdit.Visible = False
End Sub


'设置表格。
Private Sub SetHead()
    With mfg1
        .ColWidth(0) = 1000
        .ColWidth(1) = 1500
        .ColAlignment(1) = 7
        .ColAlignment(0) = 4
        .ColAlignment(2) = 7
        .ColWidth(2) = 1500
        .Rows = 13
    End With
End Sub

Private Sub InitSome(str As String)
    Dim i As Integer
    Dim j As Integer
    str = UCase(str)
    If str = "R" Then
            tbr.Buttons("add").Enabled = True
            mnuAdd.Enabled = True
            tbr.Buttons("delete").Enabled = False
            mnuDelete.Enabled = False
            tbr.Buttons("save").Enabled = False
            mnuSave.Enabled = False
            tbr.Buttons("cancel").Enabled = False
            mnuCancel.Enabled = False
            
            txtName.text = ""
            txtName.Enabled = False
            txtName.BackColor = vbButtonFace
            
            txtErr.text = ""
            txtWei.text = ""
            optCheng.value = True
            
'            txtName.SetFocus
            txtWei.text = "4"
            For i = 1 To 12
                For j = 0 To 2
                    mfg1.TextMatrix(i, j) = ""
                Next j
            Next i
    ElseIf str = "UPDATE" Then
            tbr.Buttons("add").Enabled = True
            mnuAdd.Enabled = True
            tbr.Buttons("delete").Enabled = True
            mnuDelete.Enabled = True
            tbr.Buttons("save").Enabled = True
            mnuSave.Enabled = True
            tbr.Buttons("cancel").Enabled = True
            mnuCancel.Enabled = True
    End If
End Sub


Private Sub txtEdit_Change()
   Dim i As Integer
   Dim sformat As String
   
    sformat = ""
    For i = 1 To CInt(txtWei.text)
        sformat = sformat + "0"
    Next i
    If Trim(txtEdit.text) <> "" Then
        If FormatToDouble(txtEdit.text) > 999999 Then
              MsgBox "币种汇率不能大于999999！", vbInformation, "提示："
              Exit Sub
        End If
    End If
    mfg1.TextMatrix(mfg1.Row, mfg1.Col) = Format(txtEdit.text, "0." + sformat)
End Sub

Private Sub txtEdit_KeyDown(KeyCode As Integer, Shift As Integer)
     With mfg1
            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 vbKeyUp
                    If .Row > 1 Then
                        .Row = .Row - 1
                    Else
                        .Row = .Rows - 1
                    End If
                Case vbKeyDown
                    If .Row < .Rows - 1 Then
                        .Row = .Row + 1
                    Else
                        .Row = 1
                    End If
            End Select
    End With
End Sub

Private Sub txtEdit_KeyPress(KeyAscii As Integer)

    If KeyAscii = 13 Then
        
        SendKeys "{DOWN}"
    End If
    If KeyAscii = 8 Then
        Exit Sub
    End If

    KeyAscii = DoubleEnabled(txtEdit.text, KeyAscii)

End Sub

Private Sub txtEdit_LostFocus()
   txtEdit.Visible = False
End Sub

Private Sub txtName_Click()
    txtEdit.Visible = False
End Sub

Private Sub txtName_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
       SendKeys "{Tab}"
    End If
    
    If KeyAscii > 58 Or KeyAscii < 47 Then
       Exit Sub
    Else
        KeyAscii = 13
    End If
End Sub

Private Sub txtWei_Change()
    If FormatToDouble(txtWei.text) = 0 Then
        txtErr.text = "1"
    Else
        txtErr.text = "0." & String(FormatToDouble(txtWei.text), "0") & "1"
    End If
End Sub

Private Sub ShowOneCurrency(ByVal sCurName As String)
    Dim rstExch As ADODB.Recordset             '汇率表 tZW_Exch####
    Dim rstCur As ADODB.Recordset
    Dim i As Long, j As Long
    
    
    Set rstCur = New ADODB.Recordset
    With rstCur
        .CursorLocation = adUseClient
        .Open "select * from tZW_ForeignCurrency" & glo.sOperateYear & " where cExch_Name='" & _
                sCurName & "'", glo.cnnMain, adOpenStatic, adLockReadOnly
        If .RecordCount > 0 Then
        txtName.text = Trim$("" & .Fields("cExch_Name").value)
        optCheng.value = IIf(.Fields("bCAL").value = 0, False, True)
        optChu.value = Not optCheng.value
        txtWei.text = .Fields("iDEC").value
        Else
            InitSome ("R")
        End If
        .Close
    End With
        
    Set rstExch = New ADODB.Recordset
    With rstExch
        .CursorLocation = adUseClient
        .Open "select * from tZW_Exch" & glo.sOperateYear & _
                " where cExch_Name='" & sCurName & "' order by iPeriod", _
                glo.cnnMain, adOpenStatic, adLockReadOnly
        If .RecordCount = 0 Then
            For i = 1 To mfg1.Rows - 1
                For j = 0 To 2
                    mfg1.TextMatrix(i, j) = ""
                Next j
            Next i
        Else
            i = 1
            Do Until .EOF
                If i < 10 Then
                    mfg1.TextMatrix(i, 0) = glo.sOperateYear & "-0" & Trim(str(.Fields("iperiod").value))
                Else
                    mfg1.TextMatrix(i, 0) = glo.sOperateYear & "-" & Trim(str(.Fields("iperiod").value))
                End If
                If FormatToDouble(.Fields("nFlat_HL").value) = 0 Then
                    mfg1.TextMatrix(i, 1) = ""
                Else
                    mfg1.TextMatrix(i, 1) = Format(.Fields("nFlat_HL").value, "#,###0." & String(FormatToDouble(txtWei.text), "0"))
                End If
                If FormatToDouble(.Fields("nFlat_TZ").value) = 0 Then
                    mfg1.TextMatrix(i, 2) = ""
                Else
                    mfg1.TextMatrix(i, 2) = Format(.Fields("nFlat_TZ").value, "#,###0." & String(FormatToDouble(txtWei.text), "0"))
                End If
                i = i + 1
                .MoveNext
            Loop
        End If
        .Close
    End With
    
    txtName.Enabled = False
    txtName.BackColor = vbButtonFace
    
End Sub


Private Function IsHave(newTable As String, newZD As String, newVal As String) As Boolean
    Dim rstTmp As ADODB.Recordset
    
    Set rstTmp = New ADODB.Recordset
    With rstTmp
        .CursorLocation = adUseClient
        .Open "select count(*) from " & newTable & " where " & newZD & "='" & newVal & "'", _
                glo.cnnMain, adOpenStatic, adLockReadOnly
        If Not (IsNull(.Fields(0).value) Or .Fields(0).value = 0) Then
            IsHave = True
        Else
            IsHave = False
        End If
        .Close
    End With

End Function