bunkatsuの上位バージョンです。
3オブジェクト以上に対応できるようにしました。フォームを含んでいますので、こちらからダウンロードしてください。objfind.LZH(15,479byte)
ダウンロードしてGMS用フォルダに解凍コピーした後、DRAWを起動、操作したいオブジェクトを2つ以上選択した状態でこのGMSファイルのMain.ObjFinderを実行します。
交差(全部交差)、中マド(他のオブジェクトと共通しない)、合体(全部溶接)、分割の4種類の処理がドロップダウンリストから選択できます。
が一度で
に!!(分割の場合)
以下は説明用に主要コードを抜き出したものです。(これだけでは動作しません。)
作業用配列をグローバル変数に保存します。変数受け渡しにバリアントを使ってやれば配列も受け渡しできるはずなんだけどうまくコーディングできませんでしたのでグローバルに頼ってしまいました(汗)
コアになる処理は2オブジェクトとおなじで、ユーザー関数部のbunkatsu2です。3以上に対応するために追加した処理は、処理後のオブジェクトをグループ化することです。こうすると、グループが異常な深さの階層になるほかは基本的に2オブジェクトの処理が利用できます。ただ、意味不明なグループが出来ますので最後にグループの全解除を行っています
すべてのルーチンにエラー処理を追加したつもりなのですが、まったく交差しないオブジェクト同士を交差させようとしたりすると、エラーを出します。
またオブジェクトの処理順は選択順になりますので、選択方法によっては(重なり順など)意図した結果にならない可能性があります。この場合はctrl+Aとか範囲選択で選択を行えば通常は見た目どおりに処理されると思います。(実はよく分かってません)
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CtrlDlg
Caption = "オブジェクトファインダー"
ClientHeight = 2370
ClientLeft = 45
ClientTop = 330
ClientWidth = 4710
OleObjectBlob = "CtrlDlg.frx":0000
StartUpPosition = 1 'CenterOwner
End
Attribute VB_Name = "CtrlDlg"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub canb_Click()
Unload Me
End Sub
Private Sub CommandButton1_Click()
'オリジナルオブジェクトの設定
setarry
Select Case Me.CMDList.ListIndex
Case 0
kyotsu
Case 1
sabun
Case 2
gousei
Case 3
bunkatsu
Case 4
part
End Select
Unload Me
End Sub
Private Sub UserForm_Initialize()
CMDList.AddItem "交差(全部交差)"
CMDList.AddItem "中マド(他のオブジェクトと共通しない)"
CMDList.AddItem "合体(全部溶接)"
CMDList.AddItem "分割"
' CMDList.AddItem "交差(一部交差)"
CMDList.ListIndex = 3
End Sub
Private Sub bunkatsu()
On Error Resume Next
Dim c1 As Integer
Set allo = so(1)
For c1 = 2 To sc
Set allo = bunkatsu2(allo, so(c1))
Next c1
On Error Resume Next
allo.UngroupAll
End Sub
Private Sub kyotsu()
On Error Resume Next
Dim c As Integer
Dim sf As Boolean
sf = True
'内側(すべてのオブジェクトと重なっている)オブジェクトの取り出し
If sf Then
Set allo = so(1).Duplicate
Else
Set allo = so(1)
End If
For c1 = 2 To sc
Set allo = allo.Intersect(so(c1), False, sf)
Next c1
End Sub
Private Sub sabun()
On Error Resume Next
Dim c1 As Integer, c2 As Integer
Dim soe() As Shape
ReDim soe(sc)
Dim sf As Boolean
sf = False
'中マド
'外側(他のオブジェクトと重なり合っていない)オブジェクトの取り出し
For c1 = 1 To sc
Set soe(c1) = so(c1).Duplicate
For c2 = 1 To sc
If c2 <> c1 Then
Set soe(c1) = so(c2).Trim(soe(c1), True, False)
End If
Next c2, c1
If sf = False Then
For c1 = 1 To sc
so(c1).Delete
Next c1
End If
End Sub
Private Sub gousei()
On Error Resume Next
'合成オブジェクトの作成
gouseiF (False)
End Sub
Private Sub part()
On Error GoTo oejt
Dim c1 As Integer, c2 As Integer
Dim tmp As Integer
Dim po As Shape
'合成オブジェクトの作成
gouseiF (True)
'一部重なりオブジェクトの生成
For c2 = 1 To sc - 2
For c1 = 1 To sc - c2 + 1
tmp = c1 + c2
If tmp > sc Then tmp = tmp - sc
Set po = so(tmp).Intersect(so(c1), True, True)
Set po = allo.Trim(po, False, True)
oejt:
Next c1, c2
End Sub
ここからはユーザー関数用の別モジュール
Attribute VB_Name = "UserFunc"
Function bunkatsu2(s1 As Shape, s2 As Shape) As Shape
Dim sb1 As Shape, sb2 As Shape, sb3 As Shape
ActiveDocument.ClearSelection
On Error GoTo eha:
Set sb1 = s1.Trim(s2, True, True)
Set sb2 = s2.Trim(s1, True, True)
Set sb3 = s1.Intersect(s2, False, False)
sb1.AddToSelection
sb2.AddToSelection
sb3.AddToSelection
Set bunkatsu2 = ActiveSelection.Group
Exit Function
eha:
On Error Resume Next
s1.AddToSelection
s2.AddToSelection
Set bunkatsu2 = ActiveSelection.Group
End Function
Function isSelected()
Dim r As Boolean
On Error GoTo ErrHandler
r = False
If ActiveDocument Is Nothing Then
MsgBox "ドキュメントがありません", vbCritical, "Error"
Else
If Application.ActiveSelection.Shapes.Count < 2 Then
MsgBox "オブジェクトが2個以上選択されていません", vbCritical, "Error"
Else
r = True
End If
End If
ExitSub:
isSelected = r
Exit Function
ErrHandler:
r = False
Resume ExitSub
End Function
Function gouseiF(sf As Boolean)
On Error Resume Next
Dim c As Integer
'合成オブジェクトの作成
If sf Then
Set allo = so(1).Duplicate
Else
Set allo = so(1)
End If
For c = 2 To sc
Set allo = allo.Weld(so(c), False, sf)
Next c
End Function
Function setarry()
'オリジナルオブジェクトの設定
sc = Application.ActiveSelection.Shapes.Count
ReDim so(sc)
For c1 = 1 To sc
Set so(c1) = ActiveSelection.Shapes(c1)
Next c1
ActiveDocument.ClearSelection
End Function