Kopier-Stempel


Mit dem Kopier-Stempel können Sie Ausschnitte aus einem Bild mit dem Pinsel auf eine andere Stelle im Bild übermalen.
Laden Sie sich die Zip-Datei mit VB 6 Source Code hinunter und probieren Sie es mal aus.

Projekt - Download
© FienauBerlin   Web-ComputerEcke.de
 

Quell-Code Form1
Option Explicit

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Picture1_KeyDown KeyCode, Shift End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer) Picture1_KeyUp KeyCode, Shift End Sub
Private Sub Form_Load() kStempel = True End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) shCircle.Visible = False End Sub
Private Sub imgTarget_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) shCircle.Visible = False End Sub
Private Sub Picture1_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeyMenu And kStempel Then Picture1.MousePointer = 99 Picture1.MouseIcon = PicDummy.MouseIcon 'Target sysTarget = True shCircle.Visible = False Exit Sub End If
End Sub Private Sub Picture1_KeyUp(KeyCode As Integer, Shift As Integer) If sysTarget Then Picture1.MousePointer = 99 Picture1.MouseIcon = PicDummy.DragIcon 'Pinsel sysTarget = False shCircle.Visible = True Exit Sub End If 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 X:=CLng(X), Y:=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 ImageFilter X:=CLng(X), Y:=CLng(Y) End If shCircle.Visible = True shCircle.Width = HScroll1.Value shCircle.Height = shCircle.Width shCircle.Left = X - HScroll1.Value / 2 shCircle.Top = Y - HScroll1.Value / 2 End Sub
Private Sub Picture1_MouseUp(Button As Integer, _ Shift As Integer, X As Single, Y As Single) 'Stempel If kStempel And Not (sysTarget Or imgTarget.Visible) Then Exit Sub 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:=x1, y1:=y1, x2:=x2, y2:=y2, _ xtg:=TargetX, ytg:=TargetY, Grad:=intDrop End If End If Exit Sub ErrorHandler: Exit Sub End Sub

Quell-Code Modul1
Option Explicit
 
Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, _
                      ByVal X As Long, ByVal Y As Long, _
                      ByVal crColor As Long) As Long
Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, _
                      ByVal X As Long, ByVal Y As Long) As Long
 
 
Public TargetX!, TargetY!, kStempel As Boolean, 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(x1:=xMid, y1:=yMid, x2:=X, _ y2:=Y) < Grad Then 'Für Rundung lngReadColor = GetPixel(hDC:=.hDC, _ X:=X + xtg, Y:=Y + ytg) GetRGBColor lngColor:=lngReadColor, _ Rs:=Rs, Gs:=Gs, Bs:=Bs lngWriteColor = RGB(Abs(Rs), _ Abs(Gs), _ Abs(Bs)) SetPixel hDC:=.hDC, X:=X, Y:=Y, crColor:=lngWriteColor End If Next Pic.Refresh Next .DrawMode = intDrawMode .Refresh End With Exit Sub ErrorHandler: Exit Sub End Sub
Private Function radiusAF(x1!, y1!, x2!, y2!) As Single Dim A!, B! On Error Resume Next 'Radiuswert aus zwei Koordinatenpaaren ermitteln A! = Abs(x1! - x2!) B! = Abs(y1! - y2!) radiusAF = Sqr(A! * A! + B! * B!) End Function
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 Exit Sub ErrorHandler: Exit Sub End Sub