エクセルのVBAによるセルデータのAutoCAD LTへの送信



ダイナミックスクリプトを使ったエクセルのセルの座標データの AutoCAD LT2000 への送信例です。もっとも簡単で確実な 方法です。 エクセルにボタンを一個つくり、下のプログラムで セルのデータをAutoCAD LT2000 へ送信できます。 当然、AutoCAD LT2000は立ち上げた状態にしておいて ください。
このプログラムは自動的に エクセルのセルデータをスクリプトファイル"C:\My Documents\op.scr" に保存し、SendKeysでスクリプトの実行コマンドのみを AutoCAD LT2000に送信します。(注 C:\My Documentsというフォルダがない 場合はあらかじめつくってください。)
AutoCAD LT2000とLT97でしか動作確認していませんが、AutoCADでもLTでも バージョンに関係なく動作すると思います。
このプログラムで、複数本もかけます。
A、BをX、Y座標で1本目の線
C、DをX、Y座標で2本目の線


となります。
注意:もし 図面を開くときダイアログが表示されなくなった場合は システム変数FILEDIAを1にもどしてください。
Print #1, "PLINE"の前にPrint #1, "filedia 1"を追加しました。
スクリプトを実行するときダイアログを開かせないために
SendKeys "filedia 0 " & "script" & Chr$(13) & fnb & Chr$(13), True
としているのですが、スクリプトが実行される一番最初に"filedia 1"入れた 方が安全性が高い。(2000.8.18)


Private Sub CommandButton1_Click()

    Dim x As Double, y As Double
    
    On Error GoTo ErrorHand
    
    'エクセルのセルデータのAutoCAD LT2000 への送信
    
    fnb = "C:\My Documents\op.scr"
    Close
    Open fnb For Output As #1
    
    jj = 0
    
    Do
        If Worksheets("Sheet1").Cells(1, jj + 1).Value = "" Then Exit Do
        Print #1, "filedia 1"
	Print #1, "PLINE"
        ii = 0
        Do
            ii = ii + 1
            cc = 0
            For j = jj + 1 To jj + 2
                If Worksheets("Sheet1").Cells(ii, j).Value = "" Then cc = 1: Exit For
                If j = jj + 1 Then x = Worksheets("Sheet1").Cells(ii, j).Value
                If j = jj + 2 Then y = Worksheets("Sheet1").Cells(ii, j).Value
            Next j
            If cc = 1 Then Exit Do
            Print #1, "none "; Trim(Str(x)); ","; Trim(Str(y))
            
        Loop Until ii > 1000
        
        Print #1, ""
        jj = jj + 2
        
    Loop Until jj > 1000
    
    Print #1, "filedia 1"
    Close
        
    AppActivate "AutoCAD"  ' アクティブにします。
    SendKeys "filedia 0 " & "script" & Chr$(13) & fnb & Chr$(13), True
    
    Exit Sub

ErrorHand:
    Close
    Exit Sub

End Sub
ダウンロード
acadout3.lzh (約12KB)

エクセル編PART2:VBAによるAutoCAD LTで書いた表のテキスト文字データの エクセルへの送信



上図のようにAutoCAD LTで書いた表をエクセルのセルデータに取り込む。
DXFを作成して、その中の文字データをエクセルに取り込んでいます。
下の方のダウンロードを解凍するとexcelin.xlsと表.dwgの2つのファイルができます。 (注 C:\My Documentsというフォルダがない場合はあらかじめつくってください。)
 1.AutoCADLT2000を立ち上げ、表.dwgを開く。
 2.excelin.xlsをエクセルで開く。
 3.DXF作成ボタンを押す。
 4.開始ボタンを押す。
 5.クリアボタンを押すとエクセルのセルデータはクリアされます。
DXFの中身はノートパッドを開いて自分なりに解析しただけで、むずかしい ことはしてないので、LTの他のバージョンでは使えません。


Private Sub CommandButton1_Click()

    On Error GoTo ErrorHandler
    Label5.Caption = ""
    
    aac = "C:\My Documents\ExText.dxf"
    fnc = "C:\My Documents\op.scr"
    
    'DWG→DXF
    Open fnc For Output As #1
    
    Print #1, "filedia 0"
    Print #1, "dxfout"
    Write #1, aac
    Print #1, ""
    Print #1, "filedia 1"
    Close
    
    AppActivate "AutoCAD"
    SendKeys "filedia 0 script" & Chr$(13) & fnc & Chr$(13), True
        
    Label5.Caption = aac & "の作成に成功しました"
    AppActivate "Microsoft Excel"
        
Exit Sub

ErrorHandler:
    Close
    Label5.Caption = aac & "の作成に失敗しました!!!!!!"

End Sub

Private Sub CommandButton2_Click()

    Dim xx(5000) As Single, yy(5000) As Single, moji(5000) As String
    Dim xa(50) As Single, ya(100) As Single, xi(50) As Single, xj(50) As Single
    Dim yi(100) As Single, yj(100) As Single
    
    'On Error GoTo ErrorHandler

    xa0 = Val(TextBox11.Text)
    ya0 = Val(TextBox12.Text)
    
    nx = Val(TextBox15.Text)
    ny = Val(TextBox14.Text)
    
    If TextBox1.Text <> "" Then xa(1) = Val(TextBox1.Text)
    If TextBox2.Text <> "" Then xa(2) = Val(TextBox2.Text)
    If TextBox3.Text <> "" Then xa(3) = Val(TextBox3.Text)
    If TextBox4.Text <> "" Then xa(4) = Val(TextBox4.Text)
    If TextBox5.Text <> "" Then xa(5) = Val(TextBox5.Text)
    If TextBox6.Text <> "" Then xa(6) = Val(TextBox6.Text)
    If TextBox7.Text <> "" Then xa(7) = Val(TextBox7.Text)
    If TextBox8.Text <> "" Then xa(8) = Val(TextBox8.Text)
    If TextBox9.Text <> "" Then xa(9) = Val(TextBox9.Text)
    If TextBox10.Text <> "" Then xa(10) = Val(TextBox10.Text)
    
    For i = 1 To ny
        ya(i) = Val(TextBox13.Text)
    Next i
    
    aa = 0
    For i = 1 To nx
        xi(i) = aa + xa0
        aa = aa + xa(i)
        xj(i) = aa + xa0
    Next i
    
    aa = 0
    For i = 1 To ny
        yi(i) = aa + ya0
        aa = aa + ya(i)
        yj(i) = aa + ya0
    Next i
    

    Label5.Caption = ""
    
    aad = "C:\My Documents\ExText.dxf"
    
    Open aad For Input As #1

        j = 0
        Do While Not EOF(1)
            Line Input #1, bcc
            If bcc = "TEXT" Then
                j = j + 1
                For i = 1 To 30
                    Line Input #1, bcc
                    If bcc = "AcDbText" Then Exit For
                Next i
                Input #1, dummy
                    
                Line Input #1, bcc
                xx(j) = Val(bcc)
                Input #1, dummy
                Line Input #1, bcc
                yy(j) = Val(bcc)
                Input #1, dummy
                Input #1, dummy
                Input #1, dummy
                Input #1, dummy
                Input #1, dummy
                Line Input #1, bcc
                moji(j) = bcc
                
            End If
            If j >= 5000 Then Exit Do
        Loop
    Close
    
    nn = j
    
    For i = 1 To nx
        For j = 1 To ny
            momo = ""
            For k = 1 To nn
                If xi(i) < xx(k) And xx(k) < xj(i) And yi(j) < yy(k) And yy(k) < yj(j) Then
                    momo = momo & moji(k)
                    Worksheets("Sheet1").Cells(ny - j + 2, i).Value = momo
                End If
            Next k
        Next j
    Next i

    Exit Sub

ErrorHandler:
    Close
    
End Sub

Private Sub CommandButton3_Click()

    nx = Val(TextBox15.Text)
    ny = Val(TextBox14.Text)

    For i = 1 To nx
        For j = 1 To ny
             Worksheets("Sheet1").Cells(j + 1, i).Value = ""
        Next j
    Next i

End Sub

Private Sub Label6_Click()

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)

End Sub

ダウンロード
excelin.lzh (約58KB)


Home