Skip to content

Instantly share code, notes, and snippets.

@YujiFukami

YujiFukami/SelectShapesFromCell

Created October 30, 2025 06:58
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save YujiFukami/3621bf25fde2fcedaa4f7a793590642f to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save YujiFukami/3621bf25fde2fcedaa4f7a793590642f to your computer and use it in GitHub Desktop.
Download ZIP
Raw
SelectShapesFromCell
'SelectShapesFromCell・・・元場所：IkiKaiso2.ModRibbon
'GetSelectionCell ・・・元場所：IkiKaiso2.ModCell
'SetLineXYby4Value ・・・元場所：IkiKaiso2.ModRibbon
'JudgeLineIntersect ・・・元場所：IkiKaiso2.ModRibbon
'JudgeInSquare ・・・元場所：IkiKaiso2.ModRibbon
'宣言セクション※※※※※※※※※※※※※※※※※※※※※※※※※※※
'-----------------------------------
'元場所:IkiKaiso2.ModRibbon.TP_Line
Public Type TP_Line
StartX As Double '開始点X座標
StartY As Double '開始点Y座標
EndX As Double '終了点X座標
EndY As Double '終了点Y座標
End Type
'宣言セクション終了※※※※※※※※※※※※※※※※※※※※※※※※※※※
Public Sub SelectShapesFromCell()
'選択セルに少しでもかぶっている図形を選択
'20240902
'20251030 図形とセル範囲の二つの長方形において、各辺同士の交差判定に変更
'選択セル取得
Dim SelectCell As Range: Set SelectCell = GetSelectionCell
If SelectCell Is Nothing Then Exit Sub
Dim Sheet As Worksheet: Set Sheet = SelectCell.Worksheet
'シート内の全図形でかぶっているかどうか判定
Dim Shape As Shape
Dim N As Long: N = Sheet.Shapes.Count
Dim K As Long: K = 0
Dim ShapeList As Variant: ReDim ShapeList(1 To N)
Dim CellX1 As Double: CellX1 = SelectCell.Left
Dim CellX2 As Double: CellX2 = SelectCell.Left + SelectCell.Width
Dim CellY1 As Double: CellY1 = SelectCell.Top
Dim CellY2 As Double: CellY2 = SelectCell.Top + SelectCell.Height
Dim CellCenterX As Double: CellCenterX = (CellX1 + CellX2) / 2
Dim CellCenterY As Double: CellCenterY = (CellY1 + CellY2) / 2
Dim ShapeX1 As Double
Dim ShapeX2 As Double
Dim ShapeY1 As Double
Dim ShapeY2 As Double
Dim ShapeCenterX As Double
Dim ShapeCenterY As Double
Dim LineLeftCell As TP_Line: LineLeftCell = SetLineXYby4Value(CellX1, CellY1, CellX1, CellY2)
Dim LineRightCell As TP_Line: LineRightCell = SetLineXYby4Value(CellX2, CellY1, CellX2, CellY2)
Dim LineTopCell As TP_Line: LineTopCell = SetLineXYby4Value(CellX1, CellY1, CellX2, CellY1)
Dim LineButtomCell As TP_Line: LineButtomCell = SetLineXYby4Value(CellX1, CellY2, CellX2, CellY2)
Dim LineLeftShape As TP_Line
Dim LineRightShape As TP_Line
Dim LineTopShape As TP_Line
Dim LineButtomShape As TP_Line
Dim Judge As Boolean
For Each Shape In Sheet.Shapes
'判定
ShapeX1 = Shape.Left
ShapeX2 = Shape.Left + Shape.Width
ShapeY1 = Shape.Top
ShapeY2 = Shape.Top + Shape.Height
ShapeCenterX = (ShapeX1 + ShapeX2) / 2
ShapeCenterY = (ShapeY1 + ShapeY2) / 2
LineLeftShape = SetLineXYby4Value(ShapeX1, ShapeY1, ShapeX1, ShapeY2)
LineRightShape = SetLineXYby4Value(ShapeX2, ShapeY1, ShapeX2, ShapeY2)
LineTopShape = SetLineXYby4Value(ShapeX1, ShapeY1, ShapeX2, ShapeY1)
LineButtomShape = SetLineXYby4Value(ShapeX1, ShapeY2, ShapeX2, ShapeY2)
Judge = False
Select Case True
'線分の交差判定
Case JudgeLineIntersect(LineLeftCell, LineTopShape) = True
Judge = True
GoTo SelectCaseEscape
Case JudgeLineIntersect(LineLeftCell, LineButtomShape) = True
Judge = True
GoTo SelectCaseEscape
Case JudgeLineIntersect(LineRightCell, LineTopShape) = True
Judge = True
GoTo SelectCaseEscape
Case JudgeLineIntersect(LineRightCell, LineButtomShape) = True
Judge = True
GoTo SelectCaseEscape
Case JudgeLineIntersect(LineTopCell, LineLeftShape) = True
Judge = True
GoTo SelectCaseEscape
Case JudgeLineIntersect(LineTopCell, LineRightShape) = True
Judge = True
GoTo SelectCaseEscape
Case JudgeLineIntersect(LineButtomCell, LineLeftShape) = True
Judge = True
GoTo SelectCaseEscape
Case JudgeLineIntersect(LineButtomCell, LineRightShape) = True
Judge = True
GoTo SelectCaseEscape
'長方形の内側にあるかの判定
Case JudgeInSquare(ShapeCenterX, ShapeCenterY, CellX1, CellY1, CellX2, CellY2) = True
Judge = True
GoTo SelectCaseEscape
Case JudgeInSquare(CellCenterX, CellCenterY, ShapeX1, ShapeY1, ShapeX2, ShapeY2) = True
Judge = True
GoTo SelectCaseEscape
End Select
SelectCaseEscape:
If Judge = True Then
K = K + 1
If K = 1 Then
Call Shape.Select(True)
Else
Call Shape.Select(False)
End If
End If
Next
End Sub
Private Function GetSelectionCell() As Range
'選択中のセルを取得する
'セル以外を選択している場合はNothingを返す
'処理
Dim Dummy As Object: Set Dummy = Selection
Dim Output As Range: Set Output = Nothing
If TypeName(Dummy) = "Range" Then
Set Output = Dummy
End If
'出力
Set GetSelectionCell = Output
End Function
Private Function SetLineXYby4Value(ByRef StartX As Double, _
ByRef StartY As Double, _
ByRef EndX As Double, _
ByRef EndY As Double) _
As TP_Line
'座標値4つから線分の構造体を定義する
'20251030
'引数
'StartX・・・開始点X座標
'StartY・・・開始点Y座標
'EndX ・・・終了点X座標
'EndY ・・・終了点Y座標
Dim Output As TP_Line
Output.StartX = StartX
Output.StartY = StartY
Output.EndX = EndX
Output.EndY = EndY
SetLineXYby4Value = Output
End Function
Private Function JudgeLineIntersect(ByRef Line1 As TP_Line, _
ByRef Line2 As TP_Line) _
As Boolean
'2つの線分が交差しているか判定
'20251030
'引数
'Line1・・・線分1
'Line2・・・線分2
' 座標を展開
Dim X1 As Double: X1 = Line1.StartX
Dim Y1 As Double: Y1 = Line1.StartY
Dim X2 As Double: X2 = Line1.EndX
Dim Y2 As Double: Y2 = Line1.EndY
Dim X3 As Double: X3 = Line2.StartX
Dim Y3 As Double: Y3 = Line2.StartY
Dim X4 As Double: X4 = Line2.EndX
Dim Y4 As Double: Y4 = Line2.EndY
' 分母計算（平行チェック）
Dim Denom As Double: Denom = (Y4 - Y3) * (X2 - X1) - (X4 - X3) * (Y2 - Y1)
If Denom = 0 Then
JudgeLineIntersect = False
Exit Function
End If
' 交差パラメータ計算
Dim Ua As Double: Ua = ((X4 - X3) * (Y1 - Y3) - (Y4 - Y3) * (X1 - X3)) / Denom
Dim Ub As Double: Ub = ((X2 - X1) * (Y1 - Y3) - (Y2 - Y1) * (X1 - X3)) / Denom
' Ua, Ub が 0～1 の範囲にある場合、交差
If Ua >= 0 And Ua <= 1 And Ub >= 0 And Ub <= 1 Then
JudgeLineIntersect = True
Else
JudgeLineIntersect = False
End If
End Function
Private Function JudgeInSquare(ByRef InX As Variant, _
ByRef InY As Variant, _
ByRef X1 As Variant, _
ByRef Y1 As Variant, _
ByRef X2 As Variant, _
ByRef Y2 As Variant) As Boolean
'指定の座標が四角枠内に入るか判定
'20211006
'引数
'InX・・・四角枠内に入るかどうかを判定するX座標/Variant型だが数値として扱える値
'InY・・・四角枠内に入るかどうかを判定するY座標/Variant型だが数値として扱える値
'X1 ・・・判定する四角枠の左上X座標/Variant型だが数値として扱える値
'Y1 ・・・判定する四角枠の左上Y座標/Variant型だが数値として扱える値
'X2 ・・・判定する四角枠の右下X座標/Variant型だが数値として扱える値
'Y2 ・・・判定する四角枠の右下Y座標/Variant型だが数値として扱える値
'返り値
'指定座標が四角枠内に入る場合はTrue。入らない場合はFalse
'引数チェック(入力値が数値かどうか)
If IsNumeric(InX) = False Or _
IsNumeric(InY) = False Or _
IsNumeric(X1) = False Or _
IsNumeric(Y1) = False Or _
IsNumeric(X2) = False Or _
IsNumeric(Y2) = False Then
MsgBox "数値を入れてください", vbExclamation
Stop
Exit Function
End If
'判定
Dim Output As Boolean
If X1 <= InX And InX <= X2 And Y1 <= InY And InY <= Y2 Then
Output = True
Else
Output = False
End If
'出力
JudgeInSquare = Output
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment