Adodc2.Recordset.ActiveConnection.Execute "delete from qinshi where 公寓名称='" & Trim(Combo1.Text) & "' and 寝室='" & Trim(Text1.Text) & "'"
Adodc2.Recordset.Update
End If
Combo1.Text = ""
Text1.Text = ""
Call startree1
在treeview点击的时候，上面的文本框中会显示相应的记录，这主要是对treeview进行了设置，代码如下：
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
On Error Resume Next
Text1.Text = TreeView1.SelectedItem.Text
Combo1.Text = TreeView1.SelectedItem.Parent
Text6.Text = TreeView1.SelectedItem.Text
Text7.Text = TreeView1.SelectedItem.Parent
End Sub
(3)班级设置
①班级设置效果图
图4.6班级设置
②界面制作与实现方法
此界面制作与公寓设置基本一致。在这个界面中主要用到了一个Sstab控件与一个显示表中内容的Datagrid控件。以及起到美观作用的Frame控件。
在右下角的文本框中可以输入想要添加的班级名称。然后点击添加即可完成添加操作。Datagrid中会立即刷新显示更新内容。要修改某条记录时，要先对所要修改的记录进行选择，确认选择后，点击下面的修改按钮，会在下面的文本中显示出所要修改班级的名称，此时即可输入要修改的名字。然后点击更新就会完成此操作。Datagrid也会即时更新其内容。删除操作更为简单，选择想要删除的班级名称，点击删除，确认后完成此操作。
添加班级源码：
Adodc3.Recordset.Find "class='" & Text4.Text & "'"
If Adodc3.Recordset.EOF = False Then
MsgBox "此班级已存在", , "提示"
Adodc3.Recordset.MoveFirst
Exit Sub
End If
Text5.Text = ""
If Text4.Text = "" Then
MsgBox "输入所要添加班级的名称", , "提示"
Exit Sub
End If
Adodc3.Recordset.AddNew
Adodc3.Recordset.Fields("class") = Text4.Text
Adodc3.Recordset.Update
Adodc3.RecordSource = "class"
Text4.Text = ""
Set DataGrid3.datasource = Adodc3
DataGrid3.Refresh
修改班级源码：
If Command10.Caption = "修改" Then
Text4.Text = Text5.Text
Label6.Caption = "输入想要修改的班级名称"
Command10.Caption = "更新"
Command6.Enabled = False
Command9.Enabled = False
ElseIf Command10.Caption = "更新" Then
Command9.Enabled = True
Command6.Enabled = True
Label6.Caption = "输入想要添加的班级名称"
Adodc3.Recordset.Fields("class") = Text4.Text
Adodc3.Recordset.Update
Command10.Caption = "修改"
End If
删除班级源码：
If Text5.Text = "" Then
MsgBox "选择所要删除班级的名称", , "提示"
Exit Sub
End If
If (MsgBox("你真的想删除班级名称 为 " & Text5.Text & " 的记录吗？", vbOKCancel, "系统提示")) = vbOK Then
Adodc3.Recordset.Delete
Adodc3.Recordset.Update
End If
Text5.Text = ""
Set DataGrid3.datasource = Adodc3
DataGrid3.Refresh
End Sub
4.3.3数据备份：
数据备份是一个数据库软件必不可少的一部分，利用它可以把当前数据库表进行全面的备份，以备以后使用。因为在操作中可能会导致数据遭到破坏，或者是系统的原因使数据库损坏，或者是一些其它的人为原因，这样你可以用此功能把数据恢复到最后一次备份的状态，使损失做到最少，经常备份，操作起来更有安全感。
①数据备份效果图
图4.7数据备份效果图
② 功能实现
界面制作相对程序来说比较简单，用到的是coolbar控件，点击按钮可以选择备份路径。然后点击数据备份即可。
窗体初始化部分代码如下：
Dim cnn1 As ADODB.Connection
Dim rstschema As ADODB.Recordset
Dim strcnn As String
Set cnn1 = New ADODB.Connection
strcnn = "provider=Microsoft.jet.oledb.4.0;" & "data source=" & App.Path & "\db.mdb"
cnn1.Open strcnn
Set rstschema = cnn1.OpenSchema(adSchemaTables)
Do Until rstschema.EOF
temp = rstschema!Table_Name
If Left(temp, 1) <> "M" Then
End If
rstschema.MoveNext
Loop
cnn1.Close
On Error GoTo err
PathName = App.Path & "\db.MDB"
dbasize = FileLen(PathName)
err:
Exit Sub
数据备份部分在本程序中用到了一个模块，在模块中有一个方法，dobackup。点击备份按钮后开始备份，代码如下：
If txtDestination <> "" Then
DoBackup PathName, txtDestination
MsgBox "备份成功！", , "提示"
ElseIf txtDestination = "" Then
MsgBox "You must specify a distination for the backup", vbCritical
其中DoBackup为模块中已定义的方法，在这里进行调用。
Dobackup实现方法代码如下所示：
Dim lFileOp As Long
Dim lresult As Long
Dim lFlags As Long
Dim SHFileOp As SHFILEOPSTRUCT
Dim strSourceDir As String
Dim strDestinationDir As String
Screen.MousePointer = vbHourglass
BackupFolderName = strDestinationPath
MkDir BackupFolderName & "\Backup - " & Format(Date, "yyyy.mm.dd")
lFileOp = FO_COPY
lFlags = lFlags And Not FOF_SILENT
lFlags = lFlags Or FOF_NOCONFIRMATION
lFlags = lFlags Or FOF_NOCONFIRMMKDIR
lFlags = lFlags Or FOF_FILESONLY
With SHFileOp
.wFunc = lFileOp
.pFrom = strSourcePath & vbNullChar
.pTo = strDestinationPath & "\Backup - " & Format(Date, "yyyy.mm.dd") & vbNullChar
.fFlags = lFlags
End With
lresult = SHFileOperation(SHFileOp)
Screen.MousePointer = vbDefault
frmBackupDba.lblStatus = "Backup Complete"
在备份分前先要选择一个备份路径，点击…那个按钮开始进行选择，实现方法如下：
Dim strTemp As String
strTemp = fBrowseForFolder(Me.hwnd, "Select backup path")
If strTemp <> "" Then
txtDestination = strTemp
End If
数据恢复界面同上，它的功能主要是在当前数据库遭到破坏后，可以利用它来进行数据恢复，在数据恢复前要选择所要恢复的数据库路径，如下：
Dim strTemp As String
strTemp = fBrowseForFolder(Me.hwnd, "Restore From")
If strTemp <> "" Then
txtSource = strTemp
dbasize2 = FileLen(txtSource & "\db.MDB")
lblSelectedDba = "Selected Backup Database is : " & Format((dbasize2 / 1024) / 1024, "standard") & "MB."
cmdRestore.Enabled = True
End If
Erro:
Select Case err.Number
Case 53 'File Not Found
lblSelectedDba = "No Backup at this location"
Toolbar2.Enabled = False
End Select
它主要是查看数据库是否存在，如果所恢复的数据不存在，则会提示错误。
数据恢复也用到了一个方法，在模块中也已经定义了该方法DoRestore。数据恢复代码如下：
If MsgBox("Restoring database from location " & txtSource & " will replace existing database files.Do you want to Contunue", vbYesNo) = vbYes Then
DoRestore txtSource.Text, App.Path
If NoDba = True Then
MsgBox "Database Restored Click Ok to Exit Program"
frmRestoreDba.Hide
Unload frmRestoreDba
End If
Else
lblStatus.Caption = "Database Restore Canceled"
End If
其中DoRestore实现的功能源码如下所示：
DEFSOURCE = "PROVIDER=Microsoft.jet.oledb.4.0;Persist Security Info=False;Data Source="
DBName = "\db.MDB;Jet OLEDB:Database Password=matrix-se;"
Set Db = New ADODB.Connection
Db.Open DEFSOURCE & App.Path & DBName
Dim lFileOp As Long
Dim lresult As Long
Dim lFlags As Long
Dim SHFileOp As SHFILEOPSTRUCT
Dim strSourceDir As String
Dim strDestinationDir As String
Db.Close
Screen.MousePointer = vbHourglass
BackupFolderName = strDestinationPath
lFileOp = FO_COPY
lFlags = lFlags And Not FOF_SILENT
lFlags = lFlags Or FOF_NOCONFIRMATION
lFlags = lFlags Or FOF_NOCONFIRMMKDIR
lFlags = lFlags Or FOF_FILESONLY
With SHFileOp
.wFunc = lFileOp
.pFrom = strSourcePath & "\db.MDB" & vbNullChar
.pTo = strDestinationPath & vbNullChar
.fFlags = lFlags
End With
lresult = SHFileOperation(SHFileOp)
Set Db = New ADODB.Connection
Db.Open DEFSOURCE & App.Path & DBName
Screen.MousePointer = vbDefault
frmRestoreDba.lblStatus = "Restore Complete"
说明：本程序中此部分内容参考了网上的同类型代码，对其进行修改后得到此成型作品，从功能上来讲，它已经实现了它所要完成的工作，经过测试已经没有问题，但是实现的源代码，也只有部分掌握。这实属本人精力与能力有限所置。
4.3.4 数据转换
这个功能可以把当前列表框中的任何一个表转换成excel形式，转换后你可以看到表中的内容，也可以对表进行操作，保存，修改，打印等。
①界面效果图
图4.8数据转换效果图
②实现方法
在这里用到了一个显示gif图片的控件。选择左面list中的一个表后，点击导出后即可完成，进度条中显示当前转换进度程度。
首先要在list中加载各表名。以便进行选择转换。添加表名部分在load进行加载，其中的导出与取消按钮是由coolbar制作而成。
Form的load事件处理内容如下：
TMaxAni1.FileName = App.Path & "\icon\find.gif"
TMaxAni1.ShowGif
Dim cnn1 As ADODB.Connection
Dim rstschema As ADODB.Recordset
Dim strcnn As String
Set cnn1 = New ADODB.Connection
strcnn = "provider=Microsoft.jet.oledb.4.0;" & "data source=" & App.Path & "\db.mdb"
cnn1.Open strcnn
Set rstschema = cnn1.OpenSchema(adSchemaTables)
Do Until rstschema.EOF
temp = rstschema!Table_Name
If Left(temp, 1) <> "M" Then
List2.AddItem temp
End If
rstschema.MoveNext
Loop
cnn1.Close
List2.ListIndex = 0
On Error GoTo err
PathName = App.Path & "\db.MDB"
dbasize = FileLen(PathName)
数据转换成excel用到了一个部件，在引用中用到了Microsoft Excel9.0 Object library。转换代码如下：
Select Case Button.Index
Case 1
Dim provider As String
Dim datasource As String
provider = "provider=Microsoft.jet.oledb.4.0"
datasource = "data source=" & App.Path & "\DB.mdb"
With Adodc1
.Mode = adModeReadWrite
.ConnectionString = provider & ";" & datasource
.CommandType = adCmdTable
.RecordSource = List2.Text
.Refresh
End With
ProgressBar1.Max = Adodc1.Recordset.RecordCount
ProgressBar1.Min = 0
'开始转换
Dim Irow, Icol As Integer
Dim Irowcount, Icolcount As Integer
Dim Fieldlen()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.add
Set xlSheet = xlBook.Worksheets(1)
With Adodc1.Recordset
.MoveLast
If .RecordCount < 1 Then
MsgBox ("Error!")
Exit Sub
End If
Irowcount = .RecordCount
Icolcount = .Fields.Count
ReDim Fieldlen(Icolcount)
.MoveFirst
For Irow = 1 To Irowcount + 1
For Icol = 1 To Icolcount
Select Case Irow
Case 1
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1).Name
Case 2
If IsNull(.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
Else
Fieldlen(Icol) = LenB(.Fields(Icol - 1))
End If
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
Case Else
Fieldlen1 = LenB(.Fields(Icol - 1))
If Fieldlen(Icol) < Fieldlen1 Then
xlSheet.Columns(Icol).ColumnWidth = Fieldlen1
Fieldlen(Icol) = Fieldlen1
Else
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
End If
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
End Select
Next
If Irow <> 1 Then
If Not .EOF Then .MoveNext
ProgressBar1.Value = ProgressBar1.Value + 1
End If
Next
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体"
.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True
.Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous
End With
xlApp.Visible = True
' xlBook.Save
'xlBook.Close
Set xlApp = Nothing
Adodc1.Recordset.ActiveConnection = Nothing
End With
Toolbar4.Buttons(1).Enabled = False
Case 2
Unload Me
End Select
上一页 [1] [2] [3] [4] [5] [6] [7] [8] [9] [10] ... 下一页 >>