Tweet
Hallo Forum hier der Code der nicht ganz funktioniert:
Jetzt kommt ein Link der das Ziel beschreibt:
http://www.vbarchiv.net/forum/id22_i57424t57424.html
Vielleicht hat hier jemand ne Hilfestellung parat?
Danke
masterkoch
Code:
Imports System.IO
Imports System.IO.DirectoryInfo
Imports System.IO.FileInfo
Public Class Form1
Inherits System.Windows.Forms.Form
#Region " Windows Form Designer generated code "
'...
#End Region
Private picDirectoryPath As String = "C:\\Fotos"
Dim rubbervisible As Boolean = False
Dim rubbercancel As Boolean = False
Dim rubberpos As Point
Dim rubbersize As Size
Dim rubberpos_orig As Point
Private Sub PictureBox1_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseDown
rubbercancel = False
rubberpos_orig = New Point(e.X, e.Y)
rubberpos = PictureBox1.PointToScreen(rubberpos_orig)
rubbersize = New Size(0, 0)
' Startrechteck zeichnen
DrawRubberBox()
End Sub
Private Sub PictureBox1_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseMove
If e.Button <> MouseButtons.None And rubbercancel = False Then
Dim x As Integer = e.X
Dim y As Integer = e.Y
If x < 0 Then x = 0
If x > PictureBox1.ClientSize.Width Then x = PictureBox1.ClientSize.Width
If y < 0 Then y = 0
If y > PictureBox1.ClientSize.Height Then y = PictureBox1.ClientSize.Height
' bisheriges Rechteck löschen
RemoveRubberBox()
' neues Rechteck zeichnen
rubbersize = New Size(x - rubberpos_orig.X, y - rubberpos_orig.Y)
Text = x.ToString() '& y.ToString & rubbersize.ToString()
DrawRubberBox()
End If
End Sub
Private Sub PictureBox1_MouseUp(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseUp
If rubbercancel Then Exit Sub
' Rechteck löschen
RemoveRubberBox()
' als Ergebnis Rechteck zeichnen
Dim x0, y0, x1, y1, tmp As Integer
Dim gr As Graphics = Graphics.FromHwnd(PictureBox1.Handle)
Dim img As Image
Dim buffer As Bitmap
img = PictureBox1.Image
' Rechteck von (x0,y0) nach (x1,y1)
x0 = rubberpos_orig.X
x1 = x0 + rubbersize.Width
If x0 > x1 Then tmp = x0 : x0 = x1 : x1 = tmp
y0 = rubberpos_orig.Y
y1 = y0 + rubbersize.Height
If y0 > y1 Then tmp = y0 : y0 = y1 : y1 = tmp
'buffer = CropBitmap(CType(img, Bitmap), x0, y0, x1, CInt(CLng(y1 * 1.2)))
buffer = CropBitmap(CType(img, Bitmap), x0, y0, x1, y1)
PictureBox1.Image = buffer
PictureBox1.SizeMode = PictureBoxSizeMode.StretchImage
buffer = Nothing 'verhindert OutOfMemory Exception
gr.Dispose()
'buffer.Dispose())'Exception wird ausgelöst
End Sub
Private Sub Form1_Leave(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Leave
RemoveRubberBox()
rubbercancel = True
End Sub
Private Sub Form1_KeyDown(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyEventArgs) Handles MyBase.KeyDown
RemoveRubberBox()
rubbercancel = True
End Sub
Private Sub Form1_FormClosing(ByVal sender As Object, ByVal e As FormClosingEventArgs) Handles MyBase.FormClosing
'MessageBox.Show("Hallo")
End Sub
Private Sub DrawRubberBox()
rubbervisible = True
ControlPaint.DrawReversibleFrame( _
New Rectangle(rubberpos, rubbersize), _
Color.White, FrameStyle.Dashed)
End Sub
Private Sub RemoveRubberBox()
If rubbervisible = True Then
ControlPaint.DrawReversibleFrame( _
New Rectangle(rubberpos, rubbersize), _
Color.White, FrameStyle.Dashed)
End If
rubbervisible = False
End Sub
Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
'VB.NET
Dim dir As DirectoryInfo = New DirectoryInfo(picDirectoryPath)
ListBox1.Items.AddRange(dir.GetFiles())
Dim filepath As String = ListBox1.Items.Item(0).ToString
Dim image As Image = image.FromFile(picDirectoryPath & "\\" & filepath)
PictureBox1.Image = image
'PictureBox1.SizeMode = PictureBoxSizeMode.StretchImage
End Sub
Private Sub listbox1_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ListBox1.SelectedIndexChanged
If (IsNothing(ListBox1.SelectedItem)) Then
Return
Else
Dim filepath As String = ListBox1.SelectedItem.ToString()
Dim image As Image = image.FromFile(picDirectoryPath & "\\" & filepath)
PictureBox1.Image = image
PictureBox1.SizeMode = PictureBoxSizeMode.StretchImage
End If
End Sub
Private Function CropBitmap(ByRef bmp As Bitmap, ByVal cropX As Integer, ByVal cropY As Integer, ByVal cropWidth As Integer, ByVal cropHeight As Integer) As Bitmap
Dim rect As New Rectangle(cropX, cropY, cropWidth, cropHeight)
Dim cropped As Bitmap = bmp.Clone(rect, bmp.PixelFormat)
Return cropped
End Function
End Class
http://www.vbarchiv.net/forum/id22_i57424t57424.html
Vielleicht hat hier jemand ne Hilfestellung parat?
Danke
masterkoch
Comment