TOP PAGE > 記事閲覧
ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2016/03/30(Wed) 14:09
投稿者 アルサポ
参照先 http://r-support.org/bbs/tmp/sample01.xlsm
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に書き込むプログラムコードを記載します。
記事編集 編集
Re: VBEに貼り付けて下さい
投稿日 : 2016/03/30(Wed) 14:16
投稿者 アルサポ
参照先
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
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2016/03/30(Wed) 14:23
投稿者 アルサポ
参照先
シートに作成したボタンを押すと実行処理するように出来ていて、内容としては大きく分けて
前半の「JDRAFを起動してアクティブドキュメントを取得」する部分と
後半の「APIで作図」する部分の2部構成です。

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

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

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


以上がポリラインとテキストを作図するプログラムコードを紹介しました。
これをもとに色々な図形を作図する事にも挑戦してみるのはどうでしょうか?
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2016/04/01(Fri) 10:20
投稿者 デジ
参照先
ポリライン作図と座標記入素晴らしいです。
で・・・教えて下さい。
64ビットどうしで動かしていますが「PCAD_AC_X Type Library」と「PCAD_DB_X 3.09 Type Library」
が参照不可になっています。
フォルダが違うかと思い探しましたが見つけられません
別に何か必要なのでしょうか?

もう少し頑張ってみます。
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2016/04/01(Fri) 13:49
投稿者 アルサポ
参照先
デジさん、すいません。
私の場合は、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)」のボタンでファイルを読み込んで設定してみて下さい。

うまく出来なかった時には、また投稿お願いします。
出来る限り協力させて頂きますので、挑戦してみて下さい。
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2016/04/01(Fri) 14:12
投稿者 デジ
参照先
ありがとうございます。
PCAD_AC_X Type LibraryとPCAD_DB_X 3.09 Type Libraryファイルがあると思い懸命に探していました。(笑)
動作確認です。

平面・縦断・横断等の作成がエクセルの座標入力が簡単にできます。
Z値の欄追加お願いします。これからは3次元ですから〜
当分Z値は0ですけどね(笑顔)
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2016/04/01(Fri) 15:49
投稿者 アルサポ
参照先 http://r-support.org/bbs/tmp/sample02.xlsm
デジさんうまく動いて良かったですね

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

3Dポリラインで作図するExcelをサンプルとしてリンクを貼りましたので、(軽量)ポリラインの時と
比較してみてはどうでしょうか?
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2017/02/28(Tue) 12:01
投稿者 たぬ
参照先
アルサポさん、いつもありがとうございます、Jdraf超初心者のタヌですm(__)m

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

エクセル32bit&Jdraf64bit。。。

宜しくお願い致します<(_ _)>
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2017/02/28(Tue) 12:22
投稿者 アルサポ
参照先
こんにちは、たぬさん。
同じbit(32、64)対応のソフトを利用しなければ、ExcelとJDrafは連携出来できず、
利用する事が出来ません。
なので、私の場合はマイクロソフト社がExcel(Office)の32bit版を推奨していたので、
どちらも32bit版に合わせて利用しています。
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2017/08/28(Mon) 16:05
投稿者 B級
参照先
お世話になります。
超初心者からのお願いです。
当方、Jdraf2016、excel2013を使用しております。
いづれも32bitです。
サンプルマクロを起動させると、型が一致しませんの
エラー警告がでます。助言をお願いします。
また、ポリラインの座標をEXCELに出力ができるVBAを
公開していただければと思います。
よろしくお願いします。
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2017/09/10(Sun) 18:41
投稿者 アルサポ
参照先
最近は、道路補修工事の施工管理の仕事を受け、昼夜問わず忙しく過ごしています。
なので、返信が遅くなり申し訳なく思います。すいません

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

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

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

B級さん、時間がある時にでもご返信よろしくお願い致します。
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2017/12/10(Sun) 17:36
投稿者 けんすけ
参照先
突然の質問で失礼いたします。

昔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
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2017/12/12(Tue) 12:57
投稿者 アルサポ
参照先
けんすけさん、こんにちは。
とても参考になるプログラムをありがとうございます。

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

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



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

インデックスカラーでの設定の場合は、先ほどの「Call Color.SetRGB(255, 255, 255)」の
記述を下記のように書き換えれば、インデックスカラーで設定ができます。
Color.ColorIndex = 1
数字の箇所にインデックスカラーの番号(数字)を記入して下さい(ちなみに1は赤)。
数字以外にも
acByLayer (ByLayerの時)
acByBlock (ByBlockの時)
acRed (赤の時)
acBlue (緑の時)
などがあります。
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2017/12/12(Tue) 16:56
投稿者 けんすけ
参照先
迅速なご対応をありがとうございます。

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

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

それにしても、今改めて見返すと、無駄が多すぎる・野暮天プログラムで、冷や汗が出そうです。
記事編集 編集
Re: ExcelのVBAを利用して、ポリライン、文字を作図する
投稿日 : 2017/12/14(Thu) 18:30
投稿者 けんすけ
参照先
長文で失礼します。

ご質問の、ポリラインの使い方がいまいち、とのことでしたが、おそらくAX、AYの配列の使い方と思います。
10年ほど前に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      ’文字列左下X  文字列のフォントを指定していないため、
corner(1) = Cells(LX, 3).Value      ’文字列左下Y  jdraf側のアクティブフォントでの作図
corner(2) = 0               ’文字列左下Z 色は 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



データ形式 ( | はセル区切り のつもり )

C | 座標点数
X | Y
X | Y



D | 座標点数
X | Y
X | Y



A | X | Y | 文字列
B | X | Y | 文字列
A | X | Y | 文字列
D | 座標点数
X | Y
X | Y



A | X | Y | 文字列
C | 座標点数
X | Y
X | Y



                データエンドは空白セル
記事編集 編集
件名 スレッドをトップへソート
名前
メールアドレス
URL
暗証キー
画像認証 (右画像の数字を入力) 投稿キー
コメント


- WEB PATIO -