Option Explicit
Private Declare Function ExtFloodFill Lib "gdi32" ( _
ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, _
ByVal crColor As Long, ByVal wFillType As Long) As Long
Private Declare Function SetPixel Lib "gdi32" ( _
ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, _
ByVal crColor As Long) As Long
Public LastX!, LastY!
Public UnDoX!, UnDoY!
Dim Col&, Col2&
Dim Current%, DrFill As Integer
Private Sub Command1_Click(Index As Integer)
Current% = Index
If Index = 3 Or Index = 5 Then
shpArea.Visible = False
Else
shpArea.Visible = True
End If
Image1.MousePointer = 2
End Sub
Private Sub mnuOpen_Click()
Dim Datei$, fPath$
With Dialog1
.DialogTitle = "Datei öffnen"
'Dateieintrag löschen
.FileName = ""
'Suchmaske
.Filter = "Alle Bilddateien " & _
"|*.bmp;*.wmf;*.ico;*.jpg;*.jpe;*.gif;*.cur;" & _
" *.dib;*.jpe|Windows Bitmap" & _
" " & _
"(*.BMP)| *.bmp| Windows Metafile" & _
" " & _
"(*.WMF)| *.wmf| Windows Icons - Symbole" & _
" " & _
"(*.ICO)| *.ico|JPEG File Interchange" & _
" " & _
"(*.JPG)| *.jpg|JPEG WebFile" & _
" " & _
"(*.JPE)| *.jpe|CompuServe Gif-File" & _
" " & _
"(*.GIF)| *.gif| PC Paint Brush" & _
" " & _
"(*.PCX)| *.pcx| DIB-Bitmap" & _
" " & _
"(*.DIB)| *.dib| Alle Dateien" & _
" " & _
"(* . *)| *.*"
'Filterindex
.FilterIndex = 1
'Flags setzen: Explorer-Dialog mit langen Dateinamen
.Flags = cdlOFNCreatePrompt And cdlOFNPathMustExist _
And cdlOFNExplorer 'And cdlOFNLongFileNames
'Datei öffnen
.ShowOpen
Datei$ = .FileName
End With
'Ergebnis der Dateianwahl ausgeben
Picture1.Picture = LoadPicture(Datei$)
Image1.Picture = Picture1.Image
Image1.Refresh
fPath = DirName(Datei$)
If Right$(fPath, 1) <> "\" Then fPath = fPath + "\"
File1.Path = fPath
Text3.Text = fPath
End Sub
'Alles ScaleMode = 3, Pixel
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Dim tPosA As Long, tPosB As Long, i&
If Button = 1 Then
Picture1.ForeColor = Label1.BackColor
Col = Label1.BackColor
Col2 = vbGreen
ElseIf Button = 2 Then
Picture1.ForeColor = Label2.BackColor
Col = Label2.BackColor
Col2 = vbYellow
End If
shpArea.FillColor = Col
Picture1.AutoRedraw = True 'Wichtig
Select Case Current
Case 0
Picture1.DrawWidth = 1
'Zeichenkoordinaten werden als Anfangskoordinaten
'für die nächste Zeichenfunktion verwendet
LastX! = X
LastY! = Y
Case 1, 2
Picture1.DrawWidth = 5
LastX! = X
LastY! = Y
Picture1.FontTransparent = False
If Shift Then DrFill = 0 Else DrFill = 1
Case 3
'Füllen
Picture1.FontTransparent = False
Picture1.FillStyle = 0
Picture1.FillColor = Col
ExtFloodFill Picture1.hDc, X, Y, Picture1.Point(X, Y), 1
Picture1.FontTransparent = True
Picture1.FillStyle = 1
Case 4
'Spray
If Button = 1 Or Button = 2 Then
For i = 0 To 25
tPosA = Int(Rnd * 14 - 7)
tPosB = Int(Rnd * 14 - 7)
SetPixel Picture1.hDc, X + tPosA, Y + tPosB, Col
Next i
Picture1.Refresh
End If
Case 5
'Farbsonde
If Button = vbLeftButton Then
Label1.BackColor = Picture1.Point(X, Y)
ElseIf Button = vbRightButton Then
Label2.BackColor = Picture1.Point(X, Y)
End If
Current = 10
End Select
End Sub
Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Picture1_MouseDown Button, Shift, _
((X / 8) / Screen.TwipsPerPixelX) - 0.5, _
((Y / 8) / Screen.TwipsPerPixelY) - 0.5 'PicFrame.Border
Image1.Picture = Picture1.Image
Image1.Refresh
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Dim tPosA As Long, tPosB As Long, i&
If Button = 1 Or Button = 2 Then
Select Case Current%
Case 0
'Freihand
Picture1.Line (LastX!, LastY!)-(X, Y)
LastX! = X
LastY! = Y
Case 1
If DrFill = 1 Then
'Rechteck
'nicht gefüllt (transparent)
Picture1.FillStyle = 1
If Button = 1 Or Button = 2 Then
'invertiert zeichnen
Picture1.DrawMode = 6
If UnDoX! <> 0 And UnDoY! <> 0 Then
Picture1.Line (LastX!, LastY!)-(UnDoX!, UnDoY!), , B
End If
Picture1.Line (LastX!, LastY!)-(X, Y), , B
UnDoX! = X!
UnDoY! = Y!
End If
Else
'gefüllt
Picture1.FillStyle = 0
If Button = 1 Or Button = 2 Then
'invertiert zeichnen
Picture1.DrawMode = 6
If UnDoX! <> 0 And UnDoY! <> 0 Then
Picture1.Line (LastX!, LastY!)-(UnDoX!, UnDoY!), , B
End If
Picture1.Line (LastX!, LastY!)-(X, Y), , B
UnDoX! = X!
UnDoY! = Y!
End If
End If
Case 2
'Kreis
If DrFill = 1 Then
'nicht gefüllt (transparent)
Picture1.FillStyle = 1
'invertiert zeichnen
Picture1.DrawMode = 6
If Button = 1 Or Button = 2 Then
If UnDoX! <> 0 And UnDoY! <> 0 Then
Picture1.Circle (LastX!, LastY!), Radius(LastX!, _
LastY!, UnDoX!, UnDoY!)
End If
Picture1.Circle (LastX!, LastY!), _
Radius(LastX!, LastY!, X, Y)
UnDoX! = X!
UnDoY! = Y!
End If
Else
'gefüllt bzw. Muster
Picture1.FillStyle = 0
'invertiert zeichnen
If Button = 1 Or Button = 2 Then
Picture1.DrawMode = 6
If UnDoX! <> 0 And UnDoY! <> 0 Then
Picture1.Circle (LastX!, LastY!), _
Radius(LastX!, LastY!, UnDoX!, UnDoY!)
End If
Picture1.Circle (LastX!, LastY!), _
Radius(LastX!, LastY!, X, Y)
UnDoX! = X!
UnDoY! = Y!
End If
End If
Case 4
'Spray
If Button = 1 Or Button = 2 Then
For i = 0 To 25
tPosA = Int(Rnd * 14 - 7)
tPosB = Int(Rnd * 14 - 7)
SetPixel Picture1.hDc, X + tPosA, Y + tPosB, Col
Next i
Picture1.Refresh
End If
End Select
End If
End Sub
Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Dim X12%, Y12%
X12 = X / Screen.TwipsPerPixelX: Y12 = Y / Screen.TwipsPerPixelY
AdjustToPixel X12, Y12
shpArea.Width = 9: shpArea.Height = 9
shpArea.Left = X12: shpArea.Top = Y12
If Button = 1 Or Button = 2 Then
Picture1_MouseMove Button, Shift, _
((X / 8) / Screen.TwipsPerPixelX) - 0.5, _
((Y / 8) / Screen.TwipsPerPixelY) - 0.5
Image1.Picture = Picture1.Image 'Picture
Image1.Refresh
End If
Text1.Text = (X \ 8) \ Screen.TwipsPerPixelX
Text2.Text = (Y \ 8) \ Screen.TwipsPerPixelY
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Select Case Current%
Case 0
'Freihand
If Button = 1 Or Button = 2 Then
Picture1.PSet (X, Y), Col
End If
Case 1
'Quadrat
If DrFill = 1 Then
Picture1.FillStyle = 1
'Zeichenfarbe
Picture1.DrawMode = 13
If UnDoX! <> 0 And UnDoY! <> 0 Then
Picture1.Line (LastX!, LastY!)-(UnDoX!, UnDoY!), , B
End If
Picture1.Line (LastX!, LastY!)-(X, Y), , B
UnDoX! = 0
UnDoY! = 0
Else 'Gefüllt
Picture1.DrawMode = 13
If UnDoX! <> 0 And UnDoY! <> 0 Then
Picture1.Line (LastX!, LastY!)-(UnDoX!, UnDoY!), , B
End If
'Füllfarbe für Zeichenfunktionen
Picture1.FillColor = Col2
Picture1.FillStyle = 0
Picture1.Line (LastX!, LastY!)-(X, Y), , B
UnDoX! = 0
UnDoY! = 0
End If
Case 2
'Kreis
If DrFill = 1 Then
Picture1.FillStyle = 1
'Zeichenfarbe
Picture1.DrawMode = 13
If UnDoX! <> 0 And UnDoY! <> 0 Then
Picture1.Circle (LastX!, LastY!), _
Radius(LastX!, LastY!, UnDoX!, UnDoY!)
End If
Picture1.Circle (LastX!, LastY!), _
Radius(LastX!, LastY!, X, Y)
UnDoX! = 0
UnDoY! = 0
Else
'Zeichenfarbe
Picture1.DrawMode = 13
If UnDoX! <> 0 And UnDoY! <> 0 Then
Picture1.Circle (LastX!, LastY!), _
Radius(LastX!, LastY!, UnDoX!, UnDoY!)
End If
'Füllfarbe für Zeichenfunktionen
Picture1.FillColor = Col2
Picture1.FillStyle = 0
Picture1.Circle (LastX!, LastY!), _
Radius(LastX!, LastY!, UnDoX!, UnDoY!)
UnDoX! = 0
UnDoY! = 0
End If
End Select
Picture1.Picture = Picture1.Image 'Wichtig
Picture1.Refresh 'Wichtig
Picture1.AutoRedraw = False 'Wichtig
End Sub
Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Picture1_MouseUp Button, Shift, _
((X / 8) / Screen.TwipsPerPixelX) - 0.5, _
((Y / 8) / Screen.TwipsPerPixelY) - 0.5
Image1.Picture = Picture1.Image
Image1.Refresh
End Sub
Function Radius(X1!, Y1!, X2!, Y2!) As Single 'Radiuswert ermitteln
On Error Resume Next
Dim A!, B!
A! = Abs(X1! - X2!)
B! = Abs(Y1! - Y2!)
Radius = Sqr(A! * A! + B! * B!)
End Function
Private Sub Form_Load()
Current% = 10
Picture1.MousePointer = 1
shpArea.BackStyle = 1
shpArea.BorderStyle = 0
shpArea.DrawMode = 13
shpArea.FillStyle = 0
Form_Resize
Image1.Picture = Picture1.Image
Image1.Refresh
End Sub
Private Sub File1_Click()
Picture1.Picture = LoadPicture(File1.FileName)
Form_Resize
Image1.Picture = Picture1.Image
Image1.Refresh
End Sub
Private Sub Label1_Click()
Dim X As Integer
Dialog1.CancelError = True
Dialog1.Flags = cdlCCRGBInit Or cdlCCFullOpen 'Open color dialog
Dialog1.Color = Label1.BackColor
Dialog1.ShowColor
Label1.BackColor = Dialog1.Color
End Sub
Private Sub Label2_Click()
Dim X As Integer
Dialog1.CancelError = True
Dialog1.Flags = cdlCCRGBInit Or cdlCCFullOpen
Dialog1.Color = Label2.BackColor
Dialog1.ShowColor
Label2.BackColor = Dialog1.Color
End Sub
Private Sub Form_Resize()
Image1.Width = Picture1.Width * 8
Image1.Height = Picture1.Height * 8
End Sub
Function DirName(sPath As String) As String 'Extract DirName (Pfad)
Dim iCount As Integer
'If Punkt 4.Stelle von Rechts Then
If (Left$(LCase(Right(sPath$, 4)), 1) = ".") Then
For iCount = Len(sPath) To 1 Step -1
If Mid$(sPath, iCount, 1) = "\" Then Exit For
Next
DirName = Left$(sPath, iCount - 1)
End If
End Function
Public Sub AdjustToPixel(A%, B%)
A = (A \ 8) * 8 'Zoom 8
B = (B \ 8) * 8
End Sub
Private Sub Timer1_Timer()
Text4.Text = Current
End Sub
|
Quell-Code