Das nachfolgende Beispiel zeigt, wie man mit einem "Kopier-Stempel" Ausschnitte aus einem Bild mit dem Pinsel auf eine andere Stelle im Bild übermalen kann. Erstellen Sie ein neues Projekt, platzieren auf die Form ein HScroll-Control (HScroll1), eine PictureBox (picDummy) mit Visible = False und darunter eine weitere PictureBox (Picture1) mit ScaleMode = "3 - Pixel". Setzen Sie ferner auch noch die ScaleMode-Eigenschaft der Form auf "3 - Pixel". Fügen Sie dem Projekt jetzt ein neues Modul mit nachfolgenden Code hinzu: Option Explicit ' benötigte API-Deklarationen Public Declare Function SetPixel Lib "gdi32" ( _ ByVal hDC As Long, _ ByVal X As Long, _ ByVal Y As Long, _ ByVal crColor As Long) As Long Public Declare Function GetPixel Lib "gdi32" ( _ ByVal hDC As Long, _ ByVal X As Long, _ ByVal Y As Long) As Long Public TargetX As Single Public TargetY As Single Public kStempel As Boolean Public sysTarget As Boolean Public Sub KorrFilter(ByRef Pic As PictureBox, _ Optional x1 As Long = -1, Optional y1 As Long = -1, _ Optional x2 As Long = -1, Optional y2 As Long = -1, _ Optional xtg As Single = 0, Optional ytg As Single = 0, _ Optional Grad As Integer = 8) Dim intDrawMode As Integer Dim lngReadColor As Long Dim lngWriteColor As Long Dim Rs As Long Dim Gs As Long Dim Bs As Long Dim X As Single Dim Y As Single On Error GoTo ErrorHandler If (x1 = -1) And (y1 = -1) And (x2 = -1) And (y2 = -1) Then Exit Sub With Pic intDrawMode = .DrawMode .DrawMode = vbCopyPen Dim xMid As Single, yMid As Single If x1 < x2 Then xMid = x1 + ((x2 - x1) / 2) Else xMid = x2 + ((x1 - x2) / 2) End If If y1 < y2 Then yMid = y1 + ((y2 - y1) / 2) Else yMid = y2 + ((y1 - y2) / 2) End If For X = x1 To x2 For Y = y1 To y2 If radiusAF(xMid, yMid, X, Y) < Grad Then ' Für Rundung lngReadColor = GetPixel(.hDC, X + xtg, Y + ytg) GetRGBColor lngReadColor, Rs, Gs, Bs lngWriteColor = RGB(Abs(Rs), Abs(Gs), Abs(Bs)) SetPixel .hDC, X, Y, lngWriteColor End If Next Y Pic.Refresh Next X .DrawMode = intDrawMode .Refresh End With ErrorHandler: End Sub ' Radiuswert aus zwei Koordinatenpaaren ermitteln Private Function radiusAF(x1!, y1!, x2!, y2!) As Single Dim A As Single Dim B As Single On Error Resume Next A = Abs(x1! - x2!) B = Abs(y1! - y2!) radiusAF = Sqr(A * A + B * B) End Function ' RGB Farbwerte ermitteln Private Sub GetRGBColor(lngColor As Long, ByRef Rs As Long, _ ByRef Gs As Long, ByRef Bs As Long) On Error GoTo ErrorHandler Rs = lngColor Mod 256 Gs = (lngColor \ 256) Mod 256 Bs = (lngColor \ 256) \ 256 ErrorHandler: End Sub Öffnen Sie die Form und laden in die PictureBox "Picture1" ein beliebiges Bild. Platzieren Sie jetzt noch ein Image-Control in die PictureBox benennen es "imgTarget" und setzen die Visible-Eigenschaft auf False. Der Picture-Eigenschaft weisen Sie folgendes Symbol zu: . Jetzt bitte noch ein Shape-Control in die PictureBox platzieren und folgende Eigenschaften festlegen: Name=shCircle, DrawMode=6-Invers, Height=25, Shape=3-Kreis, Width=26, Visible=False. Fügen Sie nachfolgenden Code in den Codeteil der Form: Option Explicit Private Sub Form_Load() kStempel = True End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) ' KeyEvents an Picture1 weiterleiten Picture1_KeyDown KeyCode, Shift End Sub Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer) ' KeyEvents an Picture1 weiterleiten Picture1_KeyUp KeyCode, Shift End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) ' Shape (Kreis) ausblenden shCircle.Visible = False End Sub Private Sub imgTarget_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) ' Shape (Kreis) ausblenden shCircle.Visible = False End Sub Private Sub Picture1_KeyDown(KeyCode As Integer, Shift As Integer) With Picture1 If KeyCode = vbKeyMenu And kStempel Then .MousePointer = 99 .MouseIcon = PicDummy.MouseIcon ' Target sysTarget = True shCircle.Visible = False End If End With End Sub Private Sub Picture1_KeyUp(KeyCode As Integer, Shift As Integer) With Picture1 If sysTarget Then .MousePointer = 99 .MouseIcon = PicDummy.DragIcon ' Pinsel sysTarget = False shCircle.Visible = True End If End With End Sub Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) If kStempel And Not (sysTarget Or imgTarget.Visible) Then ' Stempel MsgBox "Bitte erst den Kopier-Stempel auf den gewünschten" & vbCrLf & _ " Bereich mit der Taste Alt setzten!", vbInformation, "Kopier-Stempel" Exit Sub End If If sysTarget And Button = 1 Then ' Stempel imgTarget.Left = X - 16: imgTarget.Top = Y - 16 imgTarget.Visible = True TargetX = X: TargetY = Y Exit Sub End If Picture1.AutoRedraw = True If kStempel Then If imgTarget.Visible Then TargetX = TargetX - X TargetY = TargetY - Y Else TargetX = 0 TargetY = 0 End If End If ImageFilter CLng(X), CLng(Y) End Sub Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) If sysTarget And Button = 1 Then Exit Sub If Button = 1 Then If imgTarget.Visible Then imgTarget.Left = X + TargetX - 16 imgTarget.Top = Y + TargetY - 16 End If ' Dunkel (ApplyFilter-ModPicGrafik) ImageFilter =CLng(X), CLng(Y) End If With shCircle .Visible = True .Width = HScroll1.Value .Height = shCircle.Width .Left = X - HScroll1.Value / 2 .Top = Y - HScroll1.Value / 2 End With End Sub Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, _ X As Single, Y As Single) If kStempel And Not (sysTarget Or imgTarget.Visible) Then Exit Sub ' Stempel End If If sysTarget And Button = 1 Then Exit Sub If kStempel Then If imgTarget.Visible Then TargetX = imgTarget.Left + 16 TargetY = imgTarget.Top + 16 End If End If Picture1.AutoRedraw = False End Sub Private Sub ImageFilter(Optional X As Long = -1, Optional Y As Long = -1) On Error GoTo ErrorHandler Dim Pic As PictureBox Dim x1 As Long Dim y1 As Long Dim x2 As Long Dim y2 As Long Dim intDrop As Integer intDrop = HScroll1.Value / 2 If ((X <> -1) Or (Y <> -1)) Then x1 = X - intDrop y1 = Y - intDrop x2 = X + intDrop y2 = Y + intDrop If (x2 >= 0) And (y2 >= 0) Then KorrFilter Picture1, x1, y1, x2, y2, TargetX, TargetY, intDrop End If End If ErrorHandler: End Sub Dieser Tipp wurde bereits 9.074 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
sevISDN 1.0 Überwachung aller eingehender Anrufe! Die DLL erkennt alle über die CAPI-Schnittstelle eingehenden Anrufe und teilt Ihnen sogar mit, aus welchem Ortsbereich der Anruf stammt. Weitere Highlights: Online-Rufident, Erkennung der Anrufbehandlung u.v.m. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 Neu! sevPopUp 2.0 Dynamische Kontextmenüs! Erstellen Sie mit nur wenigen Zeilen Code Kontextmenüs dynamisch zur Laufzeit. Vordefinierte Styles (XP, Office, OfficeXP, Vista oder Windows 8) erleichtern die Anpassung an die eigenen Anwendung... |
||||||||||||||||
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. |