+

VB开发的ERP系统

              Call Toolbjzt
               Lrzt = 1
               Call Cshlrxx(Lrzt)
              LrText(0).SetFocus
              LrText(0).Locked = False
         Case "D"                   'Ctrl+D 删除
              Call Scdqjl
     End Select
  End If
End Sub

Private Sub SzToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
   Select Case Button.Key
      Case "ymsz"                                          '页面设置
          Dyymctbl.Show 1
      Case "yl"                                            '预 览
          Call bbyl(True)
      Case "dy"                                            '打 印
          Call bbyl(False)
      Case "zj"                                            '增 加
        Call Toolbjzt
        Lrzt = 1
        Call Cshlrxx(Lrzt)
        LrText(0).SetFocus
        LrText(0).Locked = False
      Case "xg"                                            '修 改
         Call Xgdqjl
      Case "sc"                                            '删 除
         Call Scdqjl
      Case "fq"                                            '取 消
        Call Toolfbjzt
      Case "sx"                                            '刷 新
       Call Cxnrtcwg
      Case "bz"                                            '帮 助
       Call F1bz
      Case "fh"                                            '退 出
       Unload Me
   End Select
End Sub
Private Sub CzxsGrid_DblClick()                            '修改当前编码记录
  Call Xgdqjl
End Sub
Private Sub Xgdqjl()                                       '修改当前编码记录
  If CzxsGrid.Row < CzxsGrid.FixedRows Then
    Exit Sub
  End If
  Call Toolbjzt
  Lrzt = 2
  Call Cshlrxx(Lrzt)
  LrText(1).SetFocus
  LrText(0).Locked = True
End Sub
Private Sub Toolbjzt()                                     'Toolbar状态(编辑状态)
  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状态(非编辑状态)
  StTab.TabEnabled(0) = True
  StTab.Tab = 0
  CzxsGrid.Enabled = True
  Frame1.Enabled = False
  StTab.TabEnabled(1) = False
  Lrzt = 0
   With SzToolbar
     .Buttons("ymsz").Enabled = True
     .Buttons("dy").Enabled = True
     .Buttons("yl").Enabled = True
     .Buttons("zj").Enabled = True
     .Buttons("xg").Enabled = True
     .Buttons("sc").Enabled = True
  End With
End Sub
Private Sub BcCommand_Click()                                           '保 存
  If Not Bclrsj Then
     Exit Sub
  End If
  If Lrzt = 2 Then
     Call Toolfbjzt
  End If
End Sub
Private Sub QxCommand_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)       '取消
  '避免执行Click程序
  Bln_Cancel = True
  Call Cancel
End Sub
Private Sub QxCommand_Click()                                                                         '取消
 If Bln_Cancel Then
    Bln_Cancel = False
    Exit Sub
 End If
 Call Cancel
End Sub
Private Sub Cancel()                                                                                  '取消
  '文本框加锁
'  For Jsqte = 0 To Max_Text_Index
'     TextValiJudgeLock(Jsqte) = True
'  Next Jsqte
  Call Toolfbjzt
End Sub
Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)   '表格格式设置(通用)
    Select Case Button.Key
      Case "bcgs"                              '保存表格格式
        Call Bcwggs(CzxsGrid, GridCode)
      Case "hfmrgs"                            '恢复默认格式
        Call Hfmrgs(CzxsGrid, GridCode)
      Case "szxsxm"                            '设置显示项目
        Call Szxsxm(CzxsGrid, 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) = " "
  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)

   '屏蔽程序改变控制
   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
'初始化成本中心
Sub CshAccountCell()
    Dim RecTemp As New ADODB.Recordset
    SqlStr = "Select * from cbhs_accountcell order by AccountCellCode"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    ReDim Combo_CostCellCode(RecTemp.RecordCount)
    Do Until RecTemp.EOF
        Combo_CostCell.AddItem "(" + Trim(RecTemp.Fields("AccountCellCode")) + ")" + RecTemp.Fields("AccountCellName")
        Combo_CostCellCode(Combo_CostCell.NewIndex) = RecTemp.Fields("AccountCellCode")
        RecTemp.MoveNext
    Loop
    If Combo_CostCell.ListCount >= 1 Then
        Combo_CostCell.ListIndex = 0
    End If
End Sub