AutoCAD VBA - Drawing Move to Origin

[senuba]

Hello everyone. I have a drawing inside AutoCAD (2021), which is not a block. I want to move this drawing to the origin point, or I want to move the origin to one of the corners of the drawing. I couldn't achieve either of these using VBA. I would appreciate your assistance. Thank you in advance

[Steven P]

Is it a single drawing? In which case it is probably a lot quicker just to do it, no LISP, however if you have many drawings that could be more efficient with a LISP

 

Is the drawing something like an xref or is it entities, lines and so on within the drawing itself?

 

Can you post a sample drawing of what you want to do?

[senuba]

13 minutes ago, Steven P said:

Is it a single drawing? In which case it is probably a lot quicker just to do it, no LISP, however if you have many drawings that could be more efficient with a LISP

 

Is the drawing something like an xref or is it entities, lines and so on within the drawing itself?

 

Can you post a sample drawing of what you want to do?

 

I am sending an example as an attachment. There is only one drawing in a single file. For example, I want to move the origin to the bottom left corner. Or I want to move the entire drawing so that the bottom left corner is at the origin.

I can get the drawing area with VBA. I can find the maximum and minimum values, as the leftmost point on the x-axis, the rightmost point on the x-axis, the bottommost point on the y-axis, and the topmost point on the y-axis, respectively, in the variables (minExtX, minExtY, maxExtX, maxExtY) relative to the origin. I want to move the point at minExtX and minExtY to the origin. (Or I want to move the drawing so that the minExtX and minExtY points are at 0,0.)

example.DWG

[Steven P]

So, if you look at the AutoCAD command copyclip and pasteclip, this will paste the copied entities and and for the insertion point this will be the most left entity and the bottom entity (bottom left corner) without the need to calculate the drawing limits. This should make it easier..

 

Try this, the command is 'Move 0-0' (or M00 )

 

(defun c:M00 ( / MySS)
  (command "undo" "end")         ; clear undo marker, Simplest undo function used
  (command "undo" "begin")       ; set undo marker
  (setq MySS (ssget "_X"))       ; Select everything 
  (command "copyclip" MySS "")   ; copy everything to the clip board. By default insert point is lower left corner
  (command "pasteclip" '(0 0 0)) ; paste everything as a copy
  (command "erase" MySS "")      ; delete original entities... after pasting just in case paste goes all wrong
  (command "undo" "end")         ; clear undo marker
); end defun

 

 

If I haven't understood this quite right post your code as you have it with a couple of notes what you are doing and will see if we can modify that

[SLW210]

You posted your thread in the LISP Forum, but inquired about VBA. Which do you want?

[BIGAL]

My $0.05

 

:Move
Select entities to move: 
Opposite Corner: 
Entities in set: 47
Select entities to move: Enter
Enter base point [Displacement] <Displacement>:(getvar 'extmin)
(-245.13133939846 -595.107261489551 0.0)
Enter base point [Displacement] <Displacement>:
Enter second point <Use base point as displacement>:0,0

 

[senuba]

On 10/6/2023 at 6:41 PM, SLW210 said:

You posted your thread in the LISP Forum, but inquired about VBA. Which do you want?

 

I just realized I opened this in "LISP". I apologize. Can you move the topic? I am looking for a solution with VBA.

[SLW210]

Moved to VBA Forum.

[Danielm103]

This is Python, but it's ActiveX, so you should be able to follow along

#AXDBLib.AxDbDocument
def PyRxCmd_doit():
    try:
        dbx = AxUt.getDbx()
        dbx.Open("e:\\example.dwg")
        
        minpt = (99999,99999,99999)
        
        ent : Ax.IAcadEntity
        for ent in dbx.ModelSpace:
            minmax = ent.GetBoundingBox(None,None)
            minpt = min(minmax[0],minpt)
        
        for ent in dbx.ModelSpace:
            ent.Move(minpt,(0,0,0))
            
        dbx.SaveAs("e:\\example2.dwg")
        
    except Exception as err:
        traceback.print_exception(err)
        

 

[senuba]

15 hours ago, Danielm103 said:

This is Python, but it's ActiveX, so you should be able to follow along

#AXDBLib.AxDbDocument
def PyRxCmd_doit():
    try:
        dbx = AxUt.getDbx()
        dbx.Open("e:\\example.dwg")
        
        minpt = (99999,99999,99999)
        
        ent : Ax.IAcadEntity
        for ent in dbx.ModelSpace:
            minmax = ent.GetBoundingBox(None,None)
            minpt = min(minmax[0],minpt)
        
        for ent in dbx.ModelSpace:
            ent.Move(minpt,(0,0,0))
            
        dbx.SaveAs("e:\\example2.dwg")
        
    except Exception as err:
        traceback.print_exception(err)
        

 

 

Sub DoIt()
    On Error GoTo ErrorHandler
    
    Dim dbx As Object
    Dim doc As Object
    Dim minpt(0 To 2) As Double
    Dim ent As Object
    Dim minmax As Variant
    Dim i As Integer

    Set doc = ThisDrawing.Application.Documents.Add

    Set dbx = doc.modelSpace

    ThisDrawing.Application.Documents.Open ("d:\example.dwg")

    For i = 0 To 2
        minpt(i) = 99999
    Next i

    For Each ent In dbx
        minmax = ent.GetBoundingBox
        For i = 0 To 2
            If minmax(i) < minpt(i) Then
                minpt(i) = minmax(i)
            End If
        Next i
    Next ent

    For Each ent In dbx
        ent.Move minpt, Array(0, 0, 0)
    Next ent

    dbx.SaveAs "e:\example2.dwg"

    MsgBox "Its okay."
    
ExitSub:
    Exit Sub
    
ErrorHandler:
    MsgBox "Error: " & Err.Description
End Sub

 

 

I converted it this way, but I still couldn't achieve what I wanted

Edited October 10, 2023 by senuba

[senuba]

If you could just provide me with the VBA code for the 'Move' command, that would be sufficient. I haven't been able to find it anywhere. I can determine how far an object is from the origin, but I just can't move it

[Danielm103]

Sorry, unfortunately I don’t have VBA

It looks like you’re really close though.

 

It looks like to me you’re working with the wrong document.

You need to be working with the model space from the document you just opened

 

Give a Man a Fish, and You Feed Him for a Day. Teach a Man To Fish, and You Feed Him for a Lifetime

 

 

 

Edited October 10, 2023 by Danielm103
typo

[senuba]

14 minutes ago, Danielm103 said:

Sorry, unfortunately I don’t have VBA

It looks like you’re really close though.

 

It looks like to me you’re working with the wrong document.

You need to be working with the model space from the document you just opened

 

Give a Man a Fish, and You Feed Him for a Day. Teach a Man To Fish, and You Feed Him for a Lifetime

 

 

 

 

You're right. I had been trying for 2 weeks, and it wasn't working. But I think I caught the fish

[senuba]

 

I'm writing the complete code just in case it's useful for someone

 

 

Sub MoveEntities()
    On Error Resume Next
    Dim doc As Object
    Dim db As Object
    Dim modelspace As Object
    Dim entity As Object
    Dim basePoint(2) As Double
    Dim displacement(2) As Double

    Set doc = ThisDrawing
    Set db = doc.Database
    Set modelspace = db.modelspace

    basePoint(0) = 0 ' X 
    basePoint(1) = 0 ' Y 
    basePoint(2) = 0 ' Z 
    
    displacement(0) = 300 ' deltaX is changable

    displacement(1) = 500  ' deltaY  is changable
    displacement(2) = 0  'deltaZ is changable

    For Each entity In modelspace
        If entity.ObjectName = "AcDbLine" Or entity.ObjectName = "AcDbCircle" Then
            entity.Move basePoint, displacement
        End If
    Next entity
    doc.SendCommand "_regen" & vbCr
    Set doc = Nothing
    Set db = Nothing
    Set modelspace = Nothing
    Set entity = Nothing
End Sub

 

Edited October 10, 2023 by senuba

[SLW210]

Thanks for posting the solution!