数码控科技猎奇Iphone动漫星座游戏电竞lolcosplay王者荣耀攻略allcnewsBLOGNEWSBLOGASKBLOGBLOGZSK全部技术问答问答技术问答it问答代码软件新闻开发博客电脑/网络手机/数码笔记本电脑互联网操作系统软件硬件编程开发360产品资源分享电脑知识文档中心IT全部全部分类 全部分类技术牛文全部分类教程最新 网页制作cms教程平面设计媒体动画操作系统网站运营网络安全服务器教程数据库工具网络安全软件教学vbscript正则表达式javascript批处理更多»编程更新教程更新游戏更新allitnewsJava 新闻网络医疗信息化安全创业站长电商科技访谈域名会议专栏创业动态融资创投创业学院 / 产品经理创业公司人物访谈营销 开发数据库服务器系统虚拟化云计算 嵌入式移动开发作业作业1常见软件all电脑网络手机数码生活游戏体育运动明星影音休闲爱好文化艺术社会民生教育科学医疗健康金融管理情感社交地区其他电脑互联网软件硬件编程开发360相关产品手机平板其他电子产品摄影器材360硬件通讯智能设备购物时尚生活常识美容塑身服装服饰出行旅游交通汽车购房置业家居装修美食烹饪单机电脑游戏网页游戏电视游戏桌游棋牌游戏手机游戏小游戏掌机游戏客户端游戏集体游戏其他游戏体育赛事篮球足球其他运动球类运动赛车健身运动运动用品影视娱乐人物音乐动漫摄影摄像收藏宠物幽默搞笑起名花鸟鱼虫茶艺彩票星座占卜书画美术舞蹈小说图书器乐声乐小品相声戏剧戏曲手工艺品历史话题时事政治就业职场军事国防节日风俗法律法规宗教礼仪礼节自然灾害360维权社会人物升学入学人文社科外语资格考试公务员留学出国家庭教育学习方法语文物理生物工程学农业数学化学健康知识心理健康孕育早教内科外科妇产科儿科皮肤科五官科男科整形中医药品传染科其他疾病医院两性肿瘤科创业投资企业管理财务税务银行股票金融理财基金债券保险贸易商务文书国民经济爱情婚姻家庭烦恼北京上海重庆天津黑龙江吉林辽宁河北内蒙古山西陕西宁夏甘肃青海新疆西藏四川贵州云南河南湖北湖南山东江苏浙江安徽江西福建广东广西海南香港澳门台湾海外地区

用vba实现将记录集输出到Excel模板

来源:本网整理

复制代码 代码如下:
'************************************************ 
'** 函数名称:  ExportTempletToExcel 
'** 函数功能:  将记录集输出到 Excel 模板 
'** 参数说明: 
'**            strExcelFile         要保存的 Excel 文件 
'**            strSQL               查询语句,就是要导出哪些内容 
'**            strSheetName         工作表名称 
'**            adoConn              已经打开的数据库连接 
'** 函数返回: 
'**            Boolean 类型 
'**            True                 成功导出模板 
'**            False                失败 
'** 参考实例: 
'**            Call ExportTempletToExcel(c:\\text.xls,查询语句,工作表1,adoConn) 
'************************************************ 
Private Function ExportTempletToExcel(ByVal strExcelFile As String, _ 
                                      ByVal strSQL As String, _ 
                                      ByVal strSheetName As String, _ 
                                      ByVal adoConn As Object) As Boolean 
   Dim adoRt                        As Object 
   Dim lngRecordCount               As Long                       ' 记录数 
   Dim intFieldCount                As Integer                    ' 字段数 
   Dim strFields                    As String                     ' 所有字段名 
   Dim i                            As Integer 

   Dim exlApplication               As Object                     ' Excel 实例 
   Dim exlBook                      As Object                     ' Excel 工作区 
   Dim exlSheet                     As Object                     ' Excel 当前要操作的工作表 

   On Error GoTo LocalErr 

   Me.MousePointer = vbHourglass 

   '// 创建 ADO 记录集对象 
   Set adoRt = CreateObject(ADODB.Recordset) 

   With adoRt 
      .ActiveConnection = adoConn 
      .CursorLocation = 3           'adUseClient 
      .CursorType = 3               'adOpenStatic 
      .LockType = 1                 'adLockReadOnly 
      .Source = strSQL 
      .Open 

      If .EOF And .BOF Then 
         ExportTempletToExcel = False 
      Else 
         '// 取得记录总数,+ 1 是表示还有一行字段名名称信息 
         lngRecordCount = .RecordCount + 1 
         intFieldCount = .Fields.Count - 1 

         For i = 0 To intFieldCount 
            '// 生成字段名信息(vbTab 在 Excel 里表示每个单元格之间的间隔) 
            strFields = strFields & .Fields(i).Name & vbTab 
         Next 

         '// 去掉最后一个 vbTab 制表符 
         strFields = Left$(strFields, Len(strFields) - Len(vbTab)) 

         '// 创建Excel实例 
         Set exlApplication = CreateObject(Excel.Application) 
         '// 增加一个工作区 
         Set exlBook = exlApplication.Workbooks.Add 
         '// 设置当前工作区为第一个工作表(默认会有3个) 
         Set exlSheet = exlBook.Worksheets(1) 
         '// 将第一个工作表改成指定的名称 
         exlSheet.Name = strSheetName 

         '// 清除“剪切板” 
         Clipboard.Clear 
         '// 将字段名称复制到“剪切板” 
         Clipboard.SetText strFields 
         '// 选中A1单元格 
         exlSheet.Range(A1).Select 
         '// 粘贴字段名称 
         exlSheet.Paste 

         '// 从A2开始复制记录集 
         exlSheet.Range(A2).CopyFromRecordset adoRt 
         '// 增加一个命名范围,作用是在导入时所需的范围 
         exlApplication.Names.Add strSheetName, = & strSheetName & !$A$1:$ & _ 
                                  uGetColName(intFieldCount + 1) & $ & lngRecordCount 
         '// 保存 Excel 文件 
         exlBook.SaveAs strExcelFile 
         '// 退出 Excel 实例 
         exlApplication.Quit 

         ExportTempletToExcel = True 
      End If 
      'adStateOpen = 1 
      If .State = 1 Then 
         .Close 
      End If 
   End With 

LocalErr: 
   '********************************************* 
   '** 释放所有对象 
   '********************************************* 
   Set exlSheet = Nothing 
   Set exlBook = Nothing 
   Set exlApplication = Nothing 
   Set adoRt = Nothing 
   '********************************************* 

   If Err.Number <> 0 Then 
      Err.Clear 
   End If 

   Me.MousePointer = vbDefault 
End Function 

'// 取得列名 
Private Function uGetColName(ByVal intNum As Integer) As String 
   Dim strColNames                  As String 
   Dim strReturn                    As String 

   '// 通常字段数不会太多,所以到 26*3 目前已经够了。 
   strColNames = A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z, & _ 
                 AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR,AS,AT,AU,AV,AW,AX,AY,AZ, & _ 
                 BA,BB,BC,BD,BE,BF,BG,BH,BI,BJ,BK,BL,BM,BN,BO,BP,BQ,BR,BS,BT,BU,BV,BW,BX,BY,BZ 
   strReturn = Split(strColNames, ,)(intNum - 1) 
   uGetColName = strReturn 
End Function 

  • 本文相关:
  • VBA 编程基础
  • excel vba 限制工作表的滚动区域代码
  • excel vba 高亮显示当前行代码
  • 当编辑框内容改变 对应的单元格也随着改变vba代码
  • VBA 浏览文件夹对话框调用的几种方法
  • 向数据报表添加一个合计字段
  • UserAccessList 集合的功能(VBA)
  • VBA UsedObjects 集合用法
  • vba 获取PPT幻灯片中的所有标题的代码
  • 免责声明 - 关于我们 - 联系我们 - 广告联系 - 友情链接 - 帮助中心 - 频道导航
    Copyright © 2017 www.zgxue.com All Rights Reserved