SQL.MDB数据库记录Rs导出到Excel.Sheet中代码(VBA+VB.Net)

SQL.MDB数据库记录Rs导出到Excel.Sheet中代码(VBA+VB.Net)

SQL.MDB数据库记录Rs导出到Excel.Sheet中代码(VBA+VB.Net)
有位网友要的代码。共享出来以前写的一小段代码段。

取出SQL，Access，数据库记录，生成Excel，写到Excel的表格中。我用的原始方法可以生成客户给的Excel文件复杂的表格中，如合同，定单，报价单，出货报告，报表，包装物料等Excel复杂格式的表。也可以用客户指定的Excel报表作为模板，把记录信息写到模板指定的位置（单元格）。实际用处还是很大的。

也有一些更简单的方法，直接导出到Excel表格中，可是Excel表格也是简单的列表形式。

VB.Net+SQL/Mdb 的方法也是差不多，只是语法不同而已。在VB.Net当然是DateTable啦。

 

VBA代码：

Private Sub CreatXlsToBaoGuang() Dim Rst As DAO.Recordset Dim RstSm As DAO.Recordset Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet lb.Caption = "创建Execl应用程序..." Me.Repaint Set xlApp = CreateObject("Excel.Application") Set xlBook = Nothing Set xlSheet = Nothing lb.Caption = "添加新的工作表..." Me.Repaint Set xlBook = xlApp.Workbooks.Add Set xlSheet = xlBook.Worksheets(1) '''''''''''''''''''''''''''''''''''''''''''''''' xlSheet.Activate lb.Caption = "设置工作表的宽度..." Me.Repaint xlSheet.Columns(1).ColumnWidth = 10 xlSheet.Columns(2).ColumnWidth = 10 xlSheet.Columns(3).ColumnWidth = 25 xlSheet.Columns(4).ColumnWidth = 10 xlSheet.Columns(5).ColumnWidth = 7 xlSheet.Columns(6).ColumnWidth = 12 SqlString = "select 客户货号,有配件,配件组号,货品中文,箱数,数量,体积立方米 from 定单明细表 where 定单号='" & contractnum & "' order by 客户货号" Set Rst = CurrentDb.OpenRecordset(SqlString) If Not (Rst.BOF And Rst.EOF) Then ' rst.MoveLast ' MsgBox rst.RecordCount =39 RowNum = 5 Rst.MoveFirst While Not Rst.EOF lb.Caption = "散货入仓报告>>>>填写大号资料..." & Rst("客户货号") Me.Repaint '将记录信息写入到excel表格的某一个单元格。 xlSheet.Cells(RowNum, 1) = Rst("客户货号") xlSheet.Cells(RowNum, 3) = IIf(IsNull(Rst("货品中文")), " ", Rst("货品中文")) Tmptext = " " '......省略掉N行 RowNum = RowNum + 1 Rst.MoveNext Wend End If Set Rst = Nothing Tmptext = "A4:G" & RowNum - 1 xlSheet.Range(Tmptext).Borders.LineStyle = 7 '细线 xlSheet.Range(Tmptext).Font.Size = 10 Tmptext = "A" & RowNum + 1 & ":C" & RowNum + 1 FillMyRange xlSheet.Range(Tmptext), "业务员：_________________", 12, 2, False Tmptext = "D" & RowNum + 1 & ":G" & RowNum + 1 FillMyRange xlSheet.Range(Tmptext), "审批人：_________________", 12, 2, False lb.Caption = "定义文件名..." Me.Repaint Tmptext = contractnum & "-(散货入仓报告).xls" lb.Caption = "保存文件..." Me.Repaint pathfile = CurrentProject.path & "/" & Tmptext xlBook.SaveAs pathfile lb.Caption = "退出Excel 程序..." Me.Repaint xlApp.ActiveWorkbook.Close SaveChanges:=False xlApp.Quit lb.Caption = "释放内存..." Me.Repaint Set xlSheet = Nothing Set xlBook = Nothing Set xlApp = Nothing lb.Caption = "当前操作生成的Excel文件路径.文件名为:" & pathfile Me.Repaint cmddeletexlsfile.Enabled = True cmdopenfile.Enabled = True End Sub

 

vb.net 代码：

 

  Private Sub BtCrtOrderPackList_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles BtCrtOrderPackList.Click If Me.ListItemNoS.Items.Count < 1 Then ShowMsg("请先添加单号到右边列表中！", MsgType.Err) Exit Sub End If Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim myRange As Excel.Range Dim i, j As Integer Dim TotalRs As Integer Dim RowNo, ColNo As Integer Dim TB, SmTB As DataTable Dim CurItemNo, CurImgPath, PicDir As String Dim SmlImgSize As Size Dim ImgRct As Rectangle Dim ImgPt As Point Dim QsCls As QSClass TotalRs = Me.ListItemNoS.Items.Count PicDir = Application.StartupPath & "/SmallPic" SmlImgSize = New Size(160, 110) 'get pic Call GetCrtRpImgPathType() If ImgPathTypePick = AddImgPathType.SysPath Or ImgPathTypePick = AddImgPathType.CustomPath Then ShowMsg("处理所选的货号的图片...") If IO.Directory.Exists(PicDir) Then IO.Directory.Delete(PicDir, True) End If IO.Directory.CreateDirectory(PicDir) If Me.ImgPathTypePick = AddImgPathType.SysPath Then QsCls = New QSClass CurItemNo = "" PrgBar.Maximum = TotalRs For i = 0 To TotalRs - 1 CurItemNo = "" PrgBar.Value = i + 1 CurItemNo = Me.ListItemNoS.Items(i).ToString ShowMsg("正在获取图片和压缩为小图片:" & CurItemNo) CurImgPath = "" CurImgPath = QsCls.GetQSImg(CurItemNo) If CurImgPath > "" Then 'CreateAndSaveSmlPic(CurImgPath, SmlImgSize, PicDir) End If Next Else CurItemNo = "" PrgBar.Maximum = TotalRs For i = 0 To TotalRs - 1 PrgBar.Value = i + 1 CurItemNo = "" CurItemNo = Me.ListItemNoS.Items(i).ToString ShowMsg("正在获取图片和压缩为小图片:" & CurItemNo) CurImgPath = "" CurImgPath = Path.Combine(ImgPathCustom, CurItemNo & ".jpg") If IO.File.Exists(CurImgPath) Then 'CreateAndSaveSmlPic(CurImgPath, SmlImgSize, PicDir) End If Next End If End If PrgBar.Visible = True PrgBar.Maximum = 10 PrgBar.Value = 1 ShowMsg("创建Excel程序...") xlApp = New Excel.Application PrgBar.Value = 3 ShowMsg("添加工作表Sheet...") xlBook = xlApp.Workbooks.Add PrgBar.Value = 5 ShowMsg("设置备料单表格行和列的格式...") xlSheet = xlBook.Worksheets.Item(1) PrgBar.Value = 6 With xlSheet .Name = String.Format("备料单{0}", Date.Today.ToShortDateString) .Cells.Font.Name = "Arial" .Cells.Font.Size = 10 .Rows.RowHeight = 14 End With '省略掉N行..... xlApp.Visible = True '或者保存为Excel文件。释放内存等等。 End Sub