ACAD 2018和ObjectDBX难题？乐筑天下 - Powered by Discuz! Archiver

yosso 发表于 2018-4-4 08:24:10

ACAD 2018和ObjectDBX难题？

使用一些古老的代码尝试从Excel工作表在ACAD 2018中创建表
一切顺利进行，直到我尝试创建一行并显示错误消息；无效的过程调用或参数
oDBxDoc.PaperSpace。AddLine sp，ep创建oDbxDoc，并在监视窗口中显示它是有效的AxDbDocument
在剥离AutoCAD 2017 my PC之前，代码（我认为）是有效的……但这个项目已经进行了几个月，我的内存越来越差
我的测试模块：
Sub ACADCreateDwg()
On Error GoTo ErrorHandler
' Testing Variables
Dim oDBx As cObjDbx
Dim oDBxDoc As AxDbDocument ' Object ' Late binding!
Dim OpenName As String
Dim SaveName As String
Dim sp(0 To 2) As Single
Dim ep(0 To 2) As Single
Set oDBx = New cObjDbx
sp(0) = 0#: sp(1) = 0#: sp(2) = 0#
ep(0) = 34#: ep(1) = 23#: ep(2) = 0#
OpenName = "D:\Dropbox\AMCE Work Folders\Substation Spreadsheets\Sag-Tension Workbook\XML OUTPUT FROM PLS-CADD\Sag_Tables.dwt"
SaveName = "TEST"
' Open the template file
oDBx.xOpen OpenName
' Cast the Doc property object as an AxDbDocument Ojbect
Set oDBxDoc = oDBx.Doc
' Add a line
oDBxDoc.PaperSpace.AddLine sp, ep
oDBx.xSaveAs oDBx.OrigPath, "Copy of ", "1"
oDBx.xClose
'There 's no New method on an AxDbDocument.
'
'If you want to create a new document that's derived
'from a template, just open the template (DWT) file
'in the AxDbDocument, and when you've done what you
'need, save it as a .DWG file.
Exit Sub
ErrorHandler:
Debug.Print Err.Description
Stop
oDBx.xClose

来自Ed Jobe的课程模块（大约2006年）
Option Explicit
'=================================================================================================
' Purpose : Create an object class for access Autocad via the ObjectDBX
'
' Date    : 01/19/18
' Updated :
'=================================================================================================
' Need code to differentiate the various versions of ACAD?
' 2018-01-19
' Replaced AXDBLib with AXDBLib
'=================================================================================================
' References Requires
' AutoCAD C:\Program Files\Common Files\Autodesk Shared\acax22enu.tlb
' AXDBLib C:\Program Files\Common Files\Autodesk Shared\axdb22enu.tlb
' ScriptingC:\Windows\SysWOW64\scrrun.dll
'=================================================================================================
'copyright 2006, Ed Jobe
' Note: This requires ObjectDBX to be registered on each
' user's machine. This is done automatically on 2004 and up.
' In your AutoCAD folder, locate the file AxDb15.dll.
' This only needs to be done once at each machine. If you are using vb instead
' of vba, you will also need to set a reference to "ObjectDBX 1.0 Type library"
' and "Microsoft Scripting Runtime".
' This class auto-registers the dll, but here is the normal procedure---
' From the dos command line, type:
' C:\> cd Autodesk\Map200i
' C:\Autodesk\Map2000i> RegSvr32.exe AxDb15.dll
'This class unfortunately doesn't follow standards for objects due to the fact that
'I was unable to Implement the properties/methods of ObjectDbx. Normally, the Open,
'Close, Save and SaveAs methods would belong in the doc class. But since you can't use
'the Implements statement on ObjectDbx, I had to move them to this class. This class
'uses late binding to be able to handle versioning. In order to access all the
'methods/properties of an AxDbDocument in your project, you must Dim a variable as
' type AxDbDocument and then the object returned by the Doc property to cast it as
' an AxDbDocument object. Therefore, this class does not reference AxDb15.dll, so
'your project needs to.
'Last error number used: 1003
'Variable declarations for Properties
Private oDoc As AxDbDocument ' Object
Private strOrigPath As String
Private strTempPath As String
Private strExt As String
Private bReadOnly As Boolean
'Property Declarations
'*********************
Public Property Get Doc() As Object
Set Doc = oDoc
End Property
Public Property Get Ext() As String
Ext = strExt
End Property
Public Property Get OrigPath() As String
OrigPath = strOrigPath
End Property
Public Property Get TempPath() As String
TempPath = strTempPath
End Property
Public Property Get ReadOnly() As Boolean
ReadOnly = bReadOnly
End Property
'Class Methods
'*************
Public Sub xClose()
'required for proper cleanup of temp files
Set oDoc = Nothing
End Sub
Private Function acadVerNum() As String
Dim verNum As String
verNum = "HKEY_CLASSES_ROOT\AutoCAD.Drawing\CurVer\"

Dim wsh As Object
' Error trapping
On Error GoTo ErrorHandler

'access Windows scripting
Set wsh = CreateObject("WScript.Shell")

'read key from registry
Dim resKey As String
resKey = wsh.RegRead(verNum)

acadVerNum = Right(resKey, 2)

Set wsh = Nothing
Exit Function

ErrorHandler:
acadVerNum = ""
Set wsh = Nothing

End Function
Public Sub xOpen(FilePath As String)
'Sets the Doc property to an ObjectDBX Document
'late binding is used to avoid setting a reference.
'
On Error GoTo ErrHandler

Dim dbxdoc As AxDbDocument 'Object
Dim strTempName As String
Dim fso As Scripting.FileSystemObject
Dim fsoFile As Scripting.File
Dim colPCs As AcadPlotConfigurations
Dim objPC As AcadPlotConfiguration
Dim varList As Variant
Dim i As Integer
Dim cnt As Integer
Dim iActiveLayout As Integer
Dim strObjDbxPath As String
Dim ACAD As Object

bReadOnly = False
strOrigPath = FilePath

Set fso = CreateObject("Scripting.FileSystemObject")

Cleanup:
'if this is not the first time a doc was opened, then
'there may be a temp file left. Clean it up!
If fso.FileExists(strTempPath) Then
   fso.DeleteFile (strTempPath)
   strTempPath = ""
End If
'check for dwt, ObjectDbx can only open dwg's
strExt = fso.GetExtensionName(FilePath)
'Calling sub can check the Ext property. If it equals "dwt", then
'a temp file was created at the location stored in the TempPath property.
SetDbxDoc:
' MSJ - added a function to obtain the acad version number
' 4/4/18
' Trying a "trick" get dbxdoc set correct.
' https://www.theswamp.org/index.php?topic=15028.0
' Set dbxdoc = New AxDbDocument

Select Case acadVerNum ' Left(ThisDrawing.GetVariable("ACADVER"), 2)
Case Is = "22"
   Set dbxdoc = AcadApplication.GetInterfaceObject("ObjectDBX.AxDbDocument.22")
Case Is = "21"
   Set dbxdoc = AcadApplication.GetInterfaceObject("ObjectDBX.AxDbDocument.21")
Case Else
   ' Unable to find ACAD version
      MsgBox "Unable to extract AutoCAD version!!!", vbCritical, "ERROR"
   GoTo ErrHandler
   'Set dbxdoc = AcadApplication.GetInterfaceObject("ObjectDBX.AxDbDocument.19")
End Select
If strExt = "dwt" Then
   Err.Raise vbObjectError + 1001
End If
dbxdoc.Open FilePath
Set oDoc = dbxdoc

Set dbxdoc = Nothing
Set fso = Nothing
Exit Sub

ErrHandler:
Select Case Err.Number
Case Is = -2147221005
   'register dll
   'STOP
   strObjDbxPath = "regsvr32 " & AcadApplication.Path & "\axdb22.dll"
   Shell (strObjDbxPath)
   Err.Clear
   GoTo SetDbxDoc
Case Is = vbObjectError + 1001, 70, -2147467259
   'vbObjectError + 1001 = filetype is *.dwt
   '70 = file access permission denied
   '-2147467259 = Method 'Open' of object 'IAxDbDocument' failed
   'Plan for occasion where the file is already open by
   'another user. This is necessary because ObjectDBX
   'does not support a ReadOnly argument for the Open method.
   'The calling sub can check the ReadOnly property. If True, then
   'then you can clean up by deleting the temp file when done. ObjectDBX also
   'does not open dwt files. If the Ext property equals "dwt", you may need to clean up.
   'I try do do it for you at CleanUp: and Class.Terminate.
   'If there are no errors, the TempPath property will = "", vbNullString.

   ' TODO - 2018-01-22 - ADD TEST TO SEE IF ACAD IS OPEN!

   ' 4/4/18 = ACAD does not work with AutoCAD 2018
   ' strTempName = ACAD.Application.Preferences.Files.TempFilePath & fso.GetBaseName(FilePath) & ".dwg"
      strTempName = autocad.Application.Preferences.Files.TempFilePath & fso.GetBaseName(FilePath) & ".dwg"

   fso.CopyFile FilePath, strTempName, True 'overwrite without prompting
   SetAttr strTempName, vbNormal
   FilePath = strTempName
   dbxdoc.Open FilePath
   strTempPath = strTempName
   bReadOnly = True
   Set oDoc = dbxdoc
   Set dbxdoc = Nothing
   Set fso = Nothing
Case Else
   MsgBox Err.Number & ": " & Err.Description, vbCritical, "ObjDbx.xOpen"
End Select
End Sub
Public Sub xSave()
'Save the currently open oDoc
'Replaces the AxDbDocument's Save method
On Error GoTo ErrHandler

If oDoc Is Nothing Then
   Err.Raise vbObjectError + 1002, , "Method failed. There is no document to save."
End If

'Use the SaveAs method, since Save "doesn't work"
oDoc.SaveAs strOrigPath
Exit Sub

ErrHandler:
Select Case Err.Number
Case Is = vbObjectError + 1002
   MsgBox Err.Number & ": " & Err.Description, vbCritical, "ObjDbx.xSave"
Case Else
   MsgBox Err.Number & ": " & Err.Description, vbCritical, "ObjDbx.xSave"
End Select

End Sub
Public Sub xSaveAs(FilePath As String, Optional Prefix As String, Optional Suffix As String)
'SaveAs the currently open oDoc
'For flexibility only, since oDoc inherits the AxDbDocument's methods.
'Also, I added some optional arguments.
On Error GoTo ErrHandler

Dim fso As Scripting.FileSystemObject
Dim strFile As String

If oDoc Is Nothing Then
   Err.Raise vbObjectError + 1003, , "Method failed. There is no document to save."
End If
Set fso = CreateObject("Scripting.FileSystemObject")
strFile = fso.GetParentFolderName(FilePath) & "\" & Prefix & _
         fso.GetBaseName(FilePath) & Suffix & "." & fso.GetExtensionName(FilePath)
oDoc.SaveAs strFile
Set fso = Nothing
Exit Sub

ErrHandler:
Select Case Err.Number
Case Is = vbObjectError + 1002
   MsgBox Err.Number & ": " & Err.Description, vbCritical, "ObjDbx.xSaveAs"
Case Else
   MsgBox Err.Number & ": " & Err.Description, vbCritical, "ObjDbx.xSaveAs"
End Select

End Sub
Private Sub Class_Terminate()
Dim fso As Scripting.FileSystemObject

'Make sure that the doc object doesn't
'have a hold on the temp file.
'Close the doc without saving changes.
Set oDoc = Nothing
'Cleanup temp file if it exists.
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(strTempPath) Then fso.DeleteFile (strTempPath)
Set fso = Nothing
End Sub

n.yuan 发表于 2018-4-4 09:56:54

我相信你&#039；我需要在新安装中加载VBA enabler:https://knowledge.autodesk.com/support/autocad/downloads/caas/downloads/content/download-the-microsoft-visual-basic-for-applications-module-vba.html

yosso 发表于 2018-4-4 10:03:36

好的，它对我来说适用于以下代码（AutoCAD2018，实际上是AutoCAD Civil3D 2018）：
Option Explicit
Public Sub DbxTest()
Dim fileName As String
fileName = "D:\Temp\SideDbTest.dwg"

Dim doc As AXDBLib.AxDbDocument

Dim sp(0 To 2) As Double
Dim ep(0 To 2) As Double

sp(0) = 0#: sp(1) = 0#: sp(2) = 0#
ep(0) = 100#: ep(1) = 100#: ep(2) = 0#

Set doc = ThisDrawing.Application.GetInterfaceObject("ObjectDBX.AxDbDocument.22")
doc.Open fileName

On Error Resume Next

doc.PaperSpace.AddLine sp, ep

If Err.Number0 Then
MsgBox "Updated failed: " & Err.Description
Else
MsgBox "Updated"
End If

doc.SaveAs fileName

End Sub
然而，我&#039；d避免使用ObjectDBX将实体添加到图纸空间，因为如果图形具有多个布局（很可能），则在打开AxDbDocument时，您不确定哪个布局是图纸空间。通常，在AutoCAD中打开并保存图形时，它是最后一个激活的布局，但在使用ObjectDBX处理图形时，您无法知道这一点
因此，如果使用ObjectDBX文档，而不是使用AxDbDocument。PaperSpace，I&#039；d使用AxDbDocument。布局（[特定布局索引]）。块来添加实体，以便始终确保将实体添加到特定布局
不过，我不知道为什么会出现这种错误，因为每个图形应该至少有一个布局。您可以试试看图形是否至少有一个布局：如果是doc.Layouts。计数（&gt）；然后为0&nbsp；文档.纸张空间.添加行…
&nbsp'' 或&nbsp'' 文档布局（0）。块。添加行&nbsp；Msgbox“；图纸中没有布局。无法将行添加到图纸空间&引用
如果结束

Gandxsla 发表于 2018-4-4 10:16:51

@Deegeeses_V.2.0 I&#039；我已经安装了VBA enabler…我想…让我检查一下。是的，它&#039；已安装。
@n.yuan&nbsp；似乎我的类代码工作不正常，最好保持简单&nbsp
谢谢大家的反馈和建议

yosso 发表于 2018-9-11 05:24:37

我很高兴成为这里的一员。以便我完全访问数据

页: [1]

乐筑天下's Archiver

ACAD 2018和ObjectDBX难题？