将值保存到excel和bac
你好我有以下代码将值保存到excel
Public strTitleBlockName As String
Public MyTxtStr(0 To 7) As String
Public Cnt, WorkbookOpen, RowCnt As Integer
Public Excel As Excel.Application
Public ExcelSheet, ExcelWorkbook As Object
Public CurrRange As Range
Public myvaratt As Variant
Sub SaveCurrValues()
If WorkbookOpen = 1 Then GoTo SkipCreatingWorkbook
' Launch Excel.
Set Excel = New Excel.Application
' Create a new workbook and find the active sheet.
Set ExcelWorkbook = Excel.Workbooks.Add
Set ExcelSheet = Excel.ActiveWorkbook.ActiveSheet
ExcelWorkbook.SaveAs "AutoGlassCalcStoredValues.xls", True
Excel.Visible = False
RowCnt = 1
With Worksheets("Sheet1")
.Select
.Range("a1").Activate
End With
MyTxtStr(0) = XOffset
MyTxtStr(1) = YOffset
MyTxtStr(2) = ScrRef
MyTxtStr(3) = GlassSpec
MyTxtStr(4) = GlassColRef
MyTxtStr(5) = GlassRef
MyTxtStr(6) = TextHeight
MyTxtStr(7) = VPScale
SkipCreatingWorkbook:
Cnt = 3
For I = 0 To Cnt
Set CurrRange = ActiveCell
CurrRange.Value = MyTxtStr(I)
CurrRange.Offset(0, 1).Select
Next
RowCnt = RowCnt + 1
With Worksheets("Sheet1")
.Select
.Range("a" & RowCnt).Activate
End With
WorkbookOpen = 1 'tell the sub that excel has already been opened
ExcelWorkbook.Save
ExcelWorkbook.Close
' Excel.Application.Quit
'Excel.Application.
End Sub
这很好用
它将值返回到acad vba表单中
我尝试了以下操作，但它返回了所需对象的错误？？？？？？
Sub LoadCurrValues()
Dim oExcel As Excel.Application
Dim oWB As Workbook
Set oExcel = New Excel.Application
Set oWB = oExcel.Workbooks.Open("AutoGlassCalcStoredValues")
Set ExcelSheet = Excel.ActiveWorkbook.ActiveSheet
TxBxXOffset.Value = oWB.Range("a1").Value
TxBxYOffset.Value = Range("b1")
TxBxScrRef.Value = Range("c1")
TxBxSpec.Value = Range("d1")
CboGlsSpcCol.Value = Range("e1")
TxBxRef.Value = Range("f1")
TxBxTHght.Value = Range("g1")
TxBxVPScale.Value = Range("h1")
ExcelWorkbook.Save
ExcelWorkbook.Close
' Excel.Application.Quit
'Excel.Application.
End Sub
cheers for any help!
col
我玩了一会儿。我正在将AutoCAD 2008和2010与Excel 2007一起使用。我希望这有帮助。
Sub LoadCurrValues()
Dim oExcel As Excel.Application
Dim oWB As Workbook
Set oExcel = New Excel.Application
Set oWB = oExcel.Workbooks.Open("c:\Testing.xls")
Set Excelsheet = Excel.ActiveWorkbook.ActiveSheet
TxBxXOffset.Value = Excelsheet.Range("a1").Value
TxBxYOffset.Value = Excelsheet.Range("b1").Value
TxBxScrRef.Value = Excelsheet.Range("c1").Value
TxBxSpec.Value = Excelsheet.Range("d1").Value
CboGlsSpcCol.Value = Excelsheet.Range("e1").Value
TxBxRef.Value = Excelsheet.Range("f1").Value
TxBxTHght.Value = Excelsheet.Range("g1").Value
TxBxVPScale.Value = Excelsheet.Range("h1").Value
oWB.Save
oExcel.Quit
End Sub
布莱恩，
谢谢你的回复。
我用excel 2007在Acad2009上运行了以下代码，但在acad 2008 excel 2003上返回错误“无效使用新关键字？？？
Sub LoadCurrValues()
Dim oExcel As Excel.Application
Dim oWB As Workbook
Dim ExcelSheet As Object
Dim ExcelWorkbook As Object
On Error Resume Next
Set oExcel = New Excel.Application
Set oWB = oExcel.Workbooks.Open("AutoGlassCalcStoredValues")
oExcel.Visible = False
'Set ExcelSheet = Excel.ActiveSheet
'set oExcel.Range(a1).Value
UFcreateGlassAtt.TxBxXOffset.Value = oWB.ActiveSheet.Range("A1").Value
UFcreateGlassAtt.TxBxYOffset.Value = oWB.ActiveSheet.Range("B1").Value
UFcreateGlassAtt.TxBxScrRef.Value = oWB.ActiveSheet.Range("C1").Value
UFcreateGlassAtt.TxBxSpec.Value = oWB.ActiveSheet.Range("D1").Value
UFcreateGlassAtt.CboGlsSpcCol.Value = oWB.ActiveSheet.Range("E1").Value
UFcreateGlassAtt.TxBxRef.Value = oWB.ActiveSheet.Range("F1").Value
UFcreateGlassAtt.TxBxTHght.Value = oWB.ActiveSheet.Range("G1").Value
UFcreateGlassAtt.TxBxVPScale.Value = oWB.ActiveSheet.Range("H1").Value
oWB.Save
oWB.Close
If Err Then Err.Clear
' Excel.Application.Quit
'Excel.Application.
End Sub
根据我的经验，Excel 2003和2007之间的引用是不同的。我认为，如果你使用CreateObject（“Excel.Application”），它将同时适用于这两种应用程序，但我并不确定，因为我不再安装2003。我以前确实遇到过这种情况，但我不记得是怎么处理的。
如果不久没有其他人给出答案，我将尝试挖掘我的一些旧代码来找到它。
Dim excelObj As Object
Set excelObj = CreateObject("excel.Application")
excelObj.Visible = True
excelObj.workbooks.Open ("c:\testing.xls")
谢谢Brian，我会查看我的一些其他代码，因为我确信我以前用excel做过这件事，它在2009年和2009年acad上都工作过，所以我不确定是不是其他原因导致了它？我必须仔细检查并比较一下。
干杯
col公司 你好
我在网上找到了这个例子
对于excel 2003
Sub BringToLife()
On Error Resume Next
Dim e As Excel.Application
Set e = New Excel.Application
e.Visible = True
e.Workbooks.Add
e.Worksheets(“Sheet1”).Cells(4, 4).Value = 256
If Err Then MsgBox Error$
End Sub
在我看来，我做得对吗？他们一定是其他原因导致了错误，但由于某种原因，在代码的“New Excel.Application”部分返回了错误。。。？
干杯
col公司
页:
[1]