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