VBnet操做Excel的代码

VBnet操做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)
End Sub
Dim xlApp As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim 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,A
E1,AF1,AG1,AH1,AI1,AJ1,AK1,AL1,AM1,AN1,AO1,AP1,A
Q1,AR1,AS1,AT1,AU1,AV1,AW1,AX1,AY1,AZ1,BA1,BB1,B
C1,BD1,BE1,BF1,BG1,BH1,BI1,BJ1,BK1,BL1,BM1,BN1,B
O1,BP1,BQ1,BR1,BS1,BT1,BU1,BV1,BW1,BX1,BY1,BZ1,C
A1,CB1,CC1,CD1,CE1,CF1,CG1,CH1,CI1,CJ1,CK1,CL1,C
M1,CN1,CO1,CP1,CQ1,CR1,CS1,CT1,CU1,CV1,CW1,CX1,C
Y1,CZ1"
strA1 = Split(strTmp1, ",")
Set xlApp = CreateObject("Excel.Application") xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
strDATE = CStr(Format(Date, "YYYY-MM-DD"))
monDialog1.DefaultExt = "xls"
monDialog1.Filename = "帐单输出" +
strDATE + ".xls"
monDialog1.Filter = "EXCEL FILE(*.xls)|*.xls"
monDialog1.ShowSave
strName = monDialog1.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 = 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"))
monDialog1.DefaultExt = "xls"
monDialog1.FileName = "SEND3B2" + strDate + ".xls"
monDialog1.Filter = "EXCEL FILE(*.xls)|*.xls"
monDialog1.ShowSave
strName = monDialog1.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].We ight:=3;
1-左 2-右 3-顶4-底 5-斜(\) 6-斜(/)
12)清除第一行第四列单元格公式：
ExcelID.ActiveSheet.Cells[1,4].ClearContents; 13)设置第一行字体属性：
ExcelID.ActiveSheet.Rows[1]:='隶书'; 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.03 5;
h.右边距2cm：
ExcelID.ActiveSheet.PageSetup.RightMargin:=2/0.0 35;
i.页面水平居中：
ExcelID.ActiveSheet.PageSetup.CenterHorizontally :=2/0.035;
j.页面垂直居中：
ExcelID.ActiveSheet.PageSetup.CenterVertically:= 2/0.035;
k.打印单元格网线：
ExcelID.ActiveSheet.PageSetup.PrintGridLines:=Tr
ue;
15)拷贝操作：
a.拷贝整个工作表：
ed.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 "
monDialog8.ShowOpen
strFile = monDialog8.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 = edRange.Columns.Count lastRow = edRange.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] := '隶书'; 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.拷贝整个工作表：ed.Range.Copy;
b.拷贝指定区域：ExcelID.ActiveSheet.Range[ 'A1:E2' ].Copy;
c.从A1位置开始粘贴：ExcelID.ActiveSheet.Range.[ 'A1' ].PasteSpecial;
d.从文件尾部开始粘贴：ExcelID.ActiveSheet.Rang
e.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].We ight:=3;
1-左 2-右 3-顶4-底 5-斜(\) 6-斜(/)
12)清除第一行第四列单元格公式：
ExcelID.ActiveSheet.Cells[1,4].ClearContents;
13)设置第一行字体属性：
ExcelID.ActiveSheet.Rows[1]:='隶书';
ExcelID.ActiveSheet.Rows[1].Font.Color :=clBlue
;
ExcelID.ActiveSheet.Rows[1].Font.Bold :=True;
ExcelID.ActiveSheet.Rows[1].Font.UnderLine:=True
;。