乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
楼主: mien

[编程交流] plot x,y and z coordinate usin

[复制链接]

0

主题

3

帖子

3

银币

初来乍到

Rank: 1

铜币
0
发表于 2022-7-6 15:47:08 | 显示全部楼层
Ah, I didn't realise I could do that, sorry.
 
Also, this code is a modified version of something I found (but have since lost the link to). The original article mentioned something rather clever to do with positioning labels dynamically so there were no overlaps. The code for that wasn't included so I just used an attribute.
 
  1. Public mstrBlockName As StringPublic blnBlockLabelFailure As BooleanPublic mstrImportType As StringPublic Sub ReadXYFile(strFileName As String)'mstrBlockName was set on userform before calling this sub routineDim myFile As IntegerDim lngIndex As LongDim strTextLine As StringDim arrText As VariantDim intCol As IntegerDim intSubStrings As IntegerDim dblX As DoubleDim dblY As DoubleDim dblZ As DoubleDim strName As String'strFileName = "C:\GIS\COORD_TEST3.csv"On Error GoTo ErrorHandlerPoint' TODO: Take this check out, have already checked on form.If Dir(strFileName) = "" Then    Call MsgBox(strFileName & " not found", vbExclamation, "Import XYZ Coordinates")    GoTo TidyUpAndExitEnd IfmyFile = FreeFileOpen strFileName For Input As #myFileDo While Not EOF(myFile)   Line Input #myFile, strTextLine   arrText = Split(strTextLine, ",")   If lngIndex = 0 Then ' read first line to determine number columns in file       intSubStrings = UBound(arrText)       'Debug.Print intSubStrings       If intSubStrings = 2 Then 'i.e. 3 columns, we are expecting X,Y,Name           mstrImportType = "XYName"       ElseIf intSubStrings = 3 Then 'i.e. 4 columns, we are expecting X,Y,Z and Name           mstrImportType = "XYZName"       Else           mstrImportType = ""           Call MsgBox("The chosen file was invalid." & _           vbCrLf & "" & _           vbCrLf & "File must comprise 3 (X,Y,Name) or 4 (X,Y,Z,Name) columns of data only.", vbExclamation, "Import XYZ Coordinates")           GoTo TidyUpAndExit       End If   End If   'if the columns are in the wrong order a type mismatch error will be thrown by the error handler   Select Case mstrImportType       Case "XYName"           dblX = arrText(0)           dblY = arrText(1)           dblZ = 0           strName = arrText(2)           Call InsertBlock(dblX, dblY, dblZ, strName)       Case "XYZName"           dblX = arrText(0)           dblY = arrText(1)           dblZ = arrText(2)           strName = arrText(3)           Call InsertBlock(dblX, dblY, dblZ, strName)       Case Else           '????????????   End Select   lngIndex = lngIndex + 1LoopTidyUpAndExit:   '**** tidy up e.g. close and set objects to nothing   Close myFileExit SubErrorHandlerPoint:   MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ReadXYFile"   'could try to catch specific error, e.g possible type mismatch and provide meaningful message   GoTo TidyUpAndExitEnd SubSub InsertBlock(xx As Double, yy As Double, zz As Double, bAttr As String)Dim insertionPnt(0 To 2) As DoubleDim blockRefObj As AcadBlockReferenceDim varAttribs As VariantDim intAttribCount As Integer'Coordinate 'x=0,y=1,z=2insertionPnt(0) = xx#: insertionPnt(1) = yy#: insertionPnt(2) = 0'InsertBlock inserts a drawing file or a named block that has been defined in the current drawing.Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, mstrBlockName, 1#, 1#, 1#, 0)' Get attribute value(s) from the block.varAttribs = blockRefObj.GetAttributes'Check how many attributes the block - if 0 set a boolean flagintAttribCount = UBound(varAttribs)If intAttribCount = -1 Then ' The block has no attributes   blnBlockLabelFailure = True   'Call MsgBox("The chosen block has no attributes to label.", vbInformation, "Import XYZ Coordinates")Else   ' We will use only the First attribute in the block found at location Zero.   ' varAttribs(0) is the first block attribute value.   ' Note, most programs uses Zero-based counting & therefore the first number is Zero when counting rather than one.   varAttribs(0).TextString = bAttr   ' Update the block so we can see the new Values applied to the block attribute values above.   ' This is similar to a localized regen, only the block is updated/regenerated.   varAttribs(0).UpdateEnd IfTidyUpAndExit:   '**** tidy up e.g. close and set objects to nothingExit SubErrorHandlerPoint:   MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure InsertBlock"   'could try to catch specific error, e.g possible type mismatch and provide meaningful message   GoTo TidyUpAndExitEnd Sub
回复

使用道具 举报

15

主题

41

帖子

26

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
75
发表于 2022-7-6 15:52:55 | 显示全部楼层
dear dvhardy, can u a give me an example complete visual basic programming for autocad for me to study it structure and function.thanks....
回复

使用道具 举报

0

主题

3

帖子

3

银币

初来乍到

Rank: 1

铜币
0
发表于 2022-7-6 15:55:06 | 显示全部楼层
Try browsing the AutoCAD ActiveX and VBA References in the help documentation to find out more about AutoCAD's object model.
 
ps I'm not actually an AutoCAD user (yet) and know next to nothing about the software. I just wanted to do what you wanted to and thought it must be possible.
 
I'm thinking of buying the book 'AutoCAD 2006 VBA: A Programmer's Reference' which gets a few good reviews on Amazon (there don't appear to be many books covering the subject)
回复

使用道具 举报

48

主题

1073

帖子

1043

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
238
发表于 2022-7-6 16:02:57 | 显示全部楼层
You and Lee should get on really well! If I've understood him correctly, he is in a similar position with LISP - just doing it because he can.
回复

使用道具 举报

114

主题

1万

帖子

1万

银币

中流砥柱

Rank: 25

铜币
543
发表于 2022-7-6 16:03:25 | 显示全部楼层
 
You can read me like a book Dave,
 
I only have around 1 year's experience in drafting, but find the LISP quite understandable - which is why I spend most of my time in this forum and don't venture much into the ACAD general side of things...
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-3-4 21:14 , Processed in 0.346656 second(s), 60 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表