首页 诗词 字典 板报 句子 名言 友答 励志 学校 网站地图
当前位置: 首页 > 教程频道 > 开发语言 > VB >

vb中表导入access中并保存解决方案

2012-01-12 
vb中表导入access中并保存图书管理系统,现在已经可以把excel中的数据显示在vb的表中,希望能把这些数据保存

vb中表导入access中并保存
图书管理系统,现在已经可以把excel中的数据显示在vb的表中,希望能把这些数据保存在access数据库指定的表中
下面是一段从网上找的例子,但是它是导出为EXCEL,我希望是能保存在指定的数据库指定的表中,希望大家帮忙哈,分数不是问题哈!
[code=VB][/code]
'通用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



[解决办法]
"vb的表"是什么控件?
[解决办法]
DATAGRID、MSHFLexGrid及MSHFLexGrid控件都可以用来当表来显示
[解决办法]
fpspread 7.0
[解决办法]
表格控件,自带引出excel功能!

热点排行