VB开发的ERP系统

Dim GridInf() As Variant                 '整个网格设置信息
Dim ReportTitle As String                '报表主标题
Dim Pmbcsjhs As Long                     '屏幕网格保持数据行数(大于等于1)
Dim Fzxwghs As Integer                   '辅助项网格行数(包括合计行)
Dim Sfxshjwg As Boolean                  '是否显示合计网格
Dim Qslz As Long                         '网格隐藏(非操作显示)列数
Dim Sjhgd As Double                      '网格数据行高度
Dim GridBoolean() As Boolean             '网格列信息(布尔型)
Dim GridStr()  As String                 '网格列信息(字符型)
Dim GridInt() As Integer                 '网格列信息(整型)
Dim Sfblbzkd As Boolean                  '是否保留帮助宽度(字段提供帮助时,是否为按钮保留空间)
Dim Dqlrwgh As Long                      '当前录入数据网格行
Dim Dqlrwgl As Long                      '当前录入数据网格列
Dim Dqlkwgh As Long                      '刚刚离开网格行(不一定为录入行)
Dim Dqlkwgl As Long                      '刚刚离开网格列
Dim Dqtoprow As Long                     '当前录入状态时最上端可视行
Dim Dqleftcol As Long                    '当前录入状态时最左端可视列
Dim Zdlrqnr As String                    '字段录入修改前内容(用来判断内容是否修改)
Dim Wbkbhlock As Boolean                 '文本框改变值锁
Dim changelock As Boolean                '网格行列改变控制锁(用来区别用户改变.程序改变)
Dim Gdtlock As Boolean                   '滚动条滚动控制(用来区别用户改变.程序改变)
Dim Yxxpdlock As Boolean                 '字段有效性判断锁(内容不修改不需进行字段有效性判断)
Dim Hyxxpdlock As Boolean                '行有效性判断锁(字段内容不修改不需进行行有效性判断)
Dim Valilock As Boolean                  '文本框失去焦点是否进行有效性控制(TRUE 为锁定*限用网格录入)
Dim Shsfts As Boolean                    '删除记录行是否提示
Dim Szzls As Integer                     '网格信息数组最大下标值(网格列数-1)

Private Sub Form_KeyPress(KeyAscii As Integer)   '控 制 焦 点 转 移(Fixed)
    Dim jdzygs As Integer                        '控件焦点转移个数
    jdzygs = 30
    Select Case KeyAscii
        Case vbKeyReturn
            If Kjjdzy(jdzygs) Then
                KeyAscii = 0
            End If
        Case 39           '屏蔽"'"
            KeyAscii = 0
    End Select

End Sub

Private Sub Form_Load()
    '调入打印页面设置窗体
    ReportTitle = "中控指标折线图"
    XtReportCode = "Qc_MidAnaZxt"
    Load Dyymctbl
  
    '以下为文本框处理程序(Fixed)
    TextGroupCode = "Qc_MidAnaGraph"
    Call Drwbkxx(TextGroupCode, Textvar(), Textboolean(), Textint(), Textstr())  '读入文本框录入信息
    Call Wbkcsh
   '调 入 网 格(Fixed)
    GridCode = "Qc_MidAnaZxt"
    Call BzWgcsh(CxbbGrid, GridCode, GridInf(), GridBoolean(), GridInt(), GridStr())
      
    Qslz = GridInf(1)
    Sjhgd = GridInf(2)
    Sfxshjwg = GridInf(7)
    Szzls = CxbbGrid.Cols - 1

    '[>>初始化查询条件默认值
    LrText(0).Text = Format(Xtrq, "yyyy-mm-dd")
    LrText(1).Text = Format(Xtrq, "yyyy-mm-dd")
    '读入生产线信息
    Call InitCmb
    '<<]
   
End Sub



Private Sub QdCommand_Click()                                   '确 定

    '录入条件有效性判断(Fixed)
    If Not Lrtjyxxpd Then
        Exit Sub
    End If
    
        
    '[>>激活查询过程
    
    Call Sub_Query
    
    '<<]
End Sub



Private Function Lrtjyxxpd() As Boolean                          '用户录入条件有效性判断
    Dim Jsqte As Integer
    Lrtjyxxpd = False
 
    '对需要进行事后判断的文本框录入内容进行有效性判断 (Fixed)
    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 Trim(Cmb_LineName.Text) = "" Then
        Tsxx = "生产线不能为空!"
        Call Xtxxts(Tsxx, 0, 1)
        Cmb_LineName.SetFocus
        Exit Function
    End If
    '物料名称不能为空
    If Trim(Cmb_MName.Text) = "" Then
        Tsxx = "物料名称不能为空!"
        Call Xtxxts(Tsxx, 0, 1)
        Cmb_MName.SetFocus
        Exit Function
    End If
    '取样点不能为空
    If Trim(Cmb_SiteName.Text) = "" Then
        Tsxx = "取样点不能为空!"
        Call Xtxxts(Tsxx, 0, 1)
        Cmb_SiteName.SetFocus
        Exit Function
    End If
    '检验项目不能为空
    If Trim(Cmb_ItemName.Text) = "" Then
        Tsxx = "检验项目不能为空!"
        Call Xtxxts(Tsxx, 0, 1)
        Cmb_ItemName.SetFocus
        Exit Function
    End If
    '文本框不能为空判断
    For Jsqte = 0 To Max_Text_Index
        If Textint(Jsqte, 8) = 1 Then     '字段不能为空
            If Len(Trim(LrText(Jsqte).Text)) = 0 Then
                Tsxx = Textstr(Jsqte, 7) & "不能为空!"
                Call Xtxxts(Tsxx, 0, 1)
                LrText(Jsqte).SetFocus
                
                Exit Function
            End If
        End If
    Next Jsqte
    '查询日期范围应由小到大
    If LrText(0).Text > LrText(1).Text And Trim(LrText(1).Text) <> "" Then
        Tsxx = "查询取样日期范围应由小到大!"
        Call Xtxxts(Tsxx, 0, 4)
        LrText(0).SetFocus
        Exit Function
    End If
  
    '<<]以上为依据实际情况自定义部分
 
    Lrtjyxxpd = True

End Function

Private Sub Cmd_Clear_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)    '将用户输入条件全部清除(可选)

    '清除文本框(Fixed)
    For Jsqte = 0 To Max_Text_Index
        LrText(Jsqte).Tag = ""
        LrText(Jsqte).Text = ""
    Next Jsqte
  
    '[>>
    Cmb_LineName.Text = Cmb_LineName.List(0)
    Cmb_LineCode.Text = Cmb_LineCode.List(0)
    Cmb_SiteName.Clear
    Cmb_SiteCode.Clear
    Cmb_MName.Clear
    Cmb_MNumber.Clear
    Cmb_ItemCode.Clear
    Cmb_ItemName.Clear
    '此处可以写入其他清除条件程序
    '<<]
  
End Sub

'[<<以下为自定义部分
Private Sub Cmb_ItemName_Click()
  If Cmb_ItemCode.ListIndex <> Cmb_ItemName.ListIndex Then
     Cmb_ItemCode.Text = Cmb_ItemCode.List(Cmb_ItemName.ListIndex)
  End If
End Sub

Private Sub Cmb_ItemName_DropDown()
    Cmb_ItemName.Clear
    Cmb_ItemCode.Clear
    Dim Rec_Item As ADODB.Recordset
    Set Rec_Item = Cw_DataEnvi.DataConnect.Execute("SELECT distinct itemcode,itemname FROM Qc_V_MidStandSub WHERE linecode='" & Trim(Cmb_LineCode.Text & "") & "' and MNumber='" & Trim(Cmb_MNumber.Text & "") & "' and sitecode='" & Trim(Cmb_SiteCode.Text & "") & "'")
    If Rec_Item.RecordCount < 1 Then
        Rec_Item.Close
        Exit Sub
    End If
    
    Do While Not Rec_Item.EOF
        Cmb_ItemName.AddItem Trim(Rec_Item!itemname & "") '检验项目名称
        Cmb_ItemCode.AddItem Trim(Rec_Item!itemcode & "") '检验项目代码
        Rec_Item.MoveNext
    Loop
    
    Rec_Item.Close
    Set Rec_Item = Nothing
End Sub
'[<<=============以下程序为控制焦点转移=================
Private Sub Cmb_ItemName_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        LrText(0).SetFocus
    End If
End Sub

Private Sub Cmb_LineName_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        Cmb_MName.SetFocus
    End If
End Sub

Private Sub Cmb_MName_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        Cmb_SiteName.SetFocus
    End If
End Sub

Private Sub Cmb_SiteName_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        Cmb_ItemName.SetFocus
    End If
End Sub
'>>]=============以上程序为控制焦点转移==================

Private Sub Cmb_LineName_Click()
    If Cmb_LineCode.ListIndex <> Cmb_LineName.ListIndex Then
        
        Cmb_LineCode.Text = Cmb_LineCode.List(Cmb_LineName.ListIndex)
        Cmb_MName_DropDown
        Cmb_SiteName_DropDown
        Cmb_ItemName_DropDown
    End If
End Sub

Private Sub Cmb_MName_Click()
    If Cmb_MNumber.ListIndex <> Cmb_MName.ListIndex Then
        
        
        Cmb_MNumber.Text = Cmb_MNumber.List(Cmb_MName.ListIndex)
        Cmb_SiteName_DropDown
        Cmb_ItemName_DropDown
    End If
End Sub

Private Sub Cmb_MName_DropDown()
    Cmb_MName.Clear
    Cmb_MNumber.Clear
    Dim Rs_MName As ADODB.Recordset
    Dim Str_MName As String
    Str_MName = "SELECT distinct MNumber,MName FROM Qc_v_MidStandMain WHERE LineCode='" & Trim(Cmb_LineCode.Text & "") & "'"
    Set Rs_MName = Cw_DataEnvi.DataConnect.Execute(Str_MName)
    If Rs_MName.RecordCount < 1 Then
        Rs_MName.Close
        Exit Sub
    End If
    
    Do While Not Rs_MName.EOF
        Cmb_MName.AddItem Trim(Rs_MName!MName & "")      '物料名称
        Cmb_MNumber.AddItem Trim(Rs_MName!MNumber & "")  '物料编码
        Rs_MName.MoveNext
    Loop
    
    Rs_MName.Close
    Set Rs_MName = Nothing
End Sub

Private Sub Cmb_SiteName_Click()
    If Cmb_SiteName.ListIndex <> -1 Then
        
        Cmb_SiteCode.Text = Cmb_SiteCode.List(Cmb_SiteName.ListIndex)
        Cmb_ItemName_DropDown
    End If
End Sub

Private Sub Cmb_SiteName_DropDown()
    Cmb_SiteName.Clear
    Cmb_SiteCode.Clear
    Dim Rec_Site As ADODB.Recordset
    Set Rec_Site = Cw_DataEnvi.DataConnect.Execute("SELECT distinct SiteCode,SiteName FROM Qc_v_MidStandMain WHERE LineCode='" & Trim(Cmb_LineCode.Text & "") & "' and MNumber='" & Trim(Cmb_MNumber.Text & "") & "'")
    If Rec_Site.RecordCount < 1 Then
        Rec_Site.Close
        Exit Sub
    End If
    
    Do While Not Rec_Site.EOF
        Cmb_SiteName.AddItem Trim(Rec_Site!sitename & "")  '取样点名称
        Cmb_SiteCode.AddItem Trim(Rec_Site!sitecode & "")  '取样点代码
        Rec_Site.MoveNext
    Loop
    
    Rec_Site.Close
    Set Rec_Site = Nothing
End Sub
Private Sub InitCmb()
    Dim Rec_Line As New ADODB.Recordset
    Cmb_LineCode.AddItem " "
    Cmb_LineName.AddItem " "
    Set Rec_Line = Cw_DataEnvi.DataConnect.Execute("Select distinct LineCode,LineName From Qc_v_MidStandMain Order By LineCode ")
    If Rec_Line.RecordCount < 1 Then
        Rec_Line.Close
        Exit Sub
    End If
    Do While Not Rec_Line.EOF
        Cmb_LineCode.AddItem Trim(Rec_Line.Fields("LineCode") & "")
        Cmb_LineName.AddItem Trim(Rec_Line.Fields("LineName") & "")
        Rec_Line.MoveNext