zͩ

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

    Me.Hide
End Sub
Private Function Lrtjyxxpd() As Boolean                          '用户录入条件有效性判断
 Dim Jsqte As Integer
 Lrtjyxxpd = False


'对需要进行事后判断的文本框录入内容进行有效性判断 (固定不变)
  For Jsqte = 0 To Max_Text_Index
    If Textint(Jsqte, 9) = 0 Or Textint(Jsqte, 9) = 2 Then
      If Not TextYxxpd(Jsqte) Then
         Exit Function
      End If
    End If
  Next Jsqte
     
 '[>>以下为依据实际情况自定义部分
    If CmbPeriod(0).ListIndex = -1 Then
        Xtxxts "请选择分析期间!", 0, 1
        Lrtjyxxpd = False
        Exit Function
    End If
    
    If CmbCompType(1).ListIndex <> 0 Then
        If CmbPeriod(1).ListIndex = -1 Then
            Xtxxts "请选择比较期间!", 0, 1
            Lrtjyxxpd = False
            Exit Function
        End If
    End If
  
 '<<]以上为依据实际情况自定义部分
 
 Lrtjyxxpd = True
End Function

Private Sub CmbCompType_Click(Index As Integer)
    Dim i As Integer
    If Combo_Change_Locked = True Then Exit Sub '如果被锁住，退出过程
    Combo_Change_Locked = True '加锁，以免引起其它变化
    Select Case Index
        Case 0
            If CmbCompType(1).ListIndex <> 0 Then
                For i = 0 To CmbCompType(1).ListCount
                    If CmbCompType(1).ListCount = -1 Then Exit Sub
                    If CmbCompType(1).List(i) = CmbCompType(0).List(CmbCompType(0).ListIndex) Then
                        CmbCompType(1).ListIndex = i
                    End If
                Next
            End If
        Case 1
            If CmbCompType(Index).ListIndex <> 0 Then
                For i = 0 To CmbCompType(0).ListCount
                    If CmbCompType(0).ListCount = -1 Then Exit Sub
                    If CmbCompType(0).List(i) = CmbCompType(1).List(CmbCompType(1).ListIndex + 1) Then
                        CmbCompType(0).ListIndex = i - 1
                    End If
                Next
            End If
    End Select
    
    CmbPeriod(0).Clear
    CmbPeriod(1).Clear
    Select Case CmbCompType(0).ListIndex
        Case 0 '年
            For i = 0 To iHowManyYears
                CmbPeriod(0).AddItem UsedYear(i)
                CmbPeriod(1).AddItem UsedYear(i)
            Next
        Case 1 '月
            For i = 1 To 12
                CmbPeriod(0).AddItem Xtyear & "." & Format(i, "00")
                CmbPeriod(1).AddItem Xtyear & "." & Format(i, "00")
            Next
        Case 2 '季
            For i = 1 To 4
                CmbPeriod(0).AddItem Xtyear & "." & Format(((i - 1) * 3 + 1), "00") & "-" & Xtyear & "." & Format(i * 3, "00")
                CmbPeriod(1).AddItem Xtyear & "." & Format(((i - 1) * 3 + 1), "00") & "-" & Xtyear & "." & Format(i * 3, "00")
            Next
    End Select
    Combo_Change_Locked = False '解锁，退出之前解锁
End Sub
Private Sub GetUsedYear()
    '由Form_Load 调用,得到此帐套已使用的年度，存于UsedYear()数据中
    Dim temRs As New ADODB.Recordset
    Dim strSql As String
    Dim i As Integer
    strSql = "SELECT DISTINCT kjyear AS cYear FROM xt_kjrlb"
    Set temRs = Cw_DataEnvi.DataConnect.Execute(strSql)
    iHowManyYears = temRs.RecordCount - 1
    ReDim UsedYear(iHowManyYears)
    With temRs
        Do Until .EOF
            UsedYear(i) = !cYear
            i = i + 1
            .MoveNext
        Loop
    End With
    If temRs.State = adStateOpen Then temRs.Close
    Set temRs = Nothing
End Sub
Private Sub MakePastParameter()
    '生成传递参数
    Me.sigStockNumbers = Val(Trim(LrText(0).Text))
    Me.sigEachStockPrice = Val(Trim(LrText(1).Text))
    Me.sigEachStockSurplus = Val(Trim(LrText(2).Text))
    Me.sigFirstStockBehoof = Val(Trim(LrText(3).Text))
    Me.sigGeneralStockNumbers = Val(Trim(LrText(4).Text))
    Me.CompType = CmbCompType(0).ListIndex
    Select Case CompType
        Case mYEAR
            Me.BasePeriod_Begin = CmbPeriod(0).List(CmbPeriod(0).ListIndex)
            Me.BasePeriod_End = CmbPeriod(0).List(CmbPeriod(0).ListIndex)
            If CmbCompType(1).ListIndex <> 0 And CmbCompType(1).ListIndex <> 0 Then
                Me.CompPeriod_Begin = CmbPeriod(1).List(CmbPeriod(1).ListIndex)
                Me.CompPeriod_End = CmbPeriod(1).List(CmbPeriod(1).ListIndex)
            End If
        Case mMONTH
            Me.BasePeriod_Begin = Left(CmbPeriod(0).List(CmbPeriod(0).ListIndex), 7)
            Me.BasePeriod_End = Right(CmbPeriod(0).List(CmbPeriod(0).ListIndex), 7)
            If CmbCompType(1).ListIndex <> 0 And CmbCompType(1).ListIndex <> 0 Then
                Me.CompPeriod_Begin = CmbPeriod(1).List(CmbPeriod(1).ListIndex)
                Me.CompPeriod_End = CmbPeriod(1).List(CmbPeriod(1).ListIndex)
            End If
        Case mTHREE_MONTH
            Me.BasePeriod_Begin = Left(CmbPeriod(0).List(CmbPeriod(0).ListIndex), 7)
            Me.BasePeriod_End = Right(CmbPeriod(0).List(CmbPeriod(0).ListIndex), 7)
            If CmbCompType(1).ListIndex <> 0 And CmbCompType(1).ListIndex <> 0 Then
                Me.CompPeriod_Begin = Left(CmbPeriod(1).List(CmbPeriod(1).ListIndex), 7)
                Me.CompPeriod_End = Right(CmbPeriod(1).List(CmbPeriod(1).ListIndex), 7)
            End If
    End Select
End Sub
'************以下为文本框录入处理程序(固定不变部分)*************'
Private Sub Wbklrwbcl(Index As Integer)    '文本框录入事后处理程序

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

Private Sub LrText_Change(Index As Integer)

   '屏蔽程序改变控制
   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
     
     Call Drbmhelp(Textint(Index, 2), Textstr(Index, 4), Trim(LrText(Index).Text))
     
     If Len(Xtfhcs) <> 0 Then
        If Textint(Index, 3) = 1 Then
           LrText(Index).Text = Xtfhcsfz
           LrText(Index).Tag = Xtfhcs
        Else
           LrText(Index).Text = Xtfhcs
           LrText(Index).Tag = 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 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