-

VB开发的ERP系统

     If Not Security_Log(Str_RightCheck, Xtczybm, 1, True) Then
        Exit Sub
     End If
           
    '[>>
    '此处可以写入禁止单据弃审的理由
    '<<]
   
    '将单据清除审核标识
    Cw_DataEnvi.DataConnect.Execute ("Update Tr_ShipDeliver Set Checker='' Where ShipDeliverId=" & Val(Lab_BillId.Caption))
    
    '清空单据审核人
    LrText(24).Text = ""
    
    '设置审核弃审按钮状态
    Call Sub_CheckStatus
    Tsxx = "弃审完毕!"
    Call Xtxxts(Tsxx, 0, 4)
    '标识单据发生变化
    Bln_BillChange = True
  
End Sub

Private Function Fun_AllowEdit() As Boolean                      '判断当前单据是否允许编辑或删除
  
    Dim RecTemp As New ADODB.Recordset     '临时使用动态集
    Fun_AllowEdit = False
    Sqlstr = "Select Checker From Tr_ShipDeliver Where ShipDeliverId=" & Val(Lab_BillId.Caption)
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    With RecTemp
        If Not .EOF Then
            If Trim(.Fields("Checker") & "") <> "" Then
                Tsxx = "该单据已审核确认,不能修改或删除!"
                Call Xtxxts(Tsxx, 0, 4)
                Exit Function
            End If
        End If
    End With
    Fun_AllowEdit = True

End Function
'[>>===================以上为根据实际业务需要自定义过程区域=============================<<]

Private Function Fun_AllowInput() As Boolean                           '当某种条件成立时禁止文本框激活使单据处于录入状态
   
    '如果单据操作状态为浏览状态则不能显示录入载体(通用)
    If Trim(Lab_OperStatus.Caption) = "1" Then
        Exit Function
    End If
   
    '[>>
    
    '此处可以填写禁止文本框激活使单据处于录入状态的理由
   
    '<<]
   
    Fun_AllowInput = True

End Function

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

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

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

End Sub

Private Sub LrText_Change(Index As Integer)
    Dim rs As New ADODB.Recordset
    Dim str_sql As String
    
    '屏蔽程序改变控制
    If TextChangeLock Then
        Exit Sub
    End If
   
    TextValiJudgeLock(Index) = False    '打开有效性判断锁
        
    '限制字段录入长度
          
    TextChangeLock = True  '加锁(防止执行Lrtext_Change)
        Select Case Textint(Index, 1)
            Case 8, 11       '金额型
                Call Sjgskz(LrText(Index), Xtjezws - Xtjexsws - 1, Xtjexsws)
            Case 9, 12       '数量型
                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
    If Index = 2 Then
        str_sql = "select ConsignCode,gy_customer.cuscode,cusname,contacttype,contactperson,address from Xs_ConsignBillMain,gy_customer where Xs_ConsignBillMain.cuscode=gy_customer.cuscode and ConsignCode='" & Trim(LrText(2)) & "'"
        Set rs = Cw_DataEnvi.DataConnect.Execute(str_sql)
        If Not rs.EOF Then
            LrText(3).Tag = Trim(rs("cuscode"))
            LrText(3) = Trim(rs("cusname"))
            LrText(4) = Trim(rs("address"))
            LrText(5) = Trim(rs("contacttype"))
            LrText(6) = Trim(rs("contactperson"))
        Else
            LrText(3) = ""
            LrText(3).Tag = ""
            LrText(4) = ""
            LrText(5) = ""
            LrText(6) = ""
        End If
    End If
    If Index = 3 Then
        str_sql = "select cuscode,cusname,contacttype,contactperson,address from gy_customer where cuscode='" & Trim(LrText(3).Tag) & "'"
        Set rs = Cw_DataEnvi.DataConnect.Execute(str_sql)
        If Not rs.EOF Then
            LrText(4) = Trim(rs("address"))
            LrText(5) = Trim(rs("contacttype"))
            LrText(6) = Trim(rs("contactperson"))
        Else
            LrText(4) = ""
            LrText(5) = ""
            LrText(6) = ""
        End If
    End If
    If Index = 7 Then
        str_sql = "select mnumber,mname,model from gy_material where mnumber='" & Trim(LrText(7)) & "'"
        Set rs = Cw_DataEnvi.DataConnect.Execute(str_sql)
        If Not rs.EOF Then
            LrText(8) = rs("mname")
            LrText(9) = rs("model")
        Else
            LrText(8) = ""
            LrText(9) = ""
        End If
    End If
    TextChangeLock = False '解锁
     
End Sub

Private Sub LrText_GotFocus(Index As Integer)                                                 '文本框得到焦点,显示相应信息
    Call TextShow(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(Button As Integer, Shift As Integer, x As Single, y As Single) '点击按钮
    Call Text_Help(Ydcommand1.Tag)
End Sub

Private Sub Text_Help(Index As Integer)                                                       '录入字段帮助
    
    If Not Ydcommand1.Visible Then
        Exit Sub
    End If
    TextValiLock = True
    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
    TextValiLock = False
    LrText(Index).SetFocus

End Sub

Private Sub TextShow(Index As Integer)        '文本框得到焦点,显示相应信息

    '如果文本框有帮助,则显示帮助按钮
    If Textboolean(Index, 1) Then
        Ydcommand1.Visible = True
        Ydcommand1.Move LrText(Index).Left + LrText(Index).Width, LrText(Index).Top
        Ydcommand1.Tag = Index
    Else
        Ydcommand1.Tag = ""
        Ydcommand1.Visible = False
    End If
    
    '[>>
    '可在此处定义其他处理动作
    '<<]

End Sub

Private Sub Wbkcsh()                          '录入文本框初始化

    Dim Int_TabIndex As Integer         'Tab焦点计数器
  
    '单据录入中文本框焦点由0开始
    LrText(0).TabIndex = 0
  
    '最大录入文本框索引值
    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 jsqte <> 0 Then
                Load LrText(jsqte)
                Load TsLabel(jsqte)
           
                '判断录入文本框是否显示
                If Textboolean(jsqte, 4) Then
                    LrText(jsqte).Visible = True
                    TsLabel(jsqte).Visible = True
                Else
                    LrText(jsqte).Visible = False
                    TsLabel(jsqte).Visible = False
                End If
            
                '判断文本框是否可编辑
                If Textboolean(jsqte, 5) Then
                    LrText(jsqte).Enabled = True
                Else
                    LrText(jsqte).Enabled = False
                End If
            End If
           
           '初始化其内容
            TextChangeLock = True
            LrText(jsqte).Text = ""
            LrText(jsqte).Tag = ""
            LrText(jsqte).MaxLength = Textint(jsqte, 5)
            TextChangeLock = False
        
            '设置文本框位置及大小,并设置相应标签内容及其位置
            LrText(jsqte).Move Textint(jsqte, 13), Textint(jsqte, 12), Textint(jsqte, 11), Textint(jsqte, 10)
            TsLabel(jsqte).Caption = Textstr(jsqte, 7) & ":"
            TsLabel(jsqte).Move Textint(jsqte, 13) - TsLabel(jsqte).Width - 20, Textint(jsqte, 12) + (Textint(jsqte, 10) - TsLabel(jsqte).Height) / 2 - 30
            
        End If
     
        '将文本框有效性判断进行加锁,在文本框内容发生变化时将锁打开
        TextValiJudgeLock(jsqte) = True
      
    Next jsqte
    
    '设置文本框焦点转移顺序(前提文本焦点从0至Max_Text_Index)
    For Int_TabIndex = 0 To Max_Text_Index
        For jsqte = 0 To Max_Text_Index
            If Textint(jsqte, 14) = Int_TabIndex Then
               LrText(jsqte).TabIndex = Int_TabIndex
            End If
        Next jsqte
    Next Int_TabIndex
  
End Sub

Private Function TextYxxpd(Index As Integer) As Boolean           '文本框有效性判断
  
    Dim Sqlstr As String
    Dim Findrec As New ADODB.Recordset
  
    '按帮助不进行有效性判断
  
    If TextValiLock Then
        TextValiLock = False
        TextYxxpd = True
        Exit Function
    End If
  
    '文本框内容未曾改变不进行有效性判断
  
    If TextValiJudgeLock(Index) Then
        Ydcommand1.Visible = False
        TextYxxpd = True
        Exit Function
    End If
  
    '文本框内容为空认为有效,并清空其Tag值
  
    If Trim(LrText(Index)) = "" Then
        LrText(Index).Tag = ""
        Call Wbklrwbcl(Index)
        Ydcommand1.Visible = False
        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.Fi