Imports System.ComponentModel Imports System.Drawing Imports System.Drawing.Drawing2D Imports System.Runtime.CompilerServices Imports System.Windows.Forms Imports Pilz.Drawing Public Class PaintingControl Inherits UserControl Implements IPaintingObjectContainer Private curObjMouseDown As PaintingObject = Nothing Private bgColor As Color = Color.White Private startMousePos As Point = Nothing Private lastMousePos As Point = Nothing Private lastHashCode As Integer = 0 Private calcOffset_MouseOnTab As Point = Point.Empty Private calcOffset_IsActive As Boolean = False Private calcOffset_LastOffset As PointF = PointF.Empty Private Overloads Property ForeColor As Color Private Overloads Property Font As Font Private Overloads Property Text As String Public Property Offset As PointF = PointF.Empty Public ReadOnly Property PaintingObjects As New PaintingObjectList(Me) 'Public Property EnableRealTransparency As Boolean = False Public Property VisibleForMouseEvents As Boolean = True Public Property AutoAreaSelection As Boolean = True Public Property AutoSingleSelection As Boolean = True Public Property AutoMultiselection As Boolean = True Public Property AutoRemoveSelection As Boolean = True Public Property AreaSelectionDashStyle As DashStyle = DashStyle.DashDot Public Property AreaSelectionColor As Color = Color.CornflowerBlue Public Property AutoMoveObjects As Boolean = True Private _IsAreaSelecting As Boolean = False Public ReadOnly Property IsMovingObjects As Boolean = False Public Property GridEnabled As Boolean = True Public Property GridVisible As Boolean = False Public Property GridChunkSize As New Size(20, 20) Public Property GridColor As Color = Color.LightGray Public Property DrawGridMethode As DelegateDrawPaintingControlGridMethode = AddressOf DefaultDrawMethodes.DrawGrid Public Property DrawAreaSelectionMethode As DelegateDrawPaintingControlAreaSelectionMethode = AddressOf DefaultDrawMethodes.DrawAreaSelection Private _ZoomFactor As New SizeF(1, 1) Private _stopDrawing As Integer = -1 Private bufferedImg As Image = Nothing Private pressedShift As Boolean = False Private pressedControl As Boolean = False Private pressedAlt As Boolean = False 'Friend WithEvents HScrollBarAdv1 As DevComponents.DotNetBar.ScrollBar.HScrollBarAdv 'Friend WithEvents VScrollBarAdv1 As DevComponents.DotNetBar.VScrollBarAdv Private savedPos As New Dictionary(Of PaintingObject, PointF) Public Event SelectionChanged(sender As Object, e As PaintingObjectEventArgs) Public Event PaintingObjectAdded(sender As Object, e As PaintingObjectEventArgs) Public Event PaintingObjectRemoved(sender As Object, e As PaintingObjectEventArgs) Public Event AfterScrollingDone(sender As Object, e As EventArgs) Public Event ZoomFactorChanged(sender As Object, e As EventArgs) Public ReadOnly Property SelectedObjects As PaintingObject() Get Dim objs As New List(Of PaintingObject) For Each obj As PaintingObject In PaintingObjects If obj.Selected Then objs.Add(obj) End If Next Return objs.ToArray End Get End Property Public ReadOnly Property IsLayoutSuspended As Boolean Get Return CInt(Me.GetType.GetField("layoutSuspendCount", Reflection.BindingFlags.Instance Or Reflection.BindingFlags.NonPublic).GetValue(Me)) <> 0 End Get End Property Public ReadOnly Property StopDrawing As Boolean Get Return _stopDrawing > -1 End Get End Property Public Overrides Property BackColor As Color Get Return bgColor End Get Set(value As Color) bgColor = value MyBase.BackColor = value 'If value <> Color.Transparent Then ' MyBase.BackColor = value 'End If End Set End Property Public ReadOnly Property IsAreaSelecting As Boolean Get Return _IsAreaSelecting AndAlso startMousePos <> lastMousePos End Get End Property Public Property ZoomFactor As SizeF Get Return _ZoomFactor End Get Set If _ZoomFactor <> Value Then _ZoomFactor = Value ResetAllBufferedImages() RaiseEvent ZoomFactorChanged(Me, New EventArgs) End If End Set End Property Public Sub New() 'SetStyle(ControlStyles.Opaque, True) 'For real transparency DoubleBuffered = True End Sub Private Sub ResetAllBufferedImages() For Each ob As PaintingObject In PaintingObjects ob.ResetImageBuffer() Next Refresh() End Sub Private Sub CheckKeyDown(sender As Object, e As KeyEventArgs) Handles Me.KeyDown, Me.KeyUp pressedShift = e.Shift pressedControl = e.Control pressedAlt = e.Alt End Sub Friend ReadOnly Property AreaSelectionRectangle As RectangleF Get Return HelpfulDrawingFunctions.GetRectangle(startMousePos, lastMousePos) End Get End Property Private Sub CheckMouseClick(sender As Object, e As MouseEventArgs) Handles Me.MouseClick For Each obj As PaintingObject In GetObjects(New Point(e.X + Offset.X, e.Y + Offset.Y)) If Not obj.MouseTransparency Then obj.RaiseMouseClick(GetMouseEventArgs(e, obj)) End If Next End Sub Private Sub CheckMouseDown(sender As Object, e As MouseEventArgs) Handles Me.MouseDown lastMousePos = New Point(e.X + Offset.X, e.Y + Offset.Y) curObjMouseDown = GetObjects(lastMousePos).Where(Function(n) Not n.MouseTransparency).LastOrDefault curObjMouseDown?.RaiseMouseDown(GetMouseEventArgs(e, curObjMouseDown)) If curObjMouseDown Is Nothing OrElse Not curObjMouseDown.Selected OrElse pressedControl Then Dim hasMovedObjects As Boolean = False If _IsMovingObjects Then For Each obj As PaintingObject In GetSelectedObjects() If HelpfulDrawingFunctions.IsPointInRectangle(lastMousePos, obj.Rectangle) Then hasMovedObjects = True Exit For End If Next End If If (Not hasMovedObjects) AndAlso (Not _IsAreaSelecting) Then Dim selChanged As New List(Of PaintingObject) If AutoRemoveSelection AndAlso Not pressedControl Then For Each obj As PaintingObject In PaintingObjects If obj.Selected Then obj.SelectedDirect = False If Not selChanged.Contains(obj) Then selChanged.Add(obj) End If End If Next End If If AutoSingleSelection AndAlso curObjMouseDown IsNot Nothing Then Dim objtosel As PaintingObject = curObjMouseDown If objtosel.EnableSelection Then objtosel.SelectedDirect = Not objtosel.Selected If Not selChanged.Contains(objtosel) Then selChanged.Add(objtosel) Else selChanged.Remove(objtosel) End If End If End If RaiseEvent SelectionChanged(Me, New PaintingObjectEventArgs(selChanged.ToArray)) End If End If If pressedControl Then calcOffset_MouseOnTab = New Point(e.X, e.Y) calcOffset_LastOffset = Offset calcOffset_IsActive = True Cursor = Cursors.Arrow Else Select Case e.Button Case MouseButtons.Left savedPos.Clear() If AutoMoveObjects Then SaveObjectPositions(e, GetSelectedObjects) End If If savedPos.Count > 0 Then _IsMovingObjects = True ElseIf AutoAreaSelection Then startMousePos = New Point(e.X + Offset.X, e.Y + Offset.Y) lastMousePos = startMousePos 'New Point(e.X - Offset.X, e.Y - Offset.Y) _IsAreaSelecting = True End If End Select End If End Sub Public Sub RaiseSelectionChanged() RaiseEvent SelectionChanged(Me, New PaintingObjectEventArgs(SelectedObjects)) End Sub Private Sub CheckMouseUp(sender As Object, e As MouseEventArgs) Handles Me.MouseUp If _IsAreaSelecting Then _IsAreaSelecting = False End If If _IsMovingObjects Then _IsMovingObjects = False For Each obj As PaintingObject In GetSelectedObjects() obj.RaiseMoved(New EventArgs) Next AutoArrangeToGrid() End If If curObjMouseDown IsNot Nothing Then If Not curObjMouseDown.MouseTransparency Then curObjMouseDown.RaiseMouseUp(GetMouseEventArgs(e, curObjMouseDown)) End If curObjMouseDown = Nothing End If If calcOffset_IsActive Then calcOffset_IsActive = False Cursor = Cursors.Default CalcNewOffset(e.Location) RaiseEvent AfterScrollingDone(Me, New EventArgs) End If End Sub Private Sub CheckMouseMove(sender As Object, e As MouseEventArgs) Handles Me.MouseMove If _IsAreaSelecting OrElse _IsMovingObjects Then lastMousePos = New Point(e.X + Offset.X, e.Y + Offset.Y) End If If _IsAreaSelecting Then SelectControlsInArea() End If If _IsMovingObjects Then UpdateObjectPositions(e) End If For Each obj As PaintingObject In GetObjects(New Point(e.X + Offset.X, e.Y + Offset.Y)) If Not obj.MouseTransparency Then obj.RaiseMouseMove(GetMouseEventArgs(e, obj)) End If Next Dim topObj As PaintingObject = GetObject(New Point(e.X + Offset.X, e.Y + Offset.Y), True) If topObj IsNot Nothing Then Cursor = topObj.Cursor ElseIf calcOffset_IsActive Then Cursor = Cursors.Arrow Else Cursor = Cursors.Default End If If calcOffset_IsActive Then If pressedControl Then CalcNewOffset(e.Location) Else calcOffset_IsActive = False End If End If Refresh() End Sub Private Sub CalcNewOffset(newMousePos As Point) Offset = New PointF(calcOffset_LastOffset.X - (newMousePos.X - calcOffset_MouseOnTab.X), calcOffset_LastOffset.Y - (newMousePos.Y - calcOffset_MouseOnTab.Y)) If Offset.X < 0 Then Offset = New PointF(0, Offset.Y) End If If Offset.Y < 0 Then Offset = New PointF(Offset.X, 0) End If End Sub Private Function GetSelectedObjects() As PaintingObject() Dim objs As New List(Of PaintingObject) For Each obj As PaintingObject In PaintingObjects If obj.Selected Then objs.Add(obj) Next Return objs.ToArray End Function Private Sub SaveObjectPositions(e As MouseEventArgs, objs As IList) For Each obj As PaintingObject In objs If Not obj.HardcodedLocation AndAlso Not savedPos.ContainsKey(obj) Then savedPos.Add(obj, New PointF(e.X - obj.Location.X + Offset.X, e.Y - obj.Location.Y + Offset.Y)) SaveObjectPositions(e, obj.PinnedObjects) End If Next End Sub Private Sub UpdateObjectPositions(e As MouseEventArgs) UpdateObjectPositions(e, GetSelectedObjects) End Sub Private Sub UpdateObjectPositions(e As MouseEventArgs, objs As IList(Of PaintingObject), Optional movedObjs As List(Of PaintingObject) = Nothing) If IsResizingObjs(objs) Then Return If movedObjs Is Nothing Then movedObjs = New List(Of PaintingObject) SuspendDrawing() For Each obj As PaintingObject In objs Dim sp As PointF = savedPos(obj) If Not movedObjs.Contains(obj) Then If UpdateObjectPosition(e, obj, sp) Then movedObjs.Add(obj) End If End If If obj.PinnedObjects.Count > 0 Then UpdateObjectPositions(e, obj.PinnedObjects, movedObjs) movedObjs.AddRange(obj.PinnedObjects.ToArray) End If Next ResumeDrawing(False) End Sub Private Function UpdateObjectPosition(e As MouseEventArgs, obj As PaintingObject, sp As PointF) As Boolean Dim moved As Boolean = False Dim cancel As New CancelEventArgs(False) obj.RaiseMovingBeforePositionUpdated(cancel) If Not cancel.Cancel Then obj.Location = New Point(e.X - sp.X + Offset.X, e.Y - sp.Y + Offset.Y) obj.RaiseMoving(New EventArgs) moved = True End If Return moved End Function Private Function IsResizingObjs(objs As IList(Of PaintingObject)) As Boolean For Each obj As PaintingObject In objs If obj.IsResizing Then Return True Next Return False End Function Private Function GetMouseEventArgs(e As MouseEventArgs, obj As PaintingObject) As MouseEventArgs Return New MouseEventArgs(e.Button, e.Clicks, e.X - obj.X + Offset.X, e.Y - obj.Y + Offset.Y, e.Delta) End Function Public Function GetObject(p As PointF, Optional UseExtRect As Boolean = False) As PaintingObject Dim val As PaintingObject = Nothing For i As Integer = PaintingObjects.Count - 1 To 0 Step -1 Dim obj As PaintingObject = PaintingObjects(i) If val Is Nothing Then If UseExtRect Then If HelpfulDrawingFunctions.IsPointInRectangle(p, obj.RectangleExtended) Then val = obj End If Else If HelpfulDrawingFunctions.IsPointInRectangle(p, obj.Rectangle) Then val = obj End If End If End If Next Return val End Function Public Function GetObjects(p As Point) As PaintingObject() Dim objs As New List(Of PaintingObject) For Each obj As PaintingObject In PaintingObjects If HelpfulDrawingFunctions.IsPointInRectangle(p, obj.RectangleExtended) Then objs.Add(obj) End If Next Return objs.ToArray End Function Public Function GetObjects(startPoint As Point, endPoint As Point) As PaintingObject() Return GetObjects(New Rectangle(startPoint, CType(endPoint - startPoint, Size))) End Function Public Function GetObjects(rect As Rectangle) As PaintingObject() Dim objs As New List(Of PaintingObject) For Each obj As PaintingObject In PaintingObjects Dim objRect As RectangleF = obj.Rectangle If HelpfulDrawingFunctions.IsPointInRectangle(objRect.Location, rect) OrElse HelpfulDrawingFunctions.IsPointInRectangle(objRect.Location + objRect.Size, rect) OrElse HelpfulDrawingFunctions.IsPointInRectangle(New PointF(objRect.Left, objRect.Bottom), rect) OrElse HelpfulDrawingFunctions.IsPointInRectangle(New PointF(objRect.Right, objRect.Top), rect) Then objs.Add(obj) End If Next Return objs.ToArray End Function Protected Overrides ReadOnly Property CreateParams As CreateParams Get Dim cp = MyBase.CreateParams 'If EnableRealTransparency Then ' cp.ExStyle = cp.ExStyle Or &H20 'WS_EX_TRANSPARENT 'End If Return cp End Get End Property ''' ''' Sorg dafür, dass Events durch dieses Control durchdringen zum Parnet-Control. ''' ''' Protected Overrides Sub WndProc(ByRef m As Message) Const WM_NCHITTEST As Integer = &H84 Const HTTRANSPARENT As Integer = -1 If Not VisibleForMouseEvents AndAlso m.Msg = WM_NCHITTEST Then m.Result = CType(HTTRANSPARENT, IntPtr) Else MyBase.WndProc(m) End If End Sub Protected Overrides Sub OnPaintBackground(e As PaintEventArgs) 'Stop Drawing directly to the parent Me.SuspendLayout() 'Draw Background 'If Not EnableRealTransparency Then MyBase.OnPaintBackground(e) 'End If End Sub Protected Overrides Sub OnPaint(e As PaintEventArgs) 'Draw PaintingObjects stuff If StopDrawing Then e.Graphics.DrawImage(bufferedImg, Point.Empty) Else With e.Graphics .SmoothingMode = SmoothingMode.HighQuality .PixelOffsetMode = PixelOffsetMode.HighQuality .PageUnit = GraphicsUnit.Pixel .InterpolationMode = InterpolationMode.HighQualityBicubic End With If GridVisible Then DrawGridMethode?.Invoke(e, Me, Offset) End If Dim baserect As RectangleF = New RectangleF(Offset, Size) For Each obj As PaintingObject In PaintingObjects If obj.Visible AndAlso HelpfulDrawingFunctions.OverlapsTwoRectangles(obj.Rectangle, baserect) Then obj.Draw(e, Offset) End If Next If _IsAreaSelecting Then DrawAreaSelectionMethode?.Invoke(e, Me, New PointF(startMousePos.X - Offset.X, startMousePos.Y - Offset.Y), New PointF(lastMousePos.X - Offset.X, lastMousePos.Y - Offset.Y)) End If End If 'Do default Drawing Methode MyBase.OnPaint(e) 'Start Drawing directly to the Form ResumeLayout(False) End Sub Public Overloads Function CreateGraphics() As Graphics Return MyBase.CreateGraphics End Function Public Sub PaintFullView(g As Graphics) For Each obj As PaintingObject In PaintingObjects If obj.Visible Then obj.Draw(g, PointF.Empty) End If Next End Sub Private Function CalcTextSize(obj As PaintingObject) As SizeF Return CalcTextSize(obj, Parent.CreateGraphics) End Function Private Function CalcTextSize(obj As PaintingObject, g As Graphics) As SizeF Return g.MeasureString(obj.Text, obj.TextFont, obj.Width) End Function Private Sub SelectControlsInArea() Dim rect As RectangleF = GetRectangle(startMousePos, lastMousePos) For Each obj As PaintingObject In PaintingObjects obj.Selected = If(startMousePos.X >= lastMousePos.X, OverlapsTwoRectangles(obj.Rectangle, rect), RectangleContainsRectangle(rect, obj.Rectangle)) Next End Sub Public Sub ArrangeToGrid(obj As PaintingObject, snapPinnedObjects As Boolean) If snapPinnedObjects OrElse Not IsPinnedObject(obj) Then Dim zoomedGridChunkSize As New SizeF(GridChunkSize.Width * ZoomFactor.Width, Me.GridChunkSize.Height * ZoomFactor.Height) Dim modTop As Integer = obj.Y Mod zoomedGridChunkSize.Height Dim modLeft As Integer = obj.X Mod zoomedGridChunkSize.Width Dim halfHeight As Integer = zoomedGridChunkSize.Height / 2 Dim halfWidth As Integer = zoomedGridChunkSize.Width / 2 Dim zoomLocation = Sub(obj2 As PaintingObject) If modTop > halfHeight Then obj2.Y += (zoomedGridChunkSize.Height - modTop) Else obj2.Y -= modTop End If If modLeft > halfWidth Then obj2.X += (zoomedGridChunkSize.Width - modLeft) Else obj2.X -= modLeft End If End Sub zoomLocation(obj) For Each pinned As PaintingObject In obj.PinnedObjects zoomLocation(pinned) Next Dim modH As Integer = obj.Height Mod zoomedGridChunkSize.Height Dim modW As Integer = obj.Width Mod zoomedGridChunkSize.Width Dim zoomSize = Sub(obj2 As PaintingObject) If obj2.EnableResize AndAlso Not obj2.HardcodedSize Then If modH > halfHeight Then obj2.Height += (zoomedGridChunkSize.Height - modH) Else obj2.Height -= modH End If If modW > halfWidth Then obj2.Width += (zoomedGridChunkSize.Width - modW) Else obj2.Width -= modW End If End If End Sub zoomSize(obj) For Each pinned As PaintingObject In obj.PinnedObjects zoomSize(pinned) Next End If End Sub Public Function IsPinnedObject(o As PaintingObject) As Boolean For Each obj As PaintingObject In PaintingObjects If obj.PinnedObjects.Contains(o) Then Return True End If Next Return False End Function Public Sub AutoArrangeToGrid() If GridEnabled Then For Each obj As PaintingObject In GetSelectedObjects() If obj.AutoAlignToGrid Then ArrangeToGrid(obj, False) End If Next If Not StopDrawing Then Refresh() End If End Sub Public Function GetFullSize() As SizeF Return GetFullSize(PaintingObjects) End Function Public Shared Function GetFullSize(objects As IEnumerable(Of PaintingObject)) As SizeF Dim curX As Single = 0 Dim curY As Single = 0 For Each po As PaintingObject In objects Dim myX As Single = po.X + po.Width If curX < myX Then curX = myX End If Dim myY As Single = po.Y + po.Height If curY < myY Then curY = myY End If Next Return New SizeF(curX + 20, curY + 20) End Function Friend Sub RaisePaintingObjectAdded(args As PaintingObjectEventArgs) RaiseEvent PaintingObjectAdded(Me, args) End Sub Friend Sub RaisePaintingObjectRemoved(args As PaintingObjectEventArgs) RaiseEvent PaintingObjectRemoved(Me, args) End Sub Private Sub PaintingControl_PaintingObjectAdded(sender As Object, e As PaintingObjectEventArgs) Handles Me.PaintingObjectAdded, Me.PaintingObjectRemoved 'CalculateScrollValues() End Sub Private Sub CheckMouseWheel(sender As Object, e As MouseEventArgs) Handles Me.MouseWheel If pressedControl Then Dim val As Single = e.Delta / 120 / 10 ZoomFactor = New SizeF(Math.Max(ZoomFactor.Width + val, 0.25), Math.Max(ZoomFactor.Height + val, 0.25)) Refresh() End If End Sub Public Sub SuspendDrawing() If _stopDrawing < 0 Then 'bufferedImg = New Bitmap(Width, Height) 'DrawToBitmap(bufferedImg, New Rectangle(0, 0, bufferedImg.Width, bufferedImg.Height)) Utils.SuspendDrawing(Me) End If _stopDrawing += 1 End Sub Public Sub ResumeDrawing() ResumeDrawing(True) End Sub Public Sub ResumeDrawing(executeRefresh As Boolean) If _stopDrawing >= 0 Then _stopDrawing -= 1 End If If _stopDrawing = -1 Then 'bufferedImg.Dispose() 'bufferedImg = Nothing 'If executeRefresh Then Refresh() Utils.ResumeDrawing(Me, executeRefresh) End If End Sub End Class