frmin_hl.frm

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

      Style           =   7
      ImageList       =   "ImageList1"
      Appearance      =   1
      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 VB.Menu mnuFile 
      Caption         =   "文件(&F)"
      Begin VB.Menu mnuExit 
         Caption         =   "退出(&X)"
      End
   End
   Begin VB.Menu mnuEdit 
      Caption         =   "编辑(&E)"
      Begin VB.Menu mnuAdd 
         Caption         =   "增加(&N)"
         Shortcut        =   ^N
      End
      Begin VB.Menu mnuDelete 
         Caption         =   "删除(&D)"
         Shortcut        =   ^D
      End
      Begin VB.Menu mnuSave 
         Caption         =   "保存(&S)"
         Shortcut        =   ^S
      End
      Begin VB.Menu mnuCancel 
         Caption         =   "取消(&C)"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
   End
End
Attribute VB_Name = "frmIN_HL"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim iEndCol As Integer                     '设置更改例号
Dim iEndRow As Integer                     '设置更改例号

Dim bSetToMfg As Boolean

Private Sub form_load()
    
    Dim sSQL As String
    Dim rstForeign As ADODB.Recordset          '汇率 foreigncurrency 记录集合
    
    bSetToMfg = True
    
    Call SetHead
    
    sSQL = "select * from tZW_ForeignCurrency" & glo.sOperateYear
    Set rstForeign = New ADODB.Recordset
    rstForeign.CursorLocation = adUseClient
    rstForeign.Open sSQL, glo.cnnMain, adOpenStatic, adLockReadOnly
    tvwCur.Nodes.Clear
    tvwCur.Nodes.Add , , "R", "目录", "RootClose", "RootOpen"      'yang
    If rstForeign.RecordCount > 0 Then
        While Not rstForeign.EOF
            tvwCur.Nodes.Add "R", tvwChild, "k" & Trim$("" & rstForeign.Fields("cExch_Name").value), _
                Trim$("" & rstForeign.Fields("cExch_Name").value), "ItemClose", "ItemOpen"
            rstForeign.MoveNext
        Wend
    Else
        tbr.Buttons("delete").Enabled = False
        mnuDelete.Enabled = False
        tbr.Buttons("save").Enabled = False
        mnuSave.Enabled = False
    End If
    rstForeign.Close
    
    Call InitSome("R")
     tvwCur.Nodes(1).Expanded = True
     tvwCur.LabelEdit = tvwManual
 End Sub

Private Sub mfg1_Click()
            Call mfg1_GotFocus
End Sub

Private Sub mfg1_GotFocus()
    If Me.Visible = True Then
        With mfg1
            If .Row > 0 And .Col > 0 Then
                
                txtEdit.Move .Left + .CellLeft, .Top + .CellTop, .cellWidth, .cellHeight
                txtEdit.Visible = True
                txtEdit.text = FormatToDouble(mfg1.TextMatrix(.Row, .Col))
                If txtEdit.Visible And txtEdit.Enabled Then
                    txtEdit.SelStart = 0
                    txtEdit.SelLength = Len(txtEdit.text)
                    txtEdit.SetFocus
                End If
                 '编辑文本框获得焦点
            End If
        End With
    End If
End Sub

Private Sub mfg1_LeaveCell()
    If txtEdit.Visible = True And mfg1.Row > 0 And mfg1.Col > 0 Then
        If FormatToDouble(txtEdit.text) = 0 Then
            mfg1.TextMatrix(mfg1.Row, mfg1.Col) = ""
        Else
            mfg1.TextMatrix(mfg1.Row, mfg1.Col) = Format(txtEdit.text, "#,###0." & String(FormatToDouble(txtWei.text), "0"))
        End If
    End If
End Sub

Private Sub mfg1_RowColChange()
        Call mfg1_GotFocus
End Sub

Private Sub mnuAdd_Click()
    Call Operate("ADD")
End Sub

Private Sub mnuCancel_Click()
    Call Operate("CANCEL")
End Sub

Private Sub mnuDelete_Click()
    Call Operate("DELETE")
End Sub

Private Sub mnuExit_Click()
   Unload Me
End Sub

Private Sub mnuHelp_Click()
    Call Operate("HELP")
End Sub

Private Sub mnuSave_Click()
    Call Operate("SAVE")
End Sub

Private Sub tbr_ButtonClick(ByVal Button As MSComctlLib.Button)
    Call Operate(UCase(Button.Key))
End Sub

Private Sub Operate(strKey As String)
    Dim adoCmd As ADODB.Command
    Dim sSQL As String
    Dim iCal As Integer                 '设置折算公式标志
    Dim iDate As Integer
    Dim dHL As Double
    Dim dTZ As Double
    
    txtEdit.Visible = False
    
    Set adoCmd = New ADODB.Command
    adoCmd.ActiveConnection = glo.cnnMain
    adoCmd.CommandType = adCmdText
    Select Case UCase(strKey)
        Case "ADD"
            tbr.Buttons("add").Enabled = False
            mnuAdd.Enabled = False
            tbr.Buttons("delete").Enabled = False
            mnuDelete.Enabled = False
            tbr.Buttons("save").Enabled = True
            mnuSave.Enabled = True
            tbr.Buttons("cancel").Enabled = True
            mnuCancel.Enabled = True
            
            txtName.text = ""
            txtName.Enabled = True
            txtName.BackColor = vbWindowBackground
'            txtName.SetFocus
            txtWei.text = "4"
            Call FillMfgNian
            
            tbr.Buttons("save").Tag = "ADD"
            optCheng.value = True
            txtName.SetFocus
        Case "DELETE"
            If MsgBox("确实要删除吗？", vbQuestion + vbYesNo, "提问") = vbYes Then
                '判断此外币是否已经使用
                Dim rstRec As New ADODB.Recordset
                               
                sSQL = "select kmdm from tzw_km" & glo.sOperateYear & "  where  wbdw='" & tvwCur.SelectedItem.text & "'"
                rstRec.Open sSQL, glo.cnnMain, adOpenStatic, adLockReadOnly
                If Not (rstRec.EOF And rstRec.BOF) Then
                    MsgBox "此币种已经在用，不能删除！", vbInformation, "提示："
                    rstRec.Close
                    Set rstRec = Nothing
                    Exit Sub
                End If
                rstRec.Close
                Set rstRec = Nothing
                
                adoCmd.CommandText = "delete from tZW_ForeignCurrency" & glo.sOperateYear & "  where cExch_Name='" & _
                        tvwCur.SelectedItem.text & "'"
                adoCmd.Execute
                
                adoCmd.CommandText = "delete from tZW_Exch" & glo.sOperateYear & _
                        " where cExch_Name='" & tvwCur.SelectedItem.text & "'"
                adoCmd.Execute
                tvwCur.Nodes.Remove tvwCur.SelectedItem.Index
                If tvwCur.Nodes.Count > 0 Then
                    txtName.Enabled = False
                    txtName.BackColor = vbButtonFace
                    txtWei.Enabled = True
'                    txtWei.SetFocus
                    txtWei.BackColor = vbWindowBackground
                    Call ShowOneCurrency(tvwCur.SelectedItem.text)
                Else
                    txtName.Enabled = False
                    txtName.BackColor = vbButtonFace
                    txtWei.Enabled = False
                    txtWei.BackColor = vbButtonFace
                    tbr.Buttons("add").Enabled = True
                    mnuAdd.Enabled = True
                    tbr.Buttons("delete").Enabled = False
                    mnuDelete.Enabled = False
                    tbr.Buttons("save").Enabled = True
                    mnuSave.Enabled = True
                    tbr.Buttons("cancel").Enabled = False
                    mnuCancel.Enabled = False
                End If
            End If
        
        Case "SAVE"
                
            '置折算方式
            If optCheng.value Then      '外币 X 汇率＝本币
                iCal = -1
            ElseIf optChu.value Then    '外币 / 汇率＝本币
                iCal = 0
            End If
            
            '处于新增一个币种的状态
            If UCase(tbr.Buttons("save").Tag) = "ADD" Then
                '检查合法性
                If Trim$("" & txtName.text) = "" Then
                    MsgBox "请输入外币名称！", vbInformation, "提示"
                    txtName.SetFocus
                    Exit Sub
                End If
                If SqlStringValid(txtName) = False Then
                    MsgBox "币种名称不能含有非法的字符！", vbInformation, "提示"
                    Exit Sub
                End If
                If IsHave("tZW_ForeignCurrency" & glo.sOperateYear, "cExch_Name", Trim$("" & txtName.text)) Then
                    MsgBox "外币名称不能重复！", vbInformation, "提示"
                    txtName.SetFocus
                    Exit Sub
                End If
                '在 tZW_ForeignCurrency 中插入一条记录
                sSQL = "INSERT INTO tZW_ForeignCurrency" & glo.sOperateYear & "(cExch_Name,bCal,iDEC,mERROR,OtherUse) values('" & _
                        Trim$("" & txtName.text) & "'," & CStr(iCal) & "," & CStr(FormatToDouble(txtWei.text)) & _
                        "," & CStr(txtErr.text) & ",0)"
                adoCmd.CommandText = sSQL
                adoCmd.Execute
                '在 TreeView 中加入新结点
                tvwCur.Nodes.Add "R", tvwChild, "k" & Trim$("" & txtName.text), _
                        Trim$("" & txtName.text), "ItemClose", "ItemOpen"
                Set tvwCur.SelectedItem = tvwCur.Nodes("k" & Trim$("" & txtName.text))
            
            Else
                '更新记录
                sSQL = "UPDATE tZW_ForeignCurrency" & glo.sOperateYear & "  set bCal=" & CStr(iCal) & ", iDEC=" & _
                        CStr(FormatToDouble(txtWei.text)) & ",mERROR= " & CStr(txtErr.text) & _
                        " where cExch_Name='" & tvwCur.SelectedItem.text & "'"
                adoCmd.CommandText = sSQL
                adoCmd.Execute
            End If
            
            If UCase(tbr.Buttons("save").Tag) <> "ADD" Then     '先删除,后插入
                        sSQL = "delete from tZW_Exch" & glo.sOperateYear & _
                        " where cExch_Name='" & tvwCur.SelectedItem.text & "'"
                        adoCmd.CommandText = sSQL
                        adoCmd.Execute
            End If
                
            '添加表 tZW_Exch#### 中12条记录
            For iDate = 1 To 12
                '输入的固定汇率值
                If Trim$("" & mfg1.TextMatrix(iDate, 1)) = "" Then
                    dHL = 0
                Else
                    dHL = FormatToDouble(mfg1.TextMatrix(iDate, 1))
                End If
                '输入的调整汇率值
                If Trim$("" & mfg1.TextMatrix(iDate, 2)) = "" Then
                    dTZ = 0
                Else
                    dTZ = FormatToDouble(mfg1.TextMatrix(iDate, 2))
                End If
                '插入记录
                
                Select Case g_FLAT
                    Case "SQL"
                        sSQL = "INSERT INTO tZW_Exch" & glo.sOperateYear & _
                                "(cExch_Name,iPeriod,iType,cDate,nFlat_HL,nFlat_TZ) values('" & _
                                Trim$("" & txtName.text) & "'," & iDate & ",0,'" & _
                                glo.sOperateDate & "'," & CStr(dHL) & "," & CStr(dTZ) & ")"
                    Case "ORACLE"
                        sSQL = "INSERT INTO tZW_Exch" & glo.sOperateYear & _
                                "(cExch_Name,iPeriod,iType,cDate,nFlat_HL,nFlat_TZ) values('" & _
                                Trim$("" & txtName.text) & "'," & iDate & ",0,TO_DATE('" & _
                                glo.sOperateDate & "','YYYY-MM-DD')," & CStr(dHL) & "," & CStr(dTZ) & ")"
                End Select
                adoCmd.CommandText = sSQL
                adoCmd.Execute
            Next iDate
                                      
            '设置保存后的状态
            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
                
            txtName.Enabled = False
            txtName.BackColor = vbButtonFace
            tbr.Buttons("save").Tag = ""
        Case "CANCEL"
              On Error GoTo Err
              bSetToMfg = False
              If tvwCur.SelectedItem.Key = "R" Then
                    Call InitSome("R")
              Else
                    Call ShowOneCurrency(tvwCur.SelectedItem.text)
                    Call InitSome("UPDATE")
              End If
              tbr.Buttons("save").Tag = ""
              Exit Sub
Err:
        MsgBox "请选择一个节点!", vbInformation
        Case "HELP"
            Call ShowHelp
        Case "QUIT"
            Unload Me
        Case "PRINT"
        Case "PREVIEW"
    End Select
       
End Sub

Private Sub FillMfgNian()
    Dim i As Integer
        mfg1.Rows = 13
    For i = 1 To 12
        If i < 10 Then
            mfg1.TextMatrix(i, 0) = Trim(glo.sOperateYear) & "-0" & Trim(str(i))
        Else
            mfg1.TextMatrix(i, 0) = Trim(glo.sOperateYear) & "-" & Trim(str(i))
        End If