【转贴】CAD_VBA基本问题

Kye

转贴,感谢原贴作者

http://www.xipick.com/forum.php? ... ge=1&authorid=1
其实很多在明经可以搜到，但确实有些也搜不到了
------------------------------------------------------------------------------------------------------------------------

1.请问VBA写的宏，可否编译成象ARX一样的程序，经加载后，在命令行打入命令后就可运行
不行，必须自己写LISP加载和运行
2.为什么在VB中可以生成可执行文件，而在VBA中却不行?
如果在VBA中能生成可执行文件，请问是怎样做的，不胜感激！！
VBA是不行，它只能内嵌于AutoCAD中运行，你可以将代码改在VB下用
3.自动加载执行VBA程序
你可以试试以下LSP函数。它与autoload的LSP函数功能一样，只要你按照它的要求写入你的执行命令名、DVB文件名及宏名就可以自动加载执行，再也不用专门写LSP程序了。
(defun AutoVBALoad (cmdname project macro)
    (eval
       (list 'defun
          (read (strcat "C:" cmdname))
          nil
          (list  
             'vl-vbarun  
             (strcat  
                project "!"  
                (if macro macro cmdname)
             )
          )
          (princ)
       )
    )
)
你把函数复制到acad2000doc.lsp文件中，以后每写一个VBA程序，就可以通过写入一行：
(AutoVBALoad <命令名> <工程文件> <宏>)
来自动调用，示例如下：
命令名为update，工程文件为myproject.dvb，模块为Foo，宏为Bar，则写为：
(AutoVBALoad "UPDATE" "MyProject.dvb" "Foo.Bar")
如果宏的位置在ThisDrawing中，则写为：
(AutoVBALoad "UPDATE" "MyProject.dvb" "Bar")
是不是很方便。
4. 当我想添加commondialog控件时，总是无法添加，并提示：没有正确授权。（是不是我用的D版AutoCad2000的原因）。
经过重装vb6,已经可以添加commondialog控件了。
5.有时文字是从别的图中复制-粘贴的,如果不打破的话,能否直接得到文字内容.
GetSubEntity 方法
它可以直接取得图元或嵌套图元的信息，取得后你就可以随便对其进行读取或更改。
语法：
object.GetSubEntity Object, PickedPoint, TransMatrix, ContextData[, Prompt]
样例：
Sub Example_GetSubEntity()
     ' This example prompts the user to select on object on the screen with a mouse click,
     ' and returns some information about the selected object.
     Dim Object As Object
     Dim PickedPoint As Variant, TransMatrix As Variant, ContextData As Variant
     Dim HasContextData As String
     
     On Error GoTo NOT_ENTITY      
TRYAGAIN:
     MsgBox "Use the mouse to click on an entity in the current drawing after dismissing this dialog box."
     ' Get information about selected object
     ThisDrawing.Utility.GetSubEntity Object, PickedPoint, TransMatrix, ContextData
     ' Process and display selected object properties
     HasContextData = IIf(VarType(ContextData) = vbEmpty, " does not ", " does ")
     MsgBox "The object you chose was an: " & TypeName(Object) & vbCrLf & _
             "Your point of selection was: " & PickedPoint(0) & ", " & _
                                               PickedPoint(1) & ", " & _
                                               PickedPoint(2) & vbCrLf & _
             "This object" & HasContextData & "have nested objects."
     Exit Sub
6. 想必河伯对Excel/ActiveX有研究, 能否请教如何获得Excel文件最后一行的信息?
可以用CurrentRegion属性计算最后一行
CurrentSheet.Range("A1").Activate
SheetRows = ExcelApp.ActiveCell.CurrentRegion.Rows.Count '有效数据行数

7. 如何调用vba命令对多义线进行fit(拟合)处理
直接用SendCommand方法，调用命令进行编辑
8. 块属性值编辑
Public Sub GetAttribute()
     '本段代码从选中的图块中获取属性值，并对其修改
    Dim entObj As AcadEntity
     Dim pickPnt As Variant
     Dim blkRefObj As AcadBlockReference
     '选择图元
    ThisDrawing.Utility.GetEntity entObj, pickPnt  
     '判断是否为块引用
    If StrComp(entObj.ObjectName, "AcDbBlockReference", 1) <> 0 Then
         MsgBox "你选择的不是一个图块，程序将退出！"
         '如果选择的不是一个块引用则程序退出运行
        Exit Sub
     End If
     '如果选择的是块引用，将其赋给块引用对象
    Set blkRefObj = entObj
     '判断该块引用是否含有属性值
    If Not blkRefObj.HasAttributes Then
         MsgBox "你选择的图块没有块属性，程序将退出！"
         '如果不含由属性值退出
        Exit Sub
     End If
     Dim attVars As Variant
     Dim I As Integer
     '获取块引用中的块属性对象
    attVars = blkRefObj.GetAttributes
     '对块属性对象进行遍历
    For I = 0 To UBound(attVars)
         MsgBox "第" & I + 1 & "属性对象的属性值分别如下：" & Chr(13) & Chr(13) & _
                "属性标签为：" & attVars(I).TagString & Chr(13) & _
                "属性值为  ：" & attVars(I).TextString
     Next
     '将块属性的标签和值进行修改
    attVars(0).TagString = "New Tag"
     attVars(0).TextString = "New Value"
     ThisDrawing.Regen True
End Sub
9.如何用程序控制对象捕捉
通过设置系统变量“osmode”来控制
10. 如何从VBA到VB？
在VB里，首先要获得Application对象，再获取Document对象，把VBA中的ThisDrawing对象设置成该Document对象即可，这样，你开发出来的程序就可以融入VB的强大功能了。
11.IntersectWith 方法
获取图中一个对象与另一对象的交点
语法
RetVal = object.IntersectWith(IntersectObject, ExtendOption)
参数
Object 该方法适用于所有图形对象 (除了Pviewport和PolygonMesh)
IntersectObject 对象，为输入项; 该对象可以是所有图形对象中的任一个。
ExtendOption AcExtendOption 枚举数; 为输入项
该选项指定两个对象是否通过延伸一个或两个或没有延伸来取得相交点。
acExtendNone 均无延伸。
acExtendThisEntity 延伸源对象。
acExtendOtherEntity 延伸作为参数传递的对象。
acExtendBoth 两个对象均延伸。
RetVal(返回值) 变体或双精度数组，返回图形中一个对象和另一对象相交的点的数组。
490
12.绘制多边形并显示多边形顶点坐标
Sub polygon()
'以下语句绘制正多边形
    Dim num As Integer
     Dim pnt As Variant
     Dim lpnt As Variant
     num = ThisDrawing.Utility.GetInteger("请选择正多边形的边数：")
     Dim fpnt As Variant
     fpnt = ThisDrawing.Utility.GetPoint(, "请选择正多边形的起点：")
     Dim leng As Double
     leng = ThisDrawing.Utility.GetDistance(fpnt, "请选择正多边形的边长：")
     ReDim lpnt(0 To num * 2 - 1) As Double
     pnt = fpnt
     lpnt(0) = pnt(0)
     lpnt(1) = pnt(1)
     Dim st As Integer
     For st = 1 To num - 1
         pnt = ThisDrawing.Utility.PolarPoint(pnt, (3.14159265 * 2 / num) * (st - 1), leng)
         lpnt(st * 2) = pnt(0)
         lpnt(st * 2 + 1) = pnt(1)
     Next st
     Dim pgon As AcadLWPolyline
     Set pgon = ThisDrawing.ModelSpace.AddLightWeightPolyline(lpnt)
     pgon.Closed = True
     ThisDrawing.Regen (True)
'以下语句获取多边形的顶点
    Dim gpnt As Variant
     gpnt = pgon.Coordinates
     Dim pntcnt As Integer
     pntcnt = UBound(gpnt)
     Dim disptxt As String
     disptxt = "多边形共有" & (pntcnt + 1) / 2 & "个顶点" & vbCrLf
     Dim i As Integer
     For i = 0 To pntcnt - 1 Step 2
         disptxt = disptxt & "第" & i / 2 + 1 & "个顶点的坐标为:" & _
                 gpnt(i) & "," & gpnt(i + 1) & vbCrLf
     Next i
     disptxt = disptxt & "明经通道VBA示例 http://www.mjtd.com"
     MsgBox disptxt, , "多边形的坐标显示"
End Sub
13.Private Sub AcadDocument_BeginDoubleClick(ByVal pPoint As Variant)
MsgBox "图上双击坐标位置" & vbCrLf & pPoint(0) & vbCrLf & _
    pPoint(1) & vbCrLf & pPoint(2)
Open "MyTest.txt" For Output Access Write As #1
Print #1, Format(pPoint(0), "0.000"), Format(pPoint(1), "0.000"),_
    Format(pPoint(2), "0.000")
Close #1
End Sub
上面的程序只能实现将坐标输出一次，而第二次双击时，会将第一次的坐标值覆盖，有什么办法可以实现连续点选输出而不覆盖吗？？？？？？
Open 语句的Output改为Append即可
14. 现有Handpoint = acadApp.ActiveDocument.Utility.GetPoint(, "请输入套料的插入点")
希望用户在捕捉点或输入点坐标动作时，如何避免用户因其他操作如缩放、PAN引起的系统报错
可以加一段以下语句：
on error goto errHandle
Handpoint = acadApp.ActiveDocument.Utility.GetPoint(, "请输入套料的插入点：")
errhandle:
if Err.Number=-2147352567 then
Err.Clear
resume
end if
15.在VBA中如何传送一个参数给Vlisp?
如:在VBA中A = "123" , 要把VBA中A的值赋给Vlisp中的B。
用sendcommand可以做到
如:
Sub valuetolisp()
     Dim a As Integer
     a = 123
     ThisDrawing.SendCommand "(setq b " & a & ") "
End Sub
如果不想命令行回显，则可以用VLAX控制。
16.请问在VBA中如何修改属性块中属性的textstring的对齐方式，谢了。
与Text一样，属性块也有HorizontalAlignment属性
P487
17.我想知道vb中的那个函数或者对象的方法可以代替在cad中按esc键取消命令
谢谢
SendCommand("")或SendCommand(Chr(27))


18点击菜单项就在该菜单上打对号是怎么实现的?
菜单项标签中可包括叹号和句号 (!.)，从而在菜单项前打上复选标记。虽然打标记的项可以被禁用，但标记一个菜单项不会使用户不能选择该项。
在下例中，Line 菜单项被打上标记。
[!.Line]
用 DIESEL 来标记标签
菜单项标签中可以包含 DIESEL 字符串表达式，用于判断在每次显示时，是否标记该标签。在下例中，如果与菜单标签相关的系统变量当前可用，则在该标签左边打上复选标记。
[$(if,$(getvar,orthomode),!.)Ortho]^O
[$(if,$(getvar,snapmode),!.)Snap]^B
[$(if,$(getvar,gridmode),!.)Grid]^G
19图层间图形实体的移动？请问各位高手：在AutoCAD VBA中怎样通过程序实现
将一图层中的图形实体移到另一图形的图层上去
文档之间复制对象
CopyObjects方法是一个非常有用的工具。这里我们看看它是怎样在图形间复制对象。首先准备两个文档。在一个文档中，创建一些对象。如果另一个文档的名称不是Drawing1.dwg，可修改以下程序中的文档名称为你的图形名称。最后，确定激活包含有要复制对象的图形并运行以下宏，这样可以将本文档中的对象复制到名称为Drawing1.dwg的另一个文档中。
Dim ss As AcadSelectionSet, doc As AcadDocument
Set doc = ThisDrawing.Application.Documents("Drawing1.dwg")
Set ss = CreateSelectionSet
ss.SelectOnScreen
ThisDrawing.CopyObjects ssArray(ss), doc.ModelSpace

20请问版主，如何实时获得当前光标的X，y，z坐标值，如同状态栏上显示坐标值
我只会在autolisp中用(grread)函数, objectarx俺不懂。
21可以设置图块中的块属性值，如内
Public Sub SetAttribute()
     Dim pickPnt As Variant
     Dim blkRefObj As AcadBlockReference
      
     '选择图元,此段你可以直接将blkRefObj设为你刚插入的块
    ThisDrawing.Utility.GetEntity blkRefObj, pickPnt

     '判断该块引用是否含有属性值
    If Not blkRefObj.HasAttributes Then
         MsgBox "你选择的图块没有块属性，程序将退出！"
         '如果不含由属性值退出
        Exit Sub
     End If  
     Dim attVars As Variant
     Dim I As Integer  
     '获取块引用中的块属性对象
    attVars = blkRefObj.GetAttributes
     '对块属性对象进行遍历
    For I = 0 To UBound(attVars)
     '将块属性的值进行修改
    If attVars(I)="mccad" Then
         attVars(I).TextString = "明经通道"
     End If  
     Next
     ThisDrawing.Regen True   
End Sub
22我的选择集中有Block和PLine,我想能使用该函数
    ThisDrawing.Application.ZoomCenter Center, Magnify
Center这个点取Block的中心点或者Pline的中心点,但是不知道该怎么取这个值,高手帮帮忙吧!!!
Dim minExt As Variant
     Dim maxExt As Variant     
     If ssetobj.Item(Me.MSHFlexGrid1.Row - 1).ObjectName = "AcDbBlockReference" Then
             ThisDrawing.Application.ZoomCenter ssetobj.Item(Me.MSHFlexGrid1.Row - 1).InsertionPoint, 40
         Else
              ssetobj.Item(Me.MSHFlexGrid1.Row - 1).GetBoundingBox minExt, maxExt
              ThisDrawing.Application.ZoomWindow minExt, maxExt
              ThisDrawing.Application.ZoomScaled 0.5, acZoomScaledRelative
     End If
23我的机器里装有cad14和cad2000,用vb写了一个程序调用cad,如何让程序每次都调用cad2000呢?
Set acadApp = GetObject(, "AutoCAD.Application.15")
24我只是想判断一下
因为我想画一条多段线，就要用到多个Getpoint，但是我不知道具体要话多少段，只是联系两点的线，我觉得如果可以象autocad里面画线那样就可以了阿
我现在是在画地理图上面的电线，是折线嘛！
然后捕捉错误来退出while。
对于取得的点可以通过数组来保存，而数组也可以用redim来重新定义
25SendCommand "_line" 没有返回值,怎么知道是否添加了line
在使用该方法前及后看看数据库中最后一个对象是否相同


26为什么修改文 字的对方正式后辩证文字会移回到零点？
在设置了文字的对齐方式（Alignment）后，应该用文本对齐位置（TextAlignmentPoint）重新指定对齐点,否则缺省（即默认）的对齐点为原点。
因为不同的文字方式文字的插入点会有所不同,所以必须计算文字插入点后,一同修改.
27删除块前，应先删除块的引用，怎样查找块的引用？（VBA）
函数如下：
'删除块引用
Public Sub DeleteBlockRef(ByVal Name As String)
     Dim EntObj As AcadEntity
     
     On Error GoTo ErrTrap
     If Name = "" Then Exit Sub
     For Each EntObj In ThisDrawing.ModelSpace
        If StrComp(EntObj.ObjectName, "AcDbBlockReference", vbTextCompare) = 0 Then
           If StrComp(EntObj.Name, Name, vbTextCompare) = 0 Then
              EntObj.Delete
           End If
        End If
     Next
     Set EntObj = Nothing
     Exit Sub
ErrTrap:
     If Not (EntObj Is Nothing) Then Set EntObj = Nothing
     On Error GoTo 0
End Sub
28使用ADO的方法如何存取ACCESS数据库?
ADO数据库读取有很多办法，在这告诉你一个比较简单的。
Dim db As Database  '在ACAD VBA中，ACAD图形数据库也用Database类，你须在工程中引用Microsoft DAO 3.51 Object Library库，并将其优先级提高到仅次于AutoCAD类型库。
Dim rst As Recordset 'rst为数据库记录集对象
Set db=DBEngine.Workspaces(0).OpenDatabase(FileName) 'FileName为你的*.mdb数据库文件名(全路径)。
Set rst = db.OpenRecordset("SELECT * FROM Table1;")  'Table1为数据库的表名。
此后，你可以用rst.MoveFirst,rst.MoveNext,rst.MoveLast等方法移动记录指针，用rst.Fields(FieldsName).Value获取FieldsName字段的内容。
不知道是否已明白你的意图，ADO连接方法：
Dim cn As Connection
Set cn = New Connection
cn.CursorLocation = adUseClient
cn.Open "PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source=" &_
         YourMdbPathName
Dim cmd As New ADODB.Command
Set cmd.ActiveConnection = cn
cmd.CommandText = YourSQLString
Dim rst As New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.Open cmd,adOpenStatic,adLockBatchOptimistic
29在Mtext的文字內容中，原始數據的1項為文字內容，但有時會包含一些格式：如(1 . "\\A1;Here),(1 . "\\C2;There).....等等，我知道，\\p是換行，\\c是表顏色，但\\a就不知道，哪位可提供詳細的全部資料，或以從哪里可得到？先謝了
格式化多行文字
\O...\o 打开或关闭上划线
\L...\l 打开或关闭下划线
\~ 插入不断开空格
\\ 插入反斜杠
\{...\} 插入开始或结束大括号
\F文件名 更改为指定的字体文件
\H值; 按图形单位更改文字高度
\H值x; 更改文字高度为当前文字高度的倍数
\S...^...; 堆叠在\u12289、#或^符号后的文字
\T值; 从0.75到4倍之间调整字符的间隔
\Q角度; 更改倾斜角度
\W值; 更改宽度因子以产生较宽的文字
\A值; 设置对齐值；有效值如下： 0(底对齐)、1(中间对齐)、2(顶对齐)
\P 换行
30如何将类似 ".5"数值改为"0.5"显示
在VB中可直接用Format函数。
如：保存小数点后两位，可以用Format(1.23456,".00")=1.23，
如果点号之前补零的话，只要Format(0.23456,"0.00")=0.23。
31请问，如何将图上所有的数字（成千上万个数值）减去同一个常数？
这段程序提示你选择文本，然后指定增量，正的就是加，负的就是减了。如果选中的文本是数字的，那么就对它进行加或减处理。
Sub Test()
     Dim SSetObj As AcadSelectionSet
     Dim bFound As Boolean
     Dim IncreaseValue As Double
     Dim i As Integer
     
     On Error GoTo ErrTrap
     For Each SSetObj In ThisDrawing.SelectionSets
         If SSetObj.Name = "ChangeText" Then
             bFound = True
             Exit For
         End If
     Next
     If bFound = False Then
         Set SSetObj = ThisDrawing.SelectionSets.Add("ChangeText")
     Else
         Set SSetObj = ThisDrawing.SelectionSets("ChangeText")
         SSetObj.Clear
     End If
     SSetObj.SelectOnScreen
     If SSetObj.Count = 0 Then Exit Sub
     IncreaseValue = ThisDrawing.Utility.GetReal("指定数值增量: ")
     For i = 0 To SSetObj.Count - 1
         If TypeOf SSetObj(i) Is AcadText Or TypeOf SSetObj(i) Is AcadMText Then
             If IsNumeric(SSetObj(i).TextString) Then
                 SSetObj(i).TextString = SSetObj(i).TextString + IncreaseValue
             End If
         End If
     Next
     SSetObj.Delete
     Set SSetObj = Nothing
     Exit Sub
     
ErrTrap:
     If Not (SSetObj Is Nothing) Then Set SSetObj = Nothing
     On Error GoTo 0
End Sub
475
32想写一个批量插入文件的程序，能调用所需用到的电子地图，以简化工作（不需要一幅一幅的进行插入），但不知道从哪里开始着手，请教高人指点！！
多DWG文件选择及选择整个目录下的DWG文件进行插入的例子如内
首先工程中必须使用“CommonDialog-在VBA中使用的公用对话框模块”，见以下链接： http://www.mjtd.com/mcdown/list.asp?id=83 开始工程前应输入CommonDialog.cls文件及modConstants.bas文件。程序如下： '通过选定多个图形文件插入到图形中的过程 Sub IntBlkBySelectDwg() On Error GoTo Err_Control Dim BlkFile As Variant Dim i As Integer Dim InstPnt As Variant Dim BlkRefObj As AcadBlockReference Dim varCancel As Variant BlkFile = getFileBySelect("选择图形：", "dwg", "AutoCAD图形文件(*.dwg)|*.dwg") If IsArray(BlkFile) Then     ThisDrawing.Utility.Prompt vbCrLf & " 你选定了" & Str(UBound(BlkFile) + 1) & "个图形"     For i = 0 To UBound(BlkFile)                  InstPnt = ThisDrawing.Utility.GetPoint(, vbCrLf & " 请选择图形 " & JustFileName(BlkFile(i)) & " 的插入点：")         Set BlkRefObj = ThisDrawing.ModelSpace.InsertBlock(InstPnt, _                         BlkFile(i), 1#, 1#, 1#, 0#)     Next End If Exit_Here:   Exit Sub Err_Control:   Select Case Err.Number     Case -2147352567       varCancel = ThisDrawing.GetVariable("LASTPROMPT")       If InStr(1, varCancel, "*Cancel*") <> 0 And InStr(1, varCancel, "*取消*") <> 0 Then         Err.Clear         Resume Exit_Here       Else         Err.Clear         Resume       End If     Case -2145320928       Err.Clear       Resume Exit_Here     Case Else       Resume Exit_Here   End Select End Sub '通过选定整个目录中的图形文件插入到图形中的过程 Sub IntBlkByDirDwg() On Error GoTo Err_Control Dim BlkFile As Variant Dim i As Integer Dim InstPnt As Variant Dim BlkRefObj As AcadBlockReference Dim varCancel As Variant BlkFile = GetDir("选择要插入图形所在的目录：", "*.dwg") If IsArray(BlkFile) Then     ThisDrawing.Utility.Prompt vbCrLf & " 你选定了" & Str(UBound(BlkFile) + 1) & "个图形"     For i = 0 To UBound(BlkFile)                  InstPnt = ThisDrawing.Utility.GetPoint(, vbCrLf & " 请选择图形 " & JustFileName(BlkFile(i)) & " 的插入点：")         Set BlkRefObj = ThisDrawing.ModelSpace.InsertBlock(InstPnt, _                         BlkFile(i), 1#, 1#, 1#, 0#)     Next End If Exit_Here:   Exit Sub Err_Control:   Select Case Err.Number     Case -2147352567       varCancel = ThisDrawing.GetVariable("LASTPROMPT")       If InStr(1, varCancel, "*Cancel*") <> 0 And InStr(1, varCancel, "*取消*") <> 0 Then         Err.Clear         Resume Exit_Here       Else         Err.Clear         Resume       End If     Case -2145320928       Err.Clear       Resume Exit_Here     Case Else       Resume Exit_Here   End Select End Sub '选定多个文件的函数，使用了CommonDialog类 Public Function getFileBySelect(DialogTitle, DefaultExt, Filter) As Variant Dim dlg As CommonDialog Dim Files As Variant Dim i As Integer Set dlg = New CommonDialog With dlg     .DialogTitle = DialogTitle     .DefaultExt = DefaultExt     .Filter = Filter     .Flags = OFN_EXPLORER Or OFN_HIDEREADONLY Or OFN_ALLOWMULTISELECT     If .ShowOpen Then         getFileBySelect = .ParseFileNames     End If End With End Function '返回指定目录下指定名称所有文件的函数 Function GetFileListByPath(Path As String, FileName As String) As Variant     Dim s As String     Dim sFiles() As String     Dim i As Integer     s = Dir(Path & FileName)     If s <> "" Then      ReDim sFiles(i) As String      sFiles(i) = Path & s      i = 1      s = Dir()      While s <> ""         ReDim Preserve sFiles(i) As String         sFiles(i) = Path & s         i = i + 1         s = Dir()      Wend      GetFileListByPath = sFiles     End If      End Function '选定目录的函数，使用了commonDialog类 Public Function GetDir(DialogTitle As String, FileName As String) As Variant Dim dlg As CommonDialog Dim Path As String Dim FileList As Variant Set dlg = New CommonDialog     dlg.DialogTitle = DialogTitle     If dlg.Browse Then         Path = dlg.Path         If Path <> "" Then             Path = Left$(Path, InStr(Path, vbNullChar) - 1)             If Right$(Path, 1) <> "\" Then Path = Path & "\"             FileList = GetFileListByPath(Path, "*.dwg")             GetDir = FileList         End If     End If          End Function '由文件全路径名称返回文件的函数 Public Function JustFileName(FileName) As String On Error Resume Next Dim count As Integer For count = Len(FileName) - 1 To 1 Step -1     If Mid(FileName, count, 1) = "\" Or Mid(FileName, count, 1) = "/" Then         JustFileName = Right(FileName, Len(FileName) - count)         Exit For     End If Next End Function
33AutoCAD中的延长直线的命令需要先制定边界，再延长，用VBA可以编写一个直接用鼠标来确定延长位置的程序，可谓鼠标指到哪儿，直线就延长到哪儿，再也不用事先画边界了。有兴趣的同行可以给我发E－mail要求源程序
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Public Function MyHotKey(vKeyCode) As Boolean MyHotKey = (GetAsyncKeyState(vKeyCode) < 0) End Function Public Sub ExtendLineArc() Dim Object1 As AcadObject, Line2 As AcadLine, Line3 As AcadLine Dim FP As Variant, TP As Variant, OutAngle As Double, kk As Integer Dim P1(0 To 2) As Double, P2(0 To 2) As Double, RetP As Variant, SelectBase As Variant Dim ComS As String On Error Resume Next LLL1:     ThisDrawing.Utility.GetEntity Object1, SelectBase, "选择需要延长的直线或圆弧："     If Err Then         If MyHotKey(vbKeyEscape) Then             Err.Clear             Exit Sub         End If         ThisDrawing.Utility.Prompt "没有选择实体!"         Err.Clear         GoTo LLL1     ElseIf Object1.ObjectName = "AcDbLine" Then         Object1.Highlight True         RetP = ThisDrawing.Utility.GetPoint(, "延长的位置：")         P1(0) = RetP(0) + 50 * Cos(Object1.Angle + Pt / 2)         P1(1) = RetP(1) + 50 * Sin(Object1.Angle + Pt / 2)         P2(0) = RetP(0) + 50 * Cos(Object1.Angle - Pt / 2)         P2(1) = RetP(1) + 50 * Sin(Object1.Angle - Pt / 2)              FP = Object1.StartPoint: TP = Object1.EndPoint         RetP = Per_Inter(P1(0), P1(1), P2(0), P2(1), FP(0), FP(1))         If CalDis(RetP(0), RetP(1), FP(0), FP(1)) > CalDis(RetP(0), RetP(1), TP(0), TP(1)) Then             P1(0) = RetP(0): P1(1) = RetP(1)             P2(0) = FP(0):   P2(1) = FP(1)             Set Line2 = ThisDrawing.ModelSpace.AddLine(P1, P2)             Line2.Color = Object1.Color:      Object1.Delete         Else             P1(0) = RetP(0): P1(1) = RetP(1)             P2(0) = TP(0):   P2(1) = TP(1)             Object1             Set Line2 = ThisDrawing.ModelSpace.AddLine(P1, P2)             Line2.Color = Object1.Color:      Object1.Delete         End If         Object1.Highlight False         Err.Clear         GoTo LLL1     ElseIf Object1.ObjectName = "AcDbArc" Then         Dim Line1 As AcadLine         Dim SAngle As Double, EAngle As Double, DDAngle As Double, Angle1 As Double, Angle2 As Double         Object1.Highlight True         RetP = ThisDrawing.Utility.GetPoint(, "延长的位置:")         Dim Arc1 As AcadArc, arc2 As AcadCircle         If Distance(RetP, Object1.StartPoint) < 0.0000001 Or Distance(RetP, Object1.EndPoint) < 0.0000001 Then             FP = Object1.center             Set arc2 = ThisDrawing.ModelSpace.AddCircle(FP, Object1.radius)             arc2.Color = Object1.Color: Object1.Delete         ElseIf Distance(RetP, Object1.StartPoint) < Distance(RetP, Object1.EndPoint) Then             SAngle = Object1.startAngle: EAngle = Object1.endAngle             FP = Object1.center             Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, RetP)                 Angle2 = Line1.Angle: Line1.Delete             TP = Object1.StartPoint             Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, TP)                 Angle1 = Line1.Angle: Line1.Delete             DDAngle = Angle2 - Angle1             SAngle = SAngle + DDAngle             Set Arc1 = ThisDrawing.ModelSpace.AddArc(FP, Object1.radius, SAngle, EAngle)             Arc1.Color = Object1.Color: Object1.Delete         Else             SAngle = Object1.startAngle: EAngle = Object1.endAngle             FP = Object1.center             Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, RetP)                 Angle2 = Line1.Angle: Line1.Delete             TP = Object1.EndPoint             Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, TP)                 Angle1 = Line1.Angle: Line1.Delete             DDAngle = Angle2 - Angle1             EAngle = EAngle + DDAngle             Set Arc1 = ThisDrawing.ModelSpace.AddArc(FP, Object1.radius, SAngle, EAngle)             Arc1.Color = Object1.Color: Object1.Delete         End If         'Object1.Highlight False         Err.Clear         GoTo LLL1     Else         ThisDrawing.Utility.Prompt "你选择的实体无法用本工具延长！"         GoTo LLL1     End If End Sub
34 把选择的对象放大几倍，VBA怎么实现？
object.ScaleEntity BasePoint, ScaleFactor 方法：
其中object为所有图形对象及属性参照对象
BasePoint为基点
ScaleFactor为比例因子
注意对选择集的操作必须遍历选择集中的所有对象，对每个对象进行操作，而不能直接对选择集进行操作，这一点与ALISP不同。
35怎样提取图形的视图左下角、右上角和图形左下角，右上角的坐标？
左下角：Viewport.LowerLeftCorner
右上角：Viewport.UpperRightCorner
用系统变量。
对于图形界限，用下面的系统变量：
LIMMAX 存储当前空间的右上方图形界限
LIMMIN 存储当前空间的左下方图形界限
对于当前视口，用下面的系统变量：
SCREENSIZE 以像素为单位存储当前视口的大小（X 和 Y 值）
VIEWCTR 存储当前视口中视图的中心点
VIEWSIZE 存储当前视口的视图高度
先从当前视口的X和Y的比值，根据当前视口的视图高度求出当前视口的视图宽度。然后中心点的X坐标减去视图宽度的一半就是视图左下角的X坐标，中心点的Y坐标减去视图高度的一半就是视图左下角的Y坐标，右上角坐标类似。




1.  怎么查找某一个group是否存在？-
检查图形中是否含有指定名称的组合的函数
Function GetGroup(GName As String) As Boolean
     Dim objGroup As AcadGroup
     On Error Resume Next
     Set objGroup = ThisDrawing.Groups(GName)
     If Err Then
         GetGroup = False
     Else
         GetGroup = True
     End If
End Function
'GetGroup函数使用示例
Sub GGroup()
     Dim GName As String
     GName = "liec"
     Dim GroupTip As String
     If GetGroup(GName) Then
         GroupTip = "有"
     Else
         GroupTip = "无"
     End If
     MsgBox "图形中" & GroupTip & "名称为" & GName & "的组合存在", , "明经通道示例"
End Sub
2.在AutoCAD中，如果你的模板没有经过修改的话，则写入中文时会显示“？？？”这样的文字，这时，你必须手动修改文字样式，增加中文字体的支持，如使用大字体或使用TTF中文字体。
以下程序你可以保存为DVB文件，然后加入到启动组中，这样当你在写文字时系统会自动设置好中文字体，免去手动设置的麻烦。

Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
     If (CommandName = "TEXT" Or CommandName = "MTEXT") And _
     ThisDrawing.ActiveTextStyle.BigFontFile = "" And _
     LCase(Right(ThisDrawing.ActiveTextStyle.fontFile, 4)) <> ".ttf" Then
         ThisDrawing.ActiveTextStyle.BigFontFile = "gbcbig.shx"
     End If
End Sub
3. 在编程中，我遇到以下问题：
   我用DATAGRID与ADODC控键建立起与外部数据库的连接，但是不知道如何提取其中的单个数据，在VB中就不存在这问题，VB中的其他控键可以绑定ADODC控键，而VBA的控键就不行，我该怎么办呢
看看数据库的操作
用数据集Recordset的移动操作，等价于DataGrid中定位到某一行。可以有MoveFirst、MovePrevious、MoveNext、MoveLast等操作，也可以有AddNew、Delete等
4. 当我使用VBA的GetPoint方法，点击锁点工具列抓点(如：nea point,endpoint….)，在Command里居然出现了 *Cancel* 而无法抓点，不知有哪位前辈知道如何解决呢
解决方法如下：
Sub Test()
     On Error GoTo ErrTrap
     Pt = acadDoc.Utility.GetPoint(Point, Prompt)
     Exit Sub
     
ErrTrap:
     If Err.Number = -2147352567 Then '运行命令，如透明命令等。
        Err.Clear
         Resume
     ElseIf Err.Number = -2147467259 Then '右键单击结束，关于按ESC键结束命令可以参考其它有关资料。
    End If
     On Error GoTo 0
End Sub
5. Sheets("检测报告").Select
With ActiveSheet.PageSetup
        .PrintTitleRows = False
        .PrintTitleColumns = False
End With
在有的机器上可以通过，有的就不可以，请问和环境有关吗？？？？能帮帮我吗？
我的原理：定植模班，生成工作表，（通过复制），然后向其中填充数据，最后打印
现在我想实现工作表的打印设置同我的模班打印设置相同，不知道你有好的方法吗？？
正确的使用方法如下：
        .PrintTitleRows = "$1:$2"
         .PrintTitleColumns = "$A:$B"
如果不打印标题行及列，可以置为空白，如
       .PrintTitleRows = ""
        .PrintTitleColumns = ""
6. 请问如何让form.hide后form.show时能保持form先前移动后的位置？
form.startposition=0 ‘(手动)
7. 我想在对文件处理前做一个备份，代码如下(在vb中)：
Dim docsObj As AcadDocuments
Dim docTemp As AcadDocument
Dim docObj As AcadDocument
Dim spaceObj As AcadBlock
Dim returnObj As Acad3DSolid
Dim temp3Dsolid As Acad3DSolid
''''''''''''''''''''''''''
'docObj是当前文档对象，returnObj是docObj中的一个3D对象
'set spaceObj = docObj
'对象的赋值对没问题，只是下面的代码不能得到我想要的结果
''''''''''''''''''''''''''
Set docTemp = docsObj.Add
Set temp3Dsolid = spaceObj.CopyObjects(returnObj, docTemp.ModelSpace)
'我想应该在新建的文档里有returnObj对象，可结果什么也没有
'各位高手给我看看，先谢谢了！！！
问题在这一句：Set temp3Dsolid = spaceObj.CopyObjects(returnObj, docTemp.ModelSpace)。
首先CopyObjects应该是文档对象的方法，spaceObj应是AcadDocument对象，然后看看它的传递参数，第一个参数Objects应该是对象的数组，应而returnObj应该声明为Dim returnObj(0) As Acad3DSolid，然后对其赋值。最后，看看返回值RetVal，它也是对象的数组，故应声明为Dim temp3Dsolid As Variant。
8. 我需要在vb程序中实现选择内部点对某一个封闭区域进行填充，好像没有生成封闭区域的函数，如果使用sendcommand调用cad的填充命令，基本上可以实现，但是当封闭区域没有完全显示在视口内时，就会出错。大家有好的方法吗？
Hatch.AppendOuterLoop '外部区域
Hatch.AppendInnerLoop '内部区域
方法不行吗？
如果选择点的话，要把选择到的点生成 Polyline 当内部区域即可!
9怎样计算一个多边形的中心点?
如果你想知道的仅仅是正多边形的中心点位置，这很容易，若边数是奇数，中心点是这样两条线的交点：它们是多边形顶点到相对边垂线。若边数是偶数，两对相对顶点连线的交点就是中心点。
对于一般的多边形，中心点的计算方法有几种，但都比较麻烦。下面介绍的两个算法实际上都可以应用于任何2D图形的中心点计算。
算法1。该算法基于这样两个数学定理：
1、在任意指定的一个方向上，有且仅有一条直线将指定的闭合区域分成两个面积相等的部分。可用极限理论中的“夹逼定理”。具体证明略。
2、在两个不同方向上得到的上述两条直线的交点就是闭合区域的重心位置。要严格证明它，我同样也未找初等方法，要用到比较复杂的微积分知识。不过可以从重心的物理意义出发理解它。
算法1也就是通过尝试找到这样两条直线(或近似值)。这个方法对于不太熟悉微积分的朋友相对容易理解，但实际编程时要多次计算和比较区域的面积，并且在得到将区域分成面积相等的两块的直线过程中，大概要通过递归的方法逐步逼近正确值，运行效率很低。
算法2直接利用数学中重心坐标计算公式，利用微积分方法计算。
中心点X坐标为：xdxdy在区域上的二重积分/区域面积。
Y坐标为：ydxdy在区域上的二重积分/区域面积。
积分的计算就用矩形逼近求和的方法，或辛普森方法(如果你对精度要求很高的话)。
当然，针对具体的问题可能(应该几乎可以肯定)有更高效的算法。那么就需要你对具体问题准确描述。
10如何返回在命令行中输入的字符,是指在没有按下回车和空格下
用GetInput如何确定返回的是空字串还是按下了Esc键,
我已先指定了一个KeyWord ,当有输入我指定的KeyWord时,再按下Esc时,返回的还是那个KeyWord,怎么办?
如果出错号为：-2147467259
则指的是输入了字符或回车或空格
如果出错号为：-2147352567
则指的是按了取消键
11当我插入块时，鼠标的click_point为两个图块的公共插入点，即同时插入两个块
但我的问题是，如何在插入时将此两块合成一个块?
图块合并可以用CopyObjects方法，但是合并后的图块最好重新起个名字，否则原来的已经插入的图块将会被覆盖更新。



12如何把168.235642度分解成度，分，秒？我没有办法判别小数点？
使用Utility工具AngleToString方法可以实现转换：
Document.Utility.AngleToString(Angle,AngUnit,Precision)
其中，Angle参数为你输入的168.235642(Double类型)。
      AngUnit是一个枚举类型，其取值及其意义为：
         acDegrees               度
         acDegreeMinuteSeconds   度分秒
         acGrads                 梯度
         acRadians               弧度
      Precision为0到8之间的整数，表示返回值精度。
该函数返回转换后的字符串。
另外，在另一个帖子中，你提到要获得小数点后三位数字，乘1000取整除1000是个很好的方法，当然，也可以用VB的FormatNumber函数，详细使用可参考MSDN帮助。
13. 请问在VBA中怎么使一个选择集只选中模型空间中可见图元？
我隐藏&锁定&冻结了其他,然后使用了
FilterType = 60
FilterData = 0
sset.SelectOnScreen FilterType, FilterData
可是选不中任何图元，也没什么错误提示？？？
烦闷！
你必须通过图层过滤出可见的图层，然后把这些图层做为过滤器的条件
Sub GetEnt()
     Dim ss As AcadSelectionSet
     Set ss = CreateSelectionSet
     Dim Ly As String
     Ly = ""
     Dim Lyer As AcadLayer
     Dim I As Integer
     Debug.Print ThisDrawing.Layers.Count
     For I = 0 To ThisDrawing.Layers.Count - 1
         Set Lyer = ThisDrawing.Layers(I)
         If Lyer.LayerOn = True Then
             Ly = Ly & Lyer.Name & ","
         End If
     Next
     Dim fType As Variant: Dim fData As Variant
     BuildFilter fType, fData, 8, Ly
     ss.Select acSelectionSetAll, , , fType, fData
     Debug.Print ss.Count
End Sub

Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet

     Dim ss As AcadSelectionSet
     
     On Error Resume Next
     Set ss = ThisDrawing.SelectionSets(ssName)
     If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
     ss.Clear
     Set CreateSelectionSet = ss

End Function

Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
     Dim fType() As Integer, fData()
     Dim index As Long, I As Long
     
     index = LBound(gCodes) - 1
         
     For I = LBound(gCodes) To UBound(gCodes) Step 2
         index = index + 1
         ReDim Preserve fType(0 To index)
         ReDim Preserve fData(0 To index)
         fType(index) = CInt(gCodes(I))
         fData(index) = gCodes(I + 1)
     Next
     typeArray = fType: dataArray = fData
End Sub
14. windows安装了几个打印机，如何用vb指定打印机。谢谢
一般来说，使用
Layout.GetPlotDeviceNames方法之前必须使用
Layout.RefreshPlotDeviceInfo来刷新一下才能得到正确的结果。
得到所有打印机名称后，你就可以使用列表把他们列出来，供用户选择.
15.斑竹能否推荐几个好的国外的CAD二次开发的网站，多谢
http://www.vbcad.com/
http://www.vbdesign.net/
http://ourworld.compuserve.com/h ... ActiveCAD/index.htm
http://www.contractcaddgroup.com/
http://www.acadx.com/
http://www.freevbcode.com/
http://www.vbcode.com/
http://www.copypastecode.com/
http://www.vbdesign.net/cgi-bin/ikonboard.cgi
16请教，VBA中的下拉列表控件的数据是怎么和数据库内的数据邦定的？我查了好些东东都不能搞定，那位仁兄可以相告，谢谢。
你可以循环表中的记录来添加到列表中
如：
MatTbl.MoveFirst
For I = 1 To MatTbl2.RecordCount
   DimTolCl.AddItem (MatTbl2("enname") & " " & MatTbl2("cnname"))
   MatTbl2.MoveNext
Next I
17请问高手，在VB中如何将如0.00000053的数字，变成形如5.3E-7字样的科学记数法
用Utility对象的RealToString方法
比如：RealToString(0.00000053, acScientific, 1)，它的用法就是将一个实数（双精度）按指定的类型转化成字符串。
18.在vba中有 IsNumberic()函数检测变量是不是数值,但我需要一个能检验  所输的变量是不是 字符charactor的函数,或能实现此功能的办法.
写了个函数，只检测位于a-z和A-Z之间的字符。
Function IsCharacter(ByVal Expression As String) As Boolean     I
sCharacter = False   
Dim i As Integer     
Dim c As Long         
On Error GoTo ErrTrap   
If Expression = "" Then
Exit Function   
IsCharacter = True     
For i = 1 To Len(Expression)        
c = Asc(Mid(Expression, i, 1))        
If Not ((c >= 65 And c <= 90) Or (c >= 97 And c <= 122)) Then            
IsCharacter = False            
Exit For         
End If     
Next     
Exit Function     
ErrTrap:     
On Error GoTo 0
End Function
19在ADDMTEXT中，换行符\p怎么使用啊？
直接插入到字符串中，不过要用大写的表示，\P
20请大家帮我解一个数学问题
已知a b c的坐标分别为:(x1,y1) (x2,y2) (x3,y3)，求过c做直线ab的垂足点的坐标(x,y)。

呵呵，不知道有没有现成的公式呢？用直角三角形三边关系列那个二元二次方程实在太令人头痛了
斜率k=(y2-y1)/(x2-x1)
y-y1=k*(x-x1)
y-y3=-1/k*(x-x3)
21我设了一选择集，内就一个对象（样条曲线），想求出该样条曲线和另一直线的交点，却无法引用该样条曲线。请高手指点！急！！
If sset(0).EntityType = acLine Then
         Set lineObj = sset(0)
         MsgBox lineObj.Length
     End If
     lineObj是一个直线对象，引用其它对象使用相同的方法


22. 如何得到objectDBX及其帮助？

23请教CAD屏幕选取一个块后,怎样获得它的属性,并存放在一个数组里.
必须先定义一个二维数组
如：
Dim AttArray(1, UBound(vaattributes)) As Variant

然后在下面的循环中把属性填充到数组中：

       For J = 0 To UBound(vaattributes)
             AttArray(0,J)=vaattributes(J).TagString
             AttArray(1,J) = attvars(J).TextString
         Next
24. 哪位大侠知道，怎么取得任意图形的中心点坐标！
如果是指质心的话，你可以先将图形做成面域（region）
然后再找这个面域的centroid属性即可。
但要说明的是，这个centroid是个二维点，你只能得到centroid（0）和centroid（1）两个量。其余的应该好办了吧。
如果不是质心，可以用getboundary方法来找图形的几何中心
25测量坐标与屏幕坐标的转换
us1 = ThisDrawing.GetVariable("userr1")
us2 = ThisDrawing.GetVariable("userr2")
us3 = ThisDrawing.GetVariable("userr3")
ThisDrawing.GetVariable("useri5") = 666
请教：userr1，userr2，userr3，userri5这几个系统变量有什么用？
userr1，userr2，userr3，userri5
按顺序排：比例尺，左下角x坐标，左下角y坐标，高程比例尺
26VBA回车响应的问题
我想在对话框显示的时候，按回车就立即响应COMMAND1的CLICK事件。
我写的程序为：
  Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 13 Then
UserForm1.Hide
End If
End Sub
运行时，按回车无响应。
怎样才能按回车就立即响应COMMAND1的CLICK事件？
请各位多多指教。
将Command1的Default属性更改为True。这样，只要是你在编辑框中按了回车，就可以默认Command1中的点击事件。
27.是根据VBA教材的代码改的批量裁剪程序

Sub Trim()
     Dim acadapp As AcadApplication
     Dim acaddoc As AcadDocument
     
     Set acadapp = connectcad(acadapp)
     Set acaddoc = acadapp.ActiveDocument
     AppActivate acadapp.Caption '让CAD得到焦点
    Dim Pnt1 As Variant
     Dim entObj1 As AcadEntity
     acaddoc.Utility.GetEntity entObj1, Pnt1, "选择修剪边界："
     Dim det1 As String
     det1 = axEnt2lspEnt(entObj1)
     Dim Pnt2 As Variant
     Dim entObj2 As AcadEntity
     Dim sle1 As AcadSelectionSet
     On Error Resume Next
     Set sle1 = acaddoc.SelectionSets.Item("sle1")
     sle1.Clear
     If Err Then
     Err.Clear
     Set sle1 = acaddoc.SelectionSets.Add("sle1")
     End If
     acaddoc.Utility.Prompt "选择需要修剪的对象" & Chr(13)
     sle1.SelectOnScreen
     Pnt2 = acaddoc.Utility.GetPoint(, "选择修剪方向")
     Dim det2 As String
     For Each entObj2 In sle1
     det2 = GetDoubleEntTable(entObj2, Pnt2
     acaddoc.SendCommand "_trim" & vbCr & det1 & vbCr & vbCr & det2 & vbCr & vbCr
     Next
     Dim command_str As String
     command_str = Chr(3) & Chr(3)
     acaddoc.SendCommand command_str
     acaddoc.Utility.Prompt "修剪完成!"
     acaddoc.SendCommand command_str
     Set acadapp = Nothing
     End
End Sub
'转换双元表的函数
Public Function GetDoubleEntTable(entObj As AcadEntity, Pnt As Variant) As String
     Dim entHandle As String
     entHandle = entObj.Handle
     GetDoubleEntTable = "(list(handent " & Chr(34) & entHandle & Chr(34) & _
                      ")(list " & Str(Pnt(0)) & Str(Pnt(1)) & Str(Pnt(2)) & "))"
End Function
'转换点的函数

Public Function axPoint2lspPoint(Pnt As Variant) As String
     axPoint2lspPoint = Pnt(0) & "," & Pnt(1) & "," & Pnt(2)
End Function
'转换图元函数
Public Function axEnt2lspEnt(entObj As AcadEntity) As String
     Dim entHandle As String
     entHandle = entObj.Handle
     axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function
Function connectcad(acadapp As AcadApplication) As AcadApplication '连接AUTOCAD
On Error Resume Next   
'与autocad通信
    Set acadapp = GetObject(, "AutoCAD.Application")
     If Err Then
         Err.Clear
         Set acadapp = CreateObject("AutoCAD.Application")
         If Err Then
             MsgBox Err.Description
             Exit Function
         End If
     End If
Set connectcad = acadapp
End Function
Private Sub Form_Initialize()
Trim
End Sub
你的程序本身有问题：
在选择修剪方向时，其实你只认定了一个点Pnt2，然后你就使用该点组成了修剪的双元表，这样的话，对于被修剪对象来说，可能会产生点取的点在外部的问题，因为系统认定的点取的位置是Pnt2到被修剪对象上的垂直点的位置。
要达到效果，应该是：
点取一个点Pnt2后，把多段线向内偏移一小段距离，然后逐条遍历被修剪对象的选择集，求选择集中的对象与偏移的对象的交点，再通过交点来组成双元表，这样的话，应该可以解决。
双元表也就是指在进行一些对象操作时对位置有要求时使用数据格式
28. 我用sendcommand的_trim命令，经常剪不断，怎么办？
是从“实用函数”里学到的方法，做了一些修改：

Public Sub Trim(ByVal cutLine1 As AcadLine, ByVal cutLine2 As AcadLine, _
                 ByVal entSP As AcadSpline, ByVal optCode As String)
'cutLine1 cutLine2是_trim的两个边界线，endSP是要剪的样条曲线。

    Dim det1, det2 As String
     det1 = axEnt2lspEnt(cutLine1)
     det2 = axEnt2lspEnt(cutLine2)

     Dim det3, det4 As String
     det3 = GetDoubleEntTable(entSP, entSP.GetControlPoint(0))
     det4 = GetDoubleEntTable(entSP, entSP.GetControlPoint(entSP.NumberOfControlPoints - 1))
     
     If optCode = "first" Then
         ThisDrawing.SendCommand "_trim" & vbCr & det2 & vbCr & _
              vbCr & det4 & vbCr & vbCr
         GoTo rtn
     End If
     
     If optCode = "last" Then
         ThisDrawing.SendCommand "_trim" & vbCr & det1 & vbCr & _
               vbCr & det3 & vbCr & vbCr
         GoTo rtn
     End If
     
     ThisDrawing.SendCommand "_trim" & vbCr & det1 & vbCr & det2 & _
           vbCr & vbCr & det3 & vbCr & det4 & vbCr & vbCr
rtn:
End Sub

'转换双元表的函数
Private Function GetDoubleEntTable(entObj As AcadEntity, Pnt As Variant) As String
     Dim entHandle As String
     entHandle = entObj.Handle
     GetDoubleEntTable = "(list(handent " & Chr(34) & entHandle & Chr(34) & _
                      ")(list " & Str(Pnt(0)) & Str(Pnt(1)) & Str(Pnt(2)) & "))"
End Function

'转换点的函数
Private Function axPoint2lspPoint(Pnt As Variant) As String
     axPoint2lspPoint = Pnt(0) & "," & Pnt(1) & "," & Pnt(2)
End Function

'转换图元函数
Private Function axEnt2lspEnt(entObj As AcadEntity) As String
     Dim entHandle As String
     entHandle = entObj.Handle
     axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function

作用主要是把样条曲线其中两个拟合点之间的一段剪出来，但在弯比较急的地方经常剪不断，造成出错。请问怎么办？
29关于split()函数的问题
我在尝试用CommonDialog打开多个文件时，为分离各个文件名，用了split()函数，但结果却怎么也不对。具体代码如下：
Dim NewFileName() As String
CommonDialog1.filter = "Drawing Files(*.dwg)|*.dwg|" & "All Files(*.*)|*.*|"
CommonDialog1.flags = cdlOFNAllowMultiselect Or cdlOFNExplorer
CommonDialog1.FilterIndex = 1
CommonDialog1.DialogTitle = "选择文件..."
CommonDialog1.InitDir = "e:\"
CommonDialog1.ShowOpen
NewFileName() = Split(CommonDialog1.FileName, "")  
'因为用监视窗口察看CommonDialog1.FileName各文件之间用间隔，但此时的NewFileName(0) =CommonDialog1.FileName，即split()函数没起作用，但若我
定义CommonDialog1.FileName="E:\pb02009083.dwgpb02009082",则split()函数则
起作用，此时NewFileName() 为正确结果。
不知大家能否帮我解决这一难题，不胜感激。
NewFileName() = Split(CommonDialog1.FileName, Chr(0))
30我有一个问题,就是"在AUTOCAD中用VBA或Visual LISP中写一个程式,能在AUTOCAD中选中一个封闭的多义线(在封闭的多义线中有直线,倒圆角,圆弧,角度)按逆时针找出每一个2D坐标,写在一个文本文件里!
我在网上坛子里问了三个月了,十几个人说来说去,都没搞定.
Sub oef()
Dim pnt As Variant
Dim ent1 As AcadLWPolyline
Dim ent2 As AcadLWPolyline
Dim ents As Variant
Dim pnts As Variant
Dim cnt As Integer
Dim cor() As Double
Dim i As Integer
Dim txt As String
ThisDrawing.Utility.GetEntity ent1, pnt
pnts = ent1.Coordinates
cnt = (UBound(pnts) + 1) / 2
Debug.Print cnt
ReDim cor(1, cnt) As Double
For i = 0 To UBound(pnts) Step 2
cor(0, i / 2) = ent1.Coordinates(i)
cor(1, i / 2) = ent1.Coordinates(i + 1)
Next
ents = ent1.Offset(10)
Set ent2 = ents(0)
If ent2.Area > ent1.Area Then
txt = "逆时针方向，其逆时针坐标如下："
For i = 0 To UBound(cor, 2) - 1
txt = txt & vbCr & cor(0, i) & "," & cor(1, i)
Next
Else
txt = "线为顺时针方向，已经转换为逆时针的坐标如下："
For i = UBound(cor, 2) - 1 To 0 Step -1
txt = txt & vbCr & cor(0, i) & "," & cor(1, i)
Next
End If
For i = 0 To UBound(ents)
ents(i).Delete
Next
MsgBox txt

End Sub
31如何在VB中开关非当前层？
Sub SetLayerOff()
     Dim LayerName As String
     LayerName = "1"
     On Error Resume Next
     Err.Number = 0
     Dim MyLayer As AcadLayer
     Set MyLayer = ThisDrawing.Layers(LayerName)
     If Err.Number = 0 Then
         ThisDrawing.Layers(LayerName).LayerOn = False
         ThisDrawing.Utility.Prompt vbCrLf & " 图层“" & LayerName & "”已经被关闭。"
     Else
         ThisDrawing.Utility.Prompt vbCrLf & " 图层“" & LayerName & "”不存在。"
     End If
End Sub

zzyong00

顶顶！！！！！

QWQWQWQ

             顶      ！

Pegasus

我认真看完了，谢谢分享。

落叶交给了风

牛逼牛逼！谢谢分享，认真学习了~

leeli

这样的贴才是初学者的宝藏啊！谢谢了

awopei

这样的贴才是初学者的宝藏啊！谢谢了