最近做的AutoCAD画线工具——里面有读Mat文件的部分——看有没有高手给点意见！

WaitingForMe

先说明一下，源程序后面发贴，在附件中的工程当中可以看到所有的源程序。

我的本意是，从一个txt文本文件，或者Matlab的Base Workspace当中读入数据，然后在AutoCAD当中画线。在从Matlab Base Workspace读入数据，用DDE的方式最好，发现AutoCAD VBA当中的Input Box和VB当中的不一样，不提供DDE的连接~~~~后来就改成从Mat文件当中采用AxtiveX的方式来读Mat文件当中的数据~~

整个程序还附带了从Txt文件读如数据的功能，需要用到FSO对象(很多病毒VBS也用这个，所以有的人把这个冬冬删了)
还需要一个打开文件的对话框的dll需要注册，一个附带的VBS文件可以实现注册这个dll.

整个程序看附件。

WaitingForMe

'ToolForm的所有响应函数
Private Sub cmdLine_Click()
    '============================================================================
    '
    '   这是一个AucoCAD-VBA的画线程序，线是3维的空间曲线，平面曲线只需要将Z坐标
    '置为0由于程序支持从文本文件和mat文件中读入数据点的数据，所以需要线注册一个
    '打开文件的dll:
    '
    '                          safrcdlg.dll
    '
    '   请先运行Reg.VBS文件注册这个dll文件。由于注册程序中使用了FSO文件对象，所以您
    '的防毒软件可能会提示遇到病毒，同时如果您的防毒软件禁止了FSO对象，请手动注册这
    '个dll文件.
    '
    '
    '   免责声明：个人不担保代码在传播过程中不会被恶意修改，对您再使用过程中遇到的
    '               任何损失，将不负任何责任
    '
    'WaitingForMe
    '2005/8/1
    '
    '============================================================================
    Dim data As Variant
    Dim m, n, i, j, k As Integer
    Dim FileName As String
    Dim objDialog As Object
    Dim intReturn As Boolean
'===========================================================
    '读数据
    If Not ExistFileDlg Then
        MsgBox "缺少必要组件,请运行附带的VBS脚本程序!", 0, "出错了!"
        Exit Sub
    End If
   
    Set objDialog = CreateObject("SAFRCFileDlg.FileOpen")
    intReturn = objDialog.OpenFileOpenDlg
    If intReturn Then
        FileName = objDialog.FileName
        If StrComp(".mat", Right(FileName, 4), vbTextCompare) = 0 Then
           ==================
           '这里开始与Matlab相关的程序
           ==================
            Dim Result As String
            Dim sca(0, 0) As Double '标量实部临时数组
            Dim scaimg() As Double  '标量虚部临时数组
            Dim nvar As Double
            Dim ValideVar As String
            Dim size1 As Double
            Dim size2 As Double
            Set Matlab = CreateObject("Matlab.Application")
            Matlab.Visible = False
            Result = Matlab.Execute("load('" & FileName & "');acad_varnames=who;acad_n=length(acad_varnames);")
            Call Matlab.GetFullMatrix("acad_n", "base", sca, scaimg)
            nvar = sca(0, 0)
            If nvar = 0 Then
                MsgBox "Mat文件中不含变量！", 0, "出错了"
                Exit Sub
            End If
            NvalideVar = 0
            VarForm.combVars.Clear
            For i = 1 To nvar
                Result = Matlab.Execute("acad_cols=eval(['size(' acad_varnames{" & i & "} ',2)']);")
                Call Matlab.GetFullMatrix("acad_cols", "base", sca, scaimg)
                size2 = sca(0, 0)
                If size2 = 3# Then
                    Result = Matlab.Execute("acad_validevar=acad_varnames{" & i & "};")
                    ValideVar = Matlab.GetCharArray("acad_validevar", "base")
                    If VarForm.combVars.Value = "" Then
                        VarForm.combVars.Value = ValideVar
                    End If
                    Call VarForm.combVars.AddItem(ValideVar)
                    NvalideVar = NvalideVar + 1
                End If
            Next i
            'MsgBox "合法变量个数" & NvalideVar
            If NvalideVar = 0 Then
                MsgBox "没有找到合法变量！变量空间中的变量的列数必须是3！", 0, "出错了"
                Exit Sub
            Else
                VarForm.Show
                ToolForm.Hide
                objDialog.FileName = Left(FileName, Len(FileName) - 4) & ".txt"
                Exit Sub
            End If
            Exit Sub
        End If
        data = ReadTxtFile(objDialog.FileName, ",")
        m = UBound(data, 1)
        n = UBound(data, 2)
        k = -1
        ReDim points((m + 1) * (n + 1) - 1)
        For i = 0 To m
            For j = 0 To 2
                k = k + 1
                points(k) = data(i, j)
            Next j
        Next i
    Else
        Exit Sub
    End If
'===========================================================
    '画线
    Call DrawLine(points)
End Sub

Private Function ReadTxtFile(FileName, dlm)
    '从文本文件读入数据，dlm表示分隔符
    Dim Fso As Object
    Dim TextStream As Object
    Dim data() As Double
    Dim i As Integer
    Dim n As Integer
    Dim sLine As String
    Dim Temp As Variant
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set TextStream = Fso.OpenTextFile(FileName, 1)
    n = 0
    While Not TextStream.AtEndOfStream
        n = n + 1
        TextStream.SkipLine
    Wend
    TextStream.Close
    ReDim data(n - 1, 2)
    Set TextStream = Fso.OpenTextFile(FileName, 1)
    For i = 0 To n - 1
        sLine = TextStream.ReadLine
        Temp = SplitData(sLine, dlm)
        data(i, 0) = Temp(0)
        data(i, 1) = Temp(1)
        data(i, 2) = Temp(2)
    Next i
    Set Fso = Nothing
    ReadTxtFile = data
End Function

Private Function ExistFileDlg()
    '检查打开文件的对话框组件是否存在
    On Error Resume Next
    Dim objDlg As Object
    Set objDlg = CreateObject("SAFRCFileDlg.FileSave")
    Set objDlg = Nothing
    If Err.Number <> 0 Then
        ExistFileDlg = False
        Err.Clear
    Else
        ExistFileDlg = True
    End If
End Function

Private Sub Label1_Click()
    '点这个标签访问我的Web-Log，哈哈
    On Error Resume Next
    Call Shell("C:\Program Files\Internet Explorer\IEXPLORE.EXE http://waitingforme.yculblog.com")
End Sub

Private Sub Label2_Click()
    '点这个标签给我发送Email，呵呵
    On Error Resume Next
    Call Shell("C:\Program Files\Outlook Express\msimn.exe /mailurl:mailto:heroaq_2002@163.com?subject=ACAD_Line_Tool")
End Sub

WaitingForMe

'VarForm的所有响应函数
Private Sub cmdReadMat_Click()
    '从用户选择的变量读入数据并画线
    Dim sca(0, 0) As Double '标量实部临时数组
    Dim scaimg() As Double  '标量虚部临时数组
    Dim size1 As Double
    Dim size2 As Double
    Dim m As Integer
    Dim Pr() As Double
    Dim Pi() As Double
    Result = Matlab.Execute("acad_cols=size(" & combVars.Value & ",1)")
    Call Matlab.GetFullMatrix("acad_cols", "base", sca, scaimg)
    size1 = sca(0, 0)
    m = CInt(size1) - 1
   
    ReDim Pr(m, 2)
    Call Matlab.GetFullMatrix(combVars.Value, "base", Pr, Pi)

    k = -1
    ReDim points((m + 1) * 3 - 1)
    For i = 0 To m
        For j = 0 To 2
            k = k + 1
            points(k) = Pr(i, j)
        Next j
    Next i
   
    Matlab.Quit
   
    Set Matlab = Nothing
   
    Call DrawLine(points)
   
    VarForm.Hide
    ToolForm.Show
End Sub

WaitingForMe

'TanForm的所有响应函数
Private Sub cmdOK_Click()
    '设置Spline的起点和终点的切线向量
    Dim TStart(2) As Double
    Dim TEnd(2) As Double
    Dim Temp As Variant
    Dim splineObj As AcadSpline
    TanForm.Hide
    ToolForm.Show
    Temp = SplitData(TanStart.Text, ",")
    TStart(0) = Temp(0)
    TStart(1) = Temp(1)
    TStart(2) = Temp(2)
    Temp = SplitData(TanEnd.Text, ",")
    TEnd(0) = Temp(0)
    TEnd(1) = Temp(1)
    TEnd(2) = Temp(2)
    Set splineObj = ThisDrawing.ModelSpace.AddSpline(points, TStart, TEnd)
    ZoomAll
End Sub

WaitingForMe

'公共模块
Public points() As Double
Public Matlab As Object
Public NvalideVar As Integer '合法变量的个数

Public Function SplitData(str, dlm)
    '从一行字符串中返回x,y,z三个值
    '字符串中的数字可以使用各种非数字字符隔开
    Dim astr As Variant
    Dim ret(2) As Double
    While Not IsNumeric(Right(str, 1)) And Len(str) > 0
        str = Left(str, Len(str) - 1)
    Wend
    If Len(str) = 0 Then
        SplitData = "error!"
        Exit Function
    End If
    astr = Split(str, dlm, 3)
    ret(0) = CDbl(astr(0))
    ret(1) = CDbl(astr(1))
    ret(2) = CDbl(astr(2))
    SplitData = ret
End Function

Public Sub DrawLine(points)
    '画线
    Select Case ToolForm.CombLineType.Value
        Case "多段线"
            Call Line(points)
        Case "多义线"
            'Call PolyLine(points)
            Dim polyObj As Acad3DPolyline
            Set polyObj = ThisDrawing.ModelSpace.Add3DPoly(points)
            ZoomAll
        Case "样条曲线"
            ToolForm.Hide
            TanForm.Show
        Case Else
    End Select
End Sub

WaitingForMe

'[Reg.VBS]
'这是一个Dll 注册VBS程序，其中要使用WSH和FSO

Dim WSHShell
Dim Fso
Set WSHShell = CreateObject("WScript.Shell")
CrtDir=WSHShell.CurrentDirectory
If Not ExistFileDlg Then
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  objFSO.CopyFile CrtDir & "\safrcdlg.dll","C:\Winnt\System32\safrcdlg.dll"
  WshShell.Run("regsvr32 " & "C:\Winnt\System32\safrcdlg.dll")
  Set objFSO = Nothing
End If
Set WshShell=Nothing

Function ExistFileDlg
  On Error Resume Next
  Dim objDlg
  Set objDlg = CreateObject("SAFRCFileDlg.FileSave")
  Set objDlg = Nothing
  If Err.Number<>0 Then
    ExistFileDlg=false
    Err.Clear
  Else
    ExistFileDlg=true
  End If
End Function

bainhome

这还差不多:D
不过一时半会儿没看懂...:(
我也凑个热闹,不过不是我写的...:(
这个是反过来的,读入dxf中的点,线,多义线的坐标,下面是部分描述:
description:
the dxf2coord script reads the coordinates of points, lines, polylines
(LWPOLYLINES with and without elevation) 3d polylines, 3dfaces and circles
out of a acad r2000 - r2004 ascii .dxf file. this simple script treads the
.dxf file as a string and looks for the keywords for the interested entity
(e.g. 'AcDbPolyline' for polylines) and reads the following coordinates.
for details see the dxf reference.
不过昨天刚下的,还没有测试,抽时间再搞吧^_^

WaitingForMe

所有文件

bainhome

小样!:D
再来一个,这里面的线型和颜色等不能附加改动,和上面我发的那个一样...

WaitingForMe

BainHome，你的头像杂个不见了？

paradiseboy

学习了！

alexqxp

WaitingForMe wrote:
BainHome，你的头像杂个不见了？

没听那小子说的：
花开见佛,心即灵山

刚刚剃了光头，头像给剃掉了。