Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名称:ExporToExcel
'* 功能:导出数据到EXCEL
'* 用法:ExporToExcel(sql查询字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Cn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
' Rs_Data.Open strOpen, Cn, adOpenStatic, adLockReadOnly
With Rs_Data
' .MoveFirst
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True
'添加查询语句,导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With
xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With
' With xlSheet.PageSetup
' .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称:" ' & Gsmc
' .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期:"
' .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位:"
' .LeftFooter = "&""楷体_GB2312,常规""&10制表人:"
' .CenterFooter = "&""楷体_GB2312,常规""&10制表日期:"
' .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
' End With
xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = NothingEnd Function
'*********************************************************
'* 名称:ExporToExcel
'* 功能:导出数据到EXCEL
'* 用法:ExporToExcel(sql查询字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Cn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
' Rs_Data.Open strOpen, Cn, adOpenStatic, adLockReadOnly
With Rs_Data
' .MoveFirst
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True
'添加查询语句,导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With
xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With
' With xlSheet.PageSetup
' .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称:" ' & Gsmc
' .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期:"
' .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位:"
' .LeftFooter = "&""楷体_GB2312,常规""&10制表人:"
' .CenterFooter = "&""楷体_GB2312,常规""&10制表日期:"
' .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
' End With
xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = NothingEnd Function
解决方案 »
- 怎样把combo里面的数据添加到一个access里面,然后让combo的数据显示在MSFlexGrid指定的单元格上!!!!!
- vb对象赋值的问题。
- 有谁知道microsoft sql parser object library 1.0的用法
- 谁知道控件编程中的Ambient属性怎么用?
- 如何把图片中空白区域透明化
- 用VB访问ACCSESS数据库时用SQL语句的问题!!!
- 怎样直接在DataGrid实现对远程数据库的修改
- 在报表设计器中为何不能使用对齐工具?
- VB6.0导入Ico图标时出错.怎么办?
- 熟知 API 的高手们,有问题来了!
- treeview问题:编辑与保存!
- vb中如何实现实时曲线,历史曲线及打印!?
Word 提供了一个 Word 对象, 通过在 “引用” 中的该对象, 可以实现对 Word 的控制。 以下的代码演示了执行 WordBasic 语句,该段代码是动态引用对象, 无须在工程中引用Word 对象。Dim wd As Object
Set wd = CreateObject ("Word.Basic")
wd.FileNewDefault
wd.FontSize 20
wd.Insert "Hello, World"
wd.FileSaveAs "Hello.Doc"
wd.FileClose
Set wd = Nothing执行后,将产生一个 Hello.Doc 。 一个种办法是在 Word 中调试好 WordBasic 语句后, 再发布到 VB 中。类似的处理应该也可以用在 Execl 中。
1. 创建表格,插入文字
本例的功能是在文档开头插入一张 3 行 4 列的表格。可用For Each...Next 结构来循环遍历表格中的每个单元格。在 For Each...Next 结构中,InsertAfter 方法用来向表格单元格添加文字("第 1 单元格"、" 第 2 单元格"等等),oTable.AutoFormat属性用于指定表格套用格式。运行结果如图1:
@@0869600.JPG;图1@@
Set oDoc = ActiveDocument
Set oTable= oDoc.Tables.Add(Range:=oDoc.Range(Start:=0, End:=0), NumRows
:=3,NumColumns:=4)
iCount = 1
For Each oCell In oTable.Range.Cells
oCell.Range.InsertAfter "第 "& iCount & "单元格"
iCount = iCount + 1
Next oCell
oTable.AutoFormat Format:=wdTableFormatColorful2,ApplyBorders:=True, App
lyFont:=True, ApplyColor:=True
2. 在表格的列、行插入序号
1. 如果需要在表格的第一列插入序号,只需将 For Each...Next 结构中的内容改为下述程序行即可,其中InsertAfter 方法用来向表格单元格添加序号("第 1 行"、" 第2 行"等等)。
If iCount Mod 4 = 1 Then
oCell.Range.InsertAfter"第 " & (iCount - 1) / 4 + 1 & " 行"
End If
iCount = iCount + 1
2. 如果需要从表格的第二行开始插入序号,应将上述代码改为:
If iCount Mod 4 = 1 And iCount > 4 Then
oCell.Range.InsertAfter "第 "& (iCount - 1) / 4 & "行"
End If
iCount = iCount + 1
3. 在表格的列插入日期
(1) 如需在表格的第一列插入日期, 可用For Each...Next结构来循环遍历表格中的每个单元格,当判断某一单元格为第一列时,插入日期。Formart(Date,...)用于指定日期的格式,下面例子中的日期从Date+1(即当前日期第二天)开始,用户可以根据需要自定义。
Set oDoc = ActiveDocument
Set oTable =oDoc.Tables.Add(Range:=oDoc.Range(Start:=0,End:=0),NumRows:=
4,NumColumns:=4)
iCount = 1
For Each oCell In oTable.Range.Cells
If iCount Mod 4 = 1 And iCount > 4 Then
oCell.Range.InsertAfter Format(Date + (iCount - 1) / 4, "YYYY.MM.DD")
End If
If iCount Mod 4 = 2 And iCount > 4 Then
oCell.Range.InsertAftercWeekName(WeekDay(Date+(iCount - 1) / 4))
End If
iCount = iCount + 1
Next oCell
oTable.AutoFormat Format:=wdTableFormatColorful1,ApplyBorders:=True, Ap
plyFont:=True, ApplyColor:=True
@@0869601.JPG;图2@@
(2) 如果需要在表格的第二列插入星期值,可在上例的For Each...Next结构中插入以下几行:
If iCount Mod 4 = 2 And iCount > 4 Then
oCell.Range.InsertAfter cWeekName(WeekDay(Date + (iCount - 1) / 4))
End If
其中,WeekDay(Date)返回一数值(1~7),分别表示"星期日"~"星期六",CWeekName数组需要事先定义为:
Dim cWeekName(7)
cWeekName(1) = "星期日"
cWeekName(2) = "星期一"
......
cWeekName(7) ="星期六"
4. 根据单元格的内容设置不同的格式
以上例中表格为例,如果需要将所有"星期六"和"星期日"所在行格式改为蓝色背景,只要在上例程序之后追加以下几行即可(表格格式改为wdTableFormatColorful2,行数改为12行)。程序中再次使用For Each...Next结构遍历表格中的每一行(Rows),如果检测到某一行满足条件("星期六"或"星期日"),则选择一行(Selection.SelectRow),将其属性改为需要的格式(本例中为蓝色背景)。
iCount = 1
For Each Rows In oTable.Range.Rows
If (WeekDay(Date + (iCount - 1)) = 7 Or WeekDay(Date + (iCount - 1))= 1)
And iCount > 1
Then
Selection.SelectRow
With Selection.Cells
With .Shading
.Texture = wdTextureNone
.ForegroundPatternColorIndex = wdAuto
.BackgroundPatternColorIndex = wdBlue
End With
End With
End If
iCount = iCount + 1
Selection.MoveDown Unit:=wdLine, Count:=1
Next Rows
@@0869602.JPG;图3@@
以上几例简要介绍了使用VBA自动处理Word表格的例子(有关Visual Basic事件、方法、对象、属性的详细使用方法请参阅Microsoft Word Visual Basic帮助)。客户可将编制的Visual Basic代码作为Word宏指定到工具栏或快捷方式,方便以后的使用。
有没有办法在Word中将获取某些位置的数据?比如,我先定义好了一个模板,里面已经有了些固定好的东西了,然后我需要对另外一些地方(如一张表格)进行数据的采集,写入,又应该如何做.最好能在VB环境中完成.
再次谢谢高手.