| |
ようさん、こんにちは。
遅くなって申し訳ないです。解決したみたいですが
一応こんなやりかたもあるということで...
作業の流れとしては、DXFファイルはただのテキストファイルなので（正確にはバイナリ
ファイル）、テキストファイルにヘッダー部、線情報、フッター部（最低限この情報だけ
でDXFファイルは作成可能です。）を書き込み、拡張子を.dxfに変更して作成完了となり
ます。
標準モジュールにこれをコピーして下さい。
Option Explicit
'タイトル
Private Const CnsTitle = "DXF作成"
'色番号
Private Const ColorNo = 9 '使用するCADによって色番号が違う場合が
'あるので,数字を変えて試して下さい。
'0から使用可
'ご自身の環境に合わせて下さい
'使用するCADのexeのフルパス
Private Const CadFullPath = "C:\Program Files\AutoCAD LT 2000i\aclt.exe"
'使用するCADのexeがあるフォルダパス
Private Const CadFolderPath = "C:\Program Files\AutoCAD LT 2000i"
Sub MAKE_DXF()
'////////////////////////////////////////////////////////
'使用条件
'1本目の直線の始点はX0,Y0
'2本目の直線は1本目の直線に対して垂直
'円Ｃの中心は2本目の直線の終点
'円Ｄの中心は1本目の直線の始点
'////////////////////////////////////////////////////////
Dim i As Integer, j As Integer
Dim Ans, ret
Dim strFileName As String
Dim SX(1 To 4) As Double, SY(1 To 4) As Double
Dim EX(1 To 4) As Double, EY(1 To 4) As Double
Dim R(1 To 4) As Double
Dim endX As Double, endY As Double
Dim myTxtFile As String, myDxfFile As String
myTxtFile = ThisWorkbook.Path & "\make_dxf.txt"
'カレントフォルダを使用するCADのexeがあるフォルダに変更
ChDir CadFolderPath
'作成するファイル名入力
myDxfFile = Application.GetSaveAsFilename(InitialFileName:="", _
FileFilter:="DXFファイル(*.dxf),*.dxf", _
Title:="作成するDXFファイル名")
If StrConv(myDxfFile, vbUpperCase) = "FALSE" Then Exit Sub
'同名ファイルがある場合は上書き確認
If Dir(myDxfFile) <> "" Then
Ans = MsgBox(myDxfFile & "は既に作成されていますが、上書きしますか？", _
vbExclamation Or vbYesNo, CnsTitle)
If Ans = vbNo Then Exit Sub
End If
endX = 0
endY = 0
On Error GoTo err_trap
'数値入力
For j = 1 To 4
Select Case j
Case 1, 2
If j = 1 Then
SX(j) = 0
SY(j) = 0
ElseIf j = 2 Then
SX(j) = EX(j - 1)
SY(j) = EY(j - 1)
End If
If j = 1 Then
EX(j) = CDbl(InputBox(j & "点目 終点X座標は？", CnsTitle, endX))
EY(j) = 0
ElseIf j = 2 Then
EX(j) = EX(1)
EY(j) = CDbl(InputBox(j & "点目 終点Y座標は？", CnsTitle, endY))
End If
endX = EX(j)
endY = EY(j)
Case 3
R(j) = CDbl(InputBox(j & "点目 中心点X" & EX(2) & ",Y" & EY(2) & _
"の円の半径Ｒは？", CnsTitle, 0))
SX(j) = EX(2)
SY(j) = EY(2)
Case 4
R(j) = CDbl(InputBox(j & "点目 中心点X" & SX(1) & ",Y" & SY(1) & _
"の円の半径Ｒは？", CnsTitle, 0))
SX(j) = SX(1)
SY(j) = SY(1)
End Select
Next
On Error GoTo 0
On Error Resume Next
Kill myTxtFile
Kill myDxfFile
On Error GoTo 0
i = FreeFile
Open myTxtFile For Output As #i
'DXFファイル ヘッダー部書き込み（決まり文句）
Print #i, "0"
Print #i, "SECTION"
Print #i, "2"
Print #i, "HEADER"
'Print #i, "9"
'Print #i, "$OSMODE"
'Print #i, "70"
'Print #i, "317" '端点1 中点2 中心4 点8、4半円点16 交点32 接線256
'Print #i, "9"
'Print #i, "$ORTHOMODE"
'Print #i, "70"
'Print #i, "1"
Print #i, "0"
Print #i, "ENDSEC"
'DXFファイル 線情報書き込み
Print #i, "0"
Print #i, "SECTION"
Print #i, "2"
Print #i, "ENTITIES"
For j = 1 To UBound(SX, 1)
Select Case j
'直線
Case 1, 2
Print #i, "0"
Print #i, "LINE" '直線
Print #i, "8"
Print #i, "0" '画層名(LayerName)
Print #i, "6"
Print #i, "ByLayer" '線種名(LineTypeName)
Print #i, "10"
Print #i, SX(j) '始点Ｘ座標
Print #i, "20"
Print #i, SY(j) '始点Ｙ座標
Print #i, "30"
Print #i, "0" '始点Ｚ座標
Print #i, "11"
Print #i, EX(j) '終点Ｘ座標
Print #i, "21"
Print #i, EY(j) '終点Ｙ座標
Print #i, "31"
Print #i, "0" '終点Ｚ座標
Print #i, "62"
Print #i, ColorNo '色番号
'円
Case 3, 4
Print #i, "0"
Print #i, "CIRCLE" '円
Print #i, "8"
Print #i, "0"
Print #i, "6"
Print #i, "ByLayer"
Print #i, "10"
Print #i, SX(j) '中心Ｘ座標
Print #i, "20"
Print #i, SY(j) '中心Ｙ座標
Print #i, "30"
Print #i, "0" '中心Ｚ座標
Print #i, "40"
Print #i, R(j) '半径Ｒ
Print #i, "62"
Print #i, ColorNo
End Select
Next
'DXFファイル フッター部（決まり文句）
Print #i, "0"
Print #i, "ENDSEC"
Print #i, "0"
Print #i, "EOF"
Close #i
'拡張子をtxtからdxfに変更
On Error GoTo err_trap2
Name myTxtFile As myDxfFile
On Error GoTo 0
MsgBox "DXFファイル 作成終了", vbInformation, CnsTitle
'作成したDXFファイルをCADで開く
strFileName = Dir(CadFullPath) & " " & Dir(myDxfFile)
ret = Shell(strFileName, vbNormalFocus)
Exit Sub
err_trap:
MsgBox "不正な入力がありました。処理を中止します。", vbCritical, CnsTitle
Exit Sub
err_trap2:
MsgBox "同名のファイルが既に開かれています。", vbCritical, CnsTitle
End Sub
標準モジュールにはここまで
ワークシートにコマンドボタンを一つ配置して、そこに
Private Sub CommandButton1_Click()
Call MAKE_DXF
End Sub
と書いて終了です。
DXFのファイルフォーマットは２行で一つの意味があります。
詳しくはAutodesk社のDXFリファレンスを参照して下さい。（すべて英語ですが...)
DXFファイルが作成できるようになれば色々できることが増えると思います。
今回は数値の入力部分にインプットボックスを使いましたが、ユーザーフォームを作成
したり、シートから直接値を取り込む方法がなどありますので研究してみて下さい。
|
|
みそじのおじさん
- 08/9/16(火) 14:55 -
