http://www.csdn.net/develop/author/netauthor/lihonggen0/VB千里行－操作Word与Excel 关键字: vb 贴文时间 2001-3-30 1:36:47 文章类型: 转贴 给贴子投票 hktl 转贴 出处: http://www.chinabyte.com/builder/detail.shtm?buiid=870&parid=1&cate=GJBC 本文将告诉你如何使用VB代码连接Office应用程序，并简要接触一下在文件中输入数据的方法。实际上，在VB中用代码与Word和Excel进行会话并控制它们，是可行的。但是请注意，首先需要在机器上安装office应用程序，才能在VB代码中存取它们的对象。 下面就是一些例子，告诉你如何与这些程序会话，并控制它们。 Option Explicit Dim xlsApp As Excel.Application Dim wrdApp As Word.Application 只要相关的对象库已经被选择，在应用程序中进行对象变量的赋值是可能的。Microsoft Excel 8.0对象库是相对于Excel的，而 Microsoft Word 8.0 对象库是为Word服务的。 在VB的IDE环境中，从“工程”菜单中选择“引用”，可以看到系统可用的所有库列表。Private Sub Command1_Click() Set xlsApp = Excel.Application With xlsApp 'Show Excel .Visible = True 'Create a new workbook .Workbooks.Add 'Put text in to the cell that is selected .ActiveCell.Value = "Hi" 'Put text into A3 regardless of the selected cell .Range("A3").Value = "This is an example of connecting to Excel" End With End Sub 在上面的程序段中，我们在变量xlsApp中建立了一个对象，这样Excel就对用户可见了。当Excel象这样启动后，并不包含一个工作簿，所以必须创建或者执行打开操作。这里，我们建立了一个新的工作簿，然后，就可以操作其中的信息，或者打印，或者保存，或者你任意想做的事情。Private Sub Command2_Click() 'close the workbook xlsApp.Workbooks.Close 'Close Excel xlsApp.Quit End Sub 上面这段代码执行关闭程序的功能。首先，关闭工作簿，这将出现一个提示对话框，询问用户是否想保存修改；然后，退出应用程序。Private Sub Command3_Click() Set wrdApp = New Word.Application With wrdApp 'Show Word .Visible = True 'Create New Document .Documents.Add 'Add text to the document .ActiveDocument.Content.Text = "Hi" .ActiveDocument.Content.Text = "This is a test example" End With End Sub 上面这段代码中，在变量wrdApp中设置引用Word程序的对象。同样，当Word按照这种方式启动后，不会包含一个文档，所以，必须执行建立或者打开操作。这里是建立了一个新文档，然后可以操作其中的信息了，打印、保存、发送邮件，等等... 但是，在Word文档中放置文本并非容易！特别是与Excel一起工作时。为了简单地在特定的地方放置文本，需要有一个book标记。这意味着，需要事先建立一个模板。Private Sub Command4_Click() 'Close the current document wrdApp.ActiveDocument.Close 'Close Word wrdApp.Quit End Sub 上面这段代码的功能是关闭应用程序。首先，关闭当前文档，这时可能需要用户保存修改。然后，退出程序。Private Sub Form_Unload(Cancel As Integer) 'Clear the memory Set xlsApp = Nothing Set wrdApp = Nothing End Sub 最后一段代码就是关闭VB应用程序。这是优秀程序员编程的好习惯。 Well I hope this brief tutorial is helpful. It does not touch on much of what you can do to the office applications once they're open, but should give you an idea of how to get started. 好了，简单的介绍到此结束。我希望能抛砖引玉，让你更加随意地操作Office应用程序！
在用vb做程序的时候,它本身的报表并不太好使用,因此应用excel输出数据,是一个好方法,以下是一组操纵excel的函数据,希望能帮助大家.'excel vba控制函数'write by weihua 2000.10.12 '检测文件 function checkfile(byval strfile as string) as boolean dim filexls as object set filexls = createobject("scripting.filesystemobject") if isnull(strfile) or strfile = "" then checkfile = false
exit function end if if filexls.fileexists(strfile) = false then
checkfile = false set filexls = nothing exit function else
checkfile = true set filexls = nothing end if
end function '检测工作表 function checksheet(byval strsheet as string, byval strworkbook as string, xlcheckapp as excel.application) as boolean dim l as integer dim checkworkbook as excel.workbookif checkfile(strworkbook) and strsheet <> "" and not isnull(strsheet) then for l = 1 to xlcheckapp.workbooks.count if getpath(xlcheckapp.workbooks(l).path) & xlcheckapp.workbooks(l).name = strworkbook then set checkworkbook = xlcheckapp.workbooks(l) exit for end if next l
set checkworkbook = xlcheckapp.workbooks.open(strworkbook) for l = 1 to checkworkbook.worksheets.count if checkworkbook.worksheets(l).name = trim(strsheet) then checksheet = true exit for end if next lelse msgbox "工作表不存在，可能是由文件名或工作表名引起的！" checksheet = false end ifend function'建立工作表 'createmethod:1追加 'createmethod:2覆盖 function createsheet(byval strsheetname as string, byval strworkbook as string, byval createmethod as integer, xlcreateapp as excel.application) as boolean dim xlcreatesheet as excel.worksheet if checkfile(strworkbook) then
xlcreateapp.workbooks.open (strworkbook)
if createmethod = 1 then
if checksheet(strsheetname, strworkbook, xlcreateapp) = false then
set xlcreatesheet = xlcreateapp.worksheets.add xlcreatesheet.name = strsheetname xlcreateapp.activeworkbook.save
createsheet = true set xlcreatesheet = nothing else 'msgbox strsheetname & "工作表已存在！" createsheet = false set xlcreatesheet = nothing end if
elseif createmethod = 2 then if checksheet(strsheetname, strworkbook, xlcreateapp) = true then set xlcreatesheet = xlcreateapp.worksheets(strsheetname) xlcreatesheet.cells.select xlcreatesheet.cells.delete xlcreateapp.activeworkbook.save createsheet = true set xlcreatesheet = nothing else 'msgbox strsheetname & "工作表不存在！" createsheet = false set xlcreatesheet = nothing end if
end if
end if end function '删除工作表 function deletesheet(byval strsheetname as string, byval strworkbook as string, xldeleteapp as excel.application) as boolean dim i as integer dim xldeletesheet as excel.worksheet
if checkfile(strworkbook) then
if checksheet(strsheetname, strworkbook, xldeleteapp) = true then
xldeleteapp.workbooks.open (strworkbook)
if xldeleteapp.worksheets.count = 1 then msgbox "工作薄不能全部删除，" & strsheetname & "是最后一个工作表！" deletesheet = false exit function end if
xldeleteapp.worksheets(strsheetname).delete xldeleteapp.activeworkbook.save deletesheet = true else deletesheet = false end if
end if
end function'复制工作表 function copysheet(byval strsrcsheetname as string, byval strsrcworkbook as string, byval strtagsheetname as string, byval strtagworkbook as string, xlcopyapp as excel.application) as boolean dim xlsrcbook as excel.workbook dim xltagbook as excel.workbook dim excelsource as excel.worksheet dim exceltarget as excel.worksheet dim result as booleanif checkfile(strsrcworkbook) = false or checkfile(strtagworkbook) = false then set excelsource = nothing set exceltarget = nothing set xlsrcbook = nothing set xltagbook = nothing copysheet = false exit function else set xlsrcbook = xlcopyapp.workbooks.open(strsrcworkbook)
if strsrcworkbook = strtagworkbook then if strsrcsheetname = strtagsheetname then set excelsource = nothing set exceltarget = nothing set xlsrcbook = nothing set xltagbook = nothing copysheet = false exit function end if
set xltagbook = xlsrcbook else set xltagbook = xlcopyapp.workbooks.open(strtagworkbook) end if
set excelsource = xlsrcbook.worksheets(strsrcsheetname) set exceltarget = xltagbook.worksheets(strtagsheetname) excelsource.select excelsource.cells.copy exceltarget.select exceltarget.paste xlcopyapp.application.cutcopymode = xlcopy
if strsrcworkbook = strtagworkbook then xltagbook.save xlsrcbook.save else xltagbook.save end if
set excelsource = nothing set exceltarget = nothing set xlsrcbook = nothing set xltagbook = nothing copysheet = true end if end function
'复制工作表 function excelcopysheet(byval strsrcsheetname as string, byval strsrcworkbook as string, byval strtagsheetname as string, byval strtagworkbook as string, xlcopyapp as excel.application) as boolean dim xlsrcbook as excel.workbook dim xltagbook as excel.workbook dim excelsource as excel.worksheet dim exceltarget as excel.worksheet dim result as booleanif checkfile(strsrcworkbook) = false or checkfile(strtagworkbook) = false then set excelsource = nothing set exceltarget = nothing set xlsrcbook = nothing set xltagbook = nothing copysheet = false exit function else set xlsrcbook = xlcopyapp.workbooks.open(strsrcworkbook)
if strsrcworkbook = strtagworkbook then if strsrcsheetname = strtagsheetname then set excelsource = nothing set exceltarget = nothing set xlsrcbook = nothing set xltagbook = nothing copysheet = false exit function end if
set xltagbook = xlsrcbook else set xltagbook = xlcopyapp.workbooks.open(strtagworkbook) end if
set excelsource = xlsrcbook.worksheets(strsrcsheetname) set exceltarget = xltagbook.worksheets(strtagsheetname) excelsource.select excelsource.copy before exceltarget.select exceltarget.paste xlcopyapp.application.cutcopymode = xlcopy
if strsrcworkbook = strtagworkbook then xltagbook.save xlsrcbook.save else xltagbook.save end if
set excelsource = nothing set exceltarget = nothing set xlsrcbook = nothing set xltagbook = nothing copysheet = true end if end function'关闭excel应用 function closeexcelapp(xlapp as object) on error resume next xlapp.quit set xlapp = nothing end function'建立excel应用 function createexcelapp(quitapp as boolean) as object on error resume next dim xlobject as object if checkexcel thenset xlobject = getobject(, "excel.application") if err.number <> 0 then set xlobject = nothing set xlobject = createobject("excel.application") createexcelapp = xlobject else if quitapp then xlobject.quit set xlobject = nothing set xlobject = createobject("excel.application") end if createexcelapp = xlobject end ifend ifend function'检测excel环境 function checkexcel() as boolean dim xlcheckapp as object set xlcheckapp = createobject("excel.application") if xlcheckapp is nothing then msgbox "对不起，系统未检测到excel安装，请重新检查excel是否被正确安装！" checkexcel = false xlcheckapp.quit set xlcheckapp = nothing exit function else xlcheckapp.quit checkexcel = true set xlcheckapp = nothing end if end functionfunction createworkbook(byval strworkbook as string, xlapp as excel.application) dim xlcreateworkbook as excel.workbookset xlcreateworkbook = xlapp.workbooks.addxlcreateworkbook.saveas (strworkbook) end function function getpath(strpath as string) as string getpath = iif(len(strpath) = 3, strpath, strpath & "\") end function 这上面的函数只不过是一部分,其于的因为专用目的,写不标准,以后也许会整理出来一份标准的函数库的!
关键字:
vb 贴文时间
2001-3-30 1:36:47 文章类型:
转贴 给贴子投票
hktl 转贴 出处: http://www.chinabyte.com/builder/detail.shtm?buiid=870&parid=1&cate=GJBC
本文将告诉你如何使用VB代码连接Office应用程序，并简要接触一下在文件中输入数据的方法。实际上，在VB中用代码与Word和Excel进行会话并控制它们，是可行的。但是请注意，首先需要在机器上安装office应用程序，才能在VB代码中存取它们的对象。 下面就是一些例子，告诉你如何与这些程序会话，并控制它们。 Option Explicit
Dim xlsApp As Excel.Application
Dim wrdApp As Word.Application 只要相关的对象库已经被选择，在应用程序中进行对象变量的赋值是可能的。Microsoft Excel 8.0对象库是相对于Excel的，而 Microsoft Word 8.0 对象库是为Word服务的。 在VB的IDE环境中，从“工程”菜单中选择“引用”，可以看到系统可用的所有库列表。Private Sub Command1_Click()
Set xlsApp = Excel.Application
With xlsApp
'Show Excel
.Visible = True
'Create a new workbook
.Workbooks.Add
'Put text in to the cell that is selected
.ActiveCell.Value = "Hi"
'Put text into A3 regardless of the selected cell
.Range("A3").Value = "This is an example of connecting to Excel"
End With
End Sub
在上面的程序段中，我们在变量xlsApp中建立了一个对象，这样Excel就对用户可见了。当Excel象这样启动后，并不包含一个工作簿，所以必须创建或者执行打开操作。这里，我们建立了一个新的工作簿，然后，就可以操作其中的信息，或者打印，或者保存，或者你任意想做的事情。Private Sub Command2_Click()
'close the workbook
xlsApp.Workbooks.Close
'Close Excel
xlsApp.Quit
End Sub 上面这段代码执行关闭程序的功能。首先，关闭工作簿，这将出现一个提示对话框，询问用户是否想保存修改；然后，退出应用程序。Private Sub Command3_Click()
Set wrdApp = New Word.Application
With wrdApp
'Show Word
.Visible = True
'Create New Document
.Documents.Add
'Add text to the document
.ActiveDocument.Content.Text = "Hi"
.ActiveDocument.Content.Text = "This is a test example"
End With
End Sub 上面这段代码中，在变量wrdApp中设置引用Word程序的对象。同样，当Word按照这种方式启动后，不会包含一个文档，所以，必须执行建立或者打开操作。这里是建立了一个新文档，然后可以操作其中的信息了，打印、保存、发送邮件，等等... 但是，在Word文档中放置文本并非容易！特别是与Excel一起工作时。为了简单地在特定的地方放置文本，需要有一个book标记。这意味着，需要事先建立一个模板。Private Sub Command4_Click()
'Close the current document
wrdApp.ActiveDocument.Close
'Close Word
wrdApp.Quit
End Sub 上面这段代码的功能是关闭应用程序。首先，关闭当前文档，这时可能需要用户保存修改。然后，退出程序。Private Sub Form_Unload(Cancel As Integer)
'Clear the memory
Set xlsApp = Nothing
Set wrdApp = Nothing
End Sub 最后一段代码就是关闭VB应用程序。这是优秀程序员编程的好习惯。 Well I hope this brief tutorial is helpful. It does not touch on much of what you can do to the office applications once they're open, but should give you an idea of how to get started. 好了，简单的介绍到此结束。我希望能抛砖引玉，让你更加随意地操作Office应用程序！
'检测文件
function checkfile(byval strfile as string) as boolean
dim filexls as object
set filexls = createobject("scripting.filesystemobject") if isnull(strfile) or strfile = "" then
checkfile = false
exit function
end if
if filexls.fileexists(strfile) = false then
checkfile = false
set filexls = nothing
exit function
else
checkfile = true
set filexls = nothing
end if
end function
'检测工作表
function checksheet(byval strsheet as string, byval strworkbook as string, xlcheckapp as excel.application) as boolean
dim l as integer
dim checkworkbook as excel.workbookif checkfile(strworkbook) and strsheet <> "" and not isnull(strsheet) then
for l = 1 to xlcheckapp.workbooks.count
if getpath(xlcheckapp.workbooks(l).path) & xlcheckapp.workbooks(l).name = strworkbook then
set checkworkbook = xlcheckapp.workbooks(l)
exit for
end if
next l
set checkworkbook = xlcheckapp.workbooks.open(strworkbook)
for l = 1 to checkworkbook.worksheets.count
if checkworkbook.worksheets(l).name = trim(strsheet) then
checksheet = true
exit for
end if
next lelse
msgbox "工作表不存在，可能是由文件名或工作表名引起的！"
checksheet = false
end ifend function'建立工作表
'createmethod:1追加
'createmethod:2覆盖
function createsheet(byval strsheetname as string, byval strworkbook as string, byval createmethod as integer, xlcreateapp as excel.application) as boolean
dim xlcreatesheet as excel.worksheet
if checkfile(strworkbook) then
xlcreateapp.workbooks.open (strworkbook)
if createmethod = 1 then
if checksheet(strsheetname, strworkbook, xlcreateapp) = false then
set xlcreatesheet = xlcreateapp.worksheets.add
xlcreatesheet.name = strsheetname
xlcreateapp.activeworkbook.save
createsheet = true
set xlcreatesheet = nothing
else
'msgbox strsheetname & "工作表已存在！"
createsheet = false
set xlcreatesheet = nothing
end if
elseif createmethod = 2 then
if checksheet(strsheetname, strworkbook, xlcreateapp) = true then
set xlcreatesheet = xlcreateapp.worksheets(strsheetname)
xlcreatesheet.cells.select
xlcreatesheet.cells.delete
xlcreateapp.activeworkbook.save
createsheet = true
set xlcreatesheet = nothing
else
'msgbox strsheetname & "工作表不存在！"
createsheet = false
set xlcreatesheet = nothing
end if
end if
end if
end function
'删除工作表
function deletesheet(byval strsheetname as string, byval strworkbook as string, xldeleteapp as excel.application) as boolean
dim i as integer
dim xldeletesheet as excel.worksheet
if checkfile(strworkbook) then
if checksheet(strsheetname, strworkbook, xldeleteapp) = true then
xldeleteapp.workbooks.open (strworkbook)
if xldeleteapp.worksheets.count = 1 then
msgbox "工作薄不能全部删除，" & strsheetname & "是最后一个工作表！"
deletesheet = false
exit function
end if
xldeleteapp.worksheets(strsheetname).delete xldeleteapp.activeworkbook.save
deletesheet = true
else
deletesheet = false
end if
end if
end function'复制工作表
function copysheet(byval strsrcsheetname as string, byval strsrcworkbook as string, byval strtagsheetname as string, byval strtagworkbook as string, xlcopyapp as excel.application) as boolean
dim xlsrcbook as excel.workbook
dim xltagbook as excel.workbook
dim excelsource as excel.worksheet
dim exceltarget as excel.worksheet
dim result as booleanif checkfile(strsrcworkbook) = false or checkfile(strtagworkbook) = false then
set excelsource = nothing
set exceltarget = nothing
set xlsrcbook = nothing
set xltagbook = nothing
copysheet = false
exit function
else set xlsrcbook = xlcopyapp.workbooks.open(strsrcworkbook)
if strsrcworkbook = strtagworkbook then
if strsrcsheetname = strtagsheetname then
set excelsource = nothing
set exceltarget = nothing
set xlsrcbook = nothing
set xltagbook = nothing
copysheet = false
exit function
end if
set xltagbook = xlsrcbook
else
set xltagbook = xlcopyapp.workbooks.open(strtagworkbook)
end if
set excelsource = xlsrcbook.worksheets(strsrcsheetname)
set exceltarget = xltagbook.worksheets(strtagsheetname) excelsource.select
excelsource.cells.copy
exceltarget.select
exceltarget.paste
xlcopyapp.application.cutcopymode = xlcopy
if strsrcworkbook = strtagworkbook then
xltagbook.save
xlsrcbook.save
else
xltagbook.save
end if
set excelsource = nothing
set exceltarget = nothing
set xlsrcbook = nothing
set xltagbook = nothing
copysheet = true
end if
end function
function excelcopysheet(byval strsrcsheetname as string, byval strsrcworkbook as string, byval strtagsheetname as string, byval strtagworkbook as string, xlcopyapp as excel.application) as boolean
dim xlsrcbook as excel.workbook
dim xltagbook as excel.workbook
dim excelsource as excel.worksheet
dim exceltarget as excel.worksheet
dim result as booleanif checkfile(strsrcworkbook) = false or checkfile(strtagworkbook) = false then
set excelsource = nothing
set exceltarget = nothing
set xlsrcbook = nothing
set xltagbook = nothing
copysheet = false
exit function
else set xlsrcbook = xlcopyapp.workbooks.open(strsrcworkbook)
if strsrcworkbook = strtagworkbook then
if strsrcsheetname = strtagsheetname then
set excelsource = nothing
set exceltarget = nothing
set xlsrcbook = nothing
set xltagbook = nothing
copysheet = false
exit function
end if
set xltagbook = xlsrcbook
else
set xltagbook = xlcopyapp.workbooks.open(strtagworkbook)
end if
set excelsource = xlsrcbook.worksheets(strsrcsheetname)
set exceltarget = xltagbook.worksheets(strtagsheetname) excelsource.select
excelsource.copy before
exceltarget.select
exceltarget.paste
xlcopyapp.application.cutcopymode = xlcopy
if strsrcworkbook = strtagworkbook then
xltagbook.save
xlsrcbook.save
else
xltagbook.save
end if
set excelsource = nothing
set exceltarget = nothing
set xlsrcbook = nothing
set xltagbook = nothing
copysheet = true
end if
end function'关闭excel应用
function closeexcelapp(xlapp as object)
on error resume next
xlapp.quit
set xlapp = nothing
end function'建立excel应用
function createexcelapp(quitapp as boolean) as object
on error resume next
dim xlobject as object
if checkexcel thenset xlobject = getobject(, "excel.application")
if err.number <> 0 then
set xlobject = nothing
set xlobject = createobject("excel.application")
createexcelapp = xlobject
else
if quitapp then
xlobject.quit
set xlobject = nothing
set xlobject = createobject("excel.application")
end if
createexcelapp = xlobject
end ifend ifend function'检测excel环境
function checkexcel() as boolean
dim xlcheckapp as object
set xlcheckapp = createobject("excel.application") if xlcheckapp is nothing then
msgbox "对不起，系统未检测到excel安装，请重新检查excel是否被正确安装！"
checkexcel = false
xlcheckapp.quit
set xlcheckapp = nothing
exit function
else
xlcheckapp.quit
checkexcel = true
set xlcheckapp = nothing
end if
end functionfunction createworkbook(byval strworkbook as string, xlapp as excel.application)
dim xlcreateworkbook as excel.workbookset xlcreateworkbook = xlapp.workbooks.addxlcreateworkbook.saveas (strworkbook)
end function
function getpath(strpath as string) as string
getpath = iif(len(strpath) = 3, strpath, strpath & "\")
end function
这上面的函数只不过是一部分,其于的因为专用目的,写不标准,以后也许会整理出来一份标准的函数库的!