| ■103792 / ) |
Re[4]: Visual Basicで簡易CADを作成 |
□投稿者/ shiro (3回)-(2025/07/30(Wed) 12:22:13)
|
kiku 様
魔界の仮面弁士 様
回答有難うございます。VBでの壁画は始めたばかりで分からない点が多く参考になります。
画像削除方法を勉強してみます。
削除の前に問題が見つかり、自己解決出来なかったので投稿させて頂きます。
柱と壁を別々に動かすことは成功し、それをToolStripMenuItemで「柱・壁」をselect文で場合分けをしようとしました。
下記がその部分です。SnapToGridはFunctionで定めました。
初期設定で柱が設定されており、任意のグリッド座標に柱の四角形が配置されます。
その後、壁を選択し、ラバーバンド機能で柱間に壁を配置できました。
そこで、さらに柱を選択し柱を配置すると、全ての壁が消えてしまいます。
壁が消えないようにするにはどうすれば良いでしょうか。
最終的に、間違って配置した柱や壁も削除機能で削除し、最後に確定した配置から、
座標値を取得し、計算に進みたいと思っています。
記
Public Class Form1
Private snappedRectangles As New List(Of Rectangle)
Private Sub Form1_Load(ByVal sender As System.Object,
ByVal e As System.EventArgs) Handles MyBase.Load
element = "col"
柱ToolStripMenuItem.Checked = True
'描画・オフ
drawFlag = False
End Sub
'================================================================================
'PictureBoxのMouseDownイベント
'--------------------------------------------------------------------------------
Private Sub PictureBox1_MouseDown(
ByVal sender As System.Object,
ByVal e As System.Windows.Forms.MouseEventArgs) _
Handles PictureBox1.MouseDown
'描画
Select Case element
'柱
Case "col"
Dim snapPoint As Point = SnapToGrid(e.Location)
' 四角形の中心を交点に合わせる
Dim rect As New Rectangle(
snapPoint.X - rectangleSize \ 2,
snapPoint.Y - rectangleSize \ 2,
rectangleSize,
rectangleSize
)
snappedRectangles.Add(rect)
PictureBox1.Invalidate() ' 再描画
'描画フラグ・オン
drawFlag = True
'壁
Case "wall"
Dim g As Graphics
Dim wallPen As Pen
Dim snapPoint2 As Point = SnapToGrid(e.Location)
Dim rect2 As New Point(
snapPoint2.X - rectangleSize \ 2,
snapPoint2.Y - rectangleSize \ 2
)
'1回目のクリック
If drawFlag = False Then
'開始位置を取得
ptStart.X = snapPoint2.X
ptStart.Y = snapPoint2.Y
'描画フラグ・オン
drawFlag = True
'終了位置の初期化
ptEnd.X = -1
ptEnd.Y = -1
'2回目のクリック
Else
'ラバーバンドを消す
If ptEnd.X <> -1 Then
Call DrawRubberLine(ptStart, ptEnd)
End If
' 終了位置を取得
ptEnd.X = snapPoint2.X
ptEnd.Y = snapPoint2.Y
g = PictureBox1.CreateGraphics()
wallPen = New Pen(Color.Blue)
wallPen.Width = 5
'描画
g.DrawLine(wallPen, ptStart, ptEnd)
'描画フラグ・オフ
drawFlag = False
End If
End Select
End Sub
'--------------------------------------------------------------------------------
'PictureBoxのMouseMoveイベント
'--------------------------------------------------------------------------------
Private Sub PictureBox1_MouseMove(
ByVal sender As Object,
ByVal e As System.Windows.Forms.MouseEventArgs) _
Handles PictureBox1.MouseMove
'描画
Select Case element
Case "wall"
Dim snapPoint2 As Point = SnapToGrid(e.Location)
Dim rect2 As New Point(
snapPoint2.X - rectangleSize \ 2,
snapPoint2.Y - rectangleSize \ 2
)
'描画フラグ・オフのとき
If drawFlag = False Then
Exit Sub
End If
'ラバーバンドを消す
If ptEnd.X <> -1 Then
Call DrawRubberLine(ptStart, ptEnd)
End If
' 終了位置を取得
ptEnd.X = snapPoint2.X
ptEnd.Y = snapPoint2.Y
Call DrawRubberLine(ptStart, ptEnd)
End Select
End Sub
Private Sub PictureBox1_Paint(sender As Object, e As PaintEventArgs) Handles PictureBox1.Paint
For Each rect In snappedRectangles
g.FillRectangle(Brushes.Red, rect)
g.DrawRectangle(Pens.Black, rect)
Next
End Sub
'--------------------------------------------------------------------------------
'ラバーバンド（直線）を描画
'--------------------------------------------------------------------------------
Private Sub DrawRubberLine(ByVal p1 As Point, ByVal p2 As Point)
'スクリーン座標に変換
p1 = PictureBox1.PointToScreen(p1)
p2 = PictureBox1.PointToScreen(p2)
'ラバーバンドを描画
'ControlPaint.DrawReversibleLine(p1, p2, Color.White)
ControlPaint.DrawReversibleLine(p1, p2, Color.Red)
End Sub
Private Sub 柱ToolStripMenuItem_Click(sender As Object, e As EventArgs) Handles 柱ToolStripMenuItem.Click
element = "col"
'メニューの状態
柱ToolStripMenuItem.Checked = True
壁ToolStripMenuItem.Checked = False
'描画・オフ
drawFlag = False
End Sub
Private Sub 壁ToolStripMenuItem_Click(sender As Object, e As EventArgs) Handles 壁ToolStripMenuItem.Click
element = "wall"
'メニューの状態
柱ToolStripMenuItem.Checked = False
壁ToolStripMenuItem.Checked = True
'描画・オフ
drawFlag = False
End Sub
End Class
|
|
