form1.frm

VB+SQL开发的管理系统软件,希望能对学习写软件工程文档的同学们有所帮助 转载的新云软件的程序

End Sub

Private Sub Grid1_RowColChange(ByVal Row As Long, ByVal Col As Long)
hang = Row
 If Grid1.ReadOnly = True And Grid1.Rows <> 1 Then
  Grid1.Range(1, 1, Grid1.Rows - 1, Grid1.Cols - 1).BackColor = vbWhite
  Grid1.Range(Row, 1, Row, Grid1.Cols - 1).BackColor = RGB(90, 158, 214)
 End If
 Set yx3 = cnn.Execute("select * from 音像类型")
 Grid1.ComboBox(7).Clear
 Do While Not yx3.EOF
 Grid1.ComboBox(7).AddItem yx3.Fields(0)
 yx3.MoveNext
 Loop
End Sub

Private Sub Grid2_RowColChange(ByVal Row As Long, ByVal Col As Long)
If Grid2.Cell(1, 1).Text <> "" Then
If Grid2.Cell(1, 1).Text = "精确查询" Then
Grid2.ComboBox(3).Clear '以下清除表格中combo集中的内容,并加入以下内容
Grid2.ComboBox(3).AddItem "="
Grid2.ComboBox(3).AddItem ">"
Grid2.ComboBox(3).AddItem "<"
Grid2.ComboBox(3).AddItem ">="
Grid2.ComboBox(3).AddItem "<="
Grid2.ComboBox(3).AddItem "<>"
Grid2.ComboBox(2).Clear '先清空记录集
Set yx2 = cnn.Execute("select * from 入库单")
For i = 1 To Grid1.Cols - 1
Grid2.ComboBox(2).AddItem yx2.Fields(i - 1).Name
Next
Else
Grid2.ComboBox(3).Clear
Grid2.ComboBox(3).AddItem "like"
Grid2.ComboBox(2).Clear
Set yx2 = cnn.Execute("select * from 入库单")
For i = 1 To Grid1.Cols - 1
 Select Case i '这里使用case语句是因为模糊查询中数值型是不支持的
   Case 1, 2, 3, 4, 5, 6, 13
   Grid2.ComboBox(2).AddItem yx2.Fields(i - 1).Name
 End Select
Next
End If
End If
End Sub

Private Sub XPButton1_Click()
yxsave = False '当前不允许保存，允许修改
yxdel = True
Grid1.ReadOnly = True
Grid1.Rows = 1
yxsql = "select * from 入库单 order by 入库时间 desc"
yxkusee '执行过程,执行数据的查询与显示
End Sub
Private Sub yxkusee() '这里是通过引入的SQL语句来执行数据的显示
Set yx2 = cnn.Execute(yxsql)
Do While Not yx2.EOF '当YX2记录集未到结尾时执行
Grid1.Rows = Grid1.Rows + 1
Grid1.Cell(Grid1.Rows - 1, 0).Text = Grid1.Rows - 1
 For j = 1 To Grid1.Cols - 1 '设定读取列
 If Not yx2.Fields(j - 1) Is Nothing Then '空值的处理
  Grid1.Cell(Grid1.Rows - 1, j).Text = yx2.Fields(j - 1)
    If Mid(Grid1.Cell(Grid1.Rows - 1, j).Text, 1, 1) = "." Then
    Grid1.Cell(Grid1.Rows - 1, j).Text = "0" & Grid1.Cell(Grid1.Rows - 1, j).Text
   End If
 Else
 Grid1.Cell(Grid1.Rows - 1, j).Text = ""
 End If
 Next
 yx2.MoveNext
Loop
End Sub

Private Sub XPButton2_Click()
yxsave = True
addmx = True '指示当前可以添加明细，即grid的行数
Grid1.ReadOnly = False
Grid1.Rows = 1 '使用等于1可以将表格中的残余数据清空
Grid1.Rows = 2
Grid1.Cell(Grid1.Rows - 1, 0).Text = Grid1.Rows - 1
gridread
End Sub

Private Sub XPButton3_Click()
If addmx = True Then
Grid1.Rows = Grid1.Rows + 1
Grid1.Cell(Grid1.Rows - 1, 0).Text = Grid1.Rows - 1
gridread '写入初始的一些固定信息，无须用户在输入的数据
End If
End Sub
Private Sub gridread() '写入初始的一些固定信息，无须用户在输入的数据
Grid1.Cell(Grid1.Rows - 1, 1).Text = Date
 For i = 1 To Grid1.Rows - 1
Grid1.Cell(i, 2).Text = Time
 Next
Grid1.Cell(Grid1.Rows - 1, 3).Text = yxadmin
Grid1.Cell(Grid1.Rows - 1, 8).Text = "0"
Grid1.Cell(Grid1.Rows - 1, 9).Text = "0.00"
Grid1.Cell(Grid1.Rows - 1, 10).Text = "0.00"
Grid1.Cell(Grid1.Rows - 1, 11).Text = "0"
Grid1.Cell(Grid1.Rows - 1, 12).Text = "100"
Grid1.Cell(Grid1.Rows - 1, 4).SetFocus
End Sub
Private Sub Grid1_Validate(Cancel As Boolean) '设定TAB键切换
    Dim nActiveRow As Long, nActiveCol As Long
    Const VK_TAB = 9

    If GetKeyState(VK_TAB) < 0 Then
        nActiveRow = Grid1.ActiveCell.Row
        nActiveCol = Grid1.ActiveCell.Col
        If nActiveCol < Grid1.Cols - 1 Then
            Grid1.Range(nActiveRow, nActiveCol + 1, _
                        nActiveRow, nActiveCol + 1).Selected
        End If
        Cancel = True
    End If
End Sub


Private Sub XPButton4_Click() '执行保存
On Error GoTo finish:
If m <> 0 And n <> 0 Then '这里设定了如果有两行颜色一样的数据，那么系统自动给那两行变色
Grid1.Range(m, 1, m, 4).BackColor = gcolor1
Grid1.Range(n, 1, n, 4).BackColor = gcolor2
End If
For i = 1 To Grid1.Rows - 1
 For j = i + 1 To Grid1.Rows - 1
  If Grid1.Cell(i, 1).Text <> "" Then
  If Grid1.Cell(i, 4).Text = Grid1.Cell(j, 4).Text Or Grid1.Cell(i, 5).Text = Grid1.Cell(j, 5).Text Then
  MsgBox "第" & i & "行与" & j & "行的编号或助记码出现重复，请修改!", vbInformation, "重复错误"
  m = i
  n = j
  gcolor1 = Grid1.Cell(m, 1).BackColor
  gcolor2 = Grid1.Cell(n, 1).BackColor
  Grid1.Range(i, 1, i, Grid1.Cols - 1).BackColor = RGB(90, 158, 214)
  Grid1.Range(j, 1, j, Grid1.Cols - 1).BackColor = RGB(90, 158, 214)
  Exit Sub
  End If
  End If
 Next
Next
For i = 1 To Grid1.Rows - 1
 For j = 1 To Grid1.Cols - 2
 If Grid1.Cell(i, 4).Text <> "" And Grid1.Cell(i, 5).Text <> "" Then
   If Grid1.Cell(i, j).Text = "" Then
   MsgBox "第" & i & "行的数据请填完整!", vbInformation, "错误提示"
   Grid1.Cell(i, j).SetFocus
   Exit Sub
   End If
 Else
 Exit For
 End If
 Next
Next
'--------------------------------
For i = 1 To Grid1.Rows - 1
 If Grid1.Cell(i, 4).Text <> "" And Grid1.Cell(i, 5).Text <> "" Then
  '---------这里加入如果输入的类型是第一次，那么自动写入数据库
  If Grid1.Cell(i, 7).Text <> "" Then
  Set yx1 = cnn.Execute("select * from 音像类型 where 音像类型='" & Grid1.Cell(i, 7).Text & "'")
   If yx1.EOF = True Then
  Set yx1 = cnn.Execute("insert into 音像类型 values('" & Grid1.Cell(i, 7).Text & "')")
   End If
  End If
  '以下是sql组织插入语句,插入到表入库单
      yxsql = "insert into 入库单 values('" '这是组织插入到入库单的语句
    yxsql1 = "insert into 库存 values('" '这是组织插入到库存的语句
'****************以下由于前三位库存中用不到所以在这里独立开来
 For j = 1 To 6
  If j = 2 Then '这里保存时间因为用的是日期字段，所以同时也保存日期到该字段中
    yxsql = yxsql & Grid1.Cell(i, 1).Text & " " & Grid1.Cell(i, 2).Text & "','"
  Else
    yxsql = yxsql & Grid1.Cell(i, j).Text & "','"
  End If
 Next
 '-*************以下是表格中提出第4个单元格到第6个单元格的字符
 For j = 4 To 6
  yxsql1 = yxsql1 & Grid1.Cell(i, j).Text & "','"
 Next
 '**************
    yxsql = yxsql & Grid1.Cell(i, 7).Text & "',"
    yxsql1 = yxsql1 & Grid1.Cell(i, 7).Text & "',"
 For j = 8 To 11
    yxsql = yxsql & Grid1.Cell(i, j).Text & ","
    yxsql1 = yxsql1 & Grid1.Cell(i, j).Text & ","
 Next
    yxsql = yxsql & Grid1.Cell(i, 12).Text & ",'" & Grid1.Cell(i, 13).Text & "')"
    yxsql1 = yxsql1 & Grid1.Cell(i, 12).Text & ",'" & Grid1.Cell(i, 13).Text & "')"
'以上因为在组织SQL语句时会碰到数值型，所以不可以有单引号出现
Set yx2 = cnn.Execute(yxsql) '执行插入语句
'-------******以下需要确定数据库是否已有这类库存数据
yxsql2 = "select 数量 from 库存 where "
 For j = 4 To 7
  yxsql2 = yxsql2 & Grid1.Cell(0, j).Text & "='" & Grid1.Cell(i, j).Text & "' and "
 Next
'因为第9和第10单元格的类型是货币型，所以不能使用单引号
   yxsql2 = yxsql2 & Grid1.Cell(0, 9).Text & "=" & Grid1.Cell(i, 9).Text & " and " & Grid1.Cell(0, 10).Text & "=" & Grid1.Cell(i, 10).Text
'---------组织查询语句
Set yx2 = cnn.Execute(yxsql2) '执行查询
If yx2.EOF = True Then
Set yx2 = cnn.Execute(yxsql1)
Else
 '*********组织修改库存语句***********
 yxsql1 = "update 库存 set 数量=" & yx2.Fields(0) + Val(Grid1.Cell(i, 8).Text) & " where "
 For j = 4 To 7
  yxsql1 = yxsql1 & Grid1.Cell(0, j).Text & "='" & Grid1.Cell(i, j).Text & "' and "
 Next
'因为第9和第10单元格的类型是货币型，所以不能使用单引号
   yxsql1 = yxsql1 & Grid1.Cell(0, 9).Text & "=" & Grid1.Cell(i, 9).Text & " and " & Grid1.Cell(0, 10).Text & "=" & Grid1.Cell(i, 10).Text
 Set yx2 = cnn.Execute(yxsql1)
 '************************************
End If
End If
Next
MsgBox "入库操作已完成！"
addmx = False
Call XPButton1_Click
Exit Sub
finish:
MsgBox Err.Description
End Sub

Private Sub XPButton5_Click()
On Error GoTo finish:
'*************删除入库,同时也要删除库存，主要要先查询库存中该物品是否数量
'*************大于或等于用户选的数据,如果小于则建议用户重新录入新入库,数量为负
'*************这样才能实现库存同时的删除
yxsql = "select 数量 from 库存 where "
 For j = 4 To 7
  yxsql = yxsql & Grid1.Cell(0, j).Text & "='" & Grid1.Cell(hang, j).Text & "' and "
 Next
'因为第9和第10单元格的类型是货币型，所以不能使用单引号
   yxsql = yxsql & Grid1.Cell(0, 9).Text & "=" & Grid1.Cell(hang, 9).Text & " and " & Grid1.Cell(0, 10).Text & "=" & Grid1.Cell(hang, 10).Text
'---------组织查询语句
Set yx2 = cnn.Execute(yxsql) '执行语句查询
If yx2.EOF = True Then
MsgBox "库存中该库存物品不存在！"
ElseIf yx2.Fields(0) < Val(Grid1.Cell(hang, 8).Text) Then
MsgBox "库存中该物品所余数量小于要注销的数量,请检查！"
Else
'***********执行修改数量
 yxsql1 = "update 库存 set 数量=" & yx2.Fields(0) - Val(Grid1.Cell(hang, 8).Text) & " where "
 For j = 4 To 7
  yxsql1 = yxsql1 & Grid1.Cell(0, j).Text & "='" & Grid1.Cell(hang, j).Text & "' and "
 Next
'因为第9和第10单元格的类型是货币型，所以不能使用单引号
   yxsql1 = yxsql1 & Grid1.Cell(0, 9).Text & "=" & Grid1.Cell(hang, 9).Text & " and " & Grid1.Cell(0, 10).Text & "=" & Grid1.Cell(hang, 10).Text
  Set yx2 = cnn.Execute(yxsql1)
'************删除入库单记录
yxsql2 = "delete from 入库单 where "
 For j = 1 To 6
  yxsql2 = yxsql2 & Grid1.Cell(0, j).Text & "='" & Grid1.Cell(hang, j).Text & "' and "
 Next
  yxsql2 = yxsql2 & Grid1.Cell(0, 7).Text & "='" & Grid1.Cell(hang, 7).Text & "'"
 MsgBox yxsql2
 Set yx2 = cnn.Execute(yxsql2)
 MsgBox "该商品在库存中已成功注销！"
 Call XPButton1_Click
End If
Exit Sub
finish:
MsgBox Err.Description
End Sub

Private Sub XPButton6_Click()
On Error GoTo finish '防错代码，防止用户组织语句的错误或其它不可预见的错误发生
If Grid2.Cell(1, 1).Text <> "" And Grid2.Cell(1, 2).Text <> "" And Grid2.Cell(1, 3).Text <> "" And Grid2.Cell(1, 4).Text <> "" Then
    If Grid2.Cell(1, 1).Text = "精确查询" Then
     Select Case Grid2.Cell(1, 3).Text '处理字符型组织语句
      Case "数量", "单价", "进货价格", "售出价格", "总价格"
      yxsql = "select * from 入库单 where " & Grid2.Cell(1, 2).Text & Grid2.Cell(1, 3).Text & Grid2.Cell(1, 4).Text
      Case Else
      yxsql = "select * from 入库单 where " & Grid2.Cell(1, 2).Text & Grid2.Cell(1, 3).Text & "'" & Grid2.Cell(1, 4).Text & "'"
     End Select
    Else
    yxsql = "select * from 入库单 where " & Grid2.Cell(1, 2).Text & " like '%" & Grid2.Cell(1, 4).Text & "%'"
    End If
    If Grid2.Cell(1, 5).Text <> "" Then
    yxsql = yxsql & " " & Grid2.Cell(1, 5).Text
    End If
  Grid1.Rows = 1
  yxkusee
  XPFrame1.Visible = False
Else
MsgBox "查询时关键组成部分不可以出现空格！"
End If
Exit Sub
finish:
  MsgBox Err.Description
End Sub

Private Sub XPButton7_Click()
XPFrame1.Visible = False
End Sub

Private Sub XPButton8_Click()
If XPFrame1.Visible = False Then
XPFrame1.Visible = True
Else
XPFrame1.Visible = False
End If
End Sub