大家有没有直接从ＥＸＣＥＬ读取数据然后在ＣＡＤ中绘图的小程序啊！！

jlluozhenpin

这个问题非常容易做到，我的软件就可以，你可以到www.shuigong.com的施工软件中下载“飞翔水利施工软件”，ok

yefeiwolaile

Sub text()

Dim p(0 To 2) As Double '定义坐标变量

ss$ = CStr(dydqxls)

MsgBox ss

p(0) = 310.77: p(1) = 42: p(2) = 0 '坐标赋值

Set txtobj = ThisDrawing.PaperSpace.AddMText(p, 50, ss)

End Sub

Function dydqxls()

Dim ExcelApp As Excel.Application

On Error Resume Next

  Set ExcelApp = GetObject(, "Excel.Application")

        If Err <> 0 Then

        Set ExcelApp = CreateObject("Excel.Applicationn")

End If

 a = ExcelApp.ActiveWorkbook.Sheets("数据输入").Range("b11").Value

dydqxls = a

End Function

从当前EXCEL文件中提取B11单元格内数据，于CAD图纸空间指定点写一个文本，字符串为B11内字符

兰州人

我常用Autocad与Excel的程序

Sub WriteTextToMaterialTable()
  Dim Ent As AcadEntity
  Dim tt As AcadText, ll As AcadLine, ii As Integer
  Dim InsertPoint(0 To 2) As Double
  Set xlSheet = xlApp.ActiveSheet
  For ii = 1 To 6
    InsertPoint(0) = xlSheet.Cells(ii, 2): InsertPoint(1) = xlSheet.Cells(ii, 3)
    Set tt = ThisDrawing.ModelSpace.AddText(xlSheet.Cells(ii, 1), InsertPoint, xlSheet.Cells(ii, 4))
    With tt
      .Height = xlSheet.Cells(ii, 4).Value
      .ScaleFactor = xlSheet.Cells(ii, 5).Value
      .StyleName = Trim(xlSheet.Cells(ii, 6).Value)
      '.Layer = Trim(xlSheet.cells(ii, 7).Value)
      .Layer = Trim(xlSheet.Cells(ii, 8).Value)
    End With
  Next ii
End Sub

'调用Excel通讯程序

Function xlApp() As Object

    'Dim xlApp As Object    ' This Line ,Not set Excel , run Excel
    'Dim xlsheet As Object
   
    ' 发生错误时跳到下一个语句继续执行
    On Error Resume Next
    ' 连接Excel应用程序
    Set xlApp = GetObject(, "Excel.Application")
   
    If Err.Number <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True
        xlApp.Workbooks.Add
    End If

    ' 返回当前活动的工作表
'    Set xlSheet = xlApp.ActiveSheet
End Function

huiyin

先调用EXCEL生成数据文件，再调用CAD使用数据文件绘图。

lolanda

有Vlisp源代码吗？

liusong0517

hao 谢谢大家,我刚学的,在上面了解了好多东西,有成就一定共享

无声

王华武舾装辅助设计系统(船舶舾装图纸设计辅助软件gsi升级版)试用版
以下是船舶软件的下载联接。

中国国防科技论坛
http://bbs.81tech.com/index.php
下载页
http://bbs.81tech.com/read.php?t ... toread--page-1.html

由于上传过程确实过于痛苦，因为软件太大，分25个分卷。所以只好引用了。希望见谅！
如果管理员有时间的话，可以整理下，并将其上传至此！谢谢！！！
由于软件过大。尝试了N次多卷一起上传但是都不成功，只好一个一个的上传。希望管理员不要见怪，如果可能的话，希望管理员整理一下。
分25卷上传。请将所有分卷下载到同一个文件夹内再进行解压缩，然后安装既可使用。若安装不成功，请下载VB6.0中文企业版(百度搜索应该有破解版）。安装VB6.0，然后再安装此软件。此软件自动绘制CAD格式明细表的功能必须结合AutoCAD2004才能完成，其他版本不支持。若没有安装AutoCAD2004，则无法实现自动绘制明细表！要实现其他版本支持是可以实现的，只是本人时间紧迫，白天要上班，下班才有时间编写程序。本人的正职工作是船舶设计，而不是程序开发。程序开发是业余爱好而已，请各位见谅！

下图为此程序明细表的操作界面，其余界面在此不便一一展开！

点击下图可放大，便于清晰观看，增加了解！

以下是生成的明细表样本（调试时生成的，非标准格式）
点击下图可放大，便于清晰观看，增加了解！
[

&lt;王华武舾装辅助设计系统&gt;是根据舾装设计需要，在运用Access数据库的技术基础上，结合AutoCAD二次开发技术；运用VB6.0编程语言平台综合设计而成。在数据库技术的支持下，可省却设计手册查找的功能，并达成自动运算功能，省却人工复杂而烦琐的重量计算和反复的数据信息填写。在AutoCAD二次开发技术的支持下，可以完成自动绘制明细表的功能。省却人工绘制明细表的过程。与此同时，本程序还根据设计需要，完成了连接件自动匹配的运算功能模块，省却设计手册的查找和运算，从而实现快速运算匹配，并提供了图文并貌的直观性。
以上功能模块，总体上缩短了设计时间，提供了设计效率和准确性。

数据库：
明细表数据库，材料表数据库，连接件表数据库
明细表可存，可添加，可修改，可插入，可删除，其行可上下调整等。
材料表和连接件表可存，可添加，可修改，可删除等。

本人未来得及完善数据库，请使用者根据需要和程序要求自行添加相关数据。

此软件操作多次用到鼠标右键。请各位摸索。因为时间匆忙，使用手册没做详细说明。
谢谢各位。

QUAI

我好久没来了.不能帮你.

xofox

下面是一个自动读取csv文件（逗号分隔文本文件，可用execl打开）按坐标、标注等数据绘制钻孔的程序，看看有没有用

;绘制钻孔.lsp----v2.0
;从数据文件中读取钻孔参数，自动绘制钻孔及标注，请首先确认数据文件符合要求
;各行中不要出现多余的换行符，否则会发生错误
;有一列标题行，按顺序为0序号，1钻窝编号，2钻孔号，3开口X，4开口Y，5开口Z，6孔深，7方位，8倾角，9本溪顶孔深（煤孔则为末段孔深）->
;->10本溪底孔深（煤孔则为终孔岩性），11初见水孔深，12初见水量，13最大水孔深，14最大水量，15水压，16注浆量，17注浆终压，18终孔层位，19施工日期，20目的，21水温
(defun c:rdata()
  (setq sysang (getvar "ANGDIR")) ;取得角度方向（顺时针/逆时针）
  (setvar "ANGDIR" 0)   ;设置为逆时针方向
  (setq sysabase (getvar "ANGBASE")) ;取得方向的基准角度
  (setvar "ANGBASE" 0)   ;设置方向的基准角度为东
  (setq sysvar (getvar "OSMODE")) ;获得并保存对象捕捉设置
  (setvar "OSMODE" 16384)  ;关闭对象捕捉

  (setq data (open (getfiled "选择CSV数据文件" "d:/打钻资料.csv"  "csv" 8) "r"))
  (setq bh (getint "从第几条记录开始读取数据："))
  (repeat bh (setq bz (read-line data)))
  (if bz (princ "ok") (progn (princ "输入错误！！")(exit)))

  (setq b1 '(0) b2 nil)
  (setq m 0 n 1 i 0 )
  (while (setq s1 (read-line data))
      (while (<= n (strlen s1))
         (setq ch (substr s1 n 1))
              (if (= ch ",")
                (progn (setq m (1+ m)) (setq b1 (cons n b1)) )
       )
  (setq n (1+ n))
      )
      (setq b1 (reverse b1))
;      (princ b1)
      (repeat m
    (setq e1 (+ (nth i b1) 1))
    (setq e2 (nth (+ i 1) b1))
           (setq b2 (cons (substr s1  e1 (- e2 e1)) b2) )
           (setq i (1+ i))
      )
      (setq b2 (reverse b2))
   
      (setq p1 (list(atof (nth 3 b2))(atof (nth 4 b2))) )
      (setq t1 (rtos (* (atof (nth 6 b2)) (cos (*(/(atof(nth 8 b2)) 180) pi))  )))
      (setq t2 (itoa (- 90 (atoi (nth 7 b2)))))
      (setq s2 (strcat "@"  t1"<" t2))
;      (setq s3 (strcat (nth 1 b2) ":孔深" (nth 5 b2)"m,方位" (nth 6 b2)",倾角"(nth 7 b2) ".初见水孔深" (nth 8 b2) "m,初见水量" (nth 9 b2)",最大水孔深" (nth 10 b2) "m,最大水量" (nth 11 b2)",水压" (nth 12 b2) ",日期:" (nth 13 b2)",终孔层位:" (nth 14 b2)"."  ))
      (command "line" p1 s2 "")

      (command "ucs" "")   ;设置为wcs
      (setq p2  (cdr (assoc 11 (entget(entlast)))))
      (command "circle" p2 1.5)  ;画圆
      (command "pline" (list (- (car p2) 10) (cadr p2))     (list (- (car p2) 2) (cadr p2)) "")
      (command "pline" (list (+ (car p2) 2) (cadr p2))     (list (+ (car p2) 13) (cadr p2)) "") ;画线
   
      (command "-text" "j" "mc"  (list (car p2)  (+ 8 (cadr p2))) 3 0 (nth 2 b2))  ;钻孔名称
      (command "-text" "j" "mc"  (list (car p2)  (+ 5 (cadr p2))) 2 0 (strcat (nth 7 b2) "/" (nth 8 b2)));方位/倾角
      (command "-text" (list (- (car p2) 10)  (+ 0.5 (cadr p2))) 2 0 (nth 5 b2));开孔Z值
      (command "-text" (list (+ (car p2) 2) (+ 0.5 (cadr p2))) 2 0 (strcat (nth 9 b2) "/" (nth 10 b2)));本灰孔段或未段孔深岩性
      (command "-text" (list (- (car p2) 10)  (- (cadr p2) 2.5)) 2 0 (nth 11 b2))  ;初见水孔深
      (command "-text" (list (- (car p2) 10)  (- (cadr p2) 5)) 2 0 (nth 13 b2))  ;最大水孔深
      (command "-text" (list (+ (car p2) 5)  (- (cadr p2) 2.5)) 2 0 (nth 12 b2))  ;初见水量
      (command "-text" (list (+ (car p2) 5) (- (cadr p2)5)) 2 0 (strcat (nth 14 b2) "/" (nth 15 b2)));最大水量/水压
      (command "-text"  "j"  "mc" (list (car p2)   (- (cadr p2) 3)) 2 0 (strcat (nth 16 b2) "/" (nth 17 b2)))  ;注浆量/终注压力
   
      (command "ucs" "p")   ;恢复ucs
   
;      (setq x1 (+(*(cos (*(/ (atof t1) 180)pi))(atof(nth 5 b2)))(car p1)) )
;      (setq y1 (+(*(sin (*(/ (atof t1) 180)pi))(atof(nth 5 b2)))(cadr p1)) )
;      (setq p2 (list x1 y1))
;      (setq x2 (+(*(cos (+(atan 0.3) (*(/ (atof t1) 180)pi))) 50) x1))
;      (setq y2 (+(*(sin (+(atan 0.3) (*(/ (atof t1) 180)pi))) 50) y1))
;      (setq p3 (list x2 y2 ))
;      (command "-mtext" p2 "r" (itoa (- 90 (atoi (nth 6 b2)))) "h" 2.5 p3 s3 "")
;      (princ "\n")
;     (princ p3)
;          (princ",")
 ;         (princ (- y1 (cadr p1)))
;      (print y1)
;      (princ b2)
;
 (setq n 1 m 0 b1 '(0) b2 nil i 0)
   )
;  (princ "\n")

  (close data)
  (setvar "ANGDIR" sysang)  ;恢复角度方向
  (setvar "ANGBASE" sysabase)  ;恢复方向的基准角度
  (setvar "OSMODE" sysvar)  ;恢复对象捕捉设置
)

wangdeshow

10楼给wangdeshow@163.com发一个，谢谢。