网盘应用—Excel数据库开发：[7]圆满收官

本期将完成执行客户端第三个部分——“单元格即时写入数据库”功能设计，从而圆满完成“远程工单系统”的设计制作。执行客户端要比派发客户端复杂一些，不仅体现在需要根据登录用户筛选数据（参见上期），更加复杂的是，需要实时监测工作表的变化，当捕捉到变化时，以单元格为单位即时写入数据库。好在VBA提供了Worksheet_Change事件，恰好是用于实时监测工作表变化的。另外还会用到Worksheet_SelectionChange事件，通过该事件编程将选择区域简化为一个单元格，这样可以大大降低Worksheet_Change事件的设计难度。

前期准备工作（包括相关工具或所使用的原料等）

Excel/VBA/酷盘

执行客户端“单元格即时写入数据库”功能设计

Worksheet_SelectionChange事件程序设计

实现功能：如果选择了一个包含多个单元格的区域，则将所选择区域的范围缩小到仅左上角一个单元格，将该单元格的值通过Bval全局变量传递给

Worksheet_Change事件。程序代码如下：

Public Bval '编辑前的值

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If DNDST=0 Then '“免打扰”已撤除的情况下才触发该事件

If Selection.Cells.Count > 1 Then

Cells(Target.Row, Target.Column).Select

End If

Bval=Cells(Target.Row, Target.Column).Value

End If

End Sub

Worksheet_Change事件程序设计：环境初始化

Private Sub Worksheet_Change(ByVal Target As Range)

If DNDST=0 Then '“免打扰”已撤除的情况下才触发事件

Application.EnableEvents=False '禁止事件递归调用

Dim EndRow As Single '最后一行的行号

EndRow=Range("a65535").End(xlUp).Row

If Target.Column > 4 And Target.Column < 7 And _

Target.Row > 1 And Target.Row <=EndRow And _

Target.Cells.Count=1 Then '限定触发范围为可编辑区域

Dim erow, ecol As Long, DBrow As Integer

Dim Wr As Byte '是否写入数据库的标志

Dim Eval As Variant '编辑后的值

erow=Target.Row: ecol=Target.Column

DBrow=Cells(erow, 9): Wr=1

Eval=Cells(erow, ecol).Value

'......

End Sub

Worksheet_Change事件程序设计：判别输入数据有效性、单元格是否有变化

Private Sub Worksheet_Change(ByVal Target As Range)

'......

If ecol=5 And Eval <> "" Then

If IsDate(Eval)=True Then

If Eval < Cells(erow, 3) Then

MsgBox "“" & Eval & "”" & "完成时间不能在通知时间以先！", _

vbOKOnly, "请输入有效日期，例如：“2015-1-31”"

Wr=0

Else

If Eval > Date Then

MsgBox "“" & Eval & "”" & "完成时间不能大于今天！今天是" _

& Date, vbOKOnly, "请输入有效日期，例如：“2015-1-31”"

Wr=0

End If

End If

Else

MsgBox "“" & Eval & "”" & "不是一个有效的日期！", _

vbOKOnly, "请输入有效日期，例如：“2015-1-31”"

Wr=0

End If

End If

If Bval=Eval Then Wr=0

If Wr=0 Then '无需写入数据库

Cells(erow, ecol)=Bval

GoTo Ex '退出

End If

'......

End Sub

Worksheet_Change事件程序设计：写入数据库

Private Sub Worksheet_Change(ByVal Target As Range)

'......

Application.ScreenUpdating=False

Application.ShowWindowsInTaskbar=False

Dim DB As String

DB="d:\kp\远程工单\远程工单数据库.xls"

Do

If Dir(DB) <> "" Then

Workbooks.Open Filename:=DB, Password:="111"

Else

MsgBox "连接数据库失败！" & vbCrLf & vbCrLf & DB & "不存在！"

GoTo Ex

End If

Workbooks("远程工单数据库.xls").Sheets(1).Cells(DBrow, ecol)=Eval

Application.DisplayAlerts=False

Workbooks("远程工单数据库.xls").Close savechanges:=True

Application.DisplayAlerts=True

If Dir(DB & "*冲突*.*") <> "" Then

Kill (DB & "*冲突*.*")

Else

Exit Do

End If

Loop

'......

End Sub

Worksheet_Change事件程序设计：重新分类标色

Private Sub Worksheet_Change(ByVal Target As Range)

'......

Application.StatusBar=Cells(erow, 1).Value & "号工单“" & _

Trim(Left(Cells(1, ecol).Value, 6)) & "”的修改写入数据库！"

If ecol=5 Then

If Cells(erow, 5) >=Cells(erow, 3) Then '完成白色

Sheets(1).Unprotect ("111")

Cells(erow, 4).Interior.ColorIndex=2

Else

If Cells(erow, 4) < Date Then '过期红色

Sheets(1).Unprotect ("111")

Cells(erow, 4).Interior.ColorIndex=3

Else '未完成未过期绿色

Sheets(1).Unprotect ("111")

Cells(erow, 4).Interior.ColorIndex=43

End If

End If

End If

Sheets(1).Protect ("111")

End If

'......

End Sub

Worksheet_Change事件程序设计：恢复默认环境

Private Sub Worksheet_Change(ByVal Target As Range)

'......

Ex:

Application.ShowWindowsInTaskbar=True

Application.ScreenUpdating=True

Application.EnableEvents=True

End If

End Sub

至此，以酷盘为传输媒介的远程工单系统设计制作完成，感谢朋友们的鼓励支持。读程序是很辛苦的，好在系统终于设计完工了，请朋友们下载作为学习的参考资料。下载地址：

http://pan.baidu.com/s/1pJJW6pX

（待续。。。）

下期预告：下期是此系列经验的最后一期，我们将对远程工单系统做一次全面测试。敬请期待！

网盘应用—Excel数据库开发(共8篇)上一篇：指日告罄|下一篇：慎终承始经验内容仅供参考，如果您需解决具体问题(尤其法律、医学等领域)，建议您详细咨询相关领域专业人士。作者声明：本教程系本人依照真实经历原创，未经许可，谢绝转载。