VB操作EXCEL文件大全

Private Sub writeToExcel(strTmp1() As String, colTmp1 As Collection)
'
'    Dim tmp1
    Dim i1 As Integer, intCol As Integer, intRow As Integer
    Dim xlApp As New Excel.Application
    Dim xlBook As New Excel.Workbook
    Dim xlSheet As New Excel.Worksheet
    Dim strName As String, strArray1() As String
    Dim strS1 As String
    Dim strD1 As String

    strS1 = CurrentProject.Path + "\template.xls"
    strD1 = CurrentProject.Path + "\" + CStr(Format(Now, "YYYYMMDDHHMMSS")) + "aaa1.xls"


'    For i1 = 0 To UBound(strTmp1) - 1
'        Debug.Print strTmp1(i1) + " " + CStr(i1)
'    Next i1

'    strName = CurrentProject.Path + "\aaa1.xls"
    FileCopy strS1, strD1

    Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = False
'    Set xlBook = xlApp.Workbooks.Open(strName)

    Set xlBook = xlApp.Workbooks.Open(strD1)
    Set xlSheet = xlBook.Worksheets(1)

    With xlSheet
        .Range("F6").Value = strTmp1(1)
        .Range("H6").Value = strTmp1(2)
        .Range("F7").Value = CStr(Date)
        .Range("E10").Value = strTmp1(9)
        .Range("A15").Value = "To: " + strTmp1(8)
        .Range("B26").Value = strTmp1(4) + "PACKAGES"
        .Range("B27").Value = strTmp1(5) + "KGS"
        .Range("B28").Value = strTmp1(6) + "KGS"
        .Range("B29").Value = strTmp1(7) + "M3"
    End With

    intCol = 1
    intRow = 21

    For i1 = 1 To colTmp1.Count
        strArray1 = colTmp1.Item(i1)
        With xlSheet
            .Cells(intRow, 1).Value = strArray1(2)
            .Cells(intRow, 2).Value = strArray1(5)
            .Cells(intRow, 4).Value = strArray1(6)
            .Cells(intRow, 5).Value = strArray1(1)
            .Cells(intRow, 6).Value = strArray1(3)
            .Cells(intRow, 7).Value = strArray1(4)
            .Cells(intRow, 8).Value = strArray1(7)
            .Cells(intRow, 9).Value = strArray1(9)
            intRow = intRow + 1
            xlApp.ActiveSheet.Rows(intRow).Insert
            .Cells(intRow, 1).Value = strArray1(8)
            intRow = intRow + 1
            xlApp.ActiveSheet.Rows(intRow).Insert
        End With
        intRow = intRow + 1
        xlApp.ActiveSheet.Rows(intRow).Insert
    Next i1

    xlApp.Visible = True
    xlBook.Save
'    xlBook.Close
    Set xlSheet = Nothing
    Set xlBook = Nothing
'    xlApp.Quit

'    tmp1 = Shell(strName, 1)

'    hWndDesk = GetDesktopWindow()
'    r = ShellExecute(hWndDesk, "Open", strName, vbNullString, 0&, 1)
   Dim xlApp As New Excel.ApplicationDim xlBook As New Excel.WorkbookDim xlSheet As New Excel.Worksheet
 Public Sub exportExcel()' Dim strA1() As String, strA2() As String, strTmp1 As String, strDATE As String, strName As String, strValue As String Dim intFieldLength As Integer, i1 As Integer, i2 As Integer, lngCount As Long Dim rs1 As DAO.Recordset  strTmp1 = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1,K1,L1,M1,N1,O1,P1,Q1,R1,S1,T1,U1,V1,W1,X1,Y1,Z1,AA1,AB1,AC1,AD1,AE1,AF1,AG1,AH1,AI1,AJ1,AK1,AL1,AM1,AN1,AO1,AP1,AQ1,AR1,AS1,AT1,AU1,AV1,AW1,AX1,AY1,AZ1,BA1,BB1,BC1,BD1,BE1,BF1,BG1,BH1,BI1,BJ1,BK1,BL1,BM1,BN1,BO1,BP1,BQ1,BR1,BS1,BT1,BU1,BV1,BW1,BX1,BY1,BZ1,CA1,CB1,CC1,CD1,CE1,CF1,CG1,CH1,CI1,CJ1,CK1,CL1,CM1,CN1,CO1,CP1,CQ1,CR1,CS1,CT1,CU1,CV1,CW1,CX1,CY1,CZ1" strA1 = Split(strTmp1, ",")  Set xlApp = CreateObject("Excel.Application") xlApp.Visible = False Set xlBook = xlApp.Workbooks.Add  strDATE = CStr(Format(Date, "YYYY-MM-DD")) Me.CommonDialog1.DefaultExt = "xls" Me.CommonDialog1.Filename = "帳單輸出" + strDATE + ".xls" Me.CommonDialog1.Filter = "EXCEL FILE(*.xls)|*.xls" Me.CommonDialog1.ShowSave  strName = Me.CommonDialog1.Filename xlBook.SaveAs strName Set xlBook = xlApp.Workbooks.Open(strName) Set xlSheet = xlBook.Worksheets(1)  strSQL = "SELECT * FROM HEADCOST1; " Set rs1 = CurrentDb.OpenRecordset(strSQL) rs1.MoveLast Debug.Print rs1.RecordCount lngCount = rs1.RecordCount intFieldLength = rs1.Fields.Count' Debug.Print intFieldLength Debug.Print intFieldLength strA2() = Split(splitTable("HEADCOST1"), ",") Debug.Print UBound(strA2)  With xlSheet For i1 = 0 To intFieldLength - 1 Debug.Print i1 Debug.Print strA1(i1) .Range(strA1(i1)).Value = getZValue(strA2(i1)) Next i1 End With  If rs1.RecordCount <> 0 Then rs1.MoveFirst For i1 = 1 To lngCount For i2 = 1 To rs1.Fields.Count If IsNull(rs1(i2 - 1)) Then strValue = " " Else strValue = rs1(i2 - 1).Value End If xlSheet.Cells(i1 + 1, i2) = strValue Next i2 rs1.MoveNext Next i1 rs1.MoveFirst Else MsgBox "未讀取到數據", vbCritical, "錯誤" End If  xlBook.Save xlBook.Close  Set xlSheet = Nothing Set xlBook = Nothing xlApp.Quit Set xlApp = Nothing  rs1.Close Set rs1 = NothingEnd Sub

Private Sub Command1_Click()
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add

Dim strDate As String, strName As String, strValue As String
strDate = CStr(Format(Date, "yyyy-mm-dd"))
Me.CommonDialog1.DefaultExt = "xls"
Me.CommonDialog1.FileName = "SEND3B2" + strDate + ".xls"
Me.CommonDialog1.Filter = "EXCEL FILE(*.xls)|*.xls"
Me.CommonDialog1.ShowSave

strName = Me.CommonDialog1.FileName
Debug.Print strName
xlBook.SaveAs strName
Set xlBook = xlApp.Workbooks.Open(strName)
Set xlSheet = xlBook.Worksheets(1)
' For i1 = 0 To Me.DataGrid1.Columns.Count - 1
' xlSheet.Cells(1, i1 + 1) = Me.DataGrid1.Columns.Item(j).Caption
' Next i1
With xlSheet
.Range("A1").Value = "ORDERKEY"
.Range("B1").Value = "EXTERNORDERKEY"
.Range("C1").Value = "MM"
.Range("D1").Value = "QTY"
.Range("E1").Value = "PRODUCTDESP"
.Range("F1").Value = "DIVISION"
.Range("G1").Value = "MOQ"
.Range("H1").Value = "OVERPACKQTY"
.Range("I1").Value = "OVERPACK ?"
.Range("J1").Value = "CTNQTY"
.Range("K1").Value = "OPCTNQTY"
.Range("L1").Value = "CTN_PALLET"
.Range("M1").Value = "PALLETNO"
.Range("N1").Value = "PALLETWEIGHT"
.Range("O1").Value = "PALLETVOLUME"
.Range("P1").Value = "PALLETLENGTH"
.Range("Q1").Value = "PALLETWIDTH"
.Range("R1").Value = "PALLETHIGH"
.Range("S1").Value = "DELIVERYDATE"
.Range("T1").Value = "CONSIGNEEKEY"
.Range("U1").Value = "C_COUNTRY"
.Range("V1").Value = "BILLTOKEY"
.Range("W1").Value = "INCOTERM"
.Range("X1").Value = "STATUS"
.Range("Y1").Value = "INTERMODALVEHICLE"
.Range("Z1").Value = "ORDERGROUP"
.Range("AA1").Value = "HAWB"
.Range("AB1").Value = "REQSHIPDATE"
.Range("AC1").Value = "RELEASEDDATE"
.Range("AD1").Value = "C_COMPANY"
End With
If Me.Adodc1.Recordset.RecordCount <> 0 Then
Me.Adodc1.Recordset.MoveFirst
For i1 = 1 To Me.Adodc1.Recordset.RecordCount
For i2 = 1 To Me.Adodc1.Recordset.Fields.Count
If IsNull(Me.Adodc1.Recordset.Fields(i2 - 1)) Then
strValue = " "
Else
strValue = Me.Adodc1.Recordset.Fields(i2 - 1).Value ': Debug.Print strValue
End If
xlSheet.Cells(i1 + 1, i2) = strValue
Next i2
Me.Adodc1.Recordset.MoveNext
Next i1
Me.Adodc1.Recordset.MoveFirst
Else
MsgBox "請先查詢數據", vbCritical, "錯誤"
End If

xlBook.Save

xlBook.Close
Set xlSheet = Nothing
Set xlBook = Nothing
' xlApp.Visible = True
xlApp.Quit
Set xlApp = Nothing
End Sub

 

用VB操作Excel(VB6.0)(整理)

首先創建Excel對象，使用ComObj:
Dim ExcelID as Excel.Application
Set ExcelID as new Excel.Application

1)顯示當前窗口：
ExcelID.Visible:=True;
2)更改Excel標題欄：
ExcelID.Caption:='應用程序調用MicrosoftExcel';
3)添加新工作簿：
ExcelID.WorkBooks.Add;
4)打開已存在的工作簿：
ExcelID.WorkBooks.Open('C:\Excel\Demo.xls');
5)設置第2個工作表為活動工作表：
ExcelID.WorkSheets[2].Activate;
或ExcelID.WorkSheets['Sheet2'].Activate;
6)給單元格賦值：
ExcelID.Cells[1,4].Value:='第一行第四列';
7)設置指定列的寬度（單位：字符個數），以第一列為例：
ExcelID.ActiveSheet.Columns[1].ColumnsWidth:=5;
8)設置指定行的高度（單位：磅）（1磅＝0.035厘米），以第二行為例：
ExcelID.ActiveSheet.Rows[2].RowHeight:=1/0.035;//1厘米
9)在第8行之前插入分頁符：
ExcelID.WorkSheets[1].Rows[8].PageBreak:=1;
10)在第8列之前刪除分頁符：
ExcelID.ActiveSheet.Columns[4].PageBreak:=0;
11)指定邊框線寬度：
ExcelID.ActiveSheet.Range['B3:D4'].Borders[2].Weight:=3;
1-左 2-右 3-頂4-底 5-斜(\) 6-斜(/)
12)清除第一行第四列單元格公式：
ExcelID.ActiveSheet.Cells[1,4].ClearContents;
13)設置第一行字體屬性：
ExcelID.ActiveSheet.Rows[1].Font.Name:='隸書';
ExcelID.ActiveSheet.Rows[1].Font.Color :=clBlue;
ExcelID.ActiveSheet.Rows[1].Font.Bold :=True;
ExcelID.ActiveSheet.Rows[1].Font.UnderLine:=True;
14)進行頁面設置：
a.頁眉：
ExcelID.ActiveSheet.PageSetup.CenterHeader:='報表演示';
b.頁腳：
ExcelID.ActiveSheet.PageSetup.CenterFooter:='第&P頁';
c.頁眉到頂端邊距2cm：
ExcelID.ActiveSheet.PageSetup.HeaderMargin:=2/0.035;
d.頁腳到底端邊距3cm：
ExcelID.ActiveSheet.PageSetup.HeaderMargin:=3/0.035;
e.頂邊距2cm：
ExcelID.ActiveSheet.PageSetup.TopMargin:=2/0.035;
f.底邊距2cm：
ExcelID.ActiveSheet.PageSetup.BottomMargin:=2/0.035;
g.左邊距2cm：
ExcelID.ActiveSheet.PageSetup.LeftMargin:=2/0.035;
h.右邊距2cm：
ExcelID.ActiveSheet.PageSetup.RightMargin:=2/0.035;
i.頁面水平居中：
ExcelID.ActiveSheet.PageSetup.CenterHorizontally:=2/0.035;
j.頁面垂直居中：
ExcelID.ActiveSheet.PageSetup.CenterVertically:=2/0.035;
k.打印單元格網線：
ExcelID.ActiveSheet.PageSetup.PrintGridLines:=True;
15)拷貝操作：
a.拷貝整個工作表：
ExcelID.ActiveSheet.Used.Range.Copy;
b.拷貝指定區域：
ExcelID.ActiveSheet.Range['A1:E2'].Copy;
c.從A1位置開始粘貼：
ExcelID.ActiveSheet.Range.['A1'].PasteSpecial;
d.從文件尾部開始粘貼：
ExcelID.ActiveSheet.Range.PasteSpecial;
16)插入一行或一列：
a.ExcelID.ActiveSheet.Rows[2].Insert;
b.ExcelID.ActiveSheet.Columns[1].Insert;
17)刪除一行或一列：
a.ExcelID.ActiveSheet.Rows[2].Delete;
b.ExcelID.ActiveSheet.Columns[1].Delete;
18)打印預覽工作表：
ExcelID.ActiveSheet.PrintPreview;
19)打印輸出工作表：
ExcelID.ActiveSheet.PrintOut;
20)工作表保存：
IfnotExcelID.ActiveWorkBook.Savedthen
ExcelID.ActiveSheet.PrintPreview
Endif
21)工作表另存為：
ExcelID.SaveAs('C:\Excel\Demo1.xls');
22)放棄存盤：
ExcelID.ActiveWorkBook.Saved:=True;
23)關閉工作簿：
ExcelID.WorkBooks.Close;
24)退出Excel：
ExcelID.Quit;
25)設置工作表密碼:
ExcelID.ActiveSheet.Protect"123",DrawingObjects:=True,Contents:=True,Scenarios:=True
26)EXCEL的顯示方式為最大化
ExcelID.Application.WindowState=xlMaximized
27)工作薄顯示方式為最大化
ExcelID.ActiveWindow.WindowState=xlMaximized
28)設置打開默認工作薄數量
ExcelID.SheetsInNewWorkbook=3
29)'關閉時是否提示保存(true保存；false不保存)
ExcelID.DisplayAlerts=False
30)設置拆分窗口,及固定行位置
ExcelID.ActiveWindow.SplitRow=1
ExcelID.ActiveWindow.FreezePanes=True
31)設置打印時固定打印內容
ExcelID.ActiveSheet.PageSetup.PrintTitleRows="$1:$1"
32)設置打印標題
ExcelID.ActiveSheet.PageSetup.PrintTitleColumns=""
33)設置顯示方式(分頁方式顯示)
ExcelID.ActiveWindow.View=xlPageBreakPreview
34)設置顯示比例
ExcelID.ActiveWindow.Zoom=100
35)讓Excel響應DDE請求
Ex.Application.IgnoreRemoteRequests=False

用VB操作EXCEL示例代碼
Private Sub Command3_Click()
On Error GoTo err1
Dim i As Long
Dim j As Long
Dim objExl As Excel.Application '聲明對象變量
Me.MousePointer=11 '改變鼠標樣式
Set objExl=New Excel.Application'初始化對象變量
objExl.SheetsInNewWorkbook=1 '將新建的工作薄數量設為1
objExl.Workbooks.Add'增加一個工作薄
objExl.Sheets(objExl.Sheets.Count).Name="book1" '修改工作薄名稱
objExl.Sheets.Add,objExl.Sheets("book1")‘增加第二個工作薄在第一個之后
objExl.Sheets(objExl.Sheets.Count).Name="book2"
objExl.Sheets.Add,objExl.Sheets("book2")‘增加第三個工作薄在第二個之后
objExl.Sheets(objExl.Sheets.Count).Name="book3"

objExl.Sheets("book1").Select '選中工作薄<book1>
For i=1 To 50'循環寫入數據
For j=1 To 5
If i=1 Then
objExl.Selection.NumberFormatLocal="@" '設置格式為文本
objExl.Cells(i,j)="E"&i&j
Else
objExl.Cells(i,j)=i&j
EndIf
Next
Next
objExl.Rows("1:1").Select '選中第一行
objExl.Selection.Font.Bold=True '設為粗體
objExl.Selection.Font.Size=24 '設置字體大小
objExl.Cells.EntireColumn.AutoFit '自動調整列寬
objExl.ActiveWindow.SplitRow=1 '拆分第一行
objExl.ActiveWindow.SplitColumn=0 '拆分列
objExl.ActiveWindow.FreezePanes=True '固定拆分objExl.ActiveSheet.PageSetup.PrintTitleRows="$1:$1" '設置打印固定行
objExl.ActiveSheet.PageSetup.PrintTitleColumns=""'打印標題objExl.ActiveSheet.PageSetup.RightFooter="打印時間:"&_
Format(Now,"yyyy年mm月dd日hh:MM:ss")
objExl.ActiveWindow.View=xlPageBreakPreview'設置顯示方式
objExl.ActiveWindow.Zoom=100 '設置顯示大小
'給工作表加密碼
objExl.ActiveSheet.Protect"123",DrawingObjects:=True, _
Contents:=True,Scenarios:=True
objExl.Application.IgnoreRemoteRequests=False
objExl.Visible=True '使EXCEL可見
objExl.Application.WindowState=xlMaximized'EXCEL的顯示方式為最大化
objExl.ActiveWindow.WindowState=xlMaximized'工作薄顯示方式為最大化
objExl.SheetsInNewWorkbook=3 '將默認新工作薄數量改回3個
Set objExl=Nothing'清除對象
Me.MousePointer=0 '修改鼠標
ExitSub
err1:
objExl.SheetsInNewWorkbook=3

objExl.DisplayAlerts=False '關閉時不提示保存
objExl.Quit'關閉EXCEL
objExl.DisplayAlerts=True '關閉時提示保存
Set objExl=Nothing
Me.MousePointer=0
End Sub

Dim excelfile As Excel.Application, excelwbook As Excel.Workbook, excelsheet As Excel.Worksheet

Private Sub ImportExcelData()
'
On Error GoTo Err_ImportExcelData
Dim strFile As String
Dim strB1() As String, intTmp1 As Integer

DoCmd.RunSQL "DELETE * FROM APTmp "
Me.CommonDialog8.ShowOpen
strFile = Me.CommonDialog8.Filename

Debug.Print strFile
If strFile = "" Then
MsgBox "沒有選擇文件", vbCritical, "錯誤"
Exit Sub
End If

Set excelfile = New Excel.Application
Set excelwbook = excelfile.Workbooks.Open(strFile)
Set excelsheet = excelwbook.Sheets(1)

lastCol = excelsheet.UsedRange.Columns.Count
lastRow = excelsheet.UsedRange.Rows.Count
Debug.Print lastCol
Debug.Print lastRow

Debug.Print excelsheet.Cells(1, 1)


strB1 = Split(strFile, "\")
intTmp1 = UBound(strB1)
strFile = strB1(intTmp1)
Debug.Print strFile

' If checkFileName(strFile) = True Then
' MsgBox "此文件名已經導入過,不可再導入", vbCritical, "錯誤"
' Exit Sub
' End If

If intChange = 2 Then
Call ImportAPData2(strFile)
Else
Call ImportAPData(strFile)
End If

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing
MsgBox "EXCEL數據導入完成", , "提示"
Exit_ImportExcelData:
Exit Sub
Err_ImportExcelData:
MsgBox Err.Description
Resume Exit_ImportExcelData
End

Private Sub ImportAPData(strTmp1 As String)
'
Dim i2 As Long, strTmp2 As String, boolTmp1 As Boolean

For i2 = 2 To lastRow
Debug.Print excelsheet.Cells(i2, 7)
If checkDN(Trim(CStr(excelsheet.Cells(i2, 7))), "APT") = True Then

If checkRoute(Trim(CStr(excelsheet.Cells(i2, 5)))) = False Then
strTmp2 = Trim(CStr(excelsheet.Cells(i2, 1)))
boolTmp1 = True
Else
strTmp2 = "WBLP"
GoTo LOOP1
End If

If checkR8(Trim(CStr(excelsheet.Cells(i2, 8)))) = 1 Then GoTo LOOP1

' 1 2 3 4 5 6 7 8 9
strSQL = "INSERT INTO APTmp ( OrderType, CreateDate, GIdate, ShipTo, Route, OriginDoc, DeliveryNum, LOCATION, HAWB ) "
' strSQL = strSQL + "VALUES('" + Trim(CStr(excelsheet.Cells(i2, 1))) + "',"
strSQL = strSQL + "VALUES('" + strTmp2 + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 2))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 3))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 4))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 5))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 6))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 7))) + "', "
' If checkRoute(Trim(CStr(excelsheet.Cells(i2, 5)))) = False Then
' strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 8))) + "') "
' Else
' strSQL = strSQL + "'" + addR8TSHAWB + "')"
'
' End If
' strSQL = strSQL + "'" + strTmp1 + "'" + ") "
If Trim(CStr(excelsheet.Cells(i2, 9))) = "" Then
strSQL = strSQL + "'" + "R811" + "', "
Else
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 9))) + "', "
End If
If boolTmp1 = True Then
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 8))) + "') "
boolTmp1 = False
Else
strSQL = strSQL + "'" + addR8TSHAWB + "')"
boolTmp1 = False
GoTo LOOP1
End If
Debug.Print strSQL
DoCmd.RunSQL strSQL
LOOP1:
strTmp2 = ""
boolTmp1 = False
End If
Next i2
Call ImportTAPData
End Sub
'INSERT INTO APTmp ( OrderType, CreateDate, GIdate, ShipTo, Route, OriginDoc, DeliveryNum, HAWB )
'VALUES('1','1','1','1','1','1','1','1')

Private Sub ImportAPData2(strTmp1 As String)
'
Dim i2 As Long, strTmp2 As String, boolTmp1 As Boolean

For i2 = 2 To lastRow
Debug.Print excelsheet.Cells(i2, 10): Debug.Print excelsheet.Cells(i2, 7)
If checkDN(Trim(CStr(excelsheet.Cells(i2, 10))), "APT") = True Then

If checkRoute(Trim(CStr(excelsheet.Cells(i2, 5)))) = False Then
strTmp2 = Trim(CStr(excelsheet.Cells(i2, 1)))
boolTmp1 = True
Else
strTmp2 = "WBLP"
GoTo LOOP1
End If

If checkR8(Trim(CStr(excelsheet.Cells(i2, 12)))) = 1 Then GoTo LOOP1

' 1 2 3 4 5 6 7 8 9
strSQL = "INSERT INTO APTmp ( OrderType, CreateDate, GIdate, ShipTo, Route, OriginDoc, DeliveryNum, LOCATION, HAWB ) "
' strSQL = strSQL + "VALUES('" + Trim(CStr(excelsheet.Cells(i2, 1))) + "'," 2012-9-7 修改添加WBLP條款
strSQL = strSQL + "VALUES('" + strTmp2 + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 3))) + "',"
' strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 5))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 4))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 6))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 7))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 8))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 10))) + "', "
' If checkRoute(Trim(CStr(excelsheet.Cells(i2, 5)))) = False Then
' strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 8))) + "') "
' Else
' strSQL = strSQL + "'" + addR8TSHAWB + "')"
'
' End If
' strSQL = strSQL + "'" + strTmp1 + "'" + ") "
' If Trim(CStr(excelsheet.Cells(i2, 9))) = "" Then
strSQL = strSQL + "'" + "R811" + "', "
' Else
' strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 9))) + "', "
' End If
If boolTmp1 = True Then
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 12))) + "') "
boolTmp1 = False
Else
strSQL = strSQL + "'" + addR8TSHAWB + "')"
boolTmp1 = False
GoTo LOOP1
End If
Debug.Print strSQL
DoCmd.RunSQL strSQL
LOOP1:
strTmp2 = ""
boolTmp1 = False
End If
Next i2
Call ImportTAPData
End Sub

 

Private Sub Command3_Click()
On Error GoTo err1
Dim i As Long
Dim j As Long
Dim objExl As Excel.Application '聲明對象變量
Me.MousePointer = 11 '改變鼠標樣式
Set objExl = New Excel.Application '初始化對象變量
objExl.SheetsInNewWorkbook = 1 '將新建的工作薄數量設為1
objExl.Workbooks.Add '增加一個工作薄
objExl.Sheets(objExl.Sheets.Count).Name = "book1" '修改工作薄名稱
objExl.Sheets.Add , objExl.Sheets("book1") '增加第二個工作薄在第一個之后
objExl.Sheets(objExl.Sheets.Count).Name = "book2"
objExl.Sheets.Add , objExl.Sheets("book2") '增加第三個工作薄在第二個之后
objExl.Sheets(objExl.Sheets.Count).Name = "book3"
objExl.Sheets("book1").Select '選中工作薄<book1>
For i = 1 To 50 '循環寫入數據
For j = 1 To 5
If i = 1 Then
objExl.Selection.NumberFormatLocal = "@" '設置格式為文本
objExl.Cells(i, j) = " E " & i & j
Else
objExl.Cells(i, j) = i & j
End If
Next
Next
objExl.Rows("1:1").Select '選中第一行
objExl.Selection.Font.Bold = True '設為粗體
objExl.Selection.Font.Size = 24 '設置字體大小
objExl.Cells.EntireColumn.AutoFit '自動調整列寬
objExl.ActiveWindow.SplitRow = 1 '拆分第一行
objExl.ActiveWindow.SplitColumn = 0 '拆分列
objExl.ActiveWindow.FreezePanes = True '固定拆分
objExl.ActiveSheet.PageSetup.PrintTitleRows = "$1:$1" '設置打印固定行
objExl.ActiveSheet.PageSetup.PrintTitleColumns = "" '打印標題
objExl.ActiveSheet.PageSetup.RightFooter = "打印時間: " & _
Format(Now, "yyyy年mm月dd日 hh:MM:ss")
objExl.ActiveWindow.View = xlPageBreakPreview '設置顯示方式
objExl.ActiveWindow.Zoom = 100 '設置顯示大小
'給工作表加密碼
objExl.ActiveSheet.Protect "123", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
objExl.Application.IgnoreRemoteRequests = False
objExl.Visible = True '使EXCEL可見
objExl.Application.WindowState = xlMaximized 'EXCEL的顯示方式為最大化
objExl.ActiveWindow.WindowState = xlMaximized '工作薄顯示方式為最大化
objExl.SheetsInNewWorkbook = 3 '將默認新工作薄數量改回3個
Set objExl = Nothing '清除對象
Me.MousePointer = 0 '修改鼠標
Exit Sub

err1:
objExl.SheetsInNewWorkbook = 3
objExl.DisplayAlerts = False '關閉時不提示保存
objExl.Quit '關閉EXCEL
objExl.DisplayAlerts = True '關閉時提示保存
Set objExl = Nothing
Me.MousePointer = 0
End Sub

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
全面控制 Excel

首先創建 Excel 對象，使用ComObj:
Dim ExcelID as Excel.Application
Set ExcelID as new Excel.Application

1) 顯示當前窗口：ExcelID.Visible := True;

2) 更改 Excel 標題欄：ExcelID.Caption := '應用程序調用 Microsoft Excel';

3) 添加新工作簿：ExcelID.WorkBooks.Add;

4) 打開已存在的工作簿：ExcelID.WorkBooks.Open( 'C:\Excel\Demo.xls' );

5) 設置第2個工作表為活動工作表：ExcelID.WorkSheets[2].Activate;
或 ExcelID.WorkSheets[ 'Sheet2' ].Activate;

6) 給單元格賦值：ExcelID.Cells[1,4].Value := '第一行第四列';

7) 設置指定列的寬度（單位：字符個數），以第一列為例：
ExcelID.ActiveSheet.Columns[1].ColumnsWidth := 5;

8) 設置指定行的高度（單位：磅）（1磅＝0.035厘米），以第二行為例：
ExcelID.ActiveSheet.Rows[2].RowHeight := 1/0.035; // 1厘米

9) 在第8行之前插入分頁符：
ExcelID.WorkSheets[1].Rows[8].PageBreak := 1;

10) 在第8列之前刪除分頁符：
ExcelID.ActiveSheet.Columns[4].PageBreak := 0;

11) 指定邊框線寬度：
ExcelID.ActiveSheet.Range[ 'B3:D4' ].Borders[2].Weight := 3;
1-左 2-右 3-頂 4-底 5-斜( \ ) 6-斜( / )

12) 清除第一行第四列單元格公式：ExcelID.ActiveSheet.Cells[1,4].ClearContents;

13) 設置第一行字體屬性：
ExcelID.ActiveSheet.Rows[1].Font.Name := '隸書';
ExcelID.ActiveSheet.Rows[1].Font.Color := clBlue;
ExcelID.ActiveSheet.Rows[1].Font.Bold := True;
ExcelID.ActiveSheet.Rows[1].Font.UnderLine := True;

14) 進行頁面設置：
a.頁眉：ExcelID.ActiveSheet.PageSetup.CenterHeader := '報表演示';
b.頁腳：ExcelID.ActiveSheet.PageSetup.CenterFooter := '第&P頁';
c.頁眉到頂端邊距2cm：ExcelID.ActiveSheet.PageSetup.HeaderMargin := 2/0.035;
d.頁腳到底端邊距3cm：ExcelID.ActiveSheet.PageSetup.HeaderMargin := 3/0.035;
e.頂邊距2cm：ExcelID.ActiveSheet.PageSetup.TopMargin := 2/0.035;
f.底邊距2cm：ExcelID.ActiveSheet.PageSetup.BottomMargin := 2/0.035;
g.左邊距2cm：ExcelID.ActiveSheet.PageSetup.LeftMargin := 2/0.035;
h.右邊距2cm：ExcelID.ActiveSheet.PageSetup.RightMargin := 2/0.035;
i.頁面水平居中：ExcelID.ActiveSheet.PageSetup.CenterHorizontally := 2/0.035;
j.頁面垂直居中：ExcelID.ActiveSheet.PageSetup.CenterVertically := 2/0.035;
k.打印單元格網線：ExcelID.ActiveSheet.PageSetup.PrintGridLines := True;

15) 拷貝操作：
a.拷貝整個工作表：ExcelID.ActiveSheet.Used.Range.Copy;
b.拷貝指定區域：ExcelID.ActiveSheet.Range[ 'A1:E2' ].Copy;
c.從A1位置開始粘貼：ExcelID.ActiveSheet.Range.[ 'A1' ].PasteSpecial;
d.從文件尾部開始粘貼：ExcelID.ActiveSheet.Range.PasteSpecial;

16) 插入一行或一列：
a. ExcelID.ActiveSheet.Rows[2].Insert;
b. ExcelID.ActiveSheet.Columns[1].Insert;

17) 刪除一行或一列：
a. ExcelID.ActiveSheet.Rows[2].Delete;
b. ExcelID.ActiveSheet.Columns[1].Delete;

18) 打印預覽工作表：
ExcelID.ActiveSheet.PrintPreview;

19) 打印輸出工作表：
ExcelID.ActiveSheet.PrintOut;

20) 工作表保存：
If not ExcelID.ActiveWorkBook.Saved then
ExcelID.ActiveSheet.PrintPreview
　 End if

21) 工作表另存為：
ExcelID.SaveAs( 'C:\Excel\Demo1.xls' );

22) 放棄存盤：
ExcelID.ActiveWorkBook.Saved := True;

23) 關閉工作簿：
ExcelID.WorkBooks.Close;

24) 退出 Excel：ExcelID.Quit;

25) 設置工作表密碼:
ExcelID.ActiveSheet.Protect "123", DrawingObjects:=True, Contents:=True, Scenarios:=True

26) EXCEL的顯示方式為最大化
ExcelID.Application.WindowState = xlMaximized

27) 工作薄顯示方式為最大化
ExcelID.ActiveWindow.WindowState = xlMaximized

28) 設置打開默認工作薄數量
ExcelID.SheetsInNewWorkbook = 3

29) '關閉時是否提示保存(true 保存；false 不保存)
ExcelID.DisplayAlerts = False

30) 設置拆分窗口,及固定行位置
ExcelID.ActiveWindow.SplitRow = 1
ExcelID.ActiveWindow.FreezePanes = True

31) 設置打印時固定打印內容
ExcelID.ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"

32) 設置打印標題
ExcelID.ActiveSheet.PageSetup.PrintTitleColumns = ""

33) 設置顯示方式(分頁方式顯示)
ExcelID.ActiveWindow.View = xlPageBreakPreview

34) 設置顯示比例
ExcelID.ActiveWindow.Zoom = 100

35) 讓Excel 響應 DDE 請求
Ex.Application.IgnoreRemoteRequests = False

 

用VB操作Excel(VB6.0)(整理)
2008-09-23 22:16:30| 分類： 文章轉載 | 標簽：excel office |字號 訂閱
用VB操作Excel(VB6.0)(整理)
全面控制Excel:
首先創建Excel對象，使用ComObj:
Dim ExcelID as Excel.Application
Set ExcelID as new Excel.Application

1)顯示當前窗口：
ExcelID.Visible:=True;
2)更改Excel標題欄：
ExcelID.Caption:='應用程序調用MicrosoftExcel';
3)添加新工作簿：
ExcelID.WorkBooks.Add;
4)打開已存在的工作簿：
ExcelID.WorkBooks.Open('C:\Excel\Demo.xls');
5)設置第2個工作表為活動工作表：
ExcelID.WorkSheets[2].Activate;
或ExcelID.WorkSheets['Sheet2'].Activate;
6)給單元格賦值：
ExcelID.Cells[1,4].Value:='第一行第四列';
7)設置指定列的寬度（單位：字符個數），以第一列為例：
ExcelID.ActiveSheet.Columns[1].ColumnsWidth:=5;
8)設置指定行的高度（單位：磅）（1磅＝0.035厘米），以第二行為例：
ExcelID.ActiveSheet.Rows[2].RowHeight:=1/0.035;//1厘米
9)在第8行之前插入分頁符：
ExcelID.WorkSheets[1].Rows[8].PageBreak:=1;
10)在第8列之前刪除分頁符：
ExcelID.ActiveSheet.Columns[4].PageBreak:=0;
11)指定邊框線寬度：
ExcelID.ActiveSheet.Range['B3:D4'].Borders[2].Weight:=3;
1-左 2-右 3-頂4-底 5-斜(\) 6-斜(/)
12)清除第一行第四列單元格公式：
ExcelID.ActiveSheet.Cells[1,4].ClearContents;
13)設置第一行字體屬性：
ExcelID.ActiveSheet.Rows[1].Font.Name:='隸書';
ExcelID.ActiveSheet.Rows[1].Font.Color :=clBlue;
ExcelID.ActiveSheet.Rows[1].Font.Bold :=True;
ExcelID.ActiveSheet.Rows[1].Font.UnderLine:=True;
14)進行頁面設置：
a.頁眉：
ExcelID.ActiveSheet.PageSetup.CenterHeader:='報表演示';
b.頁腳：
ExcelID.ActiveSheet.PageSetup.CenterFooter:='第&P頁';
c.頁眉到頂端邊距2cm：
ExcelID.ActiveSheet.PageSetup.HeaderMargin:=2/0.035;
d.頁腳到底端邊距3cm：
ExcelID.ActiveSheet.PageSetup.HeaderMargin:=3/0.035;
e.頂邊距2cm：
ExcelID.ActiveSheet.PageSetup.TopMargin:=2/0.035;
f.底邊距2cm：
ExcelID.ActiveSheet.PageSetup.BottomMargin:=2/0.035;
g.左邊距2cm：
ExcelID.ActiveSheet.PageSetup.LeftMargin:=2/0.035;
h.右邊距2cm：
ExcelID.ActiveSheet.PageSetup.RightMargin:=2/0.035;
i.頁面水平居中：
ExcelID.ActiveSheet.PageSetup.CenterHorizontally:=2/0.035;
j.頁面垂直居中：
ExcelID.ActiveSheet.PageSetup.CenterVertically:=2/0.035;
k.打印單元格網線：
ExcelID.ActiveSheet.PageSetup.PrintGridLines:=True;
15)拷貝操作：
a.拷貝整個工作表：
ExcelID.ActiveSheet.Used.Range.Copy;
b.拷貝指定區域：
ExcelID.ActiveSheet.Range['A1:E2'].Copy;
c.從A1位置開始粘貼：
ExcelID.ActiveSheet.Range.['A1'].PasteSpecial;
d.從文件尾部開始粘貼：
ExcelID.ActiveSheet.Range.PasteSpecial;
16)插入一行或一列：
a.ExcelID.ActiveSheet.Rows[2].Insert;
b.ExcelID.ActiveSheet.Columns[1].Insert;
17)刪除一行或一列：
a.ExcelID.ActiveSheet.Rows[2].Delete;
b.ExcelID.ActiveSheet.Columns[1].Delete;
18)打印預覽工作表：
ExcelID.ActiveSheet.PrintPreview;
19)打印輸出工作表：
ExcelID.ActiveSheet.PrintOut;
20)工作表保存：
IfnotExcelID.ActiveWorkBook.Savedthen
ExcelID.ActiveSheet.PrintPreview
Endif
21)工作表另存為：
ExcelID.SaveAs('C:\Excel\Demo1.xls');
22)放棄存盤：
ExcelID.ActiveWorkBook.Saved:=True;
23)關閉工作簿：
ExcelID.WorkBooks.Close;
24)退出Excel：
ExcelID.Quit;
25)設置工作表密碼:
ExcelID.ActiveSheet.Protect"123",DrawingObjects:=True,Contents:=True,Scenarios:=True
26)EXCEL的顯示方式為最大化
ExcelID.Application.WindowState=xlMaximized
27)工作薄顯示方式為最大化
ExcelID.ActiveWindow.WindowState=xlMaximized
28)設置打開默認工作薄數量
ExcelID.SheetsInNewWorkbook=3
29)'關閉時是否提示保存(true保存；false不保存)
ExcelID.DisplayAlerts=False
30)設置拆分窗口,及固定行位置
ExcelID.ActiveWindow.SplitRow=1
ExcelID.ActiveWindow.FreezePanes=True
31)設置打印時固定打印內容
ExcelID.ActiveSheet.PageSetup.PrintTitleRows="$1:$1"
32)設置打印標題
ExcelID.ActiveSheet.PageSetup.PrintTitleColumns=""
33)設置顯示方式(分頁方式顯示)
ExcelID.ActiveWindow.View=xlPageBreakPreview
34)設置顯示比例
ExcelID.ActiveWindow.Zoom=100
35)讓Excel響應DDE請求
Ex.Application.IgnoreRemoteRequests=False
用VB操作EXCEL示例代碼
Private Sub Command3_Click()
On Error GoTo err1
Dim i As Long
Dim j As Long
Dim objExl As Excel.Application '聲明對象變量
Me.MousePointer=11 '改變鼠標樣式
Set objExl=New Excel.Application'初始化對象變量
objExl.SheetsInNewWorkbook=1 '將新建的工作薄數量設為1
objExl.Workbooks.Add'增加一個工作薄
objExl.Sheets(objExl.Sheets.Count).Name="book1" '修改工作薄名稱
objExl.Sheets.Add,objExl.Sheets("book1")‘增加第二個工作薄在第一個之后
objExl.Sheets(objExl.Sheets.Count).Name="book2"
objExl.Sheets.Add,objExl.Sheets("book2")‘增加第三個工作薄在第二個之后
objExl.Sheets(objExl.Sheets.Count).Name="book3"

objExl.Sheets("book1").Select '選中工作薄<book1>
For i=1 To 50'循環寫入數據
For j=1 To 5
If i=1 Then
objExl.Selection.NumberFormatLocal="@" '設置格式為文本
objExl.Cells(i,j)="E"&i&j
Else
objExl.Cells(i,j)=i&j
EndIf
Next
Next
objExl.Rows("1:1").Select '選中第一行
objExl.Selection.Font.Bold=True '設為粗體
objExl.Selection.Font.Size=24 '設置字體大小
objExl.Cells.EntireColumn.AutoFit '自動調整列寬
objExl.ActiveWindow.SplitRow=1 '拆分第一行
objExl.ActiveWindow.SplitColumn=0 '拆分列
objExl.ActiveWindow.FreezePanes=True '固定拆分objExl.ActiveSheet.PageSetup.PrintTitleRows="$1:$1" '設置打印固定行
objExl.ActiveSheet.PageSetup.PrintTitleColumns=""'打印標題objExl.ActiveSheet.PageSetup.RightFooter="打印時間:"&_
Format(Now,"yyyy年mm月dd日hh:MM:ss")
objExl.ActiveWindow.View=xlPageBreakPreview'設置顯示方式
objExl.ActiveWindow.Zoom=100 '設置顯示大小
'給工作表加密碼
objExl.ActiveSheet.Protect"123",DrawingObjects:=True, _
Contents:=True,Scenarios:=True
objExl.Application.IgnoreRemoteRequests=False
objExl.Visible=True '使EXCEL可見
objExl.Application.WindowState=xlMaximized'EXCEL的顯示方式為最大化
objExl.ActiveWindow.WindowState=xlMaximized'工作薄顯示方式為最大化
objExl.SheetsInNewWorkbook=3 '將默認新工作薄數量改回3個
Set objExl=Nothing'清除對象
Me.MousePointer=0 '修改鼠標
ExitSub
err1:
objExl.SheetsInNewWorkbook=3

objExl.DisplayAlerts=False '關閉時不提示保存
objExl.Quit'關閉EXCEL
objExl.DisplayAlerts=True '關閉時提示保存
Set objExl=Nothing
Me.MousePointer=0
End Sub
如何實現VB與EXCEL的無縫連接

 

Dim xlApp As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet

Private Sub Command1_Click()
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add

Dim strDate As String, strName As String, strValue As String
strDate = CStr(Format(Date, "yyyy-mm-dd"))
Me.CommonDialog1.DefaultExt = "xls"
Me.CommonDialog1.FileName = "SEND3B2" + strDate + ".xls"
Me.CommonDialog1.Filter = "EXCEL FILE(*.xls)|*.xls"
Me.CommonDialog1.ShowSave

strName = Me.CommonDialog1.FileName
Debug.Print strName
xlBook.SaveAs strName
Set xlBook = xlApp.Workbooks.Open(strName)
Set xlSheet = xlBook.Worksheets(1)
' For i1 = 0 To Me.DataGrid1.Columns.Count - 1
' xlSheet.Cells(1, i1 + 1) = Me.DataGrid1.Columns.Item(j).Caption
' Next i1
With xlSheet
.Range("A1").Value = "ORDERKEY"
.Range("B1").Value = "EXTERNORDERKEY"
.Range("C1").Value = "MM"
.Range("D1").Value = "QTY"
.Range("E1").Value = "PRODUCTDESP"
.Range("F1").Value = "DIVISION"
.Range("G1").Value = "MOQ"
.Range("H1").Value = "OVERPACKQTY"
.Range("I1").Value = "OVERPACK ?"
.Range("J1").Value = "CTNQTY"
.Range("K1").Value = "OPCTNQTY"
.Range("L1").Value = "CTN_PALLET"
.Range("M1").Value = "PALLETNO"
.Range("N1").Value = "PALLETWEIGHT"
.Range("O1").Value = "PALLETVOLUME"
.Range("P1").Value = "PALLETLENGTH"
.Range("Q1").Value = "PALLETWIDTH"
.Range("R1").Value = "PALLETHIGH"
.Range("S1").Value = "DELIVERYDATE"
.Range("T1").Value = "CONSIGNEEKEY"
.Range("U1").Value = "C_COUNTRY"
.Range("V1").Value = "BILLTOKEY"
.Range("W1").Value = "INCOTERM"
.Range("X1").Value = "STATUS"
.Range("Y1").Value = "INTERMODALVEHICLE"
.Range("Z1").Value = "ORDERGROUP"
.Range("AA1").Value = "HAWB"
.Range("AB1").Value = "REQSHIPDATE"
.Range("AC1").Value = "RELEASEDDATE"
.Range("AD1").Value = "C_COMPANY"
End With
If Me.Adodc1.Recordset.RecordCount <> 0 Then
Me.Adodc1.Recordset.MoveFirst
For i1 = 1 To Me.Adodc1.Recordset.RecordCount
For i2 = 1 To Me.Adodc1.Recordset.Fields.Count
If IsNull(Me.Adodc1.Recordset.Fields(i2 - 1)) Then
strValue = " "
Else
strValue = Me.Adodc1.Recordset.Fields(i2 - 1).Value ': Debug.Print strValue
End If
xlSheet.Cells(i1 + 1, i2) = strValue
Next i2
Me.Adodc1.Recordset.MoveNext
Next i1
Me.Adodc1.Recordset.MoveFirst
Else
MsgBox "請先查詢數據", vbCritical, "錯誤"
End If

xlBook.Save

xlBook.Close
Set xlSheet = Nothing
Set xlBook = Nothing
' xlApp.Visible = True
xlApp.Quit
Set xlApp = Nothing
End Sub
Private Sub Command1_Click()
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add

Dim strDate As String, strName As String, strValue As String
strDate = CStr(Format(Date, "yyyy-mm-dd"))
Me.CommonDialog1.DefaultExt = "xls"
Me.CommonDialog1.FileName = "SEND3B2" + strDate + ".xls"
Me.CommonDialog1.Filter = "EXCEL FILE(*.xls)|*.xls"
Me.CommonDialog1.ShowSave

strName = Me.CommonDialog1.FileName
Debug.Print strName
xlBook.SaveAs strName
Set xlBook = xlApp.Workbooks.Open(strName)
Set xlSheet = xlBook.Worksheets(1)
' For i1 = 0 To Me.DataGrid1.Columns.Count - 1
' xlSheet.Cells(1, i1 + 1) = Me.DataGrid1.Columns.Item(j).Caption
' Next i1
With xlSheet
.Range("A1").Value = "ORDERKEY"
.Range("B1").Value = "EXTERNORDERKEY"
.Range("C1").Value = "MM"
.Range("D1").Value = "QTY"
.Range("E1").Value = "PRODUCTDESP"
.Range("F1").Value = "DIVISION"
.Range("G1").Value = "MOQ"
.Range("H1").Value = "OVERPACKQTY"
.Range("I1").Value = "OVERPACK ?"
.Range("J1").Value = "CTNQTY"
.Range("K1").Value = "OPCTNQTY"
.Range("L1").Value = "CTN_PALLET"
.Range("M1").Value = "PALLETNO"
.Range("N1").Value = "PALLETWEIGHT"
.Range("O1").Value = "PALLETVOLUME"
.Range("P1").Value = "PALLETLENGTH"
.Range("Q1").Value = "PALLETWIDTH"
.Range("R1").Value = "PALLETHIGH"
.Range("S1").Value = "DELIVERYDATE"
.Range("T1").Value = "CONSIGNEEKEY"
.Range("U1").Value = "C_COUNTRY"
.Range("V1").Value = "BILLTOKEY"
.Range("W1").Value = "INCOTERM"
.Range("X1").Value = "STATUS"
.Range("Y1").Value = "INTERMODALVEHICLE"
.Range("Z1").Value = "ORDERGROUP"
.Range("AA1").Value = "HAWB"
.Range("AB1").Value = "REQSHIPDATE"
.Range("AC1").Value = "RELEASEDDATE"
.Range("AD1").Value = "C_COMPANY"
End With
If Me.Adodc1.Recordset.RecordCount <> 0 Then
Me.Adodc1.Recordset.MoveFirst
For i1 = 1 To Me.Adodc1.Recordset.RecordCount
For i2 = 1 To Me.Adodc1.Recordset.Fields.Count
If IsNull(Me.Adodc1.Recordset.Fields(i2 - 1)) Then
strValue = " "
Else
strValue = Me.Adodc1.Recordset.Fields(i2 - 1).Value ': Debug.Print strValue
End If
xlSheet.Cells(i1 + 1, i2) = strValue
Next i2
Me.Adodc1.Recordset.MoveNext
Next i1
Me.Adodc1.Recordset.MoveFirst
Else
MsgBox "請先查詢數據", vbCritical, "錯誤"
End If

xlBook.Save

xlBook.Close
Set xlSheet = Nothing
Set xlBook = Nothing
' xlApp.Visible = True
xlApp.Quit
Set xlApp = Nothing
End Sub

Sub test1()
'
Dim xlApp As New Excel.Application
Dim ExcelID As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim strName As String

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add

Set ExcelID = New Excel.Application

strName = CurrentProject.Path + "\aaa.xls"
Debug.Print strName
xlBook.SaveAs strName

Set xlBook = xlApp.Workbooks.Open(strName)
Set xlSheet = xlBook.Worksheets(1)

xlSheet.Range("A1").Value = "abcdefg"
xlSheet.Range("A2").Value = "abcdefg2"
xlSheet.Cells(2, 2).Value = "bbbb"
' xlApp.Workbooks [1].Activate
xlApp.ActiveSheet.Rows(2).Insert
' ExcelID.Workbooks(1).Activate
' ExcelID.ActiveSheet.Rows(2).Insert
' xlSheet.Rows [2].Insert

xlApp.Visible = True
xlBook.Save
xlBook.Close

Set xlSheet = Nothing
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
Debug.Print "ok"

End Sub

Dim excelfile As Excel.Application, excelwbook As Excel.Workbook, excelsheet As Excel.Worksheet
Dim lastCol As Long, lastRow As Long
Dim strFile As String

Private Sub importExcelDate()
'
On Error GoTo Err_importExcelDate
Dim result As Integer

With Me.Application.FileDialog(msoFileDialogFilePicker)
.Title = "請選擇EXCEL文件"
.Filters.Add "EXCEL2000-2003", "*.xls"
.Filters.Add "EXCEL2007-2010", "*.xlsx"
.FilterIndex = 1
.AllowMultiSelect = False
result = .Show
If result <> 0 Then
strFile = Trim(.SelectedItems.Item(1))
Else
MsgBox "沒有選擇文件", vbCritical, "提示"
Exit Sub
End If
End With
Debug.Print strFile

Set excelfile = New Excel.Application
Set excelwbook = excelfile.Workbooks.Open(strFile)
Set excelsheet = excelwbook.Sheets(1)

lastCol = excelsheet.UsedRange.Columns.Count
lastRow = excelsheet.UsedRange.Rows.Count
Debug.Print lastCol: Debug.Print lastRow

Debug.Print excelsheet.Cells(1, 1)

Call importALLDate

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing
MsgBox "導入完成", vbOKOnly, "完成"
Exit Sub
Err_importExcelDate:
Debug.Print Err.Description
End Sub

Private Sub ImportExcelData()
'
On Error GoTo Err_ImportExcelData
' Dim strFile As String
Dim strB1() As String, intTmp1 As Integer

DoCmd.RunSQL "DELETE * FROM APTmp "
Me.CommonDialog8.CancelError = True

Me.CommonDialog8.ShowOpen
strFile = Me.CommonDialog8.Filename
If Me.CommonDialog8.Filename = "" Then
Exit Sub
End If


Debug.Print strFile
If strFile = "" Then
MsgBox "沒有選擇文件", vbCritical, "錯誤"
Exit Sub
End If

Set excelfile = New Excel.Application
Set excelwbook = excelfile.Workbooks.Open(strFile)
Set excelsheet = excelwbook.Sheets(1)

lastCol = excelsheet.UsedRange.Columns.Count
lastRow = excelsheet.UsedRange.Rows.Count
Debug.Print lastCol
Debug.Print lastRow

Debug.Print excelsheet.Cells(1, 1)


strB1 = Split(strFile, "\")
intTmp1 = UBound(strB1)
strFile = strB1(intTmp1)
Debug.Print strFile

' If checkFileName(strFile) = True Then
' MsgBox "此文件名已經導入過,不可再導入", vbCritical, "錯誤"
' Exit Sub
' End If


Call ImportAPData(strFile)
strFile = SetstrFile

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing

Exit_ImportExcelData:
Exit Sub
Err_ImportExcelData:
' MsgBox Err.Description
Resume Exit_ImportExcelData
End Sub

Private Sub ImportAPData(strTmp1 As String)
'
Dim i2 As Long

For i2 = 2 To lastRow
Debug.Print excelsheet.Cells(i2, 7)
If checkDN(Trim(CStr(excelsheet.Cells(i2, 7))), "APT") = True Then
' 1 2 3 4 5 6 7 8
strSQL = "INSERT INTO APTmp ( OrderType, CreateDate, GIdate, ShipTo, Route, OriginDoc, DeliveryNum, HAWB ) "
' strSQL = strSQL + "VALUES('" + Trim(CStr(excelsheet.Cells(i2, 1))) + "',"
strSQL = strSQL + "VALUES('" + Trim("CIP") + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 2))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 3))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 4))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 5))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 6))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 7))) + "', "
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 8))) + "') "
' strSQL = strSQL + "'" + strTmp1 + "'" + ") "
Debug.Print strSQL
DoCmd.RunSQL strSQL
End If
Next i2
Call ImportTAPData
End Sub

Private Sub Command10_Click() '導入分單
On Error GoTo Err_Command10_Click
Dim strFile As String

Me.CommonDialog8.ShowOpen
strFile = Me.CommonDialog8.Filename

Debug.Print strFile
If strFile = "" Then
MsgBox "沒有選擇文件", vbCritical, "錯誤"
Exit Sub
End If

Set excelfile = New Excel.Application
Set excelwbook = excelfile.Workbooks.Open(strFile)
Set excelsheet = excelwbook.Sheets(1)

lastCol = excelsheet.UsedRange.Columns.Count
lastRow = excelsheet.UsedRange.Rows.Count

Debug.Print lastCol
Debug.Print lastRow

Debug.Print excelsheet.Cells(1, 1)

If ImportHAWBData = False Then
MsgBox "導入未成功，請檢查文件中有沒有重復的DN", vbCritical, "提示"
' Exit Sub
End If

Call updateHAWB

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing

Exit_Command10_Click:
Exit Sub

Err_Command10_Click:
MsgBox Err.Description
Resume Exit_Command10_Click

End Sub

Public Function ImportHAWBData() As Boolean
'
On Error GoTo Err_ImportHAWBData
Dim i7 As Long
Dim rst1 As DAO.Recordset

strSQL = "SELECT HAWBTmp.DN, HAWBTmp.HAWB, HAWBTmp.ISIMPORT "
strSQL = strSQL + "FROM HAWBTmp; "
Debug.Print strSQL

Set rst1 = CurrentDb.OpenRecordset(strSQL)

For i7 = 2 To lastRow
Debug.Print excelsheet.Cells(i7, 1)
If excelsheet.Cells(i7, 1) <> "" And excelsheet.Cells(i7, 2) <> "" Then
If checkDN(Trim(CStr(excelsheet.Cells(i7, 1)))) = True Then
rst1.AddNew
rst1.Fields(0) = Trim(CStr(excelsheet.Cells(i7, 1)))
rst1.Fields(1) = Trim(CStr(excelsheet.Cells(i7, 2)))
rst1.Update
End If
End If
Next i7
ImportHAWBData = True
Exit Function
Err_ImportHAWBData:
MsgBox Err.Description
ImportHAWBData = False
End Function

Private Sub ImportExcelData()
'
On Error GoTo Err_ImportExcelData
Dim strFile As String
Dim strB1() As String, intTmp1 As Integer

DoCmd.RunSQL "DELETE * FROM APTmp "
Me.CommonDialog8.ShowOpen
strFile = Me.CommonDialog8.Filename

Debug.Print strFile
If strFile = "" Then
MsgBox "沒有選擇文件", vbCritical, "錯誤"
Exit Sub
End If

Set excelfile = New Excel.Application
Set excelwbook = excelfile.Workbooks.Open(strFile)
Set excelsheet = excelwbook.Sheets(1)

lastCol = excelsheet.UsedRange.Columns.Count
lastRow = excelsheet.UsedRange.Rows.Count
Debug.Print lastCol
Debug.Print lastRow

Debug.Print excelsheet.Cells(1, 1)


strB1 = Split(strFile, "\")
intTmp1 = UBound(strB1)
strFile = strB1(intTmp1)
Debug.Print strFile

' If checkFileName(strFile) = True Then
' MsgBox "此文件名已經導入過,不可再導入", vbCritical, "錯誤"
' Exit Sub
' End If


Call ImportAPData(strFile)

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing

Exit_ImportExcelData:
Exit Sub
Err_ImportExcelData:
MsgBox Err.Description
Resume Exit_ImportExcelData
End Sub

Private Sub ImportAPData(strTmp1 As String)
'
Dim i2 As Long

For i2 = 2 To lastRow
Debug.Print excelsheet.Cells(i2, 7)
If checkDN(Trim(CStr(excelsheet.Cells(i2, 7))), "APT") = True Then
'----2012/7/25--更新添加R8TS的規則，其規則為當ROUTE字段為CMBLP1時自動添加時間戳為分單號
' 1 2 3 4 5 6 7 8
strSQL = "INSERT INTO APTmp ( OrderType, CreateDate, GIdate, ShipTo, Route, OriginDoc, DeliveryNum, HAWB ) "
strSQL = strSQL + "VALUES('" + Trim(CStr(excelsheet.Cells(i2, 1))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 2))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 3))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 4))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 5))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 6))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 7))) + "', "
If checkRoute(Trim(CStr(excelsheet.Cells(i2, 5)))) = False Then
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 8))) + "') "
Else
strSQL = strSQL + "'" + addR8TSHAWB + "')"
End If
' strSQL = strSQL + "'" + strTmp1 + "'" + ") "
Debug.Print strSQL
DoCmd.RunSQL strSQL
End If
Next i2
Call ImportTAPData
End Sub

Private Sub ImportExcelFile()
'
Me.CommonDialog2.CancelError = True
Me.CommonDialog2.ShowOpen
strFile = Me.CommonDialog2.Filename
If Me.CommonDialog2.Filename = "" Then
Exit Sub
End If

Debug.Print strFile
If strFile = "" Then
MsgBox "沒有選擇文件", vbCritical, "錯誤"
End If

Set excelfile = New Excel.Application
Set excelwbook = excelfile.Workbooks.Open(strFile)
Set excelsheet = excelwbook.Sheets(1)

lastCol = excelsheet.UsedRange.Columns.Count
lastRow = excelsheet.UsedRange.Rows.Count
Debug.Print lastCol
Debug.Print lastRow

Call importHEADFile

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing

End Sub

Private Sub Command10_Click() '導入分單
On Error GoTo Err_Command10_Click
Dim strFile As String

Me.CommonDialog8.ShowOpen
strFile = Me.CommonDialog8.Filename

Debug.Print strFile
If strFile = "" Then
MsgBox "沒有選擇文件", vbCritical, "錯誤"
Exit Sub
End If

Set excelfile = New Excel.Application
Set excelwbook = excelfile.Workbooks.Open(strFile)
Set excelsheet = excelwbook.Sheets(1)

lastCol = excelsheet.UsedRange.Columns.Count
lastRow = excelsheet.UsedRange.Rows.Count

Debug.Print lastCol
Debug.Print lastRow

Debug.Print excelsheet.Cells(1, 1)

If ImportHAWBData = False Then
MsgBox "導入未成功，請檢查文件中有沒有重復的DN", vbCritical, "提示"
' Exit Sub
End If

Call updateHAWB

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing

Exit_Command10_Click:
Exit Sub

Err_Command10_Click:
MsgBox Err.Description
Resume Exit_Command10_Click

End Sub

Public Function ImportHAWBData() As Boolean
'
On Error GoTo Err_ImportHAWBData
Dim i7 As Long
Dim rst1 As DAO.Recordset

strSQL = "SELECT HAWBTmp.DN, HAWBTmp.HAWB, HAWBTmp.ISIMPORT "
strSQL = strSQL + "FROM HAWBTmp; "
Debug.Print strSQL

Set rst1 = CurrentDb.OpenRecordset(strSQL)

For i7 = 2 To lastRow
Debug.Print excelsheet.Cells(i7, 1)
If excelsheet.Cells(i7, 1) <> "" And excelsheet.Cells(i7, 2) <> "" Then
If checkDN(Trim(CStr(excelsheet.Cells(i7, 1)))) = True Then
rst1.AddNew
rst1.Fields(0) = Trim(CStr(excelsheet.Cells(i7, 1)))
rst1.Fields(1) = Trim(CStr(excelsheet.Cells(i7, 2)))
rst1.Update
End If
End If
Next i7
ImportHAWBData = True
Exit Function
Err_ImportHAWBData:
MsgBox Err.Description
ImportHAWBData = False
End Function

 

Private Sub ImportExcelData()
'
Dim strFile As String
Dim strB1() As String
Dim intTmp1 As Integer

' DoCmd.RunSQL "DELETE * FROM APTmp "
Me.CommonDialog5.ShowOpen
strFile = Me.CommonDialog5.Filename

Debug.Print strFile
If strFile = "" Then
MsgBox "沒有選擇文件", vbCritical, "錯誤"
Exit Sub
End If

Set excelfile = New Excel.Application
Set excelwbook = excelfile.Workbooks.Open(strFile)
Set excelsheet = excelwbook.Sheets(1)

lastCol = excelsheet.UsedRange.Columns.Count
lastRow = excelsheet.UsedRange.Rows.Count
Debug.Print lastCol
Debug.Print lastRow

Debug.Print excelsheet.Cells(1, 1)

strB1 = Split(strFile, "\")
intTmp1 = UBound(strB1)
strFile = strB1(intTmp1)
Debug.Print strFile

Call ImportItemData(strFile)

Call updateDN

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing
Me.Child2.Requery
End Sub
' strB1 = Split(strFile, "\")
' intTmp1 = UBound(strB1)
' strFile = strB1(intTmp1)
' Debug.Print strFile
Private Sub ImportItemData(strTmp1 As String)
'
Dim i2 As Long
For i2 = 2 To lastRow
Debug.Print excelsheet.Cells(i2, 1)
strSQL = "INSERT INTO ITEM ( DNNo, Item, Material, Route, Refdoc, DlvQty, SU, AcGIDate, QTY, IFN ) "
strSQL = strSQL + "VALUES('" + Trim(CStr(excelsheet.Cells(i2, 1))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 2))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 6))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 8))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 9))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 13))) + "',"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 14))) + "',"
strSQL = strSQL + "#" + Trim(CStr(excelsheet.Cells(i2, 15))) + "#,"
strSQL = strSQL + "'" + Trim(CStr(excelsheet.Cells(i2, 17))) + "',"
strSQL = strSQL + "'" + strTmp1 + "' "
strSQL = strSQL + "); "
Debug.Print strSQL
DoCmd.RunSQL strSQL
Next i2
End Sub