+

财务分析 财财务分析务分析

     If Ydcommand.Visible Then
       Ydcommand.Left = .Left + .CellLeft + .CellWidth - Ydcommand.Width + Wbkpy
       Ydcommand.Top = .Top + .CellTop + .CellHeight - Ydcommand.Height + Wbkpy
     End If
     If Ydtext.Visible Then
       If Ydcommand.Visible Then
         If Sfblbzkd Then
         Ydtext.Width = .CellWidth - Ydcommand.Width
        Else
         Ydtext.Width = .CellWidth - Wbkpy1
        End If
       Else
         Ydtext.Width = .CellWidth - Wbkpy1
       End If
      
       Ydtext.Left = .CellLeft + .Left + Wbkpy
       Ydtext.Top = .CellTop + .Top + Wbkpy
       Ydtext.Height = .CellHeight - Wbkpy1
     End If
   End With

End Sub
Private Sub Lrsjhx()                                                   '文本框录入数据回写
  With WglrGrid
   If YdCombo.Visible Then
    .Text = Trim(YdCombo.Text)
   End If
   If Ydtext.Visible Then
    .Text = Trim(Ydtext.Text)
   End If
   
   '(如果字段录入内容发生变化,则打开有效性判断锁)
   If Zdlrqnr <> Trim(.Text) Then
      Yxxpdlock = False
      Hyxxpdlock = False
   End If
   
   '如果字段录入内容不为空则写数据行有效性标志
   
   If Len(Trim(.Text)) <> 0 Then
      Call Xyxhbz(.Row)
   End If
   
   '隐藏文本框,帮助按钮,列表组合框
   Call Ycwbk
   
  End With
End Sub
Private Sub WglrGrid_KeyDown(KeyCode As Integer, Shift As Integer)    '网格录入增行，删行快捷键
  
  '如果单据操作状态为浏览状态则不能显示录入载体
  If Trim(Lab_OperStatus.Caption) = "1" Then
      Exit Sub
  End If

  Select Case KeyCode
     Case vbKeyDelete               '删行
       Call Scdqfl
     Case vbKeyInsert               '增行
       Call zjlrfl
  End Select
End Sub
Private Sub WglrGrid_KeyPress(KeyAscii As Integer)                     '网格接受键盘录入
  Dim Str_ChangeTe As String    '临时交换内容
  Dim Coljsq As Long            '临时列计数器
  Dim Int_SaveKey As Integer    '保存KeyAscii值

  '如果单据操作状态为浏览状态则不能显示录入载体
  If Trim(Lab_OperStatus.Caption) = "1" Then
      Exit Sub
  End If

  Int_SaveKey = KeyAscii

  With WglrGrid
    '屏 蔽 回 车 键
   If KeyAscii = vbKeyReturn Then
       KeyAscii = 0
       Rowjsq = .Row
        Coljsq = .Col + 1
        If Coljsq > .Cols - 1 Then
           If Rowjsq < .Rows - 1 Then
              Rowjsq = Rowjsq + 1
           End If
           Coljsq = Qslz
        End If
        Do While Rowjsq <= .Rows - 1
           If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
              Coljsq = Coljsq + 1
              If Coljsq > .Cols - 1 Then
                 Rowjsq = Rowjsq + 1
                 Coljsq = Qslz
              End If
           Else
              Exit Do
           End If
         Loop
         If Rowjsq <= .Rows - 1 Then
           .Select Rowjsq, Coljsq
        End If
      Exit Sub
    End If
    '接受用户录入
  Select Case KeyAscii
     Case 0 To 32

          '显示录入载体
          Call xswbk

     Case Else

           '防止非编辑字段SendKeys()出现死循环
          If Not GridBoolean(.Col, 1) Or .Row < .FixedRows Then
             Exit Sub
          End If

          If GridBoolean(.Col, 3) Then

             '列表框录入
             Call xswbk

          Else
            
            Ydtext.Text = ""
            Call InputFieldLimit(Ydtext, GridInt(WglrGrid.Col, 1), KeyAscii)
            If KeyAscii = 0 Then
               Exit Sub
            End If
    
            '写有效行数据标志
            Call Xyxhbz(.Row)
            Call xswbk
            Ydtext.Text = ""
            Valilock = True
              SendKeys Chr(KeyAscii), wait
              DoEvents
            Valilock = False

          End If
     End Select
  End With
End Sub
Private Sub zjlrfl()                                                    '增加录入分录
  With WglrGrid
    If Not (Ydtext.Visible Or YdCombo.Visible) Then
       If Not Fun_Drfrmyxxpd Then
          Exit Sub
       End If
    Else
       Exit Sub
    End If
    If .Row < .FixedRows Then
       Exit Sub
    End If
    .AddItem "", .Row
    .RowHeight(.Row) = Sjhgd
    
    
    If .Row <> .Rows - 1 Then
       If .TextMatrix(.Row + 1, 0) = "*" Then
          .TextMatrix(.Row, 0) = "*"
       Else
          .RemoveItem .Rows - 1
       End If
    End If
    Call Xldqh
    Call Xldql
    Hyxxpdlock = False
  End With
End Sub
Private Sub Scdqfl()                                                    '删除当前分录
 Dim Answer As Integer, Scqwghz As Long, Scqwglz As Long, Hjlzte As Long, Sflrzt As Boolean
 Dim RecTemp As New ADODB.Recordset             '临时使用动态集
 Dim SqlStr As String                           '临时连接字符串
 Dim Str_NowItemCode As String                  '辅助核算项目编码(现)
 
 With WglrGrid
    Scqwghz = .Row
    Scqwglz = .Col
    If .TextMatrix(.Row, 0) = "*" Then
    
        '判断是否为录入状态
        If Ydtext.Visible Or YdCombo.Visible Then
          Sflrzt = True
          Validate = True
           Call Lrsjhx
          Validate = False
        End If
       
       Call Xldqh
       changelock = True
         .Select .Row, 0
       changelock = False
       If Shsfts Then
          .Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = QBColor(12)
          Tsxx = "请确认是否删除当前记录?"
          yhAnswer = Xtxxts(Tsxx, 2, 2)
          If yhAnswer = 2 Then
             .Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = &H80000005
              changelock = True
                .Select Scqwghz, Scqwglz
              changelock = False
              
              '如为录入状态,则恢复录入
              If Sflrzt Then
                 Call xswbk
              End If
              
             Exit Sub
          End If
       End If
       
       On Error GoTo Swcwcl
    
       Cw_DataEnvi.DataConnect.BeginTrans
       
       If Val(WglrGrid.TextMatrix(.Row, 1)) <> 0 Then
          SqlStr = "SELECT i_id From cwfx_CashIncomeCostSet WHERE  I_id=" & Val(WglrGrid.TextMatrix(.Row, 1))
          Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
          If Not RecTemp.EOF Then
             SqlStr = "Delete cwfx_CashIncomeCostSet Where I_id=" & Val(WglrGrid.TextMatrix(.Row, 1))
             Cw_DataEnvi.DataConnect.Execute (SqlStr)
          End If
       End If
       
       Cw_DataEnvi.DataConnect.CommitTrans
       
       .RemoveItem .Row
 
       If .Rows < Pmbcsjhs + .FixedRows + Fzxwghs + 1 Then
          .AddItem ""
          .RowHeight(.Rows - 1) = Sjhgd
       End If
       changelock = True
         .Select .Row, Scqwglz
       changelock = False
       
    End If
 End With
 
 Exit Sub
 
'[>>事务错误处理
Swcwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    txss = "删除过程中出现错误!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Sub
'<<]
End Sub
Private Sub Qkwlzd(sjh As Long, Sjl As Long)                            '清空为零字段
  If Not GridBoolean(Sjl, 5) Then
     Exit Sub
  End If
  With WglrGrid
    If Val(Trim(.TextMatrix(sjh, Sjl))) = 0 Then
       .TextMatrix(sjh, Sjl) = ""
    End If
  End With
End Sub
Private Sub fhyxh()                                                     '返回录入数据有效行,同时让得到焦点网格可见
  With WglrGrid
   If .Row >= .FixedRows Then
      If .TextMatrix(.Row, 0) <> "*" Then
         For Rowjsq = .FixedRows To .Rows - 1
             If .TextMatrix(Rowjsq, 0) <> "*" Then
                Exit For
             End If
         Next Rowjsq
         If Rowjsq <= .Rows - 1 Then
            changelock = True
              .Select Rowjsq, .Col
            changelock = False
         Else
            changelock = True
              .Select .Rows - 1, .Col
            changelock = False
         End If
      End If
      Call Xldqh
   End If
  End With
End Sub
Private Sub Xldqh()                                                      '显露当前行
  Dim Toprowte As Long
  With WglrGrid
    Toprowte = 0
    Do While .CellTop + .RowHeight(.Row) + Fzxwghs * Sjhgd > .Height And .TopRow <> Toprowte
       Toprowte = .TopRow
       .TopRow = .TopRow + 1
    Loop
    Toprowte = 0
    Do While .CellTop < .FixedRows * .RowHeight(0) And .TopRow <> Toprowte
       Toprowte = .TopRow
       .TopRow = .TopRow - 1
    Loop
  End With
End Sub
Private Sub Xldql()                                                     '显露当前列
 Dim Leftcolte As Long
 With WglrGrid
   If .Col >= Qslz Then
    If .LeftCol > .Col Then
       .LeftCol = .Col
    End If
    Leftcolte = 0
    Do While .CellLeft + .CellWidth > .Width And .LeftCol <> Leftcolte
       Leftcolte = .LeftCol
       .LeftCol = .LeftCol + 1
    Loop
  End If
 End With
End Sub
Private Function pdhwk(sjh As Long)                                     '判断网格行是否为空行(所有录入字段均为空*非录入字段除外)
 With WglrGrid
   For Coljsq = Qslz To .Cols - 1
       If Len(Trim(.TextMatrix(sjh, Coljsq))) <> 0 And GridBoolean(Coljsq, 1) Then
          pdhwk = False
          Exit Function
       End If
   Next Coljsq
   pdhwk = True
 End With
End Function
Private Sub Xyxhbz(sjh As Long)                                         '写行有效性标志,并判断是否增行
   With WglrGrid
    If .TextMatrix(sjh, 0) = "*" Then
       Exit Sub
    End If
    .TextMatrix(sjh, 0) = "*"
    If sjh >= .Rows - Fzxwghs - 1 Then
       .AddItem ""
       .RowHeight(.Rows - 1) = Sjhgd
    End If
   End With
End Sub
Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)   '表格格式设置(通用)
    Select Case Button.Key
      Case "bcgs"                              '保存表格格式
        Call Bcwggs(WglrGrid, GridCode)
      Case "hfmrgs"                            '恢复默认格式
        Call Hfmrgs(WglrGrid, GridCode)
    End Select
End Sub
Private Sub bbyl(bbylte As Boolean)                    '报表打印预览
  Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
  Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
  Bbxbtgs = 1                                          '报 表 小 标 题 行 数
  Bbbwhgs = 0                                          '报 表 表 尾 行 数
  ReDim Bbxbt(1 To Bbxbtgs)
  ReDim bbxbtzzxs(1 To Bbxbtgs)
  If Bbbwhgs <> 0 Then
     ReDim Bbbwh(1 To Bbbwhgs)
     ReDim Bbbwhzzxs(1 To Bbbwhgs)
  End If
  Bbzbt = ReportTitle
  Bbxbt(1) = Space(10) + Fun_FormatOutPut("会计年度:" + Str(Int_OriYear), 28)

  Call Scyxsjb(WglrGrid)                               '生成报表数据
  Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
  If Not bbylte Then
     Unload DY_Tybbyldy
  End If
End Sub