📄 purveys.frm
字号:
VERSION 5.00
Object = "{CFA7AFF4-3242-4269-9172-7389D695AE01}#1.0#0"; "StoneXP.ocx"
Object = "{DAAC6951-59A4-4C08-9D6E-FE3919B64861}#1.0#0"; "FlexCell.ocx"
Begin VB.Form purveys
BorderStyle = 0 'None
Caption = "供货商信息管理"
ClientHeight = 5490
ClientLeft = 0
ClientTop = 0
ClientWidth = 11010
Icon = "purveys.frx":0000
LinkTopic = "xiaoqu"
MaxButton = 0 'False
ScaleHeight = 5490
ScaleWidth = 11010
ShowInTaskbar = 0 'False
StartUpPosition = 1 '所有者中心
Begin StoneXP.XPButton XPButton4
Height = 375
Left = 6600
TabIndex = 5
Top = 4920
Width = 975
_ExtentX = 1720
_ExtentY = 661
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ButtonStyle = 1
Caption = "修 改"
MousePointer = 99
End
Begin FlexCell.Grid Grid1
Height = 4815
Left = 0
TabIndex = 3
Top = 0
Width = 11055
_ExtentX = 19500
_ExtentY = 8493
Appearance = 0
Cols = 9
Rows = 30
ScrollBars = 2
End
Begin StoneXP.XPButton XPButton1
Height = 375
Left = 4440
TabIndex = 1
Top = 4920
Width = 975
_ExtentX = 1720
_ExtentY = 661
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ButtonStyle = 1
Caption = "增 加"
MousePointer = 99
End
Begin StoneXP.XPButton XPButton2
Height = 375
Left = 5520
TabIndex = 2
Top = 4920
Width = 975
_ExtentX = 1720
_ExtentY = 661
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ButtonStyle = 1
Caption = "保 存"
MousePointer = 99
End
Begin StoneXP.XPButton XPButton5
Height = 375
Left = 8760
TabIndex = 0
Top = 4920
Width = 975
_ExtentX = 1720
_ExtentY = 661
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ButtonStyle = 1
Caption = "退 出"
MousePointer = 99
End
Begin StoneXP.XPButton XPButton3
Height = 375
Left = 7680
TabIndex = 4
Top = 4920
Width = 975
_ExtentX = 1720
_ExtentY = 661
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ButtonStyle = 1
Caption = "删 除"
MousePointer = 99
End
Begin VB.Menu cz
Caption = "操作"
Visible = 0 'False
Begin VB.Menu renovate
Caption = "刷新"
End
End
End
Attribute VB_Name = "purveys"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'作者：性灵工作室
'发布日期：2007/03/03
'描 述：简单小型超市采购系统
'网 站：http://www.Mndsoft.com/ (VB6源码博客)
'网 站：http://www.VbDnet.com/ (VB.NET源码博客,主要基于.NET2005)
'e-mail ：Mndsoft@163.com
'e-mail ：Mndsoft@126.com
'OICQ ：88382850
' 如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************
Dim i As Integer
Private Declare Function GetKeyState Lib "user32" _
(ByVal nVirtKey As Long) As Integer
Dim gcolor1, gcolor2 As String
Dim m, n As Integer
Private Sub Form_Load()
With Grid1 '这里是grid的一些参数，包含背景色与单元格的列的宽度等等
.AllowUserResizing = True
.DisplayFocusRect = False
'.ExtencgastCol = True
.Appearance = Flat
.FixedRowColStyle = Flat
.ScrollBarStyle = Flat
.DefaultFont.Name = "Tahoma"
.DefaultFont.Size = 8
.BackColorFixed = RGB(128, 217, 193) 'RGB(90, 158, 214)
.BackColorFixedSel = RGB(128, 217, 193) 'RGB(110, 180, 230)
.BackColorBkg = RGB(128, 217, 193) 'RGB(90, 158, 214)
.BackColorScrollBar = RGB(128, 217, 193)
.BackColor1 = RGB(231, 235, 247)
.BackColor2 = RGB(239, 243, 255)
.GridColor = RGB(148, 190, 231)
.Column(0).Width = 0
.Column(1).Width = 100
.Column(2).Width = 100
.Column(7).Width = 113
End With
Me.BackColor = RGB(128, 217, 193)
cgtable = "供货商" '当前指向表名为权限
Call callmain
End Sub
Private Sub callmain()
cgsave = False
cgedit = True
cgdel = True
Set cg1 = cnn.Execute("select * from " & cgtable)
Grid1.Rows = 1 '清除所有记录
i = 8
Grid1.Cols = i + 1 '必须+1,因为实际上为4行,但第一行是隐藏的
For i = 0 To i - 1 '显示数据的字段名
Grid1.Cell(0, i + 1).Text = cg1.Fields(i).Name '读取表中的各字段名
Next
n = i
i = 1
Do While Not cg1.EOF '通过do while语句将数据从数据库读出并写入到grid控件中
Grid1.Rows = Grid1.Rows + 1
For j = 1 To n '设定读取列
If cg1.Fields(j - 1) = Null Then '空值的处理
Grid1.Cell(i, j).Text = ""
Else
Grid1.Cell(i, j).Text = cg1.Fields(j - 1)
If Mid(Grid1.Cell(i, j).Text, 1, 1) = "." Then
Grid1.Cell(i, j).Text = "0" & Grid1.Cell(i, j).Text
End If
End If
Next
i = i + 1
cg1.MoveNext '读取下一记录
Loop
Grid1.Column(1).Locked = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call XPButton5_Click
End Sub
Private Sub Grid1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then '当用户点击鼠标右键时显示菜单cz
PopupMenu cz
End If
End Sub
Private Sub Grid1_RowColChange(ByVal Row As Long, ByVal Col As Long)
hang = Row '这里是追踪当前鼠标所操作的行位置
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 renovate_Click()
Call callmain
End Sub
Private Sub xpbutton1_Click()
cgsave = True
Set cg1 = cnn.Execute("select * from " & cgtable)
Grid1.Rows = 1 '清除所有记录
Grid1.Rows = 21 '默认为2行
For i = 0 To 1 '显示数据的字段名
Grid1.Cell(0, i + 1).Text = cg1.Fields(i).Name '读取表中的各字段名
Next
Grid1.Column(1).Locked = False
Grid1.Cell(1, 1).SetFocus
XPButton2.Default = True
End Sub
Private Sub XPButton2_Click()
If cgsave = False Then
MsgBox "不支持保存操作！", vbInformation, "当前不支持"
Exit Sub
End If
Call Grid1_RowColChange(hang, 1)
If m <> 0 And n <> 0 Then
Grid1.Range(m, 1, m, 2).BackColor = gcolor1
Grid1.Range(n, 1, n, 2).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, 2).Text = "" Then
MsgBox "第" & i & "行的数据请填完整!", vbInformation, "错误提示"
Grid1.Cell(i, 2).SetFocus
Exit Sub
End If
If Grid1.Cell(i, 1).Text = Grid1.Cell(j, 1).Text And Grid1.Cell(i, 2).Text = Grid1.Cell(j, 2).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, 2).BackColor = RGB(90, 158, 214)
Grid1.Range(j, 1, j, 2).BackColor = RGB(90, 158, 214)
Exit Sub
End If
End If
Next
Next
For i = 1 To Grid1.Rows - 1 '这里是每一行分别组织一个插入语句，并把数据写入数据库
If Grid1.Cell(i, 1).Text <> "" Then
sql = "insert into 供货商 values('"
For j = 1 To Grid1.Cols - 2
sql = sql & Grid1.Cell(i, j).Text & "','"
Next
sql = sql & Grid1.Cell(i, Grid1.Cols - 1).Text & "')"
Set cg2 = cnn.Execute(sql)
End If
Next
MsgBox "资料已保存！", vbInformation, "完成"
Call callmain
End Sub
Private Sub XPButton3_Click()
If cgdel = False Then '如果当前在添加记录，那么修改和删除都就应是不可用的
MsgBox "当前删除操作不被允许!", vbInformation, "非使用对象"
Exit Sub
End If
If hang = 0 Then
Exit Sub
End If
If Grid1.Cell(hang, 1).Text = "" Then
Exit Sub
End If
'这里组织了SQL中的删除语句进行记录的删除
Set cg1 = cnn.Execute("delete from " & cgtable & " where " & cg1.Fields(0).Name & "='" & Grid1.Cell(hang, 1).Text & "' and " & cg1.Fields(1).Name & "='" & Grid1.Cell(hang, 2).Text & "' and " & cg1.Fields(2).Name & "='" & Grid1.Cell(hang, 3).Text & "'")
MsgBox "目标己删除,请刷新数据!", vbInformation, "删除成功"
Call callmain
End Sub
Private Sub XPButton4_Click()
On Error GoTo finish:
Dim delok As String
delok = MsgBox("确认修改刚才修改的所有数据吗？？", vbQuestion + vbOKCancel, "提示")
If delok = vbOK Then
hang = 1
Do While hang <= Grid1.Rows - 1
If Grid1.Cell(hang, 1).Text = "" Then
MsgBox "己完成修改操作!", , "提示"
Exit Sub
End If
'利用SQL的update语句进行修改操作
sql = "update 供货商 set "
For j = 2 To Grid1.Cols - 2
sql = sql & cg1.Fields(j - 1).Name & "='" & Grid1.Cell(hang, j).Text & "',"
Next
sql = sql & cg1.Fields(7).Name & "='" & Grid1.Cell(hang, 8).Text & "' where " & cg1.Fields(0).Name & "='" & Grid1.Cell(hang, 1).Text & "'"
Set cg2 = cnn.Execute(sql) '用cg2更新数据集,这样可实现批量更新
hang = hang + 1
Loop
MsgBox "己完成修改操作!", , "提示"
End If
Exit Sub
finish:
MsgBox Err.Description
End Sub
Private Sub XPButton5_Click()
Unload Me
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -