'導流路作成 by Den '2006/01/13 導流路描画版作成（文字、変化点位置は未対応） '2006/01/14 設計車両により導流路幅員の自動取得を可能にした。 ' 文字、変化点位置の作図を可能にした。 ' 作図単位(M,mm)に対応した。 '2006/01/19 内側円のオフセット方法を変更した。 '2006/01/20 Zoom方法を変更し、2005以前のVersionにも対応した '2006/01/24 内側円の作図時に幅員が消去されるバグをFixした。 Dim Acad,Dlay,kbai,Taka,sten,kesu,kubun,R1,Scheck Call Main Sub Main() Set Acad = CreateObject("AcadRemocon.Body") If Not Acad.CheckVersion("314") Then Exit Sub 'ARemoのバージョンチェック Scheck = 0 '戻るボタンのフラグ PI=3.14159265358979 Yomikomi '設定ファイルの読み込み Do CreateDialog 'ダイアログ作成&表示 Do Acad.dlWaitEvent CtrlName, CtrlValue, CtrlListIndex 'イベント発生待ち Select Case CtrlName 'イベント処理 Case "rdo1" kesu=1 Case "rdo2" kesu=1000 Case "kubun" R1=Acad.dlGetProperty("R1", "Text") kubun=Acad.dlGetProperty("kubun", "ListIndex") sten=Acad.dlGetProperty("sten", "Text") Taka=Acad.dlGetProperty("Taka", "Text") kbai=Acad.dlGetProperty("kbai", "Text") Dlay=Acad.dlGetProperty("Dlay", "Text") Acad.dlunload: CreateDialog Case "cmdOK" 'OKボタン Exit Do Case "cmdAA" '戻るボタン Acad.acPostCommand "_undo e 1 " Acad.dlSetProperty "cmdAA", "Enabled", 0 '戻るボタンを無効 Case "cmdCancel" 'キャンセルボタン Kakidasi: Exit Sub End Select Loop While True kakidasi '設定書き出し Scheck = 1 '戻るボタンを有効にする R1=Acad.dlGetProperty("R1", "Text") kubun=Acad.dlGetProperty("kubun", "ListIndex") sten=Acad.dlGetProperty("sten", "Text") Taka=Acad.dlGetProperty("Taka", "Text") kbai=Acad.dlGetProperty("kbai", "Text") Dlay=Acad.dlGetProperty("Dlay", "Text") Acad.acGetVar "clayer",clayer '現在層の取得 If Dlay="" Then Dlay=clayer Acad.dlHide If kubun="0" Then If R1<13 Then Exit Sub If R1>=13 Then W1=8.5 If R1>=14 Then W1=8.0 If R1>=15 Then W1=7.5 If R1>=16 Then W1=7.0 If R1>=17 Then W1=6.5 If R1>=19 Then W1=6.0 If R1>=21 Then W1=5.5 If R1>=25 Then W1=5.0 If R1>=30 Then W1=4.5 If R1>=40 Then W1=4.0 If R1>=60 Then W1=3.5 ElseIf kubun="1" Then If R1<13 Then Exit Sub If R1>=13 Then W1=5.5 If R1>=15 Then W1=5.0 If R1>=19 Then W1=4.5 If R1>=25 Then W1=4.0 If R1>=40 Then W1=3.5 Else If R1<8 Then Exit Sub If R1>=8 Then W1=4.0 If R1>=9 Then W1=3.5 If R1>=12 Then W1=3.0 If R1>=16 Then W1=2.75 End If R1=R1*kesu '外側半径 W1=W1*kesu '導流路幅員 R2=R1-W1 '内側半径 R3=R2*kbai '内側接円半径 Dlay2=Dlay&"karikari" '仮導流路レイヤ名 If Not Acad.acPostCommand("^C^C_undo be ") Then Er: Exit Sub 'undo開始 Acad.acPostCommand "-layer m "&Dlay&"^M^M" '導流路レイヤを作成 Acad.acPostCommand "-view s doryukari^My^M" '現在のビューを仮登録 Acad.acPostCommand "_ucs w " If Not Acad.acGetPoint("【外側幅員を指示/[Enter]で中止】","nea^M",X1,Y1) Then Er: Exit Do Acad.acDxfOut ,"non @^M^M" '幅員をDxfOut Acad.DxfExtract Cnt,Arr,"ENTITIES","","*","8" Flay=Arr(1,1) '幅員レイヤ If Flay=Dlay Then Acad.acShowMessage "導流路レイヤと幅員レイヤが同一なので作図できません。":Er :Exit Sub If Not Acad.acGetPoint("【相対する外側幅員を指示/[Enter]で中止】","nea^M",X3,Y3) Then Er: Exit Do Acad.acPostCommand "_circle t tan "&X1&","&Y1&"^Mtan "&X3&","&Y3&"^M"&R1&"^M" '接円作成 Acad.acDxfOut ,"last^M^M" '円をDxfOut Acad.DxfExtract Cnt,Arr,"ENTITIES","","*","10|20" X0=Arr(1,1)*1:Y0=Arr(2,1)*1 '円の中心座標取得 kaku0=atn((Y0-(Y3+Y1)/2)/(X0-(X3+X1)/2)) '円消去側の方向角 hoko=X0-(X3+X1)/2 If hoko<0 then kaku0=kaku0+180 X5=X0+cos(kaku0)*R1:Y5=Y0+sin(kaku0)*R1 '円消去側の座標 bai=1.1 ZX1=X0-R1*bai:ZY1=Y0-R1*bai:ZX2=X0+R1*bai:ZY2=Y0+R1*bai Acad.acPostCommand "_zoom w non "&ZX1&","&ZY1&"^Mnon "&ZX2&","&ZY2&"^M" '円範囲をズーム Acad.acPostCommand "_trim '-layer of "&Dlay&"^My^M^Mnon "&X1&","&Y1&"^Mnon "&X3&","&Y3&"^M^M'-layer on "&Dlay&"^M^Mnon "&X5&","&Y5&"^M^M" Acad.acDxfOut "","last^M^M" '円弧をDxfOut Acad.DxfExtract Cnt,Arr,"ENTITIES","","*","10|20|50|51" Xsoto0=Arr(1,1)*1:Ysoto0=Arr(2,1)*1 '外側円弧の中心座標 kaku1=Arr(3,1)*1:kaku2=Arr(4,1)*1 '円弧始点終点角 If kaku2((X2-Xuti2)^2+(Y2-Yuti2)^2) then tmp=Xuti1:Xuti1=Xuti2:Xuti2=tmp:tmp=Yuti1:Yuti1=Yuti2:Yuti2=tmp End If Acad.acPostCommand "_circle t tan "&X2&","&Y2&"^Mtan "&Xuti3&","&Yuti3&"^M"&R3&"^M" '接円作成 Acad.acDxfOut ,"last^M^M" '円をDxfOut Acad.DxfExtract Cnt,Arr,"ENTITIES","","*","10|20" X0=Arr(1,1)*1:Y0=Arr(2,1)*1 '円の中心座標取得 kaku0=atn((Y0-Y2)/(X0-X2)) '円消去側の方向角 If X00 Then '変化点(円)の作成 Acad.acPostCommand "_circle "&Xsoto1&","&Ysoto1&"^M"&sten&"^M" Acad.acPostCommand "_circle "&Xsoto2&","&Ysoto2&"^M"&sten&"^M" Acad.acPostCommand "_circle "&Xuti5&","&Yuti5&"^M"&sten&"^M" Acad.acPostCommand "_circle "&Xuti6&","&Yuti6&"^M"&sten&"^M" Acad.acPostCommand "_circle "&Xuti8&","&Yuti8&"^M"&sten&"^M" Acad.acPostCommand "_circle "&Xuti9&","&Yuti9&"^M"&sten&"^M" End If If Taka<>0 Then '文字(半径)の作成 Str="R="&round(R1/kesu,1) If Xsoto2=Xsoto1 Then kaku=90 Else kaku=Atn((Ysoto2-Ysoto1)/(Xsoto2-Xsoto1))/PI*180 Acad.acPostCommand "-text j bc "&Xsoto3&","&Ysoto3&"^M"&Taka&"^M"&kaku&"^M"&Str&"^M" Str="R="&round(R2/kesu,1) Acad.acPostCommand "-text j bc "&Xuti3&","&Yuti3&"^M"&Taka&"^M"&kaku&"^M"&Str&"^M" Str="R="&round(R3/kesu,1) If Xuti6=Xuti5 Then kaku=90 Else kaku=Atn((Yuti6-Yuti5)/(Xuti6-Xuti5))/PI*180 Acad.acPostCommand "-text j bc "&Xuti10&","&Yuti10&"^M"&Taka&"^M"&kaku&"^M"&Str&"^M" If Xuti9=Xuti8 Then kaku=90 Else kaku=Atn((Yuti9-Yuti8)/(Xuti9-Xuti8))/PI*180 Acad.acPostCommand "-text j bc "&Xuti11&","&Yuti11&"^M"&Taka&"^M"&kaku&"^M"&Str&"^M" End If Acad.acPostCommand "-v r doryukari^M d doryukari^M" 'ビューを元に戻し、仮登録を削除 Acad.acPostCommand "_undo e " 'undo終了 Loop Acad.acPostCommand "_ucs p " End Sub Sub CreateDialog()'-------------------------------------------------------------ダイアログ作成＆表示 Acad.dlLoad "導流路作図", True, True 'Enterキーで移動可能にする Acad.dlAddLabel "", "作図画層", 9, -1, 1 Acad.dlAddText "Dlay", Dlay, 22, 1 Acad.dlAddLabel "", "設計車両", 9, -1, 1 Acad.dlAddDrop "kubun","セミトレーラ連結車|普通自動車|小型自動車",kubun,22,1 Acad.dlAddLabel "", "外側半径", 9, -1, 1 If kubun=2 Then Acad.dlAddCombo "R1","8|9|10|11|12|13|14|15|16|17|18|19|20",R1,7,-1 Else If R1<13 Then R1=13 Acad.dlAddCombo "R1","13|14|15|16|17|18|19|20|21|22|23|24|25|26|27|28|29|30",R1,7,-1 End If Acad.dlAddLabel "", " 緩和円倍数", 12, -1, 1 Acad.dlAddText "kbai", kbai, 3, 1 Acad.dlAddLabel "", "文 字 高", 9, -1, 1 Acad.dlAddText "Taka", Taka, 6, -1 Acad.dlAddLabel "", " 小円半径", 10, -1, 1 Acad.dlAddText "sten", sten, 6, 1 Acad.dlAddLabel "", "作図単位", 10, -1, 1 Acad.dlAddRadio "rdo1", "Ｍ", rdo1, 6, -1 Acad.dlAddRadio "rdo2", "mm", rdo2, 5, 2 Acad.dlAddButton "cmdOK", "作　図", 9, -1 Acad.dlAddLabel "", "", 2, -1, 1 Acad.dlAddButton "cmdAA", "戻　る", 9, -1 Acad.dlAddLabel "", "", 2, -1, 1 Acad.dlAddButton "cmdCancel", "終　了", 9, 0 If Scheck = 0 Then Acad.dlSetProperty "cmdAA", "Enabled", 0 '再作図ボタンを無効 Else Acad.dlSetProperty "cmdAA", "Enabled", 1 '再作図ボタンを有効 End If Acad.dlSetProperty "Dlay", "ToolTipText" ,"空白で現在層、幅員レイヤと同一は不可" Acad.dlSetProperty "R1", "ToolTipText" ,"リスト選択 or 数値入力" Acad.dlSetProperty "kbai", "ToolTipText" ,"3〜4倍が標準である" Acad.dlSetProperty "Taka", "ToolTipText" ,"文字高「0」で作図しない" Acad.dlSetProperty "sten", "ToolTipText" ,"小円の半径「0」で作図しない" Acad.dlSetProperty "cmdAA", "ToolTipText" ,"直前の作図を消去します" If kesu=1 Then Acad.dlSetProperty "rdo1", "Value" ,1 Else Acad.dlSetProperty "rdo2", "Value" ,1 Acad.dlShow 'ダイアログ表示 End Sub Sub Yomikomi()'-----------------------------------------------------------------設定読み込み Acad.GetIniStr Dlay, "Dlay", "Den_導流路" '導流路のレイヤ名 Acad.GetIniStr kbai, "kbai", "Den_導流路" '緩和円の倍数(3〜4が標準) Acad.GetIniStr Taka, "Taka", "Den_導流路" '文字高さ（0で作図しない） Acad.GetIniStr sten, "sten", "Den_導流路" '変化点位置の円の大きさ（0で作図しない） Acad.GetIniStr kesu, "kesu", "Den_導流路" '作図単位係数(M単位は1、mm単位は1000) Acad.GetIniStr kubun, "kubun", "Den_導流路" '設計車両 Acad.GetIniStr R1, "R1", "Den_導流路" '外側半径 ' If Dlay="" Then Dlay="Doryuro" If kbai="" Then kbai=3 If Taka="" Then Taka=1.25 If sten="" Then sten=0.25 If kesu="" Then kesu=1 If kubun="" Then kubun=2 If R1="" Then R1=13 End Sub Sub Kakidasi()'-----------------------------------------------------------------設定書き出し Acad.PutIni Acad.dlGetProperty("Dlay", "Text"), "Dlay", "Den_導流路" Acad.PutIni Acad.dlGetProperty("kbai", "Text"), "kbai", "Den_導流路" Acad.PutIni Acad.dlGetProperty("Taka", "Text"), "Taka", "Den_導流路" Acad.PutIni Acad.dlGetProperty("sten", "Text"), "sten", "Den_導流路" Acad.PutIni kesu, "kesu", "Den_導流路" Acad.PutIni Acad.dlGetProperty("kubun", "ListIndex"), "kubun", "Den_導流路" Acad.PutIni Acad.dlGetProperty("R1", "Text"), "R1", "Den_導流路" End Sub Sub Er() Acad.acPostCommand "_undo e 1 " 'undo終了 If Acad.ErrNumber = vbObjectError + 1000 Then 'ここにキャンセル時の処理を追加 Else Acad.ShowError End If End Sub