supermab.com   HOME > AutoCad VBA コード置き場

HOMEへ  

AutoCad VBA コード置き場

目次 :
【はじめに】
【コマンド定義】
【寸法値上書き検出】
【寸法尺度検出】
【文字スタイル変更】
【文字抽出&変更】
【断面係数算出】





【はじめに】

ここは、日常作業で発生するAutoCad VBAコードの置き場です。
利用・改変は自由ですが、改変コードも公開したいので、送付していただけるとうれしいです。
新規の投稿もお待ちしています。使えるコードが増殖すると便利かも?
匿名でも結構ですが、ハンドルネーム・サイトリンクなどを明記してただければ掲載いたします。
ほんとは、ブログやファイルアップローダ など設置するのが良いのかもしれませんが、そのうち考えます。

ということで見切り発車ですが、どうぞよろしくお願いいたします。

TOPへ


【コマンド定義】 2010/01/07

はじめということで、作成したサブルーチン(以下 Sub()) を、AutoCad にコマンド定義するコードです。
「Defun」では、SubName という Sub() を、CommandName という AutoCad コマンドとして定義します。
「Defuns」では、作成した複数の Sub() について、「Defun」を実行します。
登録したコマンドは、AutoCad のコマンドラインから設定した CommandName を入力して実行できます。
頻繁に利用する処理は、カスタムボタンを作り、マクロ定義しておくと便利です。

'-------------------------------------------
' VBAコマンド定義
'-------------------------------------------
Private Sub Defun(CommandName, SubName As String)
Dim Cmd As String
 Cmd = Chr(34) & "-vbarun" & Chr(34) & " " & Chr(34) & "acadproject.thisdrawing." & SubName & Chr(34)
 ThisDrawing.SendCommand "(defun C:" & CommandName & "() (command " & Cmd & ")(princ))" & vbCr
End Sub
'-------------------------------------------
' VBAコマンド一括登録
'-------------------------------------------
Public Sub Defuns()
 Defun "CommandA", "SubA"  '処理A
 Defun "CommandB", "SubB"  '処理B
 Defun "CommandC", "SubC"  '処理C
 ・・・
End Sub
' 処理A
Public Sub SubA()
 ・・・
 ・・・
End Sub

' 処理B
Public Sub SubB()
 ・・・
End Sub

' 処理C
Public Sub SubC()
 ・・・
End Sub




【寸法値上書き検出】 2010/01/08

偽尺で作成されたCADデータは、厄介なもので製作上のトラブルの原因になります。
切板データを、CADデータから形状抜き出しで作成したりする場合偽尺でないかチェックする必要があります。
CheckTextOverride() は、図面上の寸法オブジェクトのなかに、寸法値が上書きされているものがないかチェックするコードです。
寸法値が上書きされている寸法オブジェクトが見つかった場合、引き出し線・寸法値を acRed(赤) に変更します。

'-------------------------------------------
' 寸法値上書き検出
'-------------------------------------------
Public Sub CheckTextOverride()
Dim trgDim As AcadDimension
Dim ent As AcadEntity
Dim trgStr As String
Dim count As Integer
Dim ms As Double
Dim ov As Double
 count = 0
On Error GoTo err
With ThisDrawing
  For Each ent In .ModelSpace
   If ent.ObjectName = "AcDbRotatedDimension" Or _
    ent.ObjectName = "AcDbAlignedDimension" Or _
    ent.ObjectName = "AcDbRadialDimension" Or _
    ent.ObjectName = "AcDb3PointAngularDimension" Then
    Set trgDim = ent
    If Not trgDim.TextOverride Like "" And Not trgDim.TextOverride Like "*<>*" Then
     trgDim.TextColor = acRed '色を変更
     trgDim.DimensionLineColor = acRed '色を変更
     count = count + 1
    End If
   End If
   If ent.ObjectName = "AcDbDiametricDimension" Or _
    ent.ObjectName = "AcDbRadialDimension" Then
    Set trgDim = ent
      If trgDim.TextOverride <> "" Then
        trgDim.TextColor = acRed '色を変更
        trgDim.DimensionLineColor = acRed '色を変更
          count = count + 1
      End If
   End If
 Next
End With
 MsgBox (Str(count) & "個上書きされてます")
Exit Sub
err:
  MsgBox (ent.ObjectName)
End Sub


【寸法尺度検出】 2010/01/09

図面内に記載された詳細データは尺度が違う場合があります。気をつけないと製作上のトラブルの原因になります。
CheckScaleFactor() は、図面上の寸法オブジェクトのなかの、寸法尺度が1でないものを検出するコードです。
寸法尺度が1でない寸法オブジェクトが見つかった場合、引き出し線・寸法値を acRed(赤) に変更します。

'-------------------------------------------
' 寸法尺度検出
'-------------------------------------------
Public Sub CheckScaleFactor()
Dim trgDim As AcadDimension
Dim ent As AcadEntity
Dim trgStr As String
Dim count As Integer
Dim ms As Double
Dim ov As Double
 count = 0
On Error GoTo err
With ThisDrawing
  For Each ent In .ModelSpace
   If ent.ObjectName = "AcDb3PointAngularDimension" Then
     MsgBox (ent.ObjectName)
   End If
   If ent.ObjectName = "AcDbRotatedDimension" Or _
     ent.ObjectName = "AcDbAlignedDimension" Or _
     Set trgDim = ent
     If trgDim.LinearScaleFactor <> 1# Then 'ScaleFactorが"1"でない時
       trgDim.TextColor = acRed
       trgDim.DimensionLineColor = acRed
       trgDim.TextSuffix = "( x" & trgDim.LinearScaleFactor & ")"
       count = count + 1
     End If
   End If
   If ent.ObjectName = "AcDbDiametricDimension" Or _
     ent.ObjectName = "AcDbRadialDimension" Then
     Set trgDim = ent
     If trgDim.LinearScaleFactor <> 1# Then 'ScaleFactorが"1"でない時
       trgDim.TextColor = acRed
       trgDim.DimensionLineColor = acRed
       trgDim.TextSuffix = "( x" & trgDim.LinearScaleFactor & ")"
       count = count + 1
     End If
   End If
  Next
End With
  MsgBox (Str(count) & "個尺度が違います")
Exit Sub
err:
  MsgBox (ent.ObjectName)
  MsgBox (trgDim.LinearScaleFactor)
End Sub

HOMEへ TOPへ

Copyright © 2008-2011 supermab.com
All rights reserved.