vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
sevDataGrid - Gönnen Sie Ihrem SQL-Kommando diesen krönenden Abschluß!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück

 Sie sind aktuell nicht angemeldet.Funktionen: Einloggen  |  Neu registrieren  |  Suchen

VB.NET - Fortgeschrittene
Rechteck mit Ziehpunkten vergrößern/verkleinern Teil1 
Autor: Dikn
Datum: 22.07.18 11:30

vb2010
PictureBox [pb1] – BorderStyle: None, W/H: 480/270, SizeMode: Zoom,
CheckBox [cbWH] – Haken, wenn Rechteck nur im Seitenverhältnis 16/9

Funktioniert, aber geht das einfacher/besser????

Option Strict On
 
Class Form1
 
  Dim Rect As New Rectangle(190, 45, 160, 90)
  Dim Diff As Size
  Dim DragRect As Boolean
 
  Dim typeRect As String = "0"
  Dim xM, yM As Integer
 
  Private Sub Form1_Load(sender As Object, e As System.EventArgs) Handles _
    Me.Load
  DoubleBuffered = TrueMe.pb1.Image = Bitmap.FromFile("C:\...\Bilder\IMG_1000.JPG")
  End Sub
 
 
  Private Sub pb1_MouseDown (sender As Object, e As MouseEventArgs) Handles _
    pb1.MouseDown
  typeRect = getRecType(e.X, e.Y)
 
  Select Case typeRect
    Case "Rect"
      Cursor.Current = Cursors.Hand
      If e.Button = MouseButtons.Left AndAlso Rect.Contains(e.Location) Then
        Diff.Width = e.X - Rect.X
        Diff.Height = e.Y - Rect.Y
        DragRect = True
      End If
    Case "OL"
      Cursor.Current = Cursors.SizeNWSE
      DragRect = True
    Case "OM"
      Cursor.Current = Cursors.SizeNS
      DragRect = True
    Case "ML"
      DragRect = True
      Cursor.Current = Cursors.SizeWE
    Case Else
      Beep
  End Select
  End Sub
 
  Private Sub pb1_MouseMove (sender As Object, e As MouseEventArgs) Handles _
    pb1.MouseMove
  Dim x1, x2, y1, y2, w, h As Integer
 
  If typeRect = "Rect" Then
    Rect.Location = e.Location - Diff
 
    If Rect.X < 0 Then Rect.X = 0
    If Rect.Y < 0 Then Rect.Y = 0
    If Rect.X+Rect.Width > pb1.Width-1 Then Rect.X = pb1.Width-1-Rect.Width
    If Rect.Y+Rect.Height > pb1.Height-1 Then Rect.Y = pb1.Height-1-Rect.Height
 
  ElseIf typeRect <> "0" Then
    x1 = Rect.X
    y1 = Rect.Y
    x2 = Rect.X+Rect.Width
    y2 = Rect.Y+Rect.Height
    w = Rect.Width
    h = Rect.Height
 
    Select Case typeRect
      Case "OL"
        x1 = e.X
        y1 = e.y
        If x1 < 0 Then x1 = 0
        If y1 < 0 Then y1 = 0
 
        If cbWH.Checked = True Then
          w = CInt((x2-x1)/16)*16
          h = CInt(w/16*9)
          x1 = x2-w
          y1 = y2-h
        Else
          w = x2-x1
          h = y2-y1
        End If
 
      Case "OM"
        If e.y < 0 Then Exit Sub
        y1 = e.Y
 
        If cbWH.Checked = True Then
          h = CInt((y2-y1)/9)*9
          w =  CInt(h/9)*16
          x1 -= CInt((w-Rect.Width)/2)
          y1 = y2-h
        Else
          h = y2-y1
        End If
 
      Case "ML"
        If e.x < 0 Then Exit Sub
        x1 = e.X
 
        If cbWH.Checked = True Then
          w =  CInt((x2-x1)/16)*16
          h = CInt(w/16)*9
          x1 = x2-w
          y1 -= CInt((h-Rect.Height)/2)
        Else
          w = x2-x1
        End If
    End Select
 
 
    If cbWH.Checked = True AND w = Rect.Width Then Exit Sub
    If y1 < 0 Or x1 < 0 Or x1+w > pb1.Width-1 Or y1+h > pb1.Height-1 OR h _
      < 90 OR w < 160 Then Exit Sub
 
    Rect.X = x1
    Rect.Y = y1
    Rect.Width = w
    Rect.Height = h
 
  Else
    Select Case getRecType(e.X, e.Y)
      Case "Rect"
        Cursor.Current = Cursors.Hand
      Case "OL"
        Cursor.Current = Cursors.SizeNWSE
      Case "OM"
        Cursor.Current = Cursors.SizeNS
      Case "ML"
        Cursor.Current = Cursors.SizeWE
    End Select
 
    Exit Sub
  End If
 
  pb1.Invalidate()
  End Sub
 
  Private Sub pb1_MouseUp (sender As Object, e As MouseEventArgs) Handles _
    pb1.MouseUp
  DragRect = False
  typeRect = "0"
  End Sub
Themenbaum einblendenGesamtübersicht  |  Zum Thema  |  Suchen

Re: Rechteck mit Ziehpunkten vergrößern/verkleinern Teil2 
Autor: Dikn
Datum: 22.07.18 11:31

  Private Sub cbWH_CheckedChanged (sender As System.Object,  e As _
    System.EventArgs) Handles cbWH.CheckedChanged
  Dim rect1 As Rectangle = Rect
 
  If cbWH.Checked Then
    If Rect.Width/16 > Rect.Height/9 Then
      Rect.Height = CInt(Math.Truncate(rect1.Height/9)*9)
      Rect.Width = CInt(Math.Truncate(rect1.Height/9)*16)
      Rect.X += CInt((rect1.Width-Rect.Width)/2)
      Rect.Y += CInt((rect1.Height-Rect.Height)/2)
    ElseIf Rect.Width/16 < Rect.Height/9 Then
      Rect.Width = CInt(Math.Truncate(rect1.Width/16)*16)
      Rect.Height = CInt(Math.Truncate(rect1.Width/16)*9)
      Rect.X += CInt((rect1.Width-Rect.Width)/2)
      Rect.Y += CInt((rect1.Height-Rect.Height)/2)
    Else
      Exit Sub
    End If
 
    pb1.Refresh
  End If
  End Sub
 
  Private Sub pb1_Paint(sender As Object, e As PaintEventArgs) Handles pb1.Paint
  Dim p As New Pen(Color.Red, 1)
 
  e.Graphics.DrawRectangle(p, Rect)
 
  xM = Rect.X+CInt(Rect.Width/2) 
  yM = Rect.Y+CInt(Rect.Height/2)
 
  With e.Graphics
    .FillEllipse(Brushes.Cyan,Rect.X-4, Rect.Y-4, 8, 8)
    .DrawEllipse(p, Rect.X-4, Rect.Y-4, 8, 8)
 
    .FillRectangle(Brushes.Cyan, xM, Rect.Y-4, 8, 8)
    .DrawRectangle(p, xM, Rect.Y-4, 8, 8)
 
    .FillRectangle(Brushes.Cyan, Rect.X-4, yM-4, 8, 8)
    .DrawRectangle(p, Rect.X-4, yM-4, 8, 8)
  End With
  End Sub
 
 
  Private Function getRecType(x As Integer, y As Integer) As String
  Dim rectOL As New Rectangle(Rect.X-4, Rect.Y-4, 8, 8) 
  Dim rectOM As New Rectangle(xM, Rect.Y-4, 8, 8) 
  Dim rectML As New Rectangle(Rect.X-4, yM-4, 8, 8) 
 
  If rectOL.Contains(x,y) Then 
    getRecType = "OL"
  ElseIf rectOM.Contains(x,y) Then 
    getRecType = "OM"
  ElseIf rectML.Contains(x,y) Then 
    getRecType = "ML"
  ElseIf Rect.Contains(x,y)
    getRecType = "Rect"
  Else
    getRecType = "0"
  End If
  End Function
 
End Class
Themenbaum einblendenGesamtübersicht  |  Zum Thema  |  Suchen

Sie sind nicht angemeldet!
Um auf diesen Beitrag zu antworten oder neue Beiträge schreiben zu können, müssen Sie sich zunächst anmelden.

Einloggen  |  Neu registrieren

Funktionen:  Zum Thema  |  GesamtübersichtSuchen 

nach obenzurück
 
   

Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel