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

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