Die Community zu .NET und Classic VB.
Menü

Tipp-Upload: VB 5/6 0397: Freihandauswahl Schere

 von 

Über den Tipp  

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

  • Grafik

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
Ausschnitt, Freihandform, Schere, Freihandauswahl, Zeichenprogramm, Ausschneiden, Bildausschnitt

Damit er übernommen werden kann, müssen noch Änderungen daran vorgenommen werden. Sofern Sie der Autor sind, können Sie sich anmelden, um die Liste einzusehen.

Der Vorschlag wurde erstellt am: 17.06.2010 19:00.
Die letzte Aktualisierung erfolgte am 17.06.2010 19:00.

Zurück zur Übersicht

Beschreibung  

Der Tipp ermöglicht das Markieren, Ausschneiden und Einfügen eines
Bildausschnitts mit der Maus. Die Funktionalität ist der Freihandauswahl
von Zeichenprogrammen nachempfunden.

Schwierigkeitsgrad

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

BitBlt, CombineRgn, CreatePatternBrush, CreatePolygonRgn, CreateRectRgn, DeleteObject, FrameRgn, GetRgnBox, OffsetRgn, PaintRgn, Polyline, SetBkMode, SetBrushOrgEx, SetStretchBltMode, SetWindowRgn, StretchBlt

Download:

Download des Beispielprojektes [154,94 KB] 

' Dieser Source stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.

' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
' Ansonsten viel Spaß und Erfolg mit diesem Source!

' ------------- Anfang Projektdatei Projekt1.vbp -------------

' Die Komponente 'Microsoft Common Dialog Control 6.0' (COMDLG32.OCX) wird benötigt.
' --------- Anfang Formular "Form1" alias Form1.frm  ---------

' Steuerelement: Menü "MenuFillClose" auf MenuCut
' Steuerelement: Timersteuerelement "Timer1"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Bildfeld-Steuerelement "Picture3"
' Steuerelement: Menü "MenuFill" auf MenuCut
' Steuerelement: Menü "MenuDrawClose" auf MenuCut
' Steuerelement: Menü "MenuCut"
' Steuerelement: Menü "MenuLoad" auf MenuFile
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1" auf Picture2
' Steuerelement: Menü "MenuEnd" auf MenuFile
' Steuerelement: Menü "MenuClose" auf MenuCut
' Steuerelement: Menü "MenuDraw" auf MenuCut
' Steuerelement: Menü "MenuFile"

' Freihandform Schere
' Copyright © 2010 by Zardoz

Option Explicit

Private SW1 As Long, SH1 As Long, XD As Single, YD As Single
Private XMin As Single, YMin As Single, Breite As Long, Hoehe As Long
Private Rgn2 As Long, flgDraw As Boolean
Private NewBrush As Long
Private OldBkMode As Long
Private Z1 As Long ' Anzahl Polygonpunkte
Private Figur() As PointAPI ' Liste Polygonpunkte

Private Sub Form_Load()

    ' Einstellungen

    Dim Dat1 As String, i As Long

    With Me
        .ScaleMode = vbPixels
        .BackColor = RGB(102, 87, 65)
        .WindowState = vbMaximized
        .KeyPreview = True
        .Caption = "Freihandform Schere"

        If App.LogMode = 0 Then .Caption = .Caption & Space$(20) & "Compile me."
    End With

    Dat1 = App.Path & "\Bild1.jpeg" ' Bildpfad

    If Dir$(Dat1) = "" Then ' Existiert Datei?
        MsgBox "Datei nicht gefunden:" & vbCr & Dat1, vbExclamation + vbOKOnly, Me.Caption
        Unload Me

        Exit Sub

    End If

    With Picture3 ' Lupe
        .Visible = True
        .BorderStyle = vbBSNone
        .ScaleMode = vbPixels
        .TabStop = False
        .BackColor = vbBlack
        .Move 4, 4, 200, 200
        .AutoRedraw = True
    End With

    With Picture1 ' Sichtbares Bild
        .BorderStyle = vbBSNone
        .ScaleMode = vbPixels
        .BackColor = vbBlack
        .TabStop = False
        .AutoRedraw = True
        .Visible = True
    End With

    Call LoadPicturefile(Dat1) ' Bild laden

    With Picture2 ' Zwischenspeicher für Grafik und verschiebbarer Ausschnitt
        .Visible = False
        Set .Container = Picture1
        .BorderStyle = vbBSNone
        .ScaleMode = vbPixels
        .MousePointer = vbSizeAll
        .TabStop = False
        .BackColor = vbBlack
        .Move 0, 0, 16, 16
        .AutoRedraw = True

        ' Muster zeichnen
        For i = 1 To .ScaleWidth * Sqr(0.5) Step 2
            Picture2.Circle (8, 8), i, vbWhite
        Next i

        ' Brush für Animation erzeugen
        NewBrush = CreatePatternBrush(.Image.Handle)
        .ZOrder vbBringToFront
    End With

    flgDraw = False
    Timer1.Enabled = False
    Timer1.Interval = 100

End Sub

Private Sub MenuClose_Click()

    ' Ausscnitt aus, nicht zeichnen

    Call CutOutClr

End Sub

Private Sub MenuDraw_Click()

    ' Ausschnitt zeichnen

    Timer1.Enabled = False
    Picture1.FillColor = vbBlack
    Picture1.FillStyle = vbFSSolid

    With Picture2

        Call OffsetRgn(Rgn2, .Left, .Top) ' Maske verschieben

        .Cls ' Animierten Rahmen löschen
        .AutoRedraw = True ' Picture nach Image kopieren

        ' Bild Xor Ausschnitt
        Call BitBlt(Picture1.hdc, .Left, .Top, Breite, Hoehe, .hdc, 0, 0, vbSrcInvert)
        Call PaintRgn(Picture1.hdc, Rgn2) ' Maske zeichnen

        ' Bild Xor Ausschnitt
        Call BitBlt(Picture1.hdc, .Left, .Top, Breite, Hoehe, .hdc, 0, 0, vbSrcInvert)
        Call OffsetRgn(Rgn2, -.Left, -.Top) ' Maske zum Nullpunkt verschieben

        .Cls ' Image freigeben
        .AutoRedraw = False
    End With

    Picture1.FillStyle = vbFSTransparent
    Timer1.Enabled = True

End Sub

Private Sub MenuDrawClose_Click()

    ' Ausschnitt zeichnen und aus

    Call MenuDraw_Click
    Call CutOutClr

End Sub

Private Sub MenuFill_Click()

    ' Ausschnitt füllen

    Dim Num As Long

    On Error Resume Next

    With CommonDialog1
        .Flags = cdlCCFullOpen Or cdlCCRGBInit
        .CancelError = True
        .ShowColor
        Num = Err.Number
        Err.Clear
        On Error GoTo 0

        If Num = 0 Then

            ' Ausschnitt füllen
            Picture1.FillColor = .Color
            Picture1.FillStyle = vbFSSolid

            With Picture2

                Call OffsetRgn(Rgn2, .Left, .Top) ' Maske verschieben
                Call PaintRgn(Picture1.hdc, Rgn2) ' Maske zeichnen
                Call OffsetRgn(Rgn2, -.Left, -.Top) ' Maske zum Nullpunkt verschieben

                .Move .Left + 4, .Top + 4 ' Ergebnis sichtbar machen
            End With

            Picture1.FillStyle = vbFSTransparent
        End If

    End With

End Sub

Private Sub MenuFillClose_Click()

    ' Ausschnitt füllen und aus

    Call MenuFill_Click
    Call CutOutClr

End Sub

Private Sub MenuLoad_Click()

    ' Dateiauswahl

    Dim Num As Long

    Call CutOutClr

    Picture2.Move 0, 0

    With CommonDialog1
        .Flags = cdlOFNFileMustExist Or cdlOFNReadOnly
        .Filter = "Pictures|*.jpg;*.jpeg;*.bmp;*.gif;.wmf|"
        .CancelError = True
        On Error Resume Next
        .ShowOpen
        Num = Err.Number
        Err.Clear
        On Error GoTo 0

        If Num = 0 Then

            Call LoadPicturefile(.FileName) ' Bild laden

        End If

    End With

End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    ' Ausschnitt aktiv?
    If Picture2.Visible = True Then

        Call MenuDrawClose_Click

    Else

        ' Beginn Ausschnitt markieren
        ReDim Figur(0)
        Z1 = 0
        Figur(0).X = X
        Figur(0).Y = Y
        Picture2.Move 0, 0, SW1, SH1
        Picture2.Cls ' Autoredraw-Bild anpassen
        Picture2.AutoRedraw = True

        With Picture1

            ' Bild zwischenspeichern
            Call BitBlt(Picture2.hdc, 0, 0, SW1, SH1, .hdc, 0, 0, vbSrcCopy)

            ' Einstellungen für Linie
            .ForeColor = vbWhite
            .DrawStyle = vbDot
            OldBkMode = SetBkMode(.hdc, OPAQUE)
        End With

        flgDraw = True ' Zeichenmodus ein
    End If

End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    ' Polygonkoordinaten beim Zeichnen protokollieren

    If Button = vbLeftButton And flgDraw = True Then

        ' Verhindern, dass über den Rand gezeichnet wird
        If X < 0 Then
            X = 0
        ElseIf X >= SW1 Then
            X = SW1 - 1
        End If

        If Y < 0 Then
            Y = 0
        ElseIf Y >= SH1 Then
            Y = SH1 - 1
        End If

        Z1 = Z1 + 1

        If Z1 > UBound(Figur) Then
            ReDim Preserve Figur(Z1 + 40)
        End If

        Figur(Z1).X = X
        Figur(Z1).Y = Y

        ' Linie zeichnen
        Call Polyline(Picture1.hdc, Figur(0), Z1 + 1)

        Picture1.Refresh
    End If

    Call Zoom(X, Y) ' Lupe zeichnen

End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Dim Rgn1 As Long, Block As RECT

    If flgDraw = False Then Exit Sub ' Nicht im Zeichenmodus
    flgDraw = False ' Zeichenmodus aus

    Call SetBkMode(Picture1.hdc, OldBkMode)

    Picture1.DrawStyle = vbSolid

    ' Hintergrund wiederherstellen
    Call BitBlt(Picture1.hdc, 0, 0, SW1, SH1, Picture2.hdc, 0, 0, vbSrcCopy)

    Picture1.Refresh ' Auffrischen erzwingen

    If Z1 < 3 Then Exit Sub ' Zu wenig Punkte
    Rgn1 = CreatePolygonRgn(Figur(0), Z1 + 1, ALTERNATE)

    Call GetRgnBox(Rgn1, Block)

    With Block
        XMin = .Left
        YMin = .Top
        Breite = .Right - XMin + 1
        Hoehe = .Bottom - YMin + 1
    End With

    Erase Figur ' Speicher freigeben

    If Breite < 4 And Hoehe < 4 Then

        ' Ausschnitt zu klein (User von Maus abgerutscht :-))
        Call DeleteObject(Rgn1)

    Else

        ' Ausschnitt ok
        Rgn2 = CreateRectRgn(0, 0, 0, 0) ' Leere Region erzeugen

        Call OffsetRgn(Rgn1, -XMin, -YMin) ' Region zum Nullpunkt verschieben
        Call CombineRgn(Rgn2, Rgn1, 0, RGN_COPY) ' Region kopieren

        With Picture2
            .Move XMin, YMin, Breite, Hoehe ' Picturebox an Ausschnittgrösse anpassen
            .Cls ' Autoredraw-Bild anpassen

            ' Bildausschnitt auf Picture2 kopieren
            Call BitBlt(.hdc, 0, 0, Breite, Hoehe, Picture1.hdc, XMin, YMin, vbSrcCopy)

            Set .Picture = .Image ' Image nach Picture kopieren
            .Cls ' Image freigeben
            .AutoRedraw = False
            .Visible = True

            Call SetWindowRgn(.hwnd, Rgn1, True) ' Region übergeben

        End With

        Timer1.Enabled = True ' Animation einschalten
    End If

End Sub

Private Sub Picture2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If Button = vbRightButton Then

        ' PopupMenü aufrufen
        PopupMenu MenuCut
    Else

        ' Start Ausschnitt verschieben
        Picture2.MousePointer = vbDefault
        XD = X
        YD = Y
    End If

End Sub

Private Sub Picture2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    ' Ausschnitt mit der Maus verschieben

    With Picture2

        If Button = vbLeftButton Then
            .Move .Left + X - XD, .Top + Y - YD
            Picture1.Refresh
        End If

        Call Zoom(.Left + X, .Top + Y) ' Lupe zeichnen

    End With

End Sub

Private Sub Picture2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Picture2.MousePointer = vbSizeAll

End Sub

Private Sub Timer1_Timer()

    ' Animation

    Static Pos As Long

    Dim Pt1 As PointAPI

    If Me.WindowState = vbMinimized Then Exit Sub
    Pos = (Pos + 1) And 15

    With Picture2

        ' Koordinaten setzen
        Call SetBrushOrgEx(.hdc, Pos, Pos, Pt1)

        ' Rahmen zeichnen
        Call FrameRgn(.hdc, Rgn2, NewBrush, 1, 1)

        ' Alte Einstellungen setzen
        Call SetBrushOrgEx(.hdc, Pt1.X, Pt1.Y, Pt1)

    End With

End Sub

Private Sub Zoom(X As Single, Y As Single)

    ' Lupe zeichnen

    Dim SRR1 As Long, SHR1 As Long, OldMode As Long
    Dim SW3 As Long, SH3 As Long, Fkt As Single

    Fkt = 4 ' Vergrösserungsfaktor

    With Picture3
        SW3 = .ScaleWidth
        SH3 = .ScaleHeight
        SRR1 = SW3 / Fkt
        SHR1 = SH3 / Fkt
        Picture3.Line (0, 0)-(SW3 - 1, SH3 - 1), vbBlack, BF
        OldMode = SetStretchBltMode(.hdc, COLORONCOLOR)

        Call StretchBlt(.hdc, 0, 0, SW3, SH3, Picture1.hdc, X - SRR1 / 2, Y - SHR1 / 2, SRR1, _
            SHR1, vbSrcCopy)

        Call SetStretchBltMode(.hdc, OldMode)

        ' Fadenkreuz zeichnen
        .DrawStyle = vbDot
        OldMode = SetBkMode(.hdc, OPAQUE)
        Picture3.Line (SW3 / 2, 0)-Step(0, SH3 - 1), vbWhite
        Picture3.Line (0, SH3 / 2)-Step(SW3 - 1, 0), vbWhite

        Call SetBkMode(.hdc, OldMode)

        .DrawStyle = vbSolid
        .Refresh
    End With

End Sub

Private Sub CutOutClr()

    ' Ausschnitt löschen

    Timer1.Enabled = False

    If Picture2.Visible = True Then
        Picture2.Visible = False

        ' Rechteckform wiederherstellen
        Call SetWindowRgn(Picture2.hwnd, 0, False)

    End If

    If Rgn2 <> 0 Then

        Call DeleteObject(Rgn2) ' Region löschen

        Rgn2 = 0
    End If

End Sub

Private Sub LoadPicturefile(Dat1 As String)

    ' Bild in Picturebox laden

    Dim TmpPic As StdPicture

    Me.MousePointer = vbHourglass

    DoEvents

    Set TmpPic = LoadPicture(Dat1) ' Bild laden

    With Picture1 ' Sichtbares Bild
        SW1 = CLng(.ScaleX(TmpPic.Width, vbHimetric)) ' Bildbreite
        SH1 = CLng(.ScaleY(TmpPic.Height, vbHimetric)) ' Bildhöhe

        .Move Picture3.Left + Picture3.Width + 4, 4, SW1 + .Width - .ScaleWidth, SH1 + _
            .Height - .ScaleHeight

        .Cls
        .PaintPicture TmpPic, 0, 0 ' Bild zeichnen
    End With

    Set TmpPic = LoadPicture() ' Speicher freigeben
    Me.MousePointer = vbDefault

End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

    ' Abbruch über Esc-Taste

    If KeyCode = vbKeyEscape Then
        If Picture2.Visible = True Then

            Call CutOutClr

        Else
            Unload Me
        End If
    End If

End Sub

Private Sub MenuEnd_Click()

    ' Beenden über Menü

    Unload Me

End Sub

Private Sub Form_Unload(Cancel As Integer)

    ' Beim Beenden Speicher aufräumen

    Call CutOutClr
    Call DeleteObject(NewBrush)

End Sub

' ---------- Ende Formular "Form1" alias Form1.frm  ----------

' --------- Anfang Modul "Module1" alias Module1.bas ---------

Option Explicit

' Typen
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Type PointAPI
    X As Long
    Y As Long
End Type

' Deklarationen
' gdi32
Public Declare Function BitBlt Lib "gdi32" ( _
                        ByVal hdcDest As Long, _
                        ByVal XDest As Long, _
                        ByVal YDest As Long, _
                        ByVal nWidth As Long, _
                        ByVal nHeight As Long, _
                        ByVal hDCSrc As Long, _
                        ByVal xSrc As Long, _
                        ByVal ySrc As Long, _
                        ByVal dwRop As Long) As Long

Public Declare Function CombineRgn Lib "gdi32" ( _
                        ByVal hDestRgn As Long, _
                        ByVal hSrcRgn1 As Long, _
                        ByVal hSrcRgn2 As Long, _
                        ByVal nCombineMode As Long) As Long

Public Declare Function CreatePatternBrush Lib "gdi32" ( _
                        ByVal hBitmap As Long) As Long

Public Declare Function CreatePolygonRgn Lib "gdi32" ( _
                        lpPoint As PointAPI, _
                        ByVal nCount As Long, _
                        ByVal nPolyFillMode As Long) As Long

Public Declare Function CreateRectRgn Lib "gdi32" ( _
                        ByVal x1 As Long, _
                        ByVal y1 As Long, _
                        ByVal X2 As Long, _
                        ByVal Y2 As Long) As Long

Public Declare Function DeleteObject Lib "gdi32" ( _
                        ByVal hObject As Long) As Long

Public Declare Function FrameRgn Lib "gdi32" ( _
                        ByVal hdc As Long, _
                        ByVal hRgn As Long, _
                        ByVal hBrush As Long, _
                        ByVal nWidth As Long, _
                        ByVal nHeight As Long) As Long

Public Declare Function GetRgnBox Lib "gdi32" ( _
                        ByVal hRgn As Long, _
                        lpRect As RECT) As Long

Public Declare Function OffsetRgn Lib "gdi32" ( _
                        ByVal hRgn As Long, _
                        ByVal X As Long, _
                        ByVal Y As Long) As Long

Public Declare Function PaintRgn Lib "gdi32" ( _
                        ByVal hdc As Long, _
                        ByVal hRgn As Long) As Long

Public Declare Function Polyline Lib "gdi32" ( _
                        ByVal hdc As Long, _
                        lpPoint As PointAPI, _
                        ByVal nCount As Long) As Long

Public Declare Function SetBkMode Lib "gdi32" ( _
                        ByVal hdc As Long, _
                        ByVal nBkMode As Long) As Long

Public Declare Function SetBrushOrgEx Lib "gdi32" ( _
                        ByVal hdc As Long, _
                        ByVal nXOrg As Long, _
                        ByVal nYOrg As Long, _
                        lppt As PointAPI) As Long

Public Declare Function SetStretchBltMode Lib "gdi32" ( _
                        ByVal hdc As Long, _
                        ByVal nStretchMode As Long) As Long

Public Declare Function StretchBlt Lib "gdi32" ( _
                        ByVal hdc As Long, _
                        ByVal X As Long, _
                        ByVal Y As Long, _
                        ByVal nWidth As Long, _
                        ByVal nHeight As Long, _
                        ByVal hSrcDC As Long, _
                        ByVal xSrc As Long, _
                        ByVal ySrc As Long, _
                        ByVal nSrcWidth As Long, _
                        ByVal nSrcHeight As Long, _
                        ByVal dwRop As Long) As Long

' user32
Public Declare Function SetWindowRgn Lib "user32" ( _
                        ByVal hwnd As Long, _
                        ByVal hRgn As Long, _
                        ByVal bRedraw As Long) As Long

' Konstanten
' StretchBlt() Modes
Public Const COLORONCOLOR As Long = 3

' PolyFill() Modes
Public Const ALTERNATE As Long = 1

' Public Const WINDING As Long = 2

' CombineRgn() Styles
Public Const RGN_COPY As Long = 5

' Background Modes
Public Const OPAQUE As Long = 2

' ---------- Ende Modul "Module1" alias Module1.bas ----------

' -------------- Ende Projektdatei Projekt1.vbp --------------

Diskussion  

Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.
Folgende Diskussionen existieren bereits

Geht's nicht ohne Regions - Klaus Langbein 04.11.2011 17:30

Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.