Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
PAINT Programm
| Uploader: |  XOR |
| Datum/Zeit: | 27.03.2011 22:54:39 |
'' Ein kleines Malprogram
'' F1 -> Quads zeichnen
'' F2 -> lines zeichnen
'' F3 -> circles zeichnen
'' F4 -> free hand line
'' F5 -> full quad
'' F6 -> full circle
'' F7 -> einen bereich mit einer farbe fuellen
'' F8 -> color auswahl
'' n -> neu
'' STRL + Z -> rueckgaengig
'' ESC -> beenden
#Define FALSE &H00 '' FALSE als 0 setzen
#Define TRUE Not FALSE '' TRUE als das gegenteil von
'' von FALSE setzen
Dim shared As Integer Weite = 800 '' Fenster Weite setzen
Dim Shared As Integer Hohe = 600 '' Fenster Hohe setzen
Dim As Integer FullScreen = FALSE '' Fullscreen setzen
Dim As Integer BACK_R = 255 '' Start Farbe fuer Background
Dim As Integer BACK_G = 255
Dim As Integer BACK_B = 255
Dim As UByte FRONT_R = 0 '' Start Farbe fuer Mal-Farbe
Dim As UByte FRONT_G = 0
Dim As UByte FRONT_B = 0
Dim As Integer STEPS = 10 '' Wie oft kann man etwas
'' rueckgaengig machen kann
Dim As Integer FillColorAbweichung = 0 '' Max Color Abweichung bei der
'' Function FILL
#Define DRAW_QUADS &H01
#Define DRAW_LINES &H02
#Define DRAW_CIRCLE &H03
#Define DRAW_POINT &H04
#Define DRAW_QUADS_FULL &H05
#Define DRAW_CIRCLE_FULL &H06
#Define DRAW_FILL &H07
Dim As Any Ptr Vorschau, _ '' Bild, in das das gerade
_ '' bearbeitete obj. gemalt wird
ScreenP, _ '' Screen Bild
LASTS(0 To STEPS) '' Bilder um zum rueckgaengig machen
Dim Flag As UInteger
Dim As Integer X,Y,B,XA,YA,BA
Dim As Integer SX,SY,UPDATE
Declare Function UPDATE_COLOR_CIRCLE _ '' Function um zur color
( ByRef As UByte, _ '' auswahl ROT
ByRef As UByte, _ '' GRUEN
ByRef As UByte )_ '' BLAU
As Integer '' FERTIG
Declare Function KEYPRESSED _ '' Function un einen tastendruck
( ByVal As UInteger )_ '' zu erkennen
As Integer
Declare Sub FILL _ '' Function um eine Flache
_ '' mit einer Farbe zu fuellen
( ByVal As Any Ptr, _ '' Bild
ByVal As Any Ptr, _ '' Screen
ByVal As Integer, _ '' Position X
ByVal As Integer, _ '' Position Y
ByVal As UByte, _ '' Fill Color R
ByVal As UByte, _ '' Fill Color G
ByVal As UByte, _ '' Fill Color B
ByVal As UByte ) '' Abweichung
ScreenRes Weite, Hohe, 32, ,_ '' Window erstellen
IIf(FullScreen,1,0)
WindowTitle "PAINT" '' Windowtitle paint
Line (0,0)-(Weite,Hohe),_ '' Screen mit Backgroundcolor
RGB(BACK_R,BACK_G,BACK_B),bf '' bemalen
Vorschau = ImageCreate(Weite,Hohe,_ '' Images erstellen
RGB(255,0,255),32)
LASTS(0) = ImageCreate(Weite,Hohe,_
RGB(BACK_R,BACK_G,BACK_B),32)
ScreenP = ImageCreate(Weite,Hohe,_
RGB(BACK_R,BACK_G,BACK_B),32)
For i As Integer = 1 To STEPS
LASTS(i) = ImageCreate(Weite,Hohe,_
RGBA(255,0,255,255),32)
Next
Do
Sleep 1, 1 '' um den Prozessor nicht zu stark zu belasten
If KEYPRESSED(59) Then '' wenn taste "F1" getrueckt wird
If Flag = DRAW_QUADS Then '' wenn gerade Quads aktivirt sind
Flag = FALSE '' dann werden sie ausgeschaltet
Else
Flag = DRAW_QUADS '' ansonnsten an
EndIf
EndIf
If KEYPRESSED(60) Then '' das gleiche fuer "F2" und Lines
If Flag = DRAW_LINES Then
Flag = FALSE
Else
Flag = DRAW_LINES
EndIf
EndIf
If KEYPRESSED(61) Then '' "F3" und Circles
If Flag = DRAW_CIRCLE Then
Flag = FALSE
Else
Flag = DRAW_CIRCLE
EndIf
EndIf
If KEYPRESSED(62) Then '' "F4" und Hand Lines
If Flag = DRAW_POINT Then
Flag = FALSE
Else
Flag = DRAW_POINT
EndIf
EndIf
If KEYPRESSED(63) Then '' "F5" und Full Quads
If Flag = DRAW_QUADS_FULL Then
Flag = FALSE
Else
Flag = DRAW_QUADS_FULL
EndIf
EndIf
If KEYPRESSED(64) Then '' "F6" und Full Circles
If Flag = DRAW_CIRCLE_FULL Then
Flag = FALSE
Else
Flag = DRAW_CIRCLE_FULL
EndIf
EndIf
If KEYPRESSED(65) Then '' "F7" unf Fill
If Flag = DRAW_FILL Then
Flag = FALSE
Else
Flag = DRAW_FILL
EndIf
EndIf
If KEYPRESSED(66) Then '' wenn "F8" gedruecktwird
Do
Sleep 1, 1 '' Fasbe aendern
Loop Until MultiKey(1) Or InKey = Chr(255)+"k" _
Or UPDATE_COLOR_CIRCLE(FRONT_R,FRONT_G,FRONT_B)
Put (0,0),ScreenP,PSet '' Und screen neu zeichnen
Put (0,0),Vorschau,Trans
EndIf
If KEYPRESSED(49) Then '' wenn "n" gedrueckt wird alles zuruecksetzen
Line LASTS(0),(0,0)-(Weite,Hohe),RGB(BACK_R,BACK_G,BACK_B),bf
Line Vorschau,(0,0)-(Weite,Hohe),RGB(255,0,255),bf
Line ScreenP,(0,0)-(Weite,Hohe),RGB(BACK_R,BACK_G,BACK_B),bf
For i As Integer = 1 To STEPS
LASTS(i) = ImageCreate(Weite,Hohe,RGB(255,0,255),32)
Next
Put(0,0),LASTS(0),PSet
Flag = 0
EndIf
If KEYPRESSED(44) And MultiKey(29) Then'' mit CTRL + "z" zureuck
If STEPS > 0 then
Line Vorschau,(0,0)-(Weite,Hohe),RGB(255,0,255),bf
For i As Integer = STEPS To 2 Step -1
Put LASTS(i),(0,0),LASTS(i-1),PSet
Next
Line LASTS(1),(0,0)-(Weite,Hohe),RGB(255,0,255),bf
Put ScreenP,(0,0),LASTS(0),PSet
For i As Integer = 0 To STEPS
Put ScreenP,(0,0),LASTS(i),Trans
Next
Put (0,0),ScreenP,PSet
EndIf
EndIf
XA = X
YA = Y
BA = B
GetMouse X,Y,,B '' MausPosition
If B = 1 And BA = 0 Then '' Wenn Maus von nichtgedrueckt auf gedrueckt springt
SX = X '' startposition festlegen
SY = Y
EndIf
If xa = -1 Then xa = x
If ya = -1 Then ya = y
If B = 1 And x <> -1 And y <> -1 Then '' Wenn maus gedruekt wurde und maus im fenster ist
UPDATE = FALSE
Select Case Flag '' Flag auswaehlen
Case DRAW_QUADS
If x <> xa And y <> ya then
Line Vorschau,(0,0)-(Weite,Hohe),RGB(255,0,255),bf
Line Vorschau,(SX,SY)-(X,Y),RGB(FRONT_R,FRONT_G,FRONT_B),b
UPDATE = TRUE
EndIf
Case DRAW_LINES
If x <> xa And y <> ya Then
Line Vorschau,(0,0)-(Weite,Hohe),RGB(255,0,255),bf
Line Vorschau,(SX,SY)-(X,Y),RGB(FRONT_R,FRONT_G,FRONT_B)
UPDATE = TRUE
EndIf
Case DRAW_CIRCLE
If x <> xa And y <> ya Then
Line Vorschau,(0,0)-(Weite,Hohe),RGB(255,0,255),bf
Circle Vorschau,(SX,SY),((SX-X)^2+(SY-Y)^2)^0.5,RGB(FRONT_R,FRONT_G,FRONT_B) ''<- um den richtigen radius zu haben, wird der Pytagoras benutzt
UPDATE = TRUE
EndIf
Case DRAW_POINT
Line Vorschau,(XA,YA)-(X,Y),RGB(FRONT_R,FRONT_G,FRONT_B)
Line (XA,YA)-(X,Y),RGB(FRONT_R,FRONT_G,FRONT_B)
Case DRAW_QUADS_FULL
If x <> xa And y <> ya Then
Line Vorschau,(0,0)-(Weite,Hohe),RGB(255,0,255),bf
Line Vorschau,(SX,SY)-(X,Y),RGB(FRONT_R,FRONT_G,FRONT_B),bf
UPDATE = TRUE
EndIf
Case DRAW_CIRCLE_FULL
If x <> xa And y <> ya Then
Line Vorschau,(0,0)-(Weite,Hohe),RGB(255,0,255),bf
Circle Vorschau,(SX,SY),((SX-X)^2+(SY-Y)^2)^0.5,RGB(FRONT_R,FRONT_G,FRONT_B),,,,f
UPDATE = TRUE
EndIf
Case DRAW_FILL
Line Vorschau,(0,0)-(Weite,Hohe),RGB(255,0,255),bf
FILL ( Vorschau , ScreenP , x , y , FRONT_R , FRONT_G , FRONT_B , FillColorAbweichung)
UPDATE = TRUE
End Select
If UPDATE Then '' und screen eventuel neu zeichnen
Put (0,0),ScreenP,PSet
Put (0,0),Vorschau,Trans
EndIf
EndIf
If B = 0 And BA = 1 Then '' wenn maustaste losgelassen wird
Put LASTS(0),(0,0),LASTS(1),Trans '' bilder verschieben und screen neu zeichnen
Put ScreenP,(0,0),LASTS(0),PSet
For i As Integer = 1 To STEPS - 1
Put LASTS(i),(0,0),LASTS(i+1),PSet
Put ScreenP,(0,0),LASTS(i),Trans
Next
Put LASTS(STEPS),(0,0),Vorschau,PSet
Put ScreenP,(0,0),LASTS(STEPS),Trans
Put (0,0),ScreenP,PSet
Line Vorschau,(0,0)-(Weite,Hohe),RGB(255,0,255),bf
EndIf
Loop Until MultiKey(1) Or InKey = Chr(255)+"k"'' beenden mit ESC oder X-Button
ImageDestroy(Vorschau)
ImageDestroy(ScreenP)
For i As Integer = 0 To STEPS
ImageDestroy(LASTS(i))
Next
End
Sub DRAW_COLOR_CIRCLE ( ByVal light As UByte ,ByVal colo As UInteger )
Dim col As UInteger
Dim ent As Integer
Dim rad As Integer
Dim As UByte rr,gg,bb
For i As Integer = 0 To 255
For j As Integer = 0 To 255
ent = ((i-127)^2+(j-127)^2)^0.5
rad = ATan2(i-127,j-127)/3.141*180
If rad > -120 And rad < 120 Then
rr = 255-Abs(rad)/120*255
Else
rr = 0
EndIf
If rad+120 < 120 Or rad+120 > 240 Then
If rad+120 > 240 Then
gg = Abs(rad+120)/120*255
Else
gg = 255-Abs(rad+120)/120*255
EndIf
Else
gg = 0
EndIf
If rad-120 > -120 Or rad-120 < -240 Then
If rad-120 < -240 Then
bb = Abs(rad-120)/120*255
Else
bb = 255-Abs(rad-120)/120*255
EndIf
Else
bb = 0
EndIf
If ent*2 < 256 Then
col = RGB(light-ent*2*rr/255/255*light,light-ent*2*gg/255/255*light,light-ent*2*bb/255/255*light)
Line (i,j)-(i,j),col
EndIf
Next
Next
For j As Integer = 0 To 255
Line (256,j)-(300,j),RGB(j,j,j)
Next
Line (0,256)-(256,300),colo,bf
End Sub
Function UPDATE_COLOR_CIRCLE ( ByRef r As UByte, ByRef g As UByte, ByRef b As UByte ) As Integer
Static OOn As Integer
Static light As UByte
Dim As Integer x,y,but,xa,ya
Dim col As UInteger
Dim ent As Integer
Dim rad As Integer
Static As UByte rr,gg,bb
If OOn = 0 Then
light = 255
DRAW_COLOR_CIRCLE(light,RGB(r,g,b))
OOn = 1
ent = ((x-127)^2+(y-127)^2)^0.5
EndIf
xa = x
ya = y
GetMouse x,y,,but
If x<>xa Or Y<>Ya Then
Line (0,256)-(256,300),RGB(r,g,b),bf
ent = ((x-127)^2+(y-127)^2)^0.5
If ent * 2 < 256 Then
rad = ATan2(x-127,y-127)/3.141*180
If rad > -120 And rad < 120 Then
rr = 255-Abs(rad)/120*255
Else
rr = 0
EndIf
If rad+120 < 120 Or rad+120 > 240 Then
If rad+120 > 240 Then
gg = Abs(rad+120)/120*255
Else
gg = 255-Abs(rad+120)/120*255
EndIf
Else
gg = 0
EndIf
If rad-120 > -120 Or rad-120 < -240 Then
If rad-120 < -240 Then
bb = Abs(rad-120)/120*255
Else
bb = 255-Abs(rad-120)/120*255
EndIf
Else
bb = 0
EndIf
r = light-ent*2*rr/255/255*light
g = light-ent*2*gg/255/255*light
b = light-ent*2*bb/255/255*light
EndIf
EndIf
If but <> 0 Then
If x < 300 And x > 256 And y < 256 Then
light = y
DRAW_COLOR_CIRCLE(light,RGB(r,g,b))
EndIf
If ent * 2 < 256 Then
Do
Sleep 1,1
GetMouse x,y,,but
Loop Until but = 0
OOn = 0
Return TRUE
EndIf
EndIf
Return FALSE
End Function
Function KEYPRESSED ( ByVal num As UInteger ) As Integer
Static ke(1 To 256) As Byte
If MultiKey(num) And Not(ke(num)) Then
ke(num) = TRUE
Return TRUE
EndIf
If Not(MultiKey(num)) And ke(num) Then
ke(num) = FALSE
EndIf
Return FALSE
End Function
Function ColAbw ( ByVal col1 As UInteger , ByVal col2 As UInteger , ByVal ab As UByte ) As Integer
If Abs(LoByte(HiWord(col1))- LoByte(HiWord(col2)))<=AB Then
If Abs(HiByte(LoWord(col1))- HiByte(LoWord(col2)))<=AB Then
If Abs(LoByte(LoWord(col1))- LoByte(LoWord(col2)))<=AB Then
Return TRUE
EndIf
EndIf
EndIf
Return FALSE
End Function
Sub FILL ( ByVal n As Any Ptr, ByVal b As Any Ptr, ByVal x As Integer, ByVal y As Integer, ByVal rr As UByte, ByVal gg As UByte, ByVal bb As UByte, ByVal a As UByte )
Dim col As UInteger = Point(x,y,b)
Line n,(x,y)-(x,y),RGB(rr,gg,bb)
Dim Num As Integer = 1
Dim Posi As Byte Ptr
Posi = Allocate(Weite*Hohe)
Line n,(x,y)-(x,y),RGB(rr,gg,bb)
Do
If ColAbw(Point(x+1,y,b), col, a) And Point(x+1,y,n) = RGB(255,0,255) And x < Weite-1 Then
num += 1
x += 1
Posi[num-1] = 0
Line n,(x,y)-(x,y),RGB(rr,gg,bb)
Line (x,y)-(x,y),RGB(rr,gg,bb)
ElseIf ColAbw(Point(x,y+1,b), col, a) And Point(x,y+1,n) = RGB(255,0,255) And y < Hohe-1 Then
num += 1
y += 1
Posi[num-1] = 1
Line n,(x,y)-(x,y),RGB(rr,gg,bb)
Line (x,y)-(x,y),RGB(rr,gg,bb)
ElseIf ColAbw(Point(x-1,y,b), col, a) And Point(x-1,y,n) = RGB(255,0,255) And x > 0 Then
num += 1
x -= 1
Posi[num-1] = 2
Line n,(x,y)-(x,y),RGB(rr,gg,bb)
Line (x,y)-(x,y),RGB(rr,gg,bb)
ElseIf ColAbw(Point(x,y-1,b), col, a) And Point(x,y-1,n) = RGB(255,0,255) And y > 0 Then
num += 1
y -= 1
Posi[num-1] = 3
Line n,(x,y)-(x,y),RGB(rr,gg,bb)
Line (x,y)-(x,y),RGB(rr,gg,bb)
Else
num -= 1
If num < 0 Then Exit Do
Select Case Posi[num]
Case 0
x -= 1
Case 1
y -= 1
Case 2
x += 1
Case 3
y += 1
End Select
EndIf
Loop
DeAllocate(Posi)
End Sub