Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
Case 1
' SSPanel2.Visible = True
' probar.Value = 0
' Dim myexcel As New Excel.Application, I, J, K As Integer, col As String
' With myexcel
' On Error GoTo excle
' .Application.Visible = False
' .Workbooks.Add
' '***********画字段************
' J = 0
' 'example: b2 ----g2 ’列 本程序从b列,和第2行开始
' For I = 66 To (66 + Rs_temp.Fields.Count - 1) '从rs中头一个字段到最后一个
' col = Chr(I) & "2" 'chr(66)就是b
' Range(col).Select
' ActiveCell.FormulaR1C1 = Rs_temp.Fields(J).Name '
' J = J + 1
' Next I
' '*************以先横后竖顺序画表***************
' K = 0
' Rs_temp.MoveFirst
' DoEvents
' For J = 3 To 3 + Rs_temp.RecordCount '本程序从b3开始,所以用3
' K = 0
' For I = 66 To (66 + Rs_temp.Fields.Count - 1)
' col = Chr(I) & CStr(J) '得到目标表格的值如 c3
' Range(col).Select
' ActiveCell.FormulaR1C1 = Rs_temp.Fields(K)
' K = K + 1
' Next I
' On Error Resume Next
' probar.Value = probar.Value + 1
' Rs_temp.MoveNext
' If Rs_temp.EOF = True Then
' SSPanel2.Visible = False
' .Application.Visible = True
' End If
' Next J
' End With
'excle:
' MsgBox ("您没有安装excle2000,请先安装excel2000")
Dim Irow, Icol As Integer
Dim Irowcount, Icolcount As Integer
Dim Fieldlen1 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)
SSPanel2.Visible = True
probar.Value = 0
'On Error GoTo excle
With Rs_temp
.MoveLast
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Sub
End If
For Icol = 1 To Icolcount
Select Case Irow
'在Excel中的第一行加标题
Case 1
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1).Name
'将数组FIELDLEN()存为第一条记录的字段长
Case 2
If IsNull(.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
'如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度
Else
Fieldlen(Icol) = LenB(.Fields(Icol - 1))
End If
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
'Excel列宽等于字段长
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
'向Excel的CellS中写入字段值
Case Else
If IsNull(.Fields(Icol - 1)) Then
Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
Else
Fieldlen1 = LenB(.Fields(Icol - 1))
End If
If Fieldlen(Icol) < Fieldlen1 Then
xlSheet.Columns(Icol).ColumnWidth = IIf(Fieldlen1 > 255, 255, Fieldlen1)
'表格列宽等于较长字段长
Fieldlen(Icol) = IIf(Fieldlen1 > 255, 255, Fieldlen1)
'数组Fieldlen(Icol)中存放最大字段长度值
Else
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
End If
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
End Select
Next
If Irow > 2 Then
If Not .EOF Then .MoveNext
End If
If Not .EOF Then
If Irow < Irowcount Then
probar.Value = probar.Value + 1
End If
End If
'显示表格
Dim ExclFileName As String
ExclFileName = App.path & "\业务数据综合查询表.xls"
If Dir(ExclFileName) <> "" Then
Kill ExclFileName
End If
xlSheet.SaveAs (ExclFileName)
SSPanel2.Visible = False
xlApp.Application.Visible = True
'交还控制给Excel
'xlSheet.PrintPreview
'xlApp.Quit
End With
'excle:
' MsgBox ("您没有安装 Excle2000,请先安装 Excel2000 !")
Case 2
Unload Me
End Select
End Sub
'''''''''''''''''''''''''''''''''''''''''
' 整理:泰山 '
' 主页:http://dyqing.533.net '
' E-Mail:duyunqing@163.net '
'''''''''''''''''''''''''''''''''''''''''
'指定链接
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'Option Explicit
Dim x(1 To 4, 1 To 5) As Integer
Dim a, i, j As Integer
Dim b As String
Private Sub Command1_Click()
Dim ex As Object
Dim exbook As Object
Dim exsheet As Object
Set ex = CreateObject("Excel.Application")
Set exbook = ex.Workbooks().Add
Set exsheet = exbook.Worksheets("sheet1")
'按控件的内容赋值
'11
exsheet.Cells(1, 1).Value = Text1.Text
'为同行的几个格赋值
Range("C3").Select
ActiveCell.FormulaR1C1 = "表格"
' ex.Range("c3").Value = "表 格"
ex.Range("d3").Value = " 春 天 "
ex.Range("e3").Value = " 夏 天 "
ex.Range("f3").Value = " 秋 天 "
ex.Range("g3").Value = " 冬 天 "
'大片赋值
ex.Range("c4:g7").Value = x
'按变量赋值
a = 8
b = "c" & Trim(Str(a))
ex.Range(b).Value = "下雪"
'另外一种大片赋值
For i = 9 To 12
For j = 4 To 7
exsheet.Cells(i, j).Value = i * j
Next j
Next i
'计算赋值
exsheet.Cells(13, 1).Formula = "=R9C4 + R9C5"
'设置字体
Dim exRange As Object
Set exRange = exsheet.Cells(13, 1)
exRange.Font.Bold = True
楼上的方面也行,按行倒,不过数据多了,会慢.
oledb provider for ject4提供数据导出的功能.
我这里完整的程序,你要EMAIL我,我再发过去.
下面是代码,其实你看看重要的几句就行了.
Dim Export_Str, mdbTable As String
Dim rsExport As New ADODB.Recordset
Dim conn As New ADODB.Connection
Private Sub Close_cmd_Click()
Unload Me
End Sub
Private Sub EXport_cmd_Click()
Dim myPath, myStr As String, myPos As Integer
'******************´¦ÀíÑ¡ÔñµÄ¸÷ÖÖ±íµÄµ¼³ö
With Dialog1
If myOption(2).Value Then
.FilterIndex = 1
.ShowSave
myStr = StrReverse(.FileName) '´®È¡·´
myPos = InStr(myStr, "\") 'ÔÚ·´×Ö·û´®ÖУ¬ÕÒ´Ó×ó¿ªÊ¼µÚÒ»¸ö\µÄλÖÃ
On Error GoTo myError '·ÀFILENAMEΪ¿Õ£¬MID³ö´í
myPath = StrReverse(Mid(myStr, myPos)) 'ȡĿ¼²¿·Ö£¬²¢»¹Ô.
myStr = StrReverse(Left(myStr, myPos - 1)) 'È¡ÎļþÃû
Export_Str = "select * into [dBase III;database=" & myPath & "]." & myStr & " from Customers"
.DefaultExt = "*.DBF"
ElseIf myOption(3).Value Then
mdbTable = InputBox("Çë¸øµ¼³öµ½MDBÎļþµÄ±íÈ·¶¨±íÃû")
.FilterIndex = 2
.ShowSave
Export_Str = "select * into [;database=" & .FileName & "]." & mdbTable & " from Customers"
.DefaultExt = "*.MDB"
ElseIf myOption(4).Value Then
.FilterIndex = 3
.ShowSave
Export_Str = "select * into [Excel 8.0;database=" & .FileName & "].Customers from Customers"
.DefaultExt = "*.XLS"
ElseIf myOption(5).Value Then
.FilterIndex = 4
.ShowSave
myStr = StrReverse(.FileName) '´®È¡·´
myPos = InStr(myStr, "\") 'ÔÚ·´×Ö·û´®ÖУ¬ÕÒ´Ó×ó¿ªÊ¼µÚÒ»¸ö\µÄλÖÃ
On Error GoTo myError '·ÀFILENAMEΪ¿Õ£¬MID³ö´í
myPath = StrReverse(Mid(myStr, myPos)) 'ȡĿ¼²¿·Ö£¬²¢»¹Ô.
myStr = StrReverse(Left(myStr, myPos - 1)) 'È¡ÎļþÃû
Export_Str = "select * into [Paradox 4.X;database=" & myPath & "]." & myStr & " from Customers"
.DefaultExt = "*.DB"
End If
End With
'*****Éú³ÉÎļþ
Debug.Print Export_Str
If rsExport.State = 1 Then
rsExport.Close
End If
If Dir(Dialog1.FileName) <> "" Then
On Error GoTo myError '·ÀÓû§Ã»Ñ¡Îļþ
If Dialog1.FilterIndex <> 2 Then
Kill (Dialog1.FileName)
End If
rsExport.Open Export_Str, conn, adOpenStatic, adLockOptimistic
Else
rsExport.Open Export_Str, conn, adOpenStatic, adLockOptimistic
End If
myError:
Exit Sub
End Sub
'³õʼ»¯¶Ô»°¿ð
With Dialog1
.Filter = "FoxBase/FoxPro (*.DBF)|*.DBF|Access 8.0(*.MDB)|*.MDB|Excel 8.0(*.XLS)|*.XLS|Paradox 4.x(*.DB)|*.DB"
.DialogTitle = "µ¼³öÎļþΪ"
.CancelError = False
End With
End Sub