ExcelのVBAを使って、JDrafにポリラインと文字(テキスト)を作図するプログラムを紹介したいと思います。
今回はExcelのVBAを使ったプログラムを紹介していきます。

画像で説明が出来ないので、つたない紹介でよくわからない事があるかと思うので、
とりあえずプログラムが完成したExcelを「参照先」にリンクを貼っています。興味がある方はダウンロードして下さい。


まず、ExcelのVBAを使ってJDrafを動かすにはJDraf(？)のタイプライブラリに対して参照設定を行う必要があります。
よくわからない方は、VBE(Visual Basic Editor）を起動して、メニューの「ツール(T)-参照設定(R)」を選択して、
「PCAD_AC_X Type Library」と「PCAD_DB_X 3.09 Type Library」を選択し、OKを押すと参照設定を行ったという事になります。


つぎにプログラムコードとは別に、Excelのシートに下準備を行っていきます。
具体的には、座標値や記入する文字を入力し、プログラムを実行するためのボタンなどをシートに設置していきます。

1行目には、項目を入力します。
A列は「X座標」、B列は「Y座標」、C列は「測点名」と項目名を入力して、
2行目以降には、座標値や測点名(記入する文字)を入力して下さい。測点名は未記入でも構いません。
F列の1行目には、記入する文字の高さ(大きさ)を数字で入力しておいて下さい。

プログラムを実行するためにシートにActiveXのボタンを配置して、
ポリラインを閉じるのかを決めるチェックボックスも配置して下さい。

これでExcelのシートに記入する内容は以上です。
ざっくりした説明で申し訳ないですが、詳細は「参照先」のエクセルをダウンロードして
見比べて頂くといいと思います。

つぎの投稿はVBEに書き込むプログラムコードを記載します。

編集

Option Explicit
'VBA ウィンドウのツールメニューの参照設定から
'「PCAD_AC_X Type Library」と「PCAD_DB_X 3.09 Type Library」を選択する必要がある

Private Sub CommandButton1_Click()
    On Error Resume Next
    
    'JDRAFを起動してアクティブドキュメントを取得-----------------------------------
    Dim app As AcadApplication  'アプリケーションオブジェクト
    Dim doc As AcadDocument 'アクティブなドキュメント
    Set app = GetObject(, "PCAD_AC_X.AcadApplication")  '実行中のJDRAFを取得する
    '実行中のJDRAFがなく、取得できないとき
    If app Is Nothing Then
        Set app = CreateObject("PCAD_AC_X.AcadApplication") 'JDRAFを起動して取得する
        'JDRAFを取得できないとき
        '・JDRAFがインストールされていない
        '・JDRAFがレジストリに正しく登録されていない
        If app Is Nothing Then
            MsgBox Err.Description
            Exit Sub
        End If
    End If
    'アクティブな図面オブジェクトを取得
    Set doc = app.ActiveDocument
    
    'APIで作図---------------------------------------------------------------------
    Dim LastRow As Long
    Dim i As Long, row As Long
    Dim cell As Variant
    Dim p() As Double, p2(0 To 2) As Double '座標値
    i = 0
    '最終行を取得する
    LastRow = Range("A1048576").End(xlUp).row
    If LastRow < 3 Then
        MsgBox "3点以上の座標を記入して下さい。"
        Exit Sub
    End If
    '文字をAPIで描く
    Dim textObj As AcadText
    '2行目から座標を取得(文字も作図)
    For row = 2 To LastRow
        ReDim Preserve p(0 To i * 2 + 1)
        p2(0) = Range("A" & row).Value 'X座標
        p(i * 2) = CDbl(p2(0))
        p2(1) = Range("B" & row).Value 'Y座標
        p(i * 2 + 1) = CDbl(p2(1))
        p2(2) = 0 'Z座標(文字用)
        cell = Range("C" & row) '測点名を取得
        If Not IsEmpty(cell) Then
            Set textObj = doc.ModelSpace.AddText(cell, p2, Range("F1"))
        End If
        i = i + 1
    Next row
    
    'ポリラインをAPIで描く
    Dim plineObj As AcadLWPolyline
    Set plineObj = doc.ModelSpace.AddLightWeightPolyline(p)
    plineObj.Closed = CheckBox1.Value
End Sub

編集

シートに作成したボタンを押すと実行処理するように出来ていて、内容としては大きく分けて
前半の「JDRAFを起動してアクティブドキュメントを取得」する部分と
後半の「APIで作図」する部分の2部構成です。

前半の方は、ジェイドラフさんから頂いた開発環境資料に書いてあったものをほぼそのまま流用させて頂き、
後半の方で、作図するために座標や作図する文字の情報をシートから取得して作図する、簡単なものを掲載しています。

使う時には、実行のボタンを押した時にJDrafが起動されてなければ、起動されて作図され、
JDrafが起動されていれば、その図面に作図される仕組みになっています。

あと注意事項としては、32bitのExcelは32bitのJDrafを動かし、64bitのExcelは64bitのJDrafを動かすので、
同じビットのソフトを使わなければいけない事が動作条件になっています。


以上がポリラインとテキストを作図するプログラムコードを紹介しました。
これをもとに色々な図形を作図する事にも挑戦してみるのはどうでしょうか？

編集

ポリライン作図と座標記入素晴らしいです。
で・・・教えて下さい。
64ビットどうしで動かしていますが「PCAD_AC_X Type Library」と「PCAD_DB_X 3.09 Type Library」
が参照不可になっています。
フォルダが違うかと思い探しましたが見つけられません
別に何か必要なのでしょうか？

もう少し頑張ってみます。

編集

デジさん、すいません。
私の場合は、32bitでExcelを作成していたので
64bitでは参照設定がうまくできなのかったようですね。


少し詳しく説明すると
「PCAD_AC_X Type Library」と「PCAD_DB_X 3.09 Type Library」の参照設定は、
ファイルを読み込んで設定をしています。

32bit版の場合、
「PCAD_AC_X Type Library」のファイルの場所は、
C:\Program Files (x86)\JDraf Co Ltd\JDraf 2016\BIN\JDraf.exe
「PCAD_DB_X 3.09 Type Library」のファイルの場所は、
C:\Program Files (x86)\JDraf Co Ltd\JDraf 2016\BIN\OdaX_3.09_11.dll
です。

なので64bit版の場合は保存先が違うので、
「PCAD_AC_X Type Library」のファイルの場所は、
C:\Program Files\JDraf Co Ltd\JDraf 2016\BIN\JDraf.exe
「PCAD_DB_X 3.09 Type Library」のファイルの場所は、
C:\Program Files\JDraf Co Ltd\JDraf 2016\BIN\OdaX_3.09_11.dll
にあると思います。(64bit版はアンインストールをしたので確認はしていませんが…)

VBEのメニューの「ツール(T)-参照設定(R)」を選択すると表示されるフォームの
右側に「参照(B)」のボタンでファイルを読み込んで設定してみて下さい。

うまく出来なかった時には、また投稿お願いします。
出来る限り協力させて頂きますので、挑戦してみて下さい。

編集

ありがとうございます。
PCAD_AC_X Type LibraryとPCAD_DB_X 3.09 Type Libraryファイルがあると思い懸命に探していました。（笑）
動作確認です。

平面・縦断・横断等の作成がエクセルの座標入力が簡単にできます。
Z値の欄追加お願いします。これからは3次元ですから〜
当分Z値は0ですけどね（笑顔）

編集

デジさんうまく動いて良かったですね

Z値の追加の件ですが、高さの情報を持つという事は、(軽量)ポリラインで作図するのではなく、
3Dポリラインで作図するという事になります。

3Dポリラインで作図するExcelをサンプルとしてリンクを貼りましたので、(軽量)ポリラインの時と
比較してみてはどうでしょうか？

編集

アルサポさん、いつもありがとうございます、Jdraf超初心者のタヌですm(__)m

この場合、どうしたら良いのでしょうか？

エクセル32bit＆Jdraf64bit。。。

宜しくお願い致します<(_ _)>

編集

こんにちは、たぬさん。
同じbit(32、64)対応のソフトを利用しなければ、ExcelとJDrafは連携出来できず、
利用する事が出来ません。
なので、私の場合はマイクロソフト社がExcel(Office)の32bit版を推奨していたので、
どちらも32bit版に合わせて利用しています。

編集

お世話になります。
超初心者からのお願いです。
当方、Jdraf2016、excel2013を使用しております。
いづれも32bitです。
サンプルマクロを起動させると、型が一致しませんの
エラー警告がでます。助言をお願いします。
また、ポリラインの座標をEXCELに出力ができるVBAを
公開していただければと思います。
よろしくお願いします。

編集

最近は、道路補修工事の施工管理の仕事を受け、昼夜問わず忙しく過ごしています。
なので、返信が遅くなり申し訳なく思います。すいません

さて本題ですが、サンプルマクロが動かないという事ですが、
いくつか確認したい事があります。

まず、参照設定がうまく設定できていますか？
VBEのメニューの「ツール(T)-参照設定(R)」で確認が出来ます。
参照されていない場合は、ライブラリファイルの一覧に参照されていない
旨が書かれていると思います。

次にサンプルマクロを実行した時に、もともと入力されていた値で実行したのか、
または、B級さんが入力した値で実行したのかを教えて頂きたいです。
もともと入力されていた値でエラーを起こすのであれば、原因はわかりませんが、
B級さんが入力した値であれば、入力値とプログラムの関係に原因があるかもしれないからです。

B級さん、時間がある時にでもご返信よろしくお願い致します。

編集

突然の質問で失礼いたします。

昔AutocadをExcelのVBAで動かしていましたが、その時のプログラムをJDRAF用に変更しました。
不要な部分も多々残っていますが、一応動作はします。

区分ごとに画層を作成し、ポリライン・文字を固有の画層に作図する事が出来ます。

が、画層に色を設定することができません。

作図が完了した段階で、画層プロパティで色を個別に変更しています。

この解決策をご教示願いたく、今回の質問となりました。
よろしくお願いいたします。

当方のVBAは下記のとおりです。

Public Sub DRAW()
    Dim app As AcadApplication
    Dim doc As AcadDocument
    Dim acadms As AcadModelSpace
    Dim hlay As AcadLayer
    Dim plineObj As AcadLWPolyline
    Dim TextObj As AcadText
    Dim Color As New AcadAcCmColor                ' 画層の色設定のため追加

'
    Dim ExcelSheet As Worksheet
    Dim points() As Double
    Dim annotationObject As Object
    Dim corner(0 To 2) As Double
    Dim text As String
    Dim AX(800), AY(800) As Long
  
    On Error Resume Next
    ' 起動しているAutoCADのApplicationオブジェクトを取得
    Set app = GetObject(, "PCAD_AC_X.AcadApplication")
    If Err Then
        ' AutoCADを起動してApplicationオブジェクトを取得
        Set app = CreateObject("PCAD_AC_X.AcadApplication")
        Err.Clear
    End If
    
    app.Visible = True ' AutoCADを表示
    Set doc = app.ActiveDocument ' Documentオブジェクトを取得
    Set acadms = doc.ModelSpace ' ModelSpaceコレクションを取得
    Set ExcelSheet = ThisWorkbook.ActiveSheet ' ExcelのSheetオブジェクトを取得
    
    LX = 1
    
    Set Color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.22")       ' 画層の色設定のため追加
       
    While Cells(LX, 1).text <> "Z"
        A$ = Cells(LX, 1).text
        luy = 0
        Select Case A$
            Case "A"
                C$ = "A_name"
                luy = 1
                Call Color.SetRGB(255, 255, 255)               ' 画層の色設定のため追加
            Case "B"
                C$ = "B_name"
                luy = 1
                Call Color.SetRGB(0, 255, 0)               ' 画層の色設定のため追加
            Case "C"
                C$ = "C_line"
                Call Color.SetRGB(0, 255, 255)               ' 画層の色設定のため追加
            Case "D"
                C$ = "D_Line"
                Call Color.SetRGB(255, 255, 255)               ' 画層の色設定のため追加
        End Select
        
        If luy = 1 Then
            Set hlay = doc.Layers.Add(C$)
            doc.ActiveLayer = hlay
            
            doc.ActiveLayer.TrueColor = Color             ' 画層の色設定のため追加

            corner(0) = Cells(LX, 2).Value
            corner(1) = Cells(LX, 3).Value
            corner(2) = 0
            text = Cells(LX, 4).text
            Set TextObj = acadms.AddText(text, corner, 2.5)
            
         Else
         
            Set hlay = doc.Layers.Add(C$)
            doc.ActiveLayer = hlay
            
            doc.ActiveLayer.TrueColor = Color               ' 画層の色設定のため追加
            
            IZ0 = Cells(LX, 2).Value
            LY = 0

            For J = 1 To IZ0
                LY = LY + 1
                LX = LX + 1
                AX(LY) = Cells(LX, 1).Value
                AY(LY) = Cells(LX, 2).Value
            Next J
    
            IZ3 = IZ0 * 2
            
            ReDim points(0 To IZ3 - 1) As Double
            
            For I = 1 To IZ0
                points((I - 1) * 2) = AX(I)
                points((I - 1) * 2 + 1) = AY(I)
            Next I
            
            Set plineObj = doc.ModelSpace.AddLightWeightPolyline(points)

         End If

         LX = LX + 1
 
    Wend
    
     app.ZoomExtents ' オブジェクト範囲ズーム

End Sub

編集

けんすけさん、こんにちは。
とても参考になるプログラムをありがとうございます。

ご質問の件ですが、ARESで実行したせいなのか、
実行すると指定した色で画層が作成されていました。
どうも力になれそうもなく、すいません

実は、文字の作図方法については使い方が分かったのですが、
ポリラインの方の使い方がわかりませんでした。
時間がある時にゆっくり勉強させて頂こうと思いますが、
できれば、使い方も書いてもらうと助かります。



今回、色の設定について話題になりましたので、
この場を借りて、インデックスカラーでの設定の方法を
追記しておきます。
けんすけさんは、RGBでの色の設定をされていました(下記のような記述)。
Call Color.SetRGB(255, 255, 255)

インデックスカラーでの設定の場合は、先ほどの「Call Color.SetRGB(255, 255, 255)」の
記述を下記のように書き換えれば、インデックスカラーで設定ができます。
Color.ColorIndex = 1
数字の箇所にインデックスカラーの番号(数字)を記入して下さい(ちなみに1は赤)。
数字以外にも
acByLayer	(ByLayerの時)
acByBlock	(ByBlockの時)
acRed		(赤の時)
acBlue		(緑の時)
などがあります。

編集

迅速なご対応をありがとうございます。

ARESでは可能とのことなので安心しました。
もう一工夫して見ます。

ポリラインの使い方、との事ですが、もう少し、日時をください。今週末でも返答できそうです。

それにしても、今改めて見返すと、無駄が多すぎる・野暮天プログラムで、冷や汗が出そうです。

編集

長文で失礼します。

ご質問の、ポリラインの使い方がいまいち、とのことでしたが、おそらくAX、AYの配列の使い方と思います。
１０年ほど前にAUTOCADで作成した名残です。
ポリライン作成という観点から見直すと、不要な配列なので、全体を見直し、簡略化しました。

画層の色に関しては、今回は省略しています。
自宅のデスクトップ・パソコンでは色の設定が可能、ノート・パソコンでは不可能、という状況です。
デスクトップにはJDRAF・Ares（どちらも体験版）が同居、ノートにはJDRAF（体験版）だけがインストール、という違いのようです。

Public Sub DRAW()
    Dim app As AcadApplication
    Dim doc As AcadDocument
    Dim hlay As AcadLayer
    Dim plineObj As AcadLWPolyline
    Dim TextObj As AcadText
'
    Dim ExcelSheet As Worksheet
    Dim points() As Double
    Dim corner(0 To 2) As Double
    Dim text As String
  
    On Error Resume Next
    ' 起動しているAutoCADのApplicationオブジェクトを取得
    Set app = GetObject(, "PCAD_AC_X.AcadApplication")
    If Err Then
        ' AutoCADを起動してApplicationオブジェクトを取得
        Set app = CreateObject("PCAD_AC_X.AcadApplication")
        Err.Clear
    End If
    
    app.Visible = True ' AutoCADを表示
    Set doc = app.ActiveDocument ' Documentオブジェクトを取得
    Set ExcelSheet = ThisWorkbook.ActiveSheet ' ExcelのSheetオブジェクトを取得
    
    LX = 1
       
    While Cells(LX, 1).text <> ""　　　　　　　'　A列の文字が空白ならば終了
        A$ = Cells(LX, 1).text

        luy = 0　　　　　　　　　　　　　　　　’luy:フラグ　　0=ポリライン　　 1=文字列
        Select Case A$
            Case "A"
                C$ = "A_name"
                luy = 1
            Case "B"
                C$ = "B_name"
                luy = 1
            Case "C"
                C$ = "C_line"
            Case "D"
                C$ = "D_line"
        End Select
        
        If luy = 1 Then
            Set hlay = doc.Layers.Add(C$)　　　　　　　’レイヤー作成　作成済みであれば　
            doc.ActiveLayer = hlay                     ' アクティブレイヤーとして切り替え

            corner(0) = Cells(LX, 2).Value　　　　　　’文字列左下Ｘ　　文字列のフォントを指定していないため、
            corner(1) = Cells(LX, 3).Value　　　　　　’文字列左下Ｙ　　jdraf側のアクティブフォントでの作図
            corner(2) = 0　　　　　　　　　　　　　　 ’文字列左下Ｚ    色は　ByLayer
            text = Cells(LX, 4).text
            Set TextObj = acadms.AddText(text, corner, 2.5)　　’文字高　2.5
            LX = LX + 1
            
         Else
         
            Set hlay = doc.Layers.Add(C$)　　　　　　　’レイヤー作成　作成済みであれば　　　　　
            doc.ActiveLayer = hlay                     ' アクティブレイヤーとして切り替え
            
            IZ0 = Cells(LX, 2).Value　　　　　　　　　 ' B列から座標点数を取得
            IZ3 = IZ0 * 2　　　　　　　　　　　　　　　’ポリラインデータ配列の個数をきめる　点数×2
            
            ReDim points(0 To IZ3 - 1) As Double 　　　’ポリラインデータ格納のため、配列の大きさを再設定
            
            For I = 0 To IZ0 - 1　　　　　　　　 　　　’座標値を読み込む
                LX = LX + 1
                points(I * 2) = Cells(LX, 1).Value
                points(I * 2 + 1) = Cells(LX, 2).Value
            Next I
            
            Set plineObj = doc.ModelSpace.AddLightWeightPolyline(points)　　　’ポリライン作図　色は　ByLayer
            LX = LX + 1
            
        End If
    Wend
    
    app.ZoomExtents　　　　　　　　　　　　　　　　　　　 ' オブジェクト範囲ズーム

End Sub



データ形式　（　｜　はセル区切り のつもり ）

Ｃ　｜　座標点数
Ｘ　｜　Ｙ
Ｘ　｜　Ｙ
・
・
・
Ｄ　｜　座標点数
Ｘ　｜　Ｙ
Ｘ　｜　Ｙ
・
・
・
Ａ　｜　Ｘ　｜　Ｙ　｜　文字列
Ｂ　｜　Ｘ　｜　Ｙ　｜　文字列
Ａ　｜　Ｘ　｜　Ｙ　｜　文字列
Ｄ　｜　座標点数
Ｘ　｜　Ｙ
Ｘ　｜　Ｙ
・
・
・
Ａ　｜　Ｘ　｜　Ｙ　｜　文字列
Ｃ　｜　座標点数
Ｘ　｜　Ｙ
Ｘ　｜　Ｙ
・
・
・
　　　　　　　　　　　　　　　　データエンドは空白セル

編集