Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


24242 / 76732 ←次へ | 前へ→

【57840】Re:任意の形状を図化するには?
発言  みそじのおじさん  - 08/9/16(火) 14:55 -

引用なし
パスワード
   ようさん、こんにちは。
遅くなって申し訳ないです。解決したみたいですが
一応こんなやりかたもあるということで...

作業の流れとしては、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本目の直線に対して垂直
  '円Cの中心は2本目の直線の終点
  '円Dの中心は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) & _
          "の円の半径Rは?", CnsTitle, 0))
    SX(j) = EX(2)
    SY(j) = EY(2)
  Case 4
    R(j) = CDbl(InputBox(j & "点目 中心点X" & SX(1) & ",Y" & SY(1) & _
          "の円の半径Rは?", 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) '始点X座標
      Print #i, "20"
      Print #i, SY(j) '始点Y座標
      Print #i, "30"
      Print #i, "0" '始点Z座標
      Print #i, "11"
      Print #i, EX(j) '終点X座標
      Print #i, "21"
      Print #i, EY(j) '終点Y座標
      Print #i, "31"
      Print #i, "0" '終点Z座標
      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) '中心X座標
      Print #i, "20"
      Print #i, SY(j) '中心Y座標
      Print #i, "30"
      Print #i, "0"  '中心Z座標
      Print #i, "40"
      Print #i, R(j)  '半径R
      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のファイルフォーマットは2行で一つの意味があります。
詳しくはAutodesk社のDXFリファレンスを参照して下さい。(すべて英語ですが...)
DXFファイルが作成できるようになれば色々できることが増えると思います。

今回は数値の入力部分にインプットボックスを使いましたが、ユーザーフォームを作成
したり、シートから直接値を取り込む方法がなどありますので研究してみて下さい。
1 hits

【57783】任意の形状を図化するには? よう 08/9/13(土) 11:32 質問
【57784】Re:任意の形状を図化するには? かみちゃん 08/9/13(土) 11:42 発言
【57786】Re:任意の形状を図化するには? よう 08/9/13(土) 12:37 発言
【57789】Re:任意の形状を図化するには? みそじのおじさん 08/9/13(土) 13:02 発言
【57790】Re:任意の形状を図化するには? よう 08/9/13(土) 13:20 発言
【57793】Re:任意の形状を図化するには? みそじのおじさん 08/9/13(土) 15:06 発言
【57795】Re:任意の形状を図化するには? よう 08/9/13(土) 15:23 発言
【57798】Re:任意の形状を図化するには? みそじのおじさん 08/9/13(土) 16:09 発言
【57801】Re:任意の形状を図化するには? よう 08/9/13(土) 17:09 発言
【57830】Re:任意の形状を図化するには? よう 08/9/15(月) 19:58 発言
【57840】Re:任意の形状を図化するには? みそじのおじさん 08/9/16(火) 14:55 発言
【57843】Re:任意の形状を図化するには? よう 08/9/16(火) 23:34 お礼

24242 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free