| |
みなさん、こんにちは
しとうとさんの参考になればいいのですが・・・
細かな仕様を把握していませんので、動作が違う場合は
ご指摘ください。
'--構造体定義 STR--
Type BoxInfo '四角形の構造体情報
CX As Double '中心座標Ｘ
CY As Double '中心座標Ｙ
XX As Double '長さＸ
YY As Double '長さＹ
End Type
'--構造体定義 END--
Sub Check_contact()
Dim box1 As BoxInfo
Dim box2 As BoxInfo
Dim N As Integer
Dim M As Integer
For N = 17 To 65
If Cells(N, 5).Value = 1 Then
'--四角形情報を関連セルより取得 STR--
With box1
.CX = Cells(N, 6).Value
.CY = Cells(N, 7).Value
.XX = Cells(N, 8).Value
.YY = Cells(N, 9).Value
End With
'--四角形情報を関連セルより取得 END--
For M = N + 1 To 66
If Cells(M, 5).Value = 1 Then
'--四角形情報を関連セルより取得 STR--
With box2
.CX = Cells(M, 6).Value
.CY = Cells(M, 7).Value
.XX = Cells(M, 8).Value
.YY = Cells(M, 9).Value
End With
'--四角形情報を関連セルより取得 END--
'２つの四角形が重なり合うか？
If intervention(box1, box2) Then
'--重なる場合はセルに色づけ STR--
With Cells(N, 5).Interior
.ColorIndex = 36
.Pattern = xlSolid
End With
With Cells(M, 5).Interior
.ColorIndex = 36
.Pattern = xlSolid
End With
'--重なる場合はセルに色づけ END--
End If
End If
Next
End If
Next
End Sub
'------------------------------------
'■２つの四角形が重なるか判定する関数
'引数１：box1
'引数２：box2
'戻り値：True =重なる
' ：Flase=重ならない
'------------------------------------
Function intervention(ByRef box1 As BoxInfo, ByRef box2 As BoxInfo) As Boolean
'--比較元用座標情報格納用変数 STR--
Dim bx1 As Double
Dim bx2 As Double
Dim by1 As Double
Dim by2 As Double
'--比較元用座標情報格納用変数 END--
'--比較先用座標情報格納用変数 STR--
Dim cx1 As Double
Dim cx2 As Double
Dim cy1 As Double
Dim cy2 As Double
'--比較先用座標情報格納用変数 END--
'Ｘ軸方向に長い値を比較元に
' 短い値を比較先にセット
If box1.XX > box2.XX Then
Call setX(box1, bx1, bx2)
Call setX(box2, cx1, cx2)
Else
Call setX(box2, bx1, bx2)
Call setX(box1, cx1, cx2)
End If
'比較元のＸ軸座標の範囲に比較先のＸ軸座標が含まれているか計算
intervention = (bx1 <= cx1 And cx1 <= bx2) Or (bx1 <= cx2 And cx2 <= bx2)
'含まれていないので処理を抜ける
If intervention = False Then Exit Function
'Ｙ軸方向に長い値を比較元に
' 短い値を比較先にセット
If box1.YY > box2.YY Then
Call setY(box1, by1, by2)
Call setY(box2, cy1, cy2)
Else
Call setY(box2, by1, by2)
Call setY(box1, cy1, cy2)
End If
'比較元のＹ軸座標の範囲に比較先のＹ軸座標が含まれているか計算
intervention = (by1 <= cy1 And cy1 <= by2) Or (by1 <= cy2 And cy2 <= by2)
End Function
'------------------------
'■Ｘ座標をセットする処理
'------------------------
Sub setX(ByRef typebox As BoxInfo, x1 As Double, x2 As Double)
With typebox
x1 = .CX - .XX / 2
x2 = .CX + .XX / 2
End With
End Sub
'------------------------
'■Ｙ座標をセットする処理
'------------------------
Sub setY(ByRef typebox As BoxInfo, y1 As Double, y2 As Double)
With typebox
y1 = .CY - .YY / 2
y2 = .CY + .YY / 2
End With
End Sub
|
|
こたつねこ
- 06/4/11(火) 15:13 -
