+

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

   
    Exit Function
Swcwcl:
    
    Tsxx = "存盘过程中出现错误,程序自动恢复保存前状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Function
End Function




Private Sub BcCommand_Click()                                           '保 存
  If DEBUG_FLAG = False Then On Error Resume Next
  If Not Bclrsj Then
     Exit Sub
  End If
  If Lrzt = 2 Then
     Call Toolfbjzt
  End If
End Sub
Private Sub QxCommand_Click()                                                                         '取消
 If DEBUG_FLAG = False Then On Error Resume Next
 If Bln_Cancel Then
    Bln_Cancel = False
    Exit Sub
 End If
 
 Call Cancel
End Sub
Private Sub Cancel()                                                                                  '取消
  If DEBUG_FLAG = False Then On Error Resume Next
  '文本框加锁
  Dim Jsqte
  For Jsqte = 0 To Max_Text_Index
     TextValiJudgeLock(Jsqte) = True
  Next Jsqte
  Call Toolfbjzt
End Sub
Private Sub Scdqjl()                 '删 除 当 前 记 录
  If DEBUG_FLAG = False Then On Error Resume Next
  Dim yhAnswer As Integer
  If CzxsGrid.Row < CzxsGrid.FixedRows Then
     Exit Sub
  End If
  Tsxx = "请确认是否删除当前记录?"
  yhAnswer = Xtxxts(Tsxx, 2, 2)
  If yhAnswer = 2 Then
     Exit Sub
  End If
  On Error GoTo Cwcl
  
  '[以下需自定义部分
    Dim temRs As New ADODB.Recordset
    Dim strItem As String
    Dim strItemClass As String
    strItem = CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("006", GridStr(), Szzls))
    strItemClass = CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("005", GridStr(), Szzls))
    
    Set temRs = Cw_DataEnvi.DataConnect.Execute("delete from cwfx_ItemGrossProfitSet where ItemClassCode='" & strItemClass & "' AND ItemCode='" & strItem & "'")
  '以上为自定义部分]
    
  CzxsGrid.RemoveItem CzxsGrid.Row
  Exit Sub
Cwcl:
    If Err.Number = -2147217900 Then
     Tsxx = "该编码已经被使用,不能删除!"
     Call Xtxxts(Tsxx, 0, 1)
     Exit Sub
    Else
     Tsxx = "出现未知情况,该编码不能被删除!"
     Call Xtxxts(Tsxx, 0, 1)
     Exit Sub
    End If
End Sub
Private Sub Xgdqjl()                                       '修改当前编码记录
  If DEBUG_FLAG = False Then On Error Resume Next
  If CzxsGrid.Row < CzxsGrid.FixedRows Then
    Exit Sub
  End If
  Call Toolbjzt
  Lrzt = 2
  Call Cshlrxx(Lrzt)
  
End Sub
Private Function Cshlrxx(lrztxx As Integer) As Boolean              '初始化录入字段信息
    If DEBUG_FLAG = False Then On Error Resume Next
    Dim Jsqte
    Dim SqlStr As String
    TextChangeLock = True       '关闭Chang事件
    If lrztxx = 1 Then '新增
        For Jsqte = 0 To Max_Text_Index
            If Len(Trim(Textstr(Jsqte, 1))) <> 0 Then
                LrText(Jsqte).Text = ""
                LrText(Jsqte).Tag = ""
            End If
        TextValiJudgeLock(Jsqte) = True
        Next Jsqte
    Else  'else lrztxx=2 修改
        Dim strItemClass As String
        Dim strItem As String
        Dim temRs As New ADODB.Recordset
        strItemClass = CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("005", GridStr(), Szzls))
        strItem = CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("006", GridStr(), Szzls))
        Imgebo_ItemClass.Enabled = False
        
        With temRs
            If .State = adStateOpen Then .Close
            SqlStr = "SELECT * FROM cwfx_ItemGrossProfitSet WHERE ItemClassCode='" & strItemClass & "' AND ItemCode='" & strItem & "'"
            temRs.Open SqlStr, Cw_DataEnvi.DataConnect
            If Not (.EOF And .BOF) Then
                LrText(0).Text = Trim(!ItemCode)
                strOldItemCode = LrText(0).Text  '记录末修改前的编码
                Dim i
                For i = 1 To Imgebo_ItemClass.ComboItems.count
                    If Right(Imgebo_ItemClass.ComboItems(i).Key, Len(Imgebo_ItemClass.ComboItems(i).Key) - 1) = Trim(temRs!ItemClasscode) Then
                        Imgebo_ItemClass.Text = Imgebo_ItemClass.ComboItems(i).Text
                        Exit For
                    End If
                Next
            Else
                Tsxx = "记录已被删除!"
                Call Xtxxts(Tsxx, 0, 1)
            End If
            temRs.Close
            Set temRs = Nothing
        End With
    End If
    TextChangeLock = False
End Function
Private Sub Toolbjzt()                                     'Toolbar状态(编辑状态)
  If DEBUG_FLAG = False Then On Error Resume Next
  StTab.TabEnabled(1) = True
  StTab.Tab = 1
  Frame1.Enabled = True
  StTab.TabEnabled(0) = False
  CzxsGrid.Enabled = False
  With SzToolbar
    .Buttons("ymsz").Enabled = False
    .Buttons("dy").Enabled = False
    .Buttons("yl").Enabled = False
    .Buttons("zj").Enabled = False
    .Buttons("xg").Enabled = False
    .Buttons("sc").Enabled = False
  End With
End Sub
Private Sub Toolfbjzt()                                    'Toolbar状态(非编辑状态)
  If DEBUG_FLAG = False Then On Error Resume Next
  StTab.TabEnabled(0) = True
  StTab.Tab = 0
  CzxsGrid.Enabled = True
  Frame1.Enabled = False
  StTab.TabEnabled(1) = False
  Lrzt = 0
   With SzToolbar
     .Buttons("xg").Enabled = True
     .Buttons("sc").Enabled = True
     .Buttons("zj").Enabled = True
     .Buttons("ymsz").Enabled = True
     .Buttons("dy").Enabled = True
     .Buttons("yl").Enabled = True
  End With
End Sub


Private Sub bbyl(bbylte As Boolean)                    '报表打印预览
  If DEBUG_FLAG = False Then On Error Resume Next
  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) = " "
  bbxbtzzxs(1) = 0                                     '报表行组织形式(0-居左 1-居中 2-居右)
  Call Scyxsjb(CzxsGrid)                               '生成报表数据
  Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
  If Not bbylte Then
     Unload DY_Tybbyldy
  End If
End Sub

'************以下为文本框录入处理程序(固定不变部分)*************'

Private Sub Wbklrwbcl(Index As Integer)    '文本框录入事后处理程序

  '以下为依据实际情况自定义部分[
  
      '在此填写文本框录入事后处理程序
   
  ']以上为依据实际情况自定义部分
End Sub


Private Sub LrText_Change(Index As Integer)
    '----------固定不变部分变量声明开始--------------------
    Dim Jsqte
    Dim Int_CodeLev
    Dim CodeLev
    Dim Str_Parent
    Dim RecTemp As New ADODB.Recordset
    '----------固定不变部分变量声明结束-------------------
   '屏蔽程序改变控制
   If TextChangeLock Then
      Exit Sub
   End If
    
   TextValiJudgeLock(Index) = False    '打开有效性判断锁
    
    '限制字段录入长度
          
     TextChangeLock = True  '加锁(防止执行Lrtext_Change)
        Select Case Textint(Index, 1)
           Case 8           '金额型
             Call Sjgskz(LrText(Index), Xtjezws - Xtjexsws - 1, Xtjexsws)
           Case 9           '数量型
             Call Sjgskz(LrText(Index), Xtslzws - Xtslxsws - 1, Xtslxsws)
           Case 10          '单价型
             Call Sjgskz(LrText(Index), Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
           Case Else        '其他小数类型控制
              If Textint(Index, 6) <> 0 Or Textint(Index, 7) <> 0 Then
                 Call Sjgskz(LrText(Index), Textint(Index, 6), Textint(Index, 7))
              End If
        End Select
        
     TextChangeLock = False '解锁
End Sub
Private Sub LrText_GotFocus(Index As Integer)                                                 '文本框得到焦点,显示相应信息
   Call TextShow(Index)
   CurTextIndex = Index
   LrText(Index).SelStart = Len(LrText(Index))
End Sub
Private Sub LrText_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)            '字段按F2键提供帮助
   Select Case KeyCode
      Case vbKeyF2
        Call Text_Help(Index)
   End Select
End Sub
Private Sub LrText_KeyPress(Index As Integer, KeyAscii As Integer)                            '文本框录入事中控制
   Call InputFieldLimit(LrText(Index), Textint(Index, 1), KeyAscii)
End Sub
Private Sub LrText_LostFocus(Index As Integer)                                                '文本框失去焦点进行有效性判断及相应处理
  If Textint(Index, 9) = 0 Or Textint(Index, 9) = 1 Then '事中判断
     Call TextYxxpd(Index)
  End If
End Sub
Private Sub Ydcommand1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)     '按钮提供帮助
   Call Text_Help(Index)
End Sub
Private Sub Text_Help(Index As Integer)                                                       '录入字段帮助
  If Not Textboolean(Index, 1) Then
     Exit Sub
  End If
   TextValiJudgeLock(Index) = True
   
     '先进行有效性判断
     If Not TextYxxpd(CurTextIndex) Then
        Exit Sub
     End If
   
     If Index = 0 Then        '核算项目特殊处理
        Xtcdcs = Trim(LrText(Index).Text)
        Xtcdcsfz = GetComboKey(Imgebo_ItemClass, 0)
        XT_ItemHelp.Show 1
     Else
        Call Drbmhelp(Textint(Index, 2), Textstr(Index, 4), Trim(LrText(Index).Text))
     End If
     If Len(Xtfhcs) <> 0 Then
        If Textint(Index, 3) = 1 Then
           LrText(Index).Tag = Xtfhcsfz
           LrText(Index).Text = Xtfhcs
        Else
           LrText(Index).Tag = Xtfhcs
           LrText(Index).Text = Xtfhcsfz
        End If
      
     End If
   TextValiJudgeLock(Index) = False
   LrText(Index).SetFocus
End Sub
Private Sub TextShow(Index As Integer)        '文本框得到焦点,显示相应信息

   '填写文本框得到焦点,进行相应信息处理程序
   
End Sub
Private Sub Wbkcsh()                          '录入文本框初始化
  Dim Jsqte As Integer
  
  '最大录入文本框索引值
  Max_Text_Index = Textvar(1)
  
  ReDim TextValiJudgeLock(Max_Text_Index)
  For Jsqte = 0 To Max_Text_Index
     
     If Len(Trim(Textstr(Jsqte, 1))) <> 0 Then
        If Textboolean(Jsqte, 1) Then
            If Jsqte <> 0 And Not Textboolean(Jsqte, 3) Then
                Load Ydcommand1(Jsqte)
            End If
            Ydcommand1(Jsqte).Visible = True
            Ydcommand1(Jsqte).Move LrText(Jsqte).Left + LrText(Jsqte).Width, LrText(Jsqte).Top
        End If
        TextChangeLock = True
         LrText(Jsqte).Text = ""
         LrText(Jsqte).Tag = ""
         If Textint(Jsqte, 5) <> 0 Then
            LrText(Jsqte).MaxLength = Textint(Jsqte, 5)
         End If
        TextChangeLock = False
     End If
     TextValiJudgeLock(Jsqte) = True
  Next Jsqte
End Sub
Private Function TextYxxpd(Index As Integer) As Boolean           '文本框有效性判断
    '---------------------------------
    Dim Tsxx As String
    
    '---------------------------------
  Dim SqlStr As String
  Dim Findrec As ADODB.Recordset
  
  If TextValiJudgeLock(Index) Then    '文本框内容未曾改变不进行有效性判断
     TextYxxpd = True
     Exit Function
  End If
  If Trim(LrText(Index)) = "" Then
     LrText(Index).Tag = ""
     Call Wbklrwbcl(Index)
     TextValiJudgeLock(Index) = True
     TextYxxpd = True
     Exit Function
  End If
       Select Case Textint(Index, 4)
         Case 1      '编码型
            SqlStr = Trim(Textstr(Index, 5))
            SqlStr = Replace(SqlStr, "@", "'" + Trim(LrText(Index).Text) + "'")
            Set Findrec = Cw_DataEnvi.DataConnect.Execute(SqlStr)
            If Findrec.EOF Then
               Call Xtxxts(Trim(Textstr(Index, 6)), 0, 1)
               LrText(Index).SetFocus
               Exit Function
            Else
               Select Case Textint(Index, 3)
                 Case 0
                   If Len(Trim(Textstr(Index, 2))) <> 0 Then
                      LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
                   End If
                    If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
                      LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
                   End If
                 Case 1
                   If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
                      LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
                   End If
                    If Len(Trim(Textstr(Index, 2))) <> 0 Then
                      LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
                   End If
               End Select
            End If
         Case 2      '日期型
            If IsDate(LrText(Index).Text) Then
               LrText(Index).Text = Format(LrText(Index).Text, "yyyy-mm-dd")
             Else
               Tsxx = "非法公历日期!(格式:" + Format(Date, "yyyy-mm-dd") + ")"
               Call Xtxxts(Tsxx, 0, 1)
               LrText(Index).SetFocus
               Exit Function
            End If
         Case 3      '其他类型
         
         
       End Select
   TextValiJudgeLock(Index) = True
   TextYxxpd = True
End Function