| このページについて | ||||||||||||||||||||||||||
|
このページは、mura's home の AutoCAD掲示板 で、当方の発言（書込み）がある以下の掲示板の内容です。
タイトルおよび質問内容は上記より引用しています。 引用した質問内容は、バックカラーが となっています。 当方の発言は、バックカラーが となっています。 その他の著作権者の掲載許可を得ていない発言内容は削除（リンクを除く）しています。 また、当方では、削除部分の正当な著作権保持者を判断出来ませんので、 ご連絡を頂いても、復活させることは出来ません。ご了承下さい。
|
||||||||||||||||||||||||||
大変お世話になっております。
ブロック内の特定の色を"byblock"したいと思っています。
こちらでもいろいろ調べさせて頂き、
ブロック内の色を全部一度に変えることは出来たのですが、
複数の色の中から特定の色を選び、変更するということが出来ません。
どうかお助け願えないでしょうか・・・
よろしくお願いいたします。
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
解決済みですが・・・
フォーム付きのＶＢＡマクロです（笑）
ユーザーフォームのブロック一覧から選択できます。
ただし、Visual
Basic エディタで以下の参照設定が必要。
・Microsoft Visual Basic for Applications Extensibility
x.x
・Microsoft Forms x.x Object Library
Microsoft Forms・・・
が一覧にない場合には、
ユーザーフォームを挿入すれば表示されます。
また、「中断モードでは入力できません。」エラーで、
ブレークポイントの設定は出来ません。
'標準モジュール
Option Explicit
'ブロック内の色を変更メイン
Public Sub Main()
Dim VBC As VBComponent
Dim UF As Object
Dim I As Long
On Error GoTo Err:
Set VBC = SetNewForm()
VBC.CodeModule.InsertLines (VBC.CodeModule.CountOfLines + 1), MakeCode()
Set UF = UserForms.Add(VBC.Name)
If UF.ListBox1.ListCount > 0 Then
UF.Show
'--------------------------
'ブロック処理
With UF.ListBox1
For I = 1 To .ListCount
If .Selected(I - 1) Then
Call SetProperties(ActiveDocument.Blocks.Item(.List(I - 1)))
End If
Next I
End With
'--------------------------
Unload UF
'ユーザーフォーム削除
Application.VBE.ActiveVBProject.VBComponents.Remove VBC
ActiveDocument.Regen acActiveViewport
Else
MsgBox "ブロックがありません ", vbCritical
End If
Set UF = Nothing
Set VBC = Nothing
End
Exit Sub
Err:
Resume Next
End Sub
'プロパティ変更
Private Sub SetProperties(Block As AcadBlock)
Dim Obj As AcadEntity
On Error GoTo Err:
For Each Obj In Block
If Obj.Color = acRed Then
With Obj
.Layer = "0"
.Linetype = "ByBlock"
.Color = acByBlock
End With
End If
Next Obj
Exit Sub
Err:
Resume Next
End Sub
'ユーザーフォーム作成
Function SetNewForm() As VBComponent
Dim Ctl As Controls
On Error GoTo Err:
With Application.VBE.ActiveVBProject
Set SetNewForm = .VBComponents.Add(vbext_ct_MSForm)
End With
With SetNewForm
.Properties("Width").Value = 200
.Properties("Height").Value = 200
.Properties("Caption").Value = "Block List"
Set Ctl = .Designer.Controls
End With
With Ctl.Add("Forms.CommandButton.1")
.Cancel = True
.Caption = "キャンセル"
.top = 156
.Left = 126
.Height = 17.5
.Width = 60
End With
With Ctl.Add("Forms.CommandButton.1")
.Caption = "ＯＫ"
.top = 156
.Left = 60
.Height = 17.5
.Width = 60
End With
With Ctl.Add("Forms.CommandButton.1")
.Caption = "全選択"
.top = 129
.Left = 108
.Height = 17.5
.Width = 39.75
End With
With Ctl.Add("Forms.CommandButton.1")
.Caption = "全解除"
.top = 129
.Left = 150
.Height = 17.5
.Width = 39.75
End With
With Ctl.Add("Forms.ListBox.1")
.top = 6
.Left = 9
.Height = 125
.Width = 181
.ListStyle = 1
.MultiSelect = 1
End With
With Ctl.Add("Forms.Label.1")
.Caption = "ブロックを選択してください"
.top = 132
.Left = 12
.Height = 12
.Width = 90
End With
Set Ctl = Nothing
Exit Function
Err:
Resume Next
End Function
'ユーザーフォームのコード作成
Private Function MakeCode() As String
Dim Block As AcadObject
On Error GoTo Err:
MakeCode = ""
MakeCode = MakeCode & "Option Explicit" & vbCrLf
MakeCode = MakeCode & "" & vbCrLf
MakeCode = MakeCode & "'キャンセル" & vbCrLf
MakeCode = MakeCode & "Private Sub CommandButton1_Click()" & vbCrLf
MakeCode = MakeCode & "Dim I As Long" & vbCrLf
MakeCode = MakeCode & " Me.Hide" & vbCrLf
MakeCode = MakeCode & " 'キャンセルの場合はすべて選択解除" & vbCrLf
MakeCode = MakeCode & " For I = 1 To Me.ListBox1.ListCount" & vbCrLf
MakeCode = MakeCode & " Me.ListBox1.Selected(I - 1) = False" & vbCrLf
MakeCode = MakeCode & " Next I" & vbCrLf
MakeCode = MakeCode & "End Sub" & vbCrLf
MakeCode = MakeCode & "'ＯＫ" & vbCrLf
MakeCode = MakeCode & "Private Sub CommandButton2_Click()" & vbCrLf
MakeCode = MakeCode & " Me.Hide" & vbCrLf
MakeCode = MakeCode & "End Sub" & vbCrLf
MakeCode = MakeCode & "'全選択" & vbCrLf
MakeCode = MakeCode & "Private Sub CommandButton3_Click()" & vbCrLf
MakeCode = MakeCode & "Dim I As Long" & vbCrLf
MakeCode = MakeCode & " For I = 1 To Me.ListBox1.ListCount" & vbCrLf
MakeCode = MakeCode & " Me.ListBox1.Selected(I - 1) = True" & vbCrLf
MakeCode = MakeCode & " Next I" & vbCrLf
MakeCode = MakeCode & "End Sub" & vbCrLf
MakeCode = MakeCode & "'全解除" & vbCrLf
MakeCode = MakeCode & "Private Sub CommandButton4_Click()" & vbCrLf
MakeCode = MakeCode & "Dim I As Long" & vbCrLf
MakeCode = MakeCode & " For I = 1 To Me.ListBox1.ListCount" & vbCrLf
MakeCode = MakeCode & " Me.ListBox1.Selected(I - 1) = False" & vbCrLf
MakeCode = MakeCode & " Next I" & vbCrLf
MakeCode = MakeCode & "End Sub" & vbCrLf
MakeCode = MakeCode & "'初期化" & vbCrLf
MakeCode = MakeCode & "Public Sub UserForm_Initialize()" & vbCrLf
MakeCode = MakeCode & " 'ListBox1にリスト追加" & vbCrLf
For Each Block In ThisDrawing.Blocks
If Not (Block.IsXRef) And Not (Block.IsLayout) Then
'両方のプロパティが FALSE である場合は単純なブロック
MakeCode = MakeCode & " Me.ListBox1.AddItem """ & Block.Name & """" & vbCrLf
End If
Next Block
MakeCode = MakeCode & "End Sub" & vbCrLf
Exit Function
Err:
Resume Next
End Function |
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除