社区 › Auto Lisp › vba插入块在sc上指定

smr 发表于 2022-7-6 21:51:29

vba插入块在sc上指定

大家好
我试图使用AutoCAD菜单按钮将已知文件位置的块插入到图形中，以加载vba代码
我已经成功地做到了这一点，但我只能在用户在键盘上输入或在代码中设置的坐标处插入块。
我希望它可以由用户选择，通过点击鼠标，它浮动在光标上（即指定在屏幕上），基本上就像你插入一个块时发生的事情。
如果有人能帮忙，那就太好了。
代码随附仅供参考
密码txt文件

maratovich 发表于 2022-7-6 22:08:34

VBA中的对象方法未实现
只能使用Lisp表达式
send命令和功能：
 

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




代码取自此处http://forum.dwg.ru/showthread.php?t=23161

BIGAL 发表于 2022-7-6 22:21:50

这在菜单中可能很有用，但拖动可能是您想要的^C^C-INSERT P:/AUTODESK/LISP/SETOUT拖动

smr 发表于 2022-7-6 22:50:04

谢谢你的回复
 
通过从CUI菜单宏按钮调用LISP表达式，我成功地实现了这一点
我认为这更像是一种变通方法，但对我需要做的事情有效
 
LISP命令是：
 
（定义c:sa（）
; 移动刚插入的块
（命令“move”“l”“0,0,0”“pause”）
（普林斯）
)
 
CUI菜单宏命令为
 
^C^C-vbarun SMR\U电缆梯架。dvb！模块1.CableLadderMenu^C^C_sa
 
这将加载电缆梯架的vba用户窗体（然后选择所需内容）
将其插入当前图形中的@0,0,0
然后调用“SA”lisp move命令，移动最后插入的块
 
简单

SLW210 发表于 2022-7-6 22:52:38

请阅读代码发布指南，并编辑代码以包含在代码标签中。
Your Code Here=
Your Code Here

查看完整版本: vba插入块在sc上指定