国产一级a片免费看高清,亚洲熟女中文字幕在线视频,黄三级高清在线播放,免费黄色视频在线看

打開APP
userphoto
未登錄

開通VIP，暢享免費(fèi)電子書等14項(xiàng)超值服

開通VIP

首頁

好書

留言交流

下載APP

聯(lián)系客服
VB6操作EXCEL導(dǎo)入數(shù)據(jù)庫

  1. Private Function FunImpExcel(ByVal strFilePath As String) As Integer  
  2.     'Excel文件格式  
  3.     '第一行為表名，第二行為列名，其余行均為數(shù)據(jù)  
  4.     On Error GoTo hErr  
  5.     Dim objConn As New ADODB.Connection  
  6.     Dim objRS As New ADODB.Recordset  
  7.    
  8.     If Dir(strFilePath) = "" Then  
  9.         MsgBox "文件不存在" , vbCritical, "錯(cuò)誤"  
  10.         Exit Function    
  11.     End If  
  12.     '定義Excel對(duì)象  
  13.     Dim xlsApp As Object  
  14.     Dim xlsWb As Object  
  15.     Dim xlsWs As Object  
  16.       
  17.     Set xlsApp = CreateObject("Excel.Application") '建立excel對(duì)象  
  18.     Set xlsWb = xlsApp.Workbooks.Open(strFilePath) '要打開的文檔路徑  
  19.     Set xlsWs = xlsWb.Worksheets(1) '選工作表，有多張表時(shí)，可以參考此，變換序號(hào)指定不同的表  
  20.       
  21.     xlsWs.Activate  
  22.     xlsApp.Visible = false '隱藏，否則會(huì)在界面顯示出來  
  23.     'Excel表格的行數(shù)和列數(shù)  
  24.     Dim iRowCnt As Integer  
  25.     Dim iColCnt As Integer  
  26.     iRowCnt = xlsWs.UsedRange.Rows.Count '這個(gè)并不完全準(zhǔn)確，在操作數(shù)據(jù)時(shí)要設(shè)置退出條件  
  27.     iColCnt = xlsWs.UsedRange.Columns.Count'這個(gè)并不完全準(zhǔn)確，在操作數(shù)據(jù)時(shí)要設(shè)置退出條件  
  28.     '下面要根據(jù)具體的表格情況決定，這里前面兩行是表名和列名  
  29.     If iRowCnt <= 2 Then  
  30.         MsgBox "沒有需要導(dǎo)入的明細(xì)數(shù)據(jù)" , vbCritical, "錯(cuò)誤"  
  31.         GoTo hErr  
  32.     End If  
  33.     '從第3行開始是明細(xì)數(shù)據(jù)  
  34.     For i = 3 To iRowCnt  
  35.         '設(shè)置退出條件  
  36.         If Trim$(xlsWs.Cells(i, 3).Value) = "" Then  
  37.             mdlPub.debug_print "on date found anymore:" & i  
  38.             Exit For  
  39.         End If  
  40.         '第一條數(shù)據(jù)時(shí)，先打開數(shù)據(jù)庫，這里是access  
  41.         if 3 = i then   
  42.             '數(shù)據(jù)庫訪問操作可以封裝成一個(gè)公共的函數(shù)或過程  
  43.             Dim strConn as String  
  44.             strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=true;Data Source=test.mdb"  
  45.             objConn.CursorLocation = adUseClient  
  46.             objConn.Open strConn  
  47.             strSQL = "select * from [要導(dǎo)入的表名] where 1=2 "              
  48.             objRS.CursorLocation = adUseClient  
  49.             objRS.Open strSQL, objConn, adOpenKeyset, adLockOptimistic  
  50.         End if  
  51.         '新增一條記錄，注意各個(gè)字段的數(shù)據(jù)類型匹配問題，  
  52.         '最好全部統(tǒng)一先轉(zhuǎn)化為字符串，再轉(zhuǎn)化為對(duì)應(yīng)的類型      
  53.         objRS.AddNew  
  54.         objRS.Fields("數(shù)據(jù)庫列名１") = Trim(CStr(xlsWs.Cells(i, 1).Value))    
  55.         objRS.Fields("數(shù)據(jù)庫列名2") = Trim(CStr(xlsWs.Cells(i, 2).Value))   
  56.         '.....  
  57.         objRS.Fields("數(shù)據(jù)庫列名n") = CLng(Trim(CStr(xlsWs.Cells(i, n).Value)))    
  58.           
  59.         '如果Excel列名與要導(dǎo)入的數(shù)據(jù)庫列能按順序一一對(duì)應(yīng)，  
  60.         '則可以按以下方式,但要解決不同字段的數(shù)據(jù)格式匹配問題，比較麻煩  
  61.         'For j = 0 To RS.Fields.Count - 1  
  62.         '    RS.Fields(j) = Trim(CStr(xlsWs.Cells(i, 1).Value))  
  63.         'Next  
  64.           
  65.         '更新到數(shù)據(jù)庫  
  66.         objRS.Update  
  67.     Next i  
  68.       
  69.     objRS.Close  
  70.     objConn.Close  
  71.     Set objRS = Nothing  
  72.     Set objConn = Nothing  
  73.       
  74.     xlsWb.Close '關(guān)閉excel文件  
  75.     xlsApp.Quit '退出excel  
  76.       
  77.     Set xlsWs = Nothing  
  78.     Set xlsWb = Nothing  
  79.     Set xlsApp = Nothing  
  80.     FunImpExcel = 0'成功則返回０  
  81.       
  82.     Exit Function    
  83. hErr:  
  84.     ImpExcelCertDtl = -１　'失敗則返回１  
  85.     If Not (xlsWb Is Nothing) Then xlsWb.Close        '關(guān)閉文件  
  86.     If Not (xlsApp Is Nothing) Then xlsApp.Quit  
  87.   
  88.     Set xlsWs = Nothing  
  89.     Set xlsWb = Nothing  
  90.     Set xlsApp = Nothing  
  91.     MsgBox "文件導(dǎo)入失敗" , vbCritical, "錯(cuò)誤"  
  92.       
  93. End Function  

對(duì)于一個(gè)Excel文件中多個(gè)表格的情況，可以循環(huán)逐一導(dǎo)入。

為了方便，對(duì)于excel對(duì)象的定義可以明確一些，這樣能自動(dòng)彈出提示，方便編碼。

如：

  1. Dim xlsApp As New Excel.Application  
  2. Dim xlsWb As Excel.Workbook  
  3. Dim xlsWs As Excel.Worksheet  

但這樣定義時(shí)需要在工程中引入excel組件。

 ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

將數(shù)據(jù)導(dǎo)出至Excel

 

  1. '-----------------  
  2. '從數(shù)據(jù)從數(shù)據(jù)庫導(dǎo)出至excel，并彈出保存文件對(duì)話框  
  3. '-------------------  
  4. Private Function FunExpExcel()  
  5.   
  6.     On Error GoTo hErr  
  7.     '注意引用excel組件，也可以直接定義為對(duì)象object  
  8.     Dim xlsApp As New Excel.Application  
  9.     Dim xlsWb As Excel.Workbook  
  10.     Dim xlsWs As Excel.Worksheet  
  11.     Dim strFilePath As String  
  12.     Dim strFileNm As String  
  13.     Dim iColIdx As Integer  
  14.       
  15.     Dim objTmp As Object  
  16.   
  17.     '創(chuàng)建excel  
  18.     Set xlsApp = CreateObject("Excel.Application")  
  19.     xlsApp.Visible = False  
  20.     xlsApp.SheetsInNewWorkbook = 1 '定義表格個(gè)數(shù)  
  21.     '新增一張表格， 這里可以增加多張表  
  22.     Set xlsWb = xlsApp.Workbooks.Add  
  23.     '指定sheet，指定第一張，如果有多張，可以具體指定哪一個(gè)  
  24.     Set xlsWs = xlsWb.Worksheets(1)  
  25.        
  26.     'xlsApp.Visible = False  
  27.     xlsWs.Activate  
  28.     xlsWs.Select  
  29.     '第一行為標(biāo)題  
  30.     xlsWs.Cells(1, 1).Value = "表格標(biāo)題"  
  31.     '第二行為列名,第一列列名“序號(hào)”  
  32.     xlsWs.Cells(2, 1).Value = "序號(hào)"  
  33.     ....  
  34.     xlsWs.Cells(2, n).Value = "序號(hào)"  
  35.     '如果是datagrid，可以直接用對(duì)應(yīng)的列名  
  36.     'For iColIdx = 0 To Me.grdQryInst.Columns.Count - 1  
  37.     '    xlsWs.Cells(2, iColIdx + 2).Value = Me.datagrid1.Columns(iColIdx).Caption  
  38.     'Next  
  39.     '設(shè)置第一列序號(hào)為數(shù)字格式  
  40.     xlsWs.Columns("A:A").NumberFormatLocal = "0_ "  
  41.       
  42.     '設(shè)置其它列為文本格式,函數(shù)NumToChar26能將數(shù)字轉(zhuǎn)化為對(duì)應(yīng)的excel列名，如2->B,3->C,自已實(shí)現(xiàn)  
  43.     'xlsWs.Columns(NumToChar26(2) & ":" & NumToChar26(Me.datagrid1.Columns.Count)).NumberFormatLocal = "@"  
  44.       
  45.     '----這里打開數(shù)據(jù)庫，查詢數(shù)據(jù)略，自己實(shí)現(xiàn)，如果是datagrid,則可以按下面的方法  
  46.     'Dim RS As ADODB.Recordset  
  47.     'Set RS = Me.datagrid1.DataSource  
  48.     '從第三行開始寫明細(xì)數(shù)據(jù)  
  49.     RS.MoveFirst  
  50.     For iRowIdx = 0 To RS.RecordCount - 1  
  51.         xlsWs.Cells(iRowIdx + 3, 1).Value = CStr(iRowIdx + 1)  
  52.         '對(duì)第一行，按順序逐列寫單元格  
  53.         For iColIdx = 0 To RS.Fields.Count - 1  
  54.            xlsWs.Cells(iRowIdx + 3, iColIdx + 2).Value = RS.Fields(iColIdx).Value  
  55.         Next  
  56.         RS.MoveNext  
  57.     Next  
  58.     '-----寫完數(shù)據(jù)，下面設(shè)置導(dǎo)出excel格式　  
  59.     '標(biāo)題格式設(shè)置  
  60.     Set objTmp = xlsWs.Range(xlsWs.Cells(1, 1), xlsWs.Cells(1, iColIdx + 2 - 1))  
  61.     objTmp.Merge　'合并單元格  
  62.     '標(biāo)題排版  
  63.     With objTmp  
  64.         .HorizontalAlignment = xlCenter  
  65.         .VerticalAlignment = xlCenter  
  66.     End With  
  67.     With objTmp.Font  
  68.         .Name = "宋體"  
  69.         .Size = 18  
  70.     End With  
  71.    
  72.     '第2行開始，設(shè)置邊框，字體與標(biāo)題不同  
  73.     Set objTmp = xlsApp.Range(xlsWs.Cells(2, 1), xlsWs.Cells(iRowIdx + 3 - 1, iColIdx + 2 - 1))  
  74.     With objTmp.Font  
  75.         .Name = "宋體"  
  76.         .Size = 10  
  77.         .Underline = xlUnderlineStyleNone  
  78.         .ColorIndex = xlAutomatic  
  79.     End With  
  80.     objTmp.Borders(xlDiagonalDown).LineStyle = xlNone  
  81.     objTmp.Borders(xlDiagonalUp).LineStyle = xlNone  
  82.     With objTmp.Borders(xlEdgeLeft)  
  83.         .LineStyle = xlContinuous  
  84.         .Weight = xlThin  
  85.         .ColorIndex = xlAutomatic  
  86.     End With  
  87.     With objTmp.Borders(xlEdgeTop)  
  88.         .LineStyle = xlContinuous  
  89.         .Weight = xlThin  
  90.         .ColorIndex = xlAutomatic  
  91.     End With  
  92.     With objTmp.Borders(xlEdgeBottom)  
  93.         .LineStyle = xlContinuous  
  94.         .Weight = xlThin  
  95.         .ColorIndex = xlAutomatic  
  96.     End With  
  97.     With objTmp.Borders(xlEdgeRight)  
  98.         .LineStyle = xlContinuous  
  99.         .Weight = xlThin  
  100.         .ColorIndex = xlAutomatic  
  101.     End With  
  102.     With objTmp.Borders(xlInsideVertical)  
  103.         .LineStyle = xlContinuous  
  104.         .Weight = xlThin  
  105.         .ColorIndex = xlAutomatic  
  106.     End With  
  107.     With objTmp.Borders(xlInsideHorizontal)  
  108.         .LineStyle = xlContinuous  
  109.         .Weight = xlThin  
  110.         .ColorIndex = xlAutomatic  
  111.     End With  
  112.       
  113.     '設(shè)置列寬，自動(dòng)擴(kuò)展  
  114.     For iColIdx = 1 To Me.grdQryInst.Columns.Count + 1  
  115.         xlsWs.Columns(NumToChar26(iColIdx) & ":" &　NumToChar26(iColIdx)).EntireColumn.AutoFit  
  116.     Next  
  117.          
  118.    '彈出保存文件對(duì)話框，要在窗體上增加commondialog控件，控件命名dlgFile  
  119.     Me.dlgFile.DialogTitle = "保存至"  
  120.     Me.dlgFile.Flags = &H200  
  121.     Me.dlgFile.DefaultExt = ".xls"  
  122.       
  123.     Me.dlgFile.Filter = "Excel數(shù)據(jù)文件 *.xls|*.xls" '過濾器  
  124.     Me.dlgFile.InitDir = App.Path  
  125.     Me.dlgFile.FileName = strFileNm & ".xls"  
  126.     Me.dlgFile.ShowSave  
  127.       
  128.     If Err <> 32755 Then strFilePath = dlgFile.FileName  
  129.     If "" <> strFilePath Then  
  130.         xlsWb.SaveAs strFilePath  
  131.     Else  
  132.         mdlPub.ShowInfo "文件未保存"  
  133.     End If  
  134.       
  135.     xlsWb.Close  
  136.     xlsApp.Quit  
  137.     Set xlsWs = Nothing  
  138.     Set xlsWb = Nothing  
  139.     Set xlsApp = Nothing  
  140.     FunExpExcel = 0 '成功則返回0  
  141.     mdlPub.ShowInfo "已保存至" & strFilePath  
  142.     Exit Sub  
  143. hErr:  
  144.     FunExpExcel = -1'失敗則返回1  
  145.     If Err.Number <> 0 Then mdlPub.ShowErrMsg "導(dǎo)出錯(cuò)"  
  146.     If Not (xlsWb Is Nothing) Then Set xlsWs = Nothing  
  147.     If Not (xlsWb Is Nothing) Then  
  148.         xlsWb.Close  
  149.         Set xlsWb = Nothing  
  150.     End If  
  151.     If Not (xlsWb Is Nothing) Then  
  152.         xlsApp.Quit  
  153.         Set xlsApp = Nothing  
  154.     End If  
  155.   
  156. End Function  
  

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

h注意，在使用VB操作 excel過程中，對(duì)于excel對(duì)象的引用都要用到本地定義的excel三個(gè)變量xlsApp，xlsWb，xlsWs之一做前綴，否則，   會(huì)出現(xiàn)殘留EXCEL進(jìn)程的情況，下次操作EXCEL時(shí)會(huì)報(bào)錯(cuò)。原因是沒有加本地定義的變量做前綴，而使用了EXCEl的全局變量形式，xlsWb.Close， xlsApp.Quit語句只是退出局部EXCEL，無法退出全局EXCEL。

 

 

本站僅提供存儲(chǔ)服務(wù)，所有內(nèi)容均由用戶發(fā)布，如發(fā)現(xiàn)有害或侵權(quán)內(nèi)容，請(qǐng)點(diǎn)擊舉報(bào)。
打開APP，閱讀全文并永久保存 查看更多類似文章
猜你喜歡
類似文章
vb讀取excel內(nèi)容
EXCEL不同的單元格格式太多解決方案
VBScript操作Excel
VB.NET向Excel寫入并保存數(shù)據(jù)
ASP.NET環(huán)境下，VB.NET語言，數(shù)據(jù)保存EXCEL模板操作
excel輸出列寬自適應(yīng)和設(shè)置為文本格式
更多類似文章 >>
生活服務(wù)
分享 收藏 導(dǎo)長(zhǎng)圖 關(guān)注 下載文章
綁定賬號(hào)成功
后續(xù)可登錄賬號(hào)暢享VIP特權(quán)！
如果VIP功能使用有故障，
可點(diǎn)擊這里聯(lián)系客服！

聯(lián)系客服