Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
SelectByColorRange
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 09.03.2010 09:48:37 |
Type SelectionX
goR As Integer 'goRight
goL As Integer 'goLeft
atL As Integer '@Line
End Type
Type SelectionY
goD As Integer 'goDown
goU As Integer 'goUp
atL As Integer '@Line
End Type
Type SelectionP
SizeX As Integer 'Breite des Buffers
SizeY As Integer 'Hoehe des Buffers
LRInf As Integer 'Menge der Horizontal Informationen
UDInf As Integer 'Menge der Vertikal Informationen
LR As SelectionX Ptr
UD As SelectionY Ptr
End Type
Declare Function SelectByColorRange (Byref Buffer As Any Ptr, _
Byval SelectColor As Integer, _
Byval Invert As Integer=0, _
Byval Percent As Integer=0) _
As SelectionP Ptr
'------------------------------------------------------------------------------'
Declare Sub ExpandSelection (Byref Selection As SelectionP Ptr, _
Byval Expand As Integer=1)
'------------------------------------------------------------------------------'
Declare Sub ContractSelection (Byref Selection As SelectionP Ptr, _
Byval Contract As Integer=1)
'------------------------------------------------------------------------------'
Declare Sub InvertSelection (Byref Selection As SelectionP Ptr)
'------------------------------------------------------------------------------'
Declare Sub DelSelection (Byref Selection As SelectionP Ptr)
Function SelectByColorRange (Byref Buffer As Any Ptr, Byval SelectColor As Integer, _
Byval Invert As Integer=0, _
Byval Percent As Integer=0) As SelectionP Ptr
Dim GetInteger As Integer Ptr
Dim BufferVersion As Integer
Dim BufferSizeX As Integer
Dim BufferSizeY As Integer
If Buffer>0 And Buffer<>Screenptr Then
'Breite, Hoehe und Version des ImageBuffers ermitteln...
GetInteger = Buffer
BufferVersion = GetInteger[0]
If BufferVersion <> &h7 Then Return 0
BufferSizeX = GetInteger[2]
BufferSizeY = GetInteger[3]
Elseif Buffer=0 Or Buffer=Screenptr Then
'Breite, Hoehe und Farbtiefe vom Screen ermitteln
Screeninfo BufferSizeX, BufferSizeY, BufferVersion
'Wenn Farbtiefe < "kleiner als" 24bit, Funktion verlassen...
If Bufferversion<24 Then Return 0
Buffer=0
End If
Dim P As Single = (1.275*Percent)
If P = 0 Then P=0.001
Dim red As Ubyte = (SelectColor And &h00FF0000) Shr 16
Dim green As Ubyte = (SelectColor And &h0000FF00) Shr 8
Dim blue As Ubyte = (SelectColor And &h000000FF)
Dim Selection As SelectionP Ptr=Allocate(Len(SelectionP))
Dim Temp As Any Ptr
Dim RC As Integer
Dim RCRed As Ubyte
Dim RCGreen As Ubyte
Dim RCBlue As Ubyte
Dim X As Integer
Dim Y As Integer
/'
"---------------------------------------"
'/
Dim LRInf As Integer=0 'Menge der 'Horizontal' Information
Dim goR As Integer=-1 'Go Right (Linke Grenze) -> Start
Dim goL As Integer=-1 'Go Left (Rechte Grenze) -> Ende
Dim atY As Integer=-1 'In Reihe Y
'-=----------------------=-'
/'
"---------------------------------------"
'/
Dim UDInf As Integer=0 'Menge der 'Vertikal' Information
Dim goD As Integer=-1 'Go Down (Obere Grenze) -> Start
Dim goU As Integer=-1 'Go Up (Untere Grenze) -> Ende
Dim atX As Integer=-1 'in Reihe X
'-=----------------------=-'
/'
"LRInf - Menge der Horizontalen Informationen"
"UDInf - Menge der Vertikalen Informationen"
'/
Selection->SizeX=BufferSizeX
Selection->SizeY=BufferSizeY
Selection->LR=Allocate(Len(SelectionX))
Selection->UD=Allocate(Len(SelectionY))
/'
"-----------------------------------------------------"
'/
/'
"--------------"
' XR und XL '
"--------------"
'/
Y=0:LRInf=0
While Y<BufferSizeY 'solange wiederholen bis Vertikales Ende erreicht
'bei jeder neuen Reihe zaehler zuruecksetzen
X=0 : goR=-1 : goL=-1 : atY=-1
While X<BufferSizeX 'solange wiederholen bis horizontales Ende erreicht
RC=Point (X,Y,Buffer) 'Farbe auslesen
RCRed = (RC And &h00FF0000) Shr 16
RCGreen = (RC And &h0000FF00) Shr 8
RCBlue = (RC And &h000000FF)
If (RCRed > (red - P) And RCRed < (red + P)) And _
(RCGreen > (green - P) And RCGreen < (green + P)) And _
(RCBlue > (blue - P) And RCBlue < (blue + P)) Then
RC=Iif (Invert=0,1,0)
Else
RC=Iif (Invert=0,0,1)
End If
'Wenn ausgelesene Farbe 'SelectColor' entspricht...
'und 'Go Right->Start' nicht gesetzt, Start setzen
'und hoehe speichern
If RC=1 And goR=-1 Then
Selection->LR[LRInf].goR=X
Selection->LR[LRInf].atL=Y
goR=1
End If
'Wenn ausgelesene Farbe NICHT 'SelectColor' entspricht...
'oder das ende der Reihe erreicht und 'Start' bereits gesetzt,
''Ende' und Reihe speichern
If (RC=0 And goR<>-1) Or (X=BufferSizeX-1 And goR<>-1) Then
If X=BufferSizeX-1 Then
Selection->LR[LRInf].goL=X
Else
Selection->LR[LRInf].goL=X-1
End If
goL=1
End If
'Wenn 'Ende' gesetzt wuerde
'Informationszaehler raufsetzen und 'Start'-und-'Ende' zurueck setzen.
If goL<>-1 Then
goR=-1 : goL=-1
LRInf+=1
Temp=Reallocate(Selection->LR,(LRInf+1)*Len(SelectionX))
Selection->LR=Temp
End If
X=X+1 'solange hochzaehlen bis das Ende der Reihe erreicht...
Wend
Y=Y+1 'Naechste Reihe' 'solange hochzaehlen bis das Ende erreicht...
Wend
'-=------------------=-'
/'
"-------------"
' YU und YD
"-------------"
'/
X=0:UDInf=0
While X<BufferSizeX 'solange wiederholen bis Horizontales Ende erreicht
'bei jeder neuen Reihe zaehler zuruecksetzen
Y=0 : goD=-1 : goU=-1
While Y<BufferSizeY 'solange wiederholen bis Vertikales Ende erreicht
RC=Point (X,Y,Buffer) 'Farbe auslesen
'Farbe in R G B werte splitten
RCRed = (RC And &h00FF0000) Shr 16
RCGreen = (RC And &h0000FF00) Shr 8
RCBlue = (RC And &h000000FF)
'Abfragen ob Werte innerhalb der Toleranz sind...
If (RCRed > (red - P) And RCRed < (red + P)) And _
(RCGreen > (green - P) And RCGreen < (green + P)) And _
(RCBlue > (blue - P) And RCBlue < (blue + P)) Then
RC=Iif (Invert=0,1,0)
Else
RC=Iif (Invert=0,0,1)
End If
'Wenn ausgelesene Farbe 'SelectColor' entspricht...
'und 'Go Down->Start' nicht gesetzt, 'Start' setzen
'und vertikale position speichern
If RC=1 And goD=-1 Then
Selection->UD[UDInf].goD=Y
Selection->UD[UDInf].atL=X
goD=1
End If
'Wenn ausgelesene Farbe NICHT 'SelectColor' entspricht...
'oder das ende der Reihe erreicht und 'Start' bereits gesetzt,
''Ende' speichern
If (RC=0 And goD=1) Or (Y=BufferSizeY-1 And goD=1) Then
If Y=BufferSizeY-1 Then
Selection->UD[UDInf].goU=Y
Else
Selection->UD[UDInf].goU=Y-1
End If
goU=1
End If
'Wenn 'Ende' gesetzt wuerde
'Informationszaehler raufsetzen und 'Start'-und-'Ende' zurueck setzen.
If goU=1 Then
goD=-1 : goU=-1
UDInf+=1
Temp=Reallocate (Selection->UD,(UDInf+1)*Len(SelectionY))
Selection->UD=Temp
End If
Y=Y+1 'solange hochzaehlen bis das Ende der Reihe erreicht...
Wend
X=X+1 'Naechste Reihe' 'solange hochzaehlen bis das Ende erreicht...
Wend
'-=------------------=-'
Selection->LRInf=LRInf
Selection->UDInf=UDInf
Return Selection
End Function
Sub ExpandSelection (Byref Selection As Any Ptr, Byval Expand As Integer=1)
If Selection=0 Then Exit Sub
Dim Temp as SelectionP Ptr = Selection
If Temp->LRInf=0 Or Temp->UDInf=0 Then Exit Sub
If Expand < 1 Then Exit Sub
Dim ReSelection As Any Ptr
Dim NewSelect As SelectionP Ptr
For E As Integer=1 To Expand
ReSelection=IMGCreate (Temp->SizeX,Temp->SizeY,0)
For X As Integer=0 To Temp->LRInf-1
Line ReSelection,(Temp->LR[X].goR,Temp->LR[X].atL)-(Temp->LR[X].goL,Temp->LR[X].atL),&hFFFFFFFF
Next X
For X As Integer=0 To Temp->LRInf-1
If Temp->LR[X].goR-1 > -1 Then
Pset ReSelection,(Temp->LR[X].goR-1, Temp->LR[X].atL),&hFFFFFFFF
End If
If Temp->LR[X].goL+1 < Temp->SizeX Then
Pset ReSelection,(Temp->LR[X].goL+1, Temp->LR[X].atL),&hFFFFFFFF
End If
Next X
For Y As Integer=0 To Temp->UDInf-1
If Temp->UD[Y].goD-1 > -1 Then
Pset ReSelection,(Temp->UD[Y].atL,Temp->UD[Y].goD-1),&hFFFFFFFF
End If
If Temp->UD[Y].goU+1 < Temp->SizeY Then
Pset ReSelection,(Temp->UD[Y].atL,Temp->UD[Y].goU+1),&hFFFFFFFF
End If
Next Y
NewSelect=SelectByColorRange (ReSelection,&hFFFFFFFF)
Deallocate (Temp->LR)
Deallocate (Temp->UD)
Deallocate (Temp)
Temp=NewSelect
Deallocate (ReSelection)
Next E
Selection=Temp
End Sub
Sub ContractSelection (Byref Selection As Any Ptr, Byval Contract As Integer=1)
If Selection = 0 Then Exit Sub
Dim Temp as SelectionP Ptr=Selection
If Temp->LRInf=0 Or Temp->UDInf=0 Then Exit Sub
If Contract < 1 Then Exit Sub
Dim ReSelection As Any Ptr
Dim NewSelect As SelectionP Ptr
For C As Integer=0 To Contract-1
ReSelection=IMGCreate(Temp->SizeX,Temp->SizeY,0)
For X As Integer=0 To Temp->LRInf-1
Line ReSelection,(Temp->LR[X].goR,Temp->LR[X].atL)-(Temp->LR[X].goL,Temp->LR[X].atL),&hFFFFFFFF
Next X
For X As Integer=0 To Temp->LRInf-1
Pset ReSelection,(Temp->LR[X].goR,Temp->LR[X].atL),0
Pset ReSelection,(Temp->LR[X].goL,Temp->LR[X].atL),0
Next X
For Y As Integer=0 To Temp->UDInf-1
Pset ReSelection,(Temp->UD[Y].atL,Temp->UD[Y].goD),0
Pset ReSelection,(Temp->UD[Y].atL,Temp->UD[Y].goU),0
Next Y
NewSelect=SelectByColorRange (ReSelection,&hFFFFFFFF)
Deallocate (Temp->LR)
Deallocate (Temp->UD)
Deallocate (Temp)
Temp=NewSelect
Deallocate (ReSelection)
Next C
Selection=Temp
End Sub
Sub InvertSelection (Byref Selection As SelectionP Ptr)
If Selection=0 Then Exit Sub
Dim Temp as SelectionP Ptr = Selection
If Temp->LRInf=0 Or Temp->UDInf=0 Then Exit Sub
Dim ReSelection As Any Ptr
Dim NewSelect As SelectionP Ptr
ReSelection=IMGCreate(Temp->SizeX,Temp->SizeY,0)
For l As Integer=0 To Temp->LRInf-1
Line ReSelection,(Temp->LR[l].goR,Temp->LR[l].atL)-(Temp->LR[l].goL,Temp->LR[l].atL),&hFFFFFFFF
Next l
NewSelect = SelectByColorRange (ReSelection,0)
Deallocate (Temp->LR)
Deallocate (Temp->UD)
Deallocate (Temp)
Deallocate (ReSelection)
Selection = NewSelect
End Sub
Sub DelSelection (Byref Selection As Any Ptr)
If Selection=0 Then Exit Sub
Dim Temp as SelectionP Ptr=Selection
Deallocate (Temp->LR)
Deallocate (Temp->UD)
Deallocate (Temp)
Selection=0
End Sub
/'
"-----------------------------------------------------------------------"
'/