Jump to content

vba Insert Block Specify on screen


smr

Recommended Posts

Hi all

I am trying to insert a block from a known file location into a drawing using a AutoCAD menu button to load a vba code

I have successfully done this but I can only have the block inserted at coordinates that are either entered by the user on the keyboard or set in the code.

I am looking to have it be selectable by the user by clicking the mouse with it floating on the cursor (ie Specify on-screen) basically like what happens when you insert a block.

If anyone can help that would be great.

code attached fyi

code.txt

Link to comment
Share on other sites

Object methods in VBA is not implemented

You can only use Lisp expression

SendCommand and functions:

 

Option Explicit

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Function IsBlockExist(bName As String) As Boolean

  Dim oBlock As AcadBlock
  IsBlockExist = False
  For Each oBlock In ThisDrawing.Blocks
  If StrComp(oBlock.Name, bName, vbTextCompare) = 0 Then
  IsBlockExist = True
  End If
  Next

End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Function IsLayerExist(lName As String) As Boolean

  Dim oLayer As AcadLayer
  IsLayerExist = False
  For Each oLayer In ThisDrawing.Layers
  If StrComp(oLayer.Name, lName, vbTextCompare) = 0 Then
  IsLayerExist = True
  End If
  Next

End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Sub InsertWithGhostImage()

    Dim blkName As String, layName As String

    Dim strPt As String, comStr As String

    blkName = InputBox(vbCrLf & "Block name to insert:", "Insert Block")

    If blkName = vbNullString Then Exit Sub

    If Not IsBlockExist(blkName) Then
    MsgBox "Block " & Chr(34) & blkName & Chr(34) & " does not exist"
    Exit Sub
    End If

    layName = InputBox(vbCrLf & "Layer name to insert block on:", "Insert Block", "0")

    If Not IsLayerExist(layName) Then
    MsgBox "Layer " & Chr(34) & layName & Chr(34) & " does not exist"
    Exit Sub
    End If

    With ThisDrawing

         On Error GoTo Err_Control
         .Utility.Prompt vbCrLf & "   Specify insertion point of block  >>"
         comStr = "(command " & _
                  Chr(34) & "._-insert" & Chr(34) & _
                  vbCr & Chr(34) & blkName & _
                  Chr(34) & " pause " & vbCr & _
                  Chr(34) & "1" & Chr(34) & _
                  vbCr & Chr(34) & "1" & Chr(34) & _
                  vbCr & Chr(34) & "0" & Chr(34) & ")"
                  .SendCommand comStr & vbCr

         DoEvents

         Dim oSpace As AcadBlock
         Dim oblkRef As AcadBlockReference
         If .ActiveSpace = acModelSpace Then
              Set oSpace = .ModelSpace
         Else
              Set oSpace = .PaperSpace
         End If
         Set oblkRef = oSpace.Item(oSpace.Count - 1)

    End With

Exit_Here:

    Exit Sub

Err_Control:

    MsgBox Err.Description
    Resume Exit_Here

End Sub



Code is taken from here http://forum.dwg.ru/showthread.php?t=23161

Link to comment
Share on other sites

Thank you for your reply’s

 

I have managed to make this work by calling a LISP expression from the CUI menu macro button

I think it is more of a work around but works for what I need it to do

 

LISP command is:

 

(defun c:sa ()

; moves block that was just inserted

(command "move" "l" "" "0,0,0" "pause")

(princ)

)

 

CUI menu macro command is

 

^C^C-vbarun SMR_CableLadder.dvb!Module1.CableLadderMenu^C^C_sa

 

This loads my vba user form for cable ladder (I then select what I need)

It inserts it @ 0,0,0 in the current drawing

Then calls the “SA” lisp move command which moves the last inserted block

 

Simples

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...