vb中表导入access中并保存

KOU_ZI 2010-10-23 02:27:58

图书管理系统，现在已经可以把excel中的数据显示在vb的表中，希望能把这些数据保存在access数据库指定的表中
下面是一段从网上找的例子，但是它是导出为EXCEL，我希望是能保存在指定的数据库指定的表中，希望大家帮忙哈，分数不是问题哈！

'通用EXCEL输入输出模块
'常用的EXCEL对象操作
'请注意：无论何时，当程序或用户需要改变前单元格，都请使用ChangeCell这个方法，
' 而不要直接通过Grid的Row和Col属性来指定位置。

Option Explicit
Dim XApp As New Excel.Application
Dim XBook As New Excel.Workbook
Dim XSheet As New Excel.Worksheet
Dim Saved As Boolean
Dim SheetNames() As String
Private Type Cell
R As Long
C As Long
Color As Long
Content As String
End Type
Dim CellINF As Cell

Private Sub About_Click()
MsgBox "一些最常用的EXCEL操作技巧：快速将数据从MSFLEXGRID控件导出到EXCEL，快速将数据从EXCEL导入到MSFLEXGRID控件" & Chr(13) & Chr(9) & "如何通过剪贴板将数据在程序和EXCEL中相互粘贴" & Chr(13) & Chr(9) & "如何利用一个TEXT控件来使你的MSFLEXGRID可以编辑" & Chr(13) & Chr(9) & "如果使程序具有修改后退出提示保存的功能" & Chr(13) & Chr(9) & "最后还加了个好玩缺不实用的功能:将图片转换成EXCEL拚图。" & Chr(13) & Chr(9) & "不过这个功能超慢，不是慢在VB的Point方法上，而是慢在EXCEL上，大家到时看进程管理器就知道怎么回事。"
End Sub

Private Sub Combo1_Click()
ArrangeGrid Combo1.ListIndex
End Sub

Private Sub Command1_Click(Index As Integer)
Dim FN As String
Select Case Index
Case 0: File__Click 0

Case 1: File__Click 2

Case 2: File__Click 5
End Select
End Sub

Private Sub Edit__Click(Index As Integer)
Select Case Index
Case 0: ChangeCell 1, 1, 1
With Grid1(Combo1.ListIndex)
.RowSel = .Rows - 1
.ColSel = .Cols - 1
End With

Case 1: Clipboard.SetText Grid1(Combo1.ListIndex).Clip

Case 2: Clipboard.SetText Grid1(Combo1.ListIndex).Clip
Clipboard.SetText Grid1(Combo1.ListIndex).Clip = ""
Saved = False

Case 3: PasteGrid Combo1.ListIndex
Saved = False

End Select
End Sub

Private Sub File__Click(Index As Integer)
Dim FN As String
Select Case Index
Case 0: CommonDialog1.Filter = "*.XLS;*.CSV|*.XLS;*.CSV"
CommonDialog1.ShowOpen
FN = CommonDialog1.FileName
If FN <> "" Then OpenXls FN
Case 1:
Case 2: CommonDialog1.Filter = "*.XLS|*.XLS"
CommonDialog1.ShowSave
FN = CommonDialog1.FileName
If FN <> "" Then
Saved = SaveXls(FN)
End If
Case 3:
Case 4: CommonDialog1.Filter = "*.BMP;*.GIF;*.ICO;*.JPG|*.BMP;*.GIF;*.ICO;*.JPG"
CommonDialog1.ShowOpen
FN = CommonDialog1.FileName
If FN <> "" Then PicToExl FN

Case 5: Unload Me
End Select
End Sub

Private Sub Form_Load()
Set XApp = New Excel.Application
Combo1.AddItem ""
Combo1.ListIndex = 0
Saved = True
End Sub

Private Function SaveXls(ByVal XFileName As String) As Boolean '将数据从GRID控件保存到EXCEL文件
Dim I As Long
Dim L As Long
On Error GoTo ErrLine
XApp.Workbooks.Add
Set XBook = XApp.Workbooks(XApp.Workbooks.Count)
For I = 1 To 3
Set XSheet = XBook.Sheets(I)
XSheet.Name = I & Chr(9) & I
Next
For I = 3 To Grid1.Count - 2
XBook.Worksheets.Add
Next
Bar1.Max = Grid1.Count - 2
For I = 0 To Grid1.Count - 2
Bar1.Value = I
L = I + 1
Set XSheet = XBook.Worksheets(L)
XSheet.Name = Combo1.List(I)
With Grid1(I)
.Row = 1
.Col = 1
.RowSel = .Rows - 1
.ColSel = .Cols - 1
Clipboard.SetText .Clip
End With
XSheet.Paste
Clipboard.Clear
Next
SaveXls = True
ErrLine:
XBook.SaveAs XFileName
Set XSheet = Nothing
XBook.Close
Set XBook = Nothing
End Function

Private Sub Form_Resize()
Dim X As Long
Dim Y As Long
With Me
X = .ScaleWidth
Y = .ScaleHeight
End With
If X < 2 Then X = 2
If Y < 41 Then Y = 41
With Grid1(0)
.Move 0, 1, X - 1, Y - 26
X = .Left
Y = .Top + .Height + 3
Combo1.Move X, Y
X = X + Combo1.Width + 3
Command1(0).Move X, Y
X = X + Command1(0).Width + 3
Command1(1).Move X, Y
X = X + Command1(1).Width + 3
Command1(2).Move X, Y
X = X + Command1(2).Width + 3
Bar1.Move X, Y, .Width - Command1(2).Left - Command1(2).Width - 4
End With
End Sub

Private Sub ArrangeGrid(Optional ByVal Index As Long = 0)
Dim I As Long
Dim L As Long
Dim T As Long
Dim W As Long
Dim H As Long
With Grid1(0)
L = .Left
T = .Top
W = .Width
H = .Height
End With
For I = 0 To Grid1.Count - 1
With Grid1(I)
.Move L, T, W, H
.Visible = False
.ZOrder 1
End With
Next
With Grid1(Index)
.Visible = True
.Row = 0
.Col = 0
CellINF.Content = .Text
CellINF.Color = .CellBackColor
CellINF.C = 0
CellINF.R = 0
End With
Combo1.ListIndex = Index
ChangeCell 1, 1, 1
End Sub

Private Sub Form_Unload(Cancel As Integer) '退出前关闭EXCEL对象
Dim I As Long
If Not Saved Then
I = MsgBox("退出前保存修改文件么？" & "Yes:退出并保存，No:退出不保存，Cancel:取消", vbYesNoCancel)
Select Case I
Case vbYes: Command1_Click 1
Case vbNo:
Case vbCancel: Cancel = 1
Exit Sub
End Select
End If
XApp.Quit
Set XApp = Nothing
End Sub

'这个是本程序最最关键的地方，请自己研究
Sub ChangeCell(ByVal R As Long, ByVal C As Long, Optional Visib As Long = 0)
Dim Tmp As String
Dim Msg(1) As String
Dim LineN As Long
CellINF.Content = Trim(CellINF.Content)
With Grid1(Combo1.ListIndex)
.Row = CellINF.R '设置前一位置内容及背景
.Col = CellINF.C
.Text = CellINF.Content
.CellBackColor = CellINF.Color

Call DoSth

.Row = R '设置当前位置的内容及背景
.Col = C
CellINF.Content = Trim(.Text)
CellINF.Color = .CellBackColor
CellINF.R = R '保存当前位置及移动TEXT框
CellINF.C = C
Text1.Text = CellINF.Content
.CellBackColor = &HCCFFEE
Text1.Move Me.ScaleX(.ColPos(C) + .Left, 1, 3) - 1, Me.ScaleY(.RowPos(R) + .Top, 1, 3) - 1, Me.ScaleX(.ColWidth(C) + 10, 1, 3), Me.ScaleY(.RowHeight(R), 1, 3)
End With
With Text1
.ZOrder Visib
.Tag = Visib
If .Visible And .Enabled Then
.SetFocus
.SelStart = Len(.Text)
End If
End With
End Sub

Private Sub Grid1_DblClick(Index As Integer)
ChangeCell Grid1(Index).Row, Grid1(Index).Col, 0
End Sub

Private Sub Grid1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Select Case Button
Case 1: ChangeCell Grid1(Index).Row, Grid1(Index).Col, 1
Case 2: Me.PopupMenu Edit
End Select
End Sub

Private Sub Text1_Change()
CellINF.Content = Text1.Text
End Sub

Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer) '处理一些基本按键
If Text1.Tag = 1 Then
With Grid1(Combo1.ListIndex)
Select Case KeyCode
Case 13: Text1.ZOrder 0
Text1.Tag = 0

Case 37: If .Col > 1 Then ChangeCell .Row, .Col - 1, 1

Case 38: If .Row > 1 Then ChangeCell .Row - 1, .Col, 1

Case 39: If .Col >= .Cols - 1 Then .Cols = .Cols + 1
ChangeCell .Row, .Col + 1, 1

Case 40: If .Row >= .Rows - 1 Then .Rows = .Rows + 1
ChangeCell .Row + 1, .Col, 1

Case Else: Saved = False
End Select
End With
Else
Select Case KeyCode
Case 13: Text1.ZOrder 1
Text1.Tag = 1

Case Else: Saved = False
End Select
End If
End Sub

Private Sub PasteGrid(ByVal Index As Long) '粘贴数据到表格控件
Dim R As Long
Dim C As Long
Dim I As Long
Dim L As Long
Dim CLPBD As String
Dim Str() As String
Dim Tmp() As String
CLPBD = Replace(Clipboard.GetText, Chr(10), "")
Str = Split(CLPBD, Chr(13))
R = UBound(Str) - LBound(Str) '获得数据行数
For I = 0 To R - 1 '获得数据列数
Tmp = Split(Str(I), Chr(9))
L = UBound(Tmp) - LBound(Tmp)
If C < L Then C = L
ReDim Tmp(0)
Next
With Grid1(Index)
I = .Row + R
L = .Col + C
If I > .Rows - 1 Then .Rows = I + 1
If L > .Cols - 1 Then .Cols = L + 1
.RowSel = I
.ColSel = L
.Clip = CLPBD
Text1.Text = .Text '这两句代码不是很规范，但是无法移入ChangeCell模块，只能写这里
CellINF.Content = .Text '
End With
End Sub

Private Sub OpenXls(ByVal XFileName As String) '将EXCEL文件读入GRID控件
Dim I As Long
Dim L As Long
Dim M As Long
Dim R As Long
Dim C As Long
Dim MaxRow As Long
Dim MaxCol As Long
Dim Tmp As String
'On Error GoTo ErrLine
XApp.DisplayAlerts = False
Set XBook = XApp.Workbooks.Open(XFileName)
Me.Caption = XFileName
I = XBook.Sheets.Count
Combo1.Clear
For L = 1 To Grid1.Count - 1
Unload Grid1(L)
Next
ReDim SheetNames(I)
Bar1.Max = I
For L = 1 To I
Bar1.Value = L
M = L - 1
SheetNames(M) = XBook.Worksheets(L).Name
Combo1.AddItem SheetNames(M), M
Set XSheet = XBook.Worksheets(SheetNames(M))
With XSheet
Load Grid1(L)
Clipboard.Clear
.UsedRange.Copy
Grid1(M).Visible = False
PasteGrid M
Grid1(M).Visible = True
End With
Next
ErrLine:
Set XSheet = Nothing
XBook.Close
Set XBook = Nothing
ArrangeGrid 0
XApp.DisplayAlerts = True
End Sub

Private Sub DoSth()
'在这里可以写上一些自定义的计算和处理，比如表格的计算和格式化数据等。
'这个等同于原GRID控件的LeaveCell事件。
'但是用户可以通过GRID.ROW和GRID.COL得知“将要”得到焦点的那个单元格。
' 还可以通过CellInf结构得知“前”一个单元格的位置和内容
End Sub

Private Sub PicToExl(ByVal FileName As String)
Dim X As Long
Dim Y As Long
On Error GoTo ErrLine
With Picture1
.Picture = LoadPicture(FileName)
.PaintPicture Picture1.Picture, 1, 1, 256, 256
.Refresh
DoEvents
End With

Set XBook = XApp.Workbooks.Add
Set XSheet = XBook.Worksheets(1)
With XSheet
.Range("a1", "IV256").ColumnWidth = 0.23
.Range("a1", "IV256").RowHeight = 2.2
Bar1.Max = 256
For X = 1 To 256
For Y = 1 To 256
Cells(Y, X).Interior.Color = Picture1.Point(X, Y)
Next
Bar1.Value = X
Next
'XSheet.Cells(1, 1).Interior.Color
End With
XApp.Visible = True
Exit Sub
ErrLine:
MsgBox Err.Description
End Sub

...全文