ここは、日常作業で発生するAutoCad VBAコードの置き場です。
利用・改変は自由ですが、改変コードも公開したいので、送付していただけるとうれしいです。
新規の投稿もお待ちしています。使えるコードが増殖すると便利かも？
匿名でも結構ですが、ハンドルネーム・サイトリンクなどを明記してただければ掲載いたします。
ほんとは、ブログやファイルアップローダ など設置するのが良いのかもしれませんが、そのうち考えます。
ということで見切り発車ですが、どうぞよろしくお願いいたします。
はじめということで、作成したサブルーチン（以下 Sub()) を、AutoCad にコマンド定義するコードです。
「Defun」では、SubName という Sub() を、CommandName という AutoCad コマンドとして定義します。
「Defuns」では、作成した複数の Sub() について、「Defun」を実行します。
登録したコマンドは、AutoCad のコマンドラインから設定した CommandName を入力して実行できます。
頻繁に利用する処理は、カスタムボタンを作り、マクロ定義しておくと便利です。
'-------------------------------------------
' ＶＢＡコマンド定義
'-------------------------------------------
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
'-------------------------------------------
' ＶＢＡコマンド一括登録
'-------------------------------------------
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
偽尺で作成された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
図面内に記載された詳細データは尺度が違う場合があります。気をつけないと製作上のトラブルの原因になります。
CheckScaleFactor() は、図面上の寸法オブジェクトのなかの、寸法尺度が１でないものを検出するコードです。
寸法尺度が１でない寸法オブジェクトが見つかった場合、引き出し線・寸法値を 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
Copyright © 2008-2011 supermab.com
All rights reserved.