【转贴】CAD_VBA基本问题
转贴,感谢原贴作者
http://www.xipick.com/forum.php?mod=viewthread&tid=15313&page=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
顶顶！！！！！ 顶 ！ 我认真看完了，谢谢分享。 牛逼牛逼！谢谢分享，认真学习了~
这样的贴才是初学者的宝藏啊！谢谢了 这样的贴才是初学者的宝藏啊！谢谢了
页:
[1]