![]() |
#2
owenlu19812014-03-19 08:21
|

Public access As New ADODB.Connection
Public res As New ADODB.Recordset
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Private Sub Command1_Click()
Dim str As String
Dim sql As String
str = Text1.Text
res.Close
sql = "SELECT * FROM ziliao where 商品名 like '%" & Text1 & "%' ORDER BY 编号"
res.Open sql, access, 1, 3
Set DataGrid1.DataSource = res
res.Close
End Sub
Private Sub Command2_Click()
Dim Irow, Icol As Integer
Dim Irowcount, Icolcount As Integer
Dim Fieldlen() As Integer
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
sql = "SELECT * FROM ziliao ORDER BY 编号"
res.Open sql, access, 1, 3
Set DataGrid1.DataSource = res
With res
Irowcount = .RecordCount '记录总数
Icolcount = .Fields.Count '字段总数
ReDim Fieldlen(Icolcount) As Integer
res.MoveFirst
For Irow = 1 To Irowcount + 1
For Icol = 1 To Icolcount
Select Case Irow
Case 1 '在Excel中的第一行加标题
xlSheet.Cells(Irow, Icol).Value = RTrim(.Fields(Icol - 1).Name)
Case 2 '将数组FIELDLEN()存为第一条记录的字段长
If IsNull(.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(RTrim(.Fields(Icol - 1).Name))
Else
aa = RTrim(.Fields(Icol - 1).Name)
Fieldlen(Icol) = LenB(aa)
End If
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
xlSheet.Cells(Irow, Icol).Value = RTrim(.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
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
Dim aaa
aaa = MsgBox("是否保存该Excel表?", vbYesNo, "提示窗口")
If aaa = vbYes Then
CommonDialog1.FileName = "报表"
CommonDialog1.Filter = "Xls文件(*.Xls)|*.Xls|所有文件(*.*)|*.*"
CommonDialog1.ShowSave
On Error GoTo ErrSave
NewSheet.SaveAs CommonDialog1.FileName
' MsgBox "保存成功"
newxls.Quit
ErrSave:
Exit Sub
MsgBox Err.Description, , "提示窗口"
End If
Set xlApp = Nothing
End With
End Sub
Private Sub Form_Load()
m = 0
If Dir(App.Path + "\资料.mdb") <> "" Then
access.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + App.Path + "\资料.mdb;Persist Security Info=False;Jet OLEDB:Database Password=123"
access.Open
Set res.ActiveConnection = access '设置rs1的ActiveConnection属性,指定与其关联的数据库连接
res.CursorLocation = adUseClient '设置游标类型
res.CursorType = adOpenDynamic '设置动态游标
res.Open "SELECT * FROM ziliao ORDER BY 编号", access, 1, 3 '打开记录集,将从表Departments中读取的结果集保存到记录集res中
DataGrid1.Refresh '刷新表格
Set DataGrid1.DataSource = res '将DataSource连接到数据库
res.MoveFirst
Else
MsgBox "找不到数据库"
End If
res.Close
End Sub
Public res As New ADODB.Recordset
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Private Sub Command1_Click()
Dim str As String
Dim sql As String
str = Text1.Text
res.Close
sql = "SELECT * FROM ziliao where 商品名 like '%" & Text1 & "%' ORDER BY 编号"
res.Open sql, access, 1, 3
Set DataGrid1.DataSource = res
res.Close
End Sub
Private Sub Command2_Click()
Dim Irow, Icol As Integer
Dim Irowcount, Icolcount As Integer
Dim Fieldlen() As Integer
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
sql = "SELECT * FROM ziliao ORDER BY 编号"
res.Open sql, access, 1, 3
Set DataGrid1.DataSource = res
With res
Irowcount = .RecordCount '记录总数
Icolcount = .Fields.Count '字段总数
ReDim Fieldlen(Icolcount) As Integer
res.MoveFirst
For Irow = 1 To Irowcount + 1
For Icol = 1 To Icolcount
Select Case Irow
Case 1 '在Excel中的第一行加标题
xlSheet.Cells(Irow, Icol).Value = RTrim(.Fields(Icol - 1).Name)
Case 2 '将数组FIELDLEN()存为第一条记录的字段长
If IsNull(.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(RTrim(.Fields(Icol - 1).Name))
Else
aa = RTrim(.Fields(Icol - 1).Name)
Fieldlen(Icol) = LenB(aa)
End If
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
xlSheet.Cells(Irow, Icol).Value = RTrim(.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
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
Dim aaa
aaa = MsgBox("是否保存该Excel表?", vbYesNo, "提示窗口")
If aaa = vbYes Then
CommonDialog1.FileName = "报表"
CommonDialog1.Filter = "Xls文件(*.Xls)|*.Xls|所有文件(*.*)|*.*"
CommonDialog1.ShowSave
On Error GoTo ErrSave
NewSheet.SaveAs CommonDialog1.FileName
' MsgBox "保存成功"
newxls.Quit
ErrSave:
Exit Sub
MsgBox Err.Description, , "提示窗口"
End If
Set xlApp = Nothing
End With
End Sub
Private Sub Form_Load()
m = 0
If Dir(App.Path + "\资料.mdb") <> "" Then
access.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + App.Path + "\资料.mdb;Persist Security Info=False;Jet OLEDB:Database Password=123"
access.Open
Set res.ActiveConnection = access '设置rs1的ActiveConnection属性,指定与其关联的数据库连接
res.CursorLocation = adUseClient '设置游标类型
res.CursorType = adOpenDynamic '设置动态游标
res.Open "SELECT * FROM ziliao ORDER BY 编号", access, 1, 3 '打开记录集,将从表Departments中读取的结果集保存到记录集res中
DataGrid1.Refresh '刷新表格
Set DataGrid1.DataSource = res '将DataSource连接到数据库
res.MoveFirst
Else
MsgBox "找不到数据库"
End If
res.Close
End Sub