新人小白初学VB6.0语言

weixin_44686364 2019-03-08 03:53:43
用VB6.0+Mysql Sever2008设计一个信息管理系统:职员信息可以查询,删除。增加新数据和修改数据则不行。望大佬看看问题出在哪儿了
全局变量:
```
Option Explicit

Public guserName As String '用户名称,该变量用于存储登录用户的名称
Public guserKind As String '用户类型,该变量用于确定登录用户的类型
Public gempID As String '员工编号,该变量用于记录当前职员的编号
Public gbLog As Boolean '登录成功,该变量用于标识是否登录成功
Public conn As ADODB.Connection '数据库的connection对象

Public Function ConnStr() As String
ConnStr = "Provider=SQLOLEDB.1 ;integerated Security =SSPI; Persist Security Info=False;User ID=sa;Password=LK19960217;Initial Catalog=DBEmp;Data Source=ThePower,1433"
End Function

Public Function ExeSQL(SQL As String, rs As ADODB.Recordset, Optional enWrite As Boolean = True) As Boolean
On Error GoTo Exe_Error '如果有错误,则转入Exe_Error处
Set rs = New ADODB.Recordset
If enWrite Then
rs.Open SQL, conn, adOpenStatic, adLockOptimistic '以写方式执行SQL语句
Else
rs.Open SQL, conn, adOpenStatic, adLockReadOnly '以只读方式执行SQL语句
End If
ExeSQL = True '执行成功,返回true
Exit Function
Exe_Error:
ExeSQL = False '执行失败,返回false
Exit Function
End Function

Public Function RecExist(SQL As String) As Integer
Dim flag As String '标识SQL语句是否成功执行
Dim rs As ADODB.Recordset
flag = ExeSQL(SQL, rs, False) '执行SQL语句并返回结果
If rs.RecordCount <> 0 Then
RecExist = rs.RecordCount 'RecExist 返回值为记录数
Else
RecExist = 0 '如果记录数不存在,则返回0
End If
End Function

Public Function RefData(txtSQL As String, dgRef As DataGrid) As Integer
Dim rsData As ADODB.Recordset
Dim result As String '定义ExeSQL函数返回结果
result = ExeSQL(txtSQL, rsData, False)

If rsData.RecordCount <> 0 Then '如果返回的Recordset对象中的记录数不为0
Set dgRef.DataSource = rsData '设置DataGrid 的数据源
RefData = rsData.RecordCount
Else
MsgBox "数据为空!", vbOKOnly + vbExclamation, "警告"
RefData = 0
End If
End Function

Public Function ISEquLen(txt As TextBox, intlen As Integer) As Boolean
If Len(txt.Text) <> intlen Then '如果输入的数据位数不符合规定
MsgBox "输入数据有误请重新输入!"
txt.SetFocus '输入文本框获得焦点,让用户重新输入
ISEquLen = False
Else
ISEquLen = True
End If
End Function

Public Function OpenConn() '建立数据库链接
Set conn = New ADODB.Connection '创建新的连接
conn.Open ConnStr '打开数据库连接

End Function


Public Function CloseConn()
conn.Close '关闭数据库连接

End Function

Sub Main() '应用程序启动入口
Dim frmLog As New frmLogin '定义登录窗体变量
Dim title As String '定义字符串变量用于记录程序标题

If App.PrevInstance Then '检查应用程序实例是否运行
title = App.title
MsgBox "应用程序已经运行!"
App.title = "" '设置应用程序标题为空
frmmain.Caption = "" '设置主窗体标题为空
AppActivate title


Else
OpenConn '打开数据库连接
frmLog.Show vbModal '显示登录窗体
End If
Unload frmLog '卸载登录窗体




End Sub






增删改查:
Option Explicit
Dim strSQL As String
Dim result As Integer
Dim rs As ADODB.Recordset
Dim str As String




Private Sub cmdADD_Click()
If txtID.Text = "" Then
MsgBox "请输入编号"
txtID.SetFocus
Exit Sub
ElseIf Len(Trim(txtID.Text)) <> 4 Then
MsgBox "输入的编号必须为4位"
txtID.SetFocus
Exit Sub
Else
If txtName.Text = "" Then
MsgBox "请输入姓名"
Exit Sub
End If
End If

If cboSex.Text = "" Then
MsgBox "请选择性别"
cboSex.SetFocus
Exit Sub
End If



strSQL = "select * from tbEmp where empID='" & Trim(txtID.Text) & " '"

If RecExist(strSQL) <> 0 Then

MsgBox "该员工编号已存在,请重新输入"
txtID.SetFocus
Exit Sub

Else


strSQL = "insert into tbEmp(empID,empName,empSex,empNation,"
strSQL = strSQL & "empBirthday,empDep,empEdu,empDuty,email,idenID,mobileTel,tencentID,empAddr)"
strSQL = strSQL & " value(' "
strSQL = strSQL & Trim(txtID.Text) & " ','"
strSQL = strSQL & Trim(txtName.Text) & " ','"
strSQL = strSQL & Trim(cboSex.Text) & "','"
strSQL = strSQL & Trim(cboNation.Text) & "','"
strSQL = strSQL & Trim(txtBirthday.Text) & "','"
strSQL = strSQL & Trim(cboDep.Text) & "','"
strSQL = strSQL & Trim(cboEdu.Text) & "','"
strSQL = strSQL & Trim(cboDuty.Text) & "','"
strSQL = strSQL & Trim(txtEmail.Text) & "','"
strSQL = strSQL & Trim(txtidenID.Text) & "','"
strSQL = strSQL & Trim(txtMoblieTel.Text) & "','"
strSQL = strSQL & Trim(txtTencent.Text) & "','"
strSQL = strSQL & Trim(txtAddr.Text) & "')"

result = ExeSQL(strSQL, rs, True)
strSQL = "select empID as 员工编号,empName as 姓名,empSex as 性别 from tbEmp"
result = RefData(strSQL, Me.dgEmp)


InfoClear

End If


End Sub

Private Sub cmdCancel_Click()
Unload Me

End Sub

Private Sub initcboFields()
Me.cboFields.AddItem "员工编号"
Me.cboFields.AddItem "姓名"
Me.cboFields.AddItem "性别"
Me.cboFields.AddItem "职务"



End Sub

Private Sub cmdDel_Click()
If txtID.Text = "" Then
MsgBox "请选择要删除的记录"
Exit Sub
End If

str = MsgBox("确认要删除该记录?", vbOKCancel, "警告")
If str = vbCancel Then
Exit Sub
End If

strSQL = "delete from tbEmp where empID='" & Trim(txtID.Text) & "'"
result = ExeSQL(strSQL, rs, True)
strSQL = "select empID as 员工编号,empName as 姓名,empSex as 性别 from tbEmp"
result = RefData(strSQL, Me.dgEmp)
MsgBox "记录删除成功"
InfoClear

End Sub

Private Sub cmdModify_Click()
If txtID.Text = "" Then
MsgBox "请输入编号"
txtID.SetFocus
Exit Sub
ElseIf Len(Trim(txtID.Text)) <> 4 Then
MsgBox "输入的编号必须为4位"
txtID.SetFocus
Exit Sub
Else
If txtName.Text = "" Then
MsgBox "请输入姓名"
Exit Sub
End If
End If

If cboSex.Text = "" Then
MsgBox "请选择性别"
cboSex.SetFocus
Exit Sub
End If

strSQL = "update tbEmp set empID='" & Trim(txtID.Text)
strSQL = strSQL & "',empName='" & Trim(txtName.Text)
strSQL = strSQL & "',empSex='" & Trim(cboSex.Text)
strSQL = strSQL & "',empNation='" & Trim(cboNation.Text)
strSQL = strSQL & "',empBirthday='" & Trim(txtBirthday.Text)
strSQL = strSQL & "',empDep='" & Trim(cboDep.Text)
strSQL = strSQL & "',empEdu='" & Trim(cboEdu.Text)
strSQL = strSQL & "',empDuty='" & Trim(cboDuty.Text)
strSQL = strSQL & "',email='" & Trim(txtEmail.Text)
strSQL = strSQL & "',idenID='" & Trim(txtidenID.Text)
strSQL = strSQL & "',mobileTel='" & Trim(txtMoblieTel.Text)
strSQL = strSQL & "',tencentID='" & Trim(txtTencent.Text)
strSQL = strSQL & "',empAddr='" & Trim(txtAddr.Text)

result = ExeSQL(strSQL, rs, True)
strSQL = "select empID as 员工编号,empName as 姓名,empSex as 性别 from tbEmp"
result = RefData(strSQL, Me.dgEmp)
MsgBox "修改记录成功"


End Sub

Private Sub cmdQuery_Click()
Dim strTemp As String '定义临时字段

If cboFields.Text = "员工编号" Then
strTemp = "empID"
ElseIf cboFields.Text = "姓名" Then
strTemp = "empName"
ElseIf cboFields.Text = "性别" Then
strTemp = "empSex"
Else
strTemp = "empDuty"
End If


strSQL = "select * from tbEmp where " & strTemp & "='" & txtSelect.Text & " ' "
result = ExeSQL(strSQL, rs)
result = RefData(strSQL, dgEmp)
dgEmp_RowColChange 1, 1

End Sub

Private Sub dgEmp_RowColChange(LastRow As Variant, ByVal LastCol As Integer)

Dim rsTemp As ADODB.Recordset
strSQL = "select * from tbEmp where empID='" & dgEmp.Columns(0) & "'"
result = ExeSQL(strSQL, rsTemp)
txtName.Text = rsTemp("empName")
txtID.Text = rsTemp("empID")
cboSex.Text = rsTemp("empSex")
txtBirthday.Text = rsTemp("empBirthday")
cboNation.Text = rsTemp("empNation")
cboDep.Text = rsTemp("empDep")
cboEdu.Text = rsTemp("empEdu")
cboDuty.Text = rsTemp("empDuty")
txtEmail.Text = rsTemp("email")
txtidenID.Text = rsTemp("idenID")
txtMoblieTel.Text = rsTemp("mobileTel")
txtTencent.Text = rsTemp("tencentID")
txtAddr.Text = rsTemp("empAddr")
End Sub

Private Sub Form_Load()
strSQL = "select empID as 员工编号,empName as 姓名,empSex as 性别 from tbEmp"
result = RefData(strSQL, Me.dgEmp) '查询结果显示在DataGrid控件中
dgEmp_RowColChange 1, 1

Call initcboFields '调用这个函数
Call initSex
Call initNation
Call initDep
Call initDuty
Call initEdu

InfoClear

End Sub


Private Sub initSex()
cboSex.AddItem "男"
cboSex.AddItem "女"
End Sub

Private Sub initNation()
Dim i As Integer
strSQL = "select * from tbNation"
result = ExeSQL(strSQL, rs)
For i = 0 To rs.RecordCount - 1
cboNation.AddItem rs.Fields(1)
rs.MoveNext
Next
End Sub

Private Sub initDep()
Dim i As Integer
strSQL = "select * from tbDep"
result = ExeSQL(strSQL, rs)
For i = 0 To rs.RecordCount - 1
cboDep.AddItem rs.Fields(1)
rs.MoveNext
Next
End Sub

Private Sub initDuty()
Dim i As Integer
strSQL = "select * from tbDuty"
result = ExeSQL(strSQL, rs)
For i = 0 To rs.RecordCount - 1
cboDuty.AddItem rs.Fields(1)
rs.MoveNext
Next
End Sub

Private Sub initEdu()
Dim i As Integer
strSQL = "select * from tbEdu"
result = ExeSQL(strSQL, rs)
For i = 0 To rs.RecordCount - 1
cboEdu.AddItem rs.Fields(1)
rs.MoveNext
Next
End Sub

Private Sub InfoClear() '清空详细情况文本框
txtName.Text = ""
txtID.Text = ""
cboSex.Text = ""
txtBirthday.Text = ""
cboNation.Text = ""
cboDep.Text = ""
cboEdu.Text = ""
cboDuty.Text = ""
txtEmail.Text = ""
txtidenID.Text = ""
txtMoblieTel.Text = ""
txtTencent.Text = ""
txtAddr.Text = ""


End Sub


还有就是登录界面:
















```
...全文
1882 23 打赏 收藏 转发到动态 举报
写回复
用AI写文章
23 条回复
切换为时间正序
请发表友善的回复…
发表回复
Sophiatm 2019-03-12
  • 打赏
  • 举报
回复
新人就这么猛了吗6666
Rysxt_ 2019-03-11
  • 打赏
  • 举报
回复
初学者。。。。。。。
「已注销」 2019-03-11
  • 打赏
  • 举报
回复
" " <' > / <img src onerror=>
weixin_44752129 2019-03-11
  • 打赏
  • 举报
回复
学习了,领教了
  • 打赏
  • 举报
回复
看到您的帖子,小弟再也不敢自称小白了。
  • 打赏
  • 举报
回复
这个是汇编语言吗
aa261571017 2019-03-10
  • 打赏
  • 举报
回复
从小白到入门(java web篇)
一叶小竹 2019-03-10
  • 打赏
  • 举报
回复
初学都能这么厉害,以后定然是高手
T0927 2019-03-10
  • 打赏
  • 举报
回复
看不懂
大坚坚 2019-03-10
  • 打赏
  • 举报
回复
只会用VB6一直想学MYSQL
uc49185023 2019-03-10
  • 打赏
  • 举报
回复
哈哈!
ytdzjun 2019-03-10
  • 打赏
  • 举报
回复
早年写的一个类似的窗口操作的代码供参考,C/S结构的,conn打开的代码略。

Dim rstCf As ADODB.Recordset
Dim f_bz, f_bz1 As Integer
Dim lBookMark As Long
Private Sub cmdadd_Click(Index As Integer)
With frmcfinput
Dim i As Integer
For i = 0 To 7
'8个文本框构成组,调用时用到
Text1(i) = ""
Next i
Text1(0).SetFocus
End With
End Sub

Private Sub cmdexit_Click(Index As Integer)
With frmcfinput
rstCf.Close
Set rstCf = Nothing
Unload Me
End With
End Sub

Private Sub cmdfrst_Click(Index As Integer)
With frmcfinput
rstCf.MoveFirst
Call rfCfInput
End With
End Sub

Private Sub cmdLast_Click(Index As Integer)
With frmcfinput
rstCf.MoveLast
Call rfCfInput
End With
End Sub

Private Sub cmdNext_Click(Index As Integer)
With frmcfinput
rstCf.MoveNext
If Not rstCf.EOF Then
Call rfCfInput
Else
rstCf.MoveLast
Call rfCfInput
End If
'
'If Not rstCf.EOF Then
' If rstCf.BOF Then
' rstCf.MoveFirst
' 'Call rfCfInput
' End If
' 'rstCf.MoveNext
' If rstCf.EOF Then
' rstCf.MoveLast
' 'Call rfCfInput
' End If
' Call rfCfInput
' Else
' rstCf.MoveLast
' Call rfCfInput
'End If
End With
End Sub

Private Sub cmdprev_Click(Index As Integer)
With frmcfinput
rstCf.MovePrevious
If Not rstCf.BOF Then
Call rfCfInput
Else
rstCf.MoveFirst
Call rfCfInput
End If

'
' If Not rstCf.BOF Then
' If rstCf.EOF Then
' rstCf.MoveLast
' End If
' rstCf.MovePrevious
' If rstCf.BOF Then
' rstCf.MoveFirst
' End If
' Call rfCfInput
' Else
' rstCf.MoveFirst
' Call rfCfInput
' End If
End With
End Sub

Private Sub cmdsave_Click(Index As Integer)
With frmcfinput
If Len(Trim(Text1(0).Text)) = 0 Then
MsgBox "编号不能为空!", vbExclamation
Text1(0).SetFocus
Exit Sub
End If
If Len(Trim(Text1(3).Text)) = 0 Then
MsgBox "处分类型不能为空!", vbExclamation
Text1(3).SetFocus
Exit Sub
End If
If Not IsDate(Text1(4).Text) Then
MsgBox "时间格式应为 yy-mm-dd 方式", vbExclamation
Text1(4).SetFocus
Exit Sub
End If

If Len(Trim(Text1(5).Text)) = 0 Then
MsgBox "处分原因不能为空!", vbExclamation
Text1(5).SetFocus
Exit Sub
End If
If Len(Trim(Text1(6).Text)) = 0 Then
MsgBox "处分文号不能为空!", vbExclamation
Text1(7).SetFocus
Exit Sub
End If


rstCf.AddNew
Call fz
'On Error GoTo err
rstCf.Update
'上行将一条记录写入数据表的语句
rstCf.Requery
rstCf.MoveLast
Dim i As Integer
For i = 0 To 2
Text1(i) = ""
Next i
'
'Exit Sub
'err:
'MsgBox "处分文号不能重复!", vbExclamation
'rstCf.CancelUpdate
lBookMark = rstCf.Bookmark
Text2.Text = Str(lBookMark) & " /" & Str(rstCf.RecordCount)
Text1(0).SetFocus
End With
End Sub

Private Sub Form_Load() '连接并打开库和表

Set rstCf = New ADODB.Recordset
'注册这里用到NEW关键字
rstCf.Open "xj_xscf order by cfsj", Conn, adOpenKeyset, adLockOptimistic
If rstCf.RecordCount > 0 Then
rstCf.MoveLast
lBookMark = rstCf.Bookmark
Text2.Text = Str(lBookMark) & " /" & Str(rstCf.RecordCount)
Dim i As Integer
For i = 0 To 7
Text1(i) = ""
Next i
Else
MsgBox "数据库无相关记录!", vbOKOnly, "错误提示"
Exit Sub
End If
End Sub

Sub fz() '给各字段赋值
With frmcfinput
rstCf("xsbh") = Trim(Text1(0).Text)
rstCf("xsxm") = Trim(Text1(1).Text)
rstCf("bjmc") = Trim(Text1(2).Text)
rstCf("sscf") = Trim(Text1(3).Text)
rstCf("cfsj") = Trim(Text1(4).Text)
rstCf("cfyy") = Trim(Text1(5).Text)
rstCf("cfwh") = Trim(Text1(6).Text)
rstCf("bz") = Trim(Text1(7).Text)
End With
End Sub


Private Sub text1_gotfocus(Index As Integer)
With frmcfinput '当获得焦点时改变目标背景色
Select Case Index
Case 0
Text1(Index).BackColor = RGB(255, 255, 255)
Case 1
Text1(Index).BackColor = RGB(255, 255, 255)
Case 2
Text1(Index).BackColor = RGB(255, 255, 255)
Case 3
Text1(Index).BackColor = RGB(255, 255, 255)
Case 4
Text1(Index).BackColor = RGB(255, 255, 255)
Case 5
Text1(Index).BackColor = RGB(255, 255, 255)
Case 6
Text1(Index).BackColor = RGB(255, 255, 255)
Case 7
Text1(Index).BackColor = RGB(255, 255, 255)
End Select
If Index = 7 Then
End If
End With
End Sub

Private Sub Text1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
With frmcfinput
If KeyCode = 13 Then
If Index = 0 Then
Text1(3).SetFocus
End If
If Index = 3 Then
Text1(4).SetFocus
End If
If Index = 4 Then
Text1(5).SetFocus
End If
If Index = 5 Then
Text1(6).SetFocus
End If
If Index = 6 Then
Text1(7).SetFocus
End If
If Index = 7 Then
cmdSave(1).SetFocus
End If
End If
End With
End Sub

Private Sub Text1_LostFocus(Index As Integer)
With frmcfinput '恢复背景色
If Index = 0 Then
If Len(Trim(Text1(0).Text)) = 0 Then
cmdExit(2).SetFocus
Exit Sub
End If
Dim DK_xsqk As ADODB.Recordset
Dim DK_bjbh As ADODB.Recordset
Set DK_xsqk = New ADODB.Recordset
DK_xsqk.Open "select *from xj_xsqk where xsbh='" & Trim(Text1(0).Text) & "'", Conn, adOpenKeyset, adLockOptimistic
f_bz = 0
If DK_xsqk.RecordCount = 0 Then
f_bz = 1
MsgBox "编号为 " + Text1(0).Text + " 的角色不存在,请重输!", vbExclamation
Text1(0).SelStart = 0
Text1(0).SelLength = Len(Text1(0).Text)
Text1(0).SetFocus
DK_xsqk.Close
Set DK_xsqk = Nothing
Exit Sub
End If

If Index = 3 And f_bz = 1 Then
Text1(0).SetFocus
Exit Sub
End If
Text1(1).Text = DK_xsqk("xsxm")

Set DK_bjbh = New ADODB.Recordset
DK_bjbh.Open "select *from xj_bjbh where bjdm='" & Trim(DK_xsqk("bjdm")) & "'", Conn, adOpenKeyset, adLockOptimistic
Text1(2).Text = DK_bjbh("bjmc")
DK_bjbh.Close
Set DK_bjbh = Nothing
DK_xsqk.Close
Set DK_xsqk = Nothing

End If

If Index = 4 Then
f_bz1 = 0
If IsDate(Text1(4).Text) Then
Text1(4).Text = Format(Text1(4).Text, "yy-mm-dd")
Else
f_bz1 = 1
MsgBox "时间格式应为 yy-mm-dd 方式", vbExclamation
Text1(4).SetFocus
Exit Sub
End If

If Index = 5 And f_bz1 = 1 Then
Text1(4).SetFocus
Exit Sub
End If
End If
Select Case Index
Case 0
Text1(Index).BackColor = RGB(243, 219, 182)
Case 1
Text1(Index).BackColor = RGB(243, 219, 182)
Case 2
Text1(Index).BackColor = RGB(243, 219, 182)
Case 3
Text1(Index).BackColor = RGB(243, 219, 182)
Case 4
Text1(Index).BackColor = RGB(243, 219, 182)
Case 5
Text1(Index).BackColor = RGB(243, 219, 182)
Case 6
Text1(Index).BackColor = RGB(243, 219, 182)
Case 7
Text1(Index).BackColor = RGB(243, 219, 182)
End Select
End With
End Sub
Sub rfCfInput() '刷新各字段的值
Text1(0).Text = Trim("" & rstCf("xsbh"))
Text1(1).Text = Trim("" & rstCf("xsxm"))
Text1(2).Text = Trim("" & rstCf("bjmc"))
Text1(3).Text = Trim("" & rstCf("sscf"))
Text1(4).Text = Trim("" & rstCf("cfsj"))
Text1(5).Text = Trim("" & rstCf("cfyy"))
Text1(6).Text = Trim("" & rstCf("cfwh"))
Text1(7).Text = Trim("" & rstCf("bz"))
lBookMark = rstCf.Bookmark
Text2.Text = Str(lBookMark) & " /" & Str(rstCf.RecordCount)
End Sub
weixin_44686364 2019-03-09
  • 打赏
  • 举报
回复
weixin_44686364 2019-03-09
  • 打赏
  • 举报
回复
也没用。增加数据和修改数据代码执行不到SQL sever的表里去
milaoshu1020 2019-03-09
  • 打赏
  • 举报
回复
可以ExeSQL函数增加debug.print显示错误,看看是什么原因:
Exe_Error:
debug.print err.number & ": " & err.description
ExeSQL = False '执行失败,返回false
weixin_44686364 2019-03-09
  • 打赏
  • 举报
回复
问题是出在insert 语句和update语句根本没执行
weixin_44686364 2019-03-09
  • 打赏
  • 举报
回复
问题已经明了。增加数据错在数据库主键字段类型设置。修改数据错在update语句后缺少“where”语句
weixin_44686364 2019-03-09
  • 打赏
  • 举报
回复
十分感谢你的相助
milaoshu1020 2019-03-09
  • 打赏
  • 举报
回复
引用 8 楼 weixin_44686364 的回复:
那修改数据呢?

数据库程序里,修改字段大小.你是mysql数据库对吧?
你怎么建的表?可以参考原来的建表方法删了重新建一个.
weixin_44686364 2019-03-09
  • 打赏
  • 举报
回复
那修改数据呢?
加载更多回复(3)

7,759

社区成员

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧