SaveAs erzeugt Empfehlung zu WHERST (Autodesk/AutoCAD VBA)

Faktisch nein :/ Acad hat da einige Bugs..

Private Sub MODAUDIT_Click()
On Error Resume Next
thisdrawing.SendCommand "_AUDIT" & vbCr & "y" & vbCr
End Sub
mag helfen ..

Ich hatte da neulich auch so ein Problem ACAd stürzte nach einer bestimmten Aktion (Wie man Acad dazu bringt für Entitys VBS auszuführen sprengt den Rahmem) Aber faktisch war es so das es mir gelungen sein muss (Die VBS scripte ligen in dictionarys) etwas zu erzeugen was einen Sofortcrash hervorruft.
Abhilfe war nachdem der Block der es hervorruft zu clonen sprich mit eine Kopie des Blockes zu erzeugen. Der Unfug der den Crash verursacht hat schien nicht mit über diese Routine zu gehen. Man frage mich bitte nicht warum ud wieso !
Fakt ist, es wurde überlebt.
Sub block_definition_clone(Optional interactiv As Boolean = False)

Dim fileName As String
Dim oBlkRef As AcadBlockReference
Dim oEnt As AcadEntity, oBlock As AcadBlock
Dim varpt(2) As Double
Dim insVpt, inspt(2) As Double
Dim BNAME As String
Dim I As Long, J As Long, IDPairs As Long
Dim expObjs As Variant

Dim objSelSet As AcadSelectionSet
Dim objTarget As AcadDocument
Dim currentdrawing As AcadDocument
Set currentdrawing = thisdrawing
Dim documents As AcadDocuments '
Dim document As AcadDocument
Dim objOrgEnts() As Object
Dim destEnts As Variant
Dim intCnt As Long
Dim blo As AcadBlock
Dim strFullDef As String
Dim objBlock As AcadBlock
Dim objBlock1 As AcadBlock
Dim colBlocks As AcadBlocks
Dim objArray(0) As Object
Dim v As Variant
Dim oldname As String

' NN = InputBox("Enter new block name :", "Create New Block", "1")
' On Error GoTo Err_Control
thisdrawing.SetVariable "DELOBJ", 1
On Error GoTo Err_Control:
'Thisdrawing.Utility.GetEntity oEnt, varPt, "Select block: "
Set entity = get_entity("Select block", "acdbblockreference", v)
If entity Is Nothing Then Exit Sub
Dim sourcedoc As AcadDocument
Set sourcedoc = application.activedocument
Dim TEMPDOC As AcadDocument

If TypeOf entity Is AcadBlockReference Then
Set oBlkRef = entity
oldname = oBlkRef.effectivename
BNAME = oBlkRef.effectivename
BNAME = BLOCK_NAME_UNIQUE(BNAME)
If interactiv Then
BNAME = InputBox("New block name is: ", "BLOCKCOPY", BNAME)
End If
insVpt = oBlkRef.insertionPoint
For J = 0 To UBound(insVpt)
inspt(J) = insVpt(J)
Next

For Each oBlock In thisdrawing.BLOCKS
If oBlock.name = BNAME Then
MsgBox "Block " & BNAME & " does already exist" & _
vbNewLine & "Exit program"
Exit Sub
End If
Next
Debug.Print
Dim S As String
S = REPLACE(Now(), ".", "")
S = REPLACE(S, " ", "")
S = REPLACE(S, ":", "")

'temp document
fileName = GetTmpPath() & "temp" & S & ".dwg"
If Not FileExists(fileName) Then Call document_create(fileName)
Dim ACDbx As Object
Set ACDbx = AINTERFACE.IDoc()
ACDbx.Open fileName
Set TEMPDOC = application.activedocument

'remove old definition if exist
Set colBlocks = ACDbx.BLOCKS
For Each objBlock In colBlocks
If objBlock.name = BNAME Then
objBlock.DELETE
If interactiv Then MsgBox "OLD TEMP BlockDef " & BNAME & "FOUND and deleted"
End If
Next

'COPY TO TEMPFILE
application.activedocument = sourcedoc
Set colBlocks = thisdrawing.BLOCKS
Set objBlock = colBlocks.ITEM(oldname)
If BNAME = "" Then Exit Sub
objBlock.name = BNAME
Set objArray(0) = objBlock
R = thisdrawing.CopyObjects(objArray, ACDbx.modelspace)
objBlock.name = oldname
ACDbx.SaveAs fileName

'RELOAD FROM TEMPFILE
ACDbx.Open fileName

For Each objBlock In ACDbx.BLOCKS
If objBlock.name = BNAME Then
If interactiv Then say "Block " & BNAME & "FOUND"
Set objArray(0) = objBlock 'Create object array as required by the CopyObjects Method
ACDbx.CopyObjects objArray, thisdrawing.BLOCKS
If interactiv Then say "Block " & BNAME & "COPY"
End If
Next

Dim blockref As AcadBlockReference

Dim SNAME As String

'sname = SLOPEDIR.BLK & "\posid.dwg"
If interactiv Then
If get_POINT("Insertation point of new block : " & BNAME, varpt) Then
Set oBlkRef = block_insert(varpt, BNAME, 1#, 1#, 1#, 0#)
End If
End If

'############################

End If
'############################
Err_Control:
If err.Number = 0 Then
say "Done"
Else
Debug.Print err.DESCRIPTION
End If
End Sub

------------------
Wer es nicht versucht, hat schon verlorn
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP