Keskustelu: Koodit: VB6: Ääriviivat

petrinm [29.07.2005 12:01:02]

Koodi piirtää yksin kertaisesti kuvan (Itse pirretty tai valokuva) ääriviivat. Toiminta yksin kertaisesti: Ohjelma käy jokaisen pikselin yksi kerrallaan läpi ja katsoo käytävän pikselin ja sen viereisen pikselin värieron RGB muodossa. Jos värien ero on riittävän suuri(koodin alussa määritetään eron minimi raja) pikseli piirretään mustalla.

Tarvittavat objektit:
2 Pictureboksia (Picture1 ja Picture2)
1 Command buttoni (Command1)

Laita ykkös picture boksiin kuva( ja kakkos picture boksin AutoRedraw ominaisuus todeksi.) Pictureboksien scale moodit pikseliksi.

HUOM:koodi on todella hidas, koska se käyttää Visual Basicin peruspiirto ominaisuuksia jotka ovat hitaita.
HUOM2:Sopiva värien minimi ero riippuu täysin kuvasta!

Formiin

Private Type vaarin
    Red As Integer
    Green  As Integer
    Blue As Integer
End Type
Dim Vari As vaarin
Dim Vari2 As vaarin
Dim kk As Long
Dim kk2 As Long

Private Function Varin(vaari As Long) As vaarin
   'Functio joka pilkkoo värikoodin RGB arvoiksi
   Dim r As Integer, g As Integer, b As Integer
   r = vaari Mod 256
   g = (vaari \ 256) Mod 256
   b = vaari \ 65536

    Varin.Blue = b
    Varin.Green = g
    Varin.Red = r
    DoEvents
End Function

Private Sub Command1_Click()
ero = 10 'Haluttu minimi ero värien välillä
Picture2.Width = Picture1.Width ' Muutetaaan laatikot samankokoisiksi
Picture2.Height = Picture1.Height

For x = 0 To Picture1.Width
For y = 0 To Picture1.Height
    kk = Picture1.Point(x, y) 'otetaan väri selaus kohdasta
    kk2 = Picture1.Point(x, y + 1) 'otetaan väri viereisestä kohdasta
    Vari = Varin(kk) ' laitetaan taulukkoon värien RGB arvot
    Vari2 = Varin(kk2)
    'Tarkistetaan löytyykö päällekkäisistä pikseleista väri eroa
    If Vari.Red <> Vari2.Red And Vari.Green <> Vari2.Green And Vari.Blue <> Vari2.Blue Then
        'Jos väri on sama niin hypätään kohdan yli
        If Abs(Vari.Red - Vari2.Red) > ero Or Abs(Vari.Green - Vari2.Green) > ero Or Abs(Vari.Blue - Vari2.Blue) > ero Then
            'Jos värien ero on riittävän suuri ne piirretään
            Picture2.PSet (x, y), RGB(0, 0, 0) 'Piirretään mustalla raja kohta
        End If
    End If
    DoEvents
    kk = Picture1.Point(x, y) 'otetaan väri selaus kohdasta
    kk2 = Picture1.Point(x + 1, y) 'otetaan väri viereisestä kohdasta
    Vari = Varin(kk) ' laitetaan taulukkoon värien RGB arvot
    Vari2 = Varin(kk2)
    If Vari.Red <> Vari2.Red And Vari.Green <> Vari2.Green And Vari.Blue <> Vari2.Blue Then
        'Jos väri on sama niin hypätään kohdan yli
        If Abs(Vari.Red - Vari2.Red) > ero Or Abs(Vari.Green - Vari2.Green) > ero Or Abs(Vari.Blue - Vari2.Blue) > ero Then
            'Jos värien ero on riittävän suuri ne piirretään
            Picture2.PSet (x, y), RGB(0, 0, 0) 'Piirretään mustalla raja kohta
        End If
    End If
    DoEvents
Next y
DoEvents
Next x

End Sub

Private Sub Form_Unload(Cancel As Integer)
End 'Lopetetaan ohjelma vaikka piirto olisi kesken
End Sub

jrantala [31.07.2005 16:33:20]

Huhhuh, että osaakin olla hidas. :)

tuomas [31.07.2005 23:33:29]

Oli kyllä rikollisen hidas, vaikka vaihdoin psettien tilalle setpixel apin.

Gaxx [01.08.2005 00:09:56]

Hieno idea! Kätevä algoritmi, vaikkakin on kyllä kieltämättä tuhottoman hidas.

Edit: Tässä "hieman" optimointu versio. Huonona puolena on, että värien minimiero on hankalampi määrittää. Skaala on todella suuri!

Option Explicit

Dim kk As Long
Dim kk2 As Long
Dim ero As Long
Dim x As Integer, y As Integer

Private Sub Command1_Click()
    ero = 600000 'Haluttu minimi ero värien välillä
    Picture2.Width = Picture1.Width ' Muutetaaan laatikot samankokoisiksi
    Picture2.Height = Picture1.Height

    For x = 0 To Picture1.Width
        For y = 0 To Picture1.Height
            kk = Picture1.Point(x, y) 'otetaan väri selaus kohdasta
            kk2 = Picture1.Point(x, y + 1) 'otetaan väri viereisestä kohdasta
            'Tarkistetaan löytyykö päällekkäisistä pikseleista väri eroa
            If kk <> kk2 Then
                'Jos väri on sama niin hypätään kohdan yli
                If Abs(kk - kk2) > ero Then
                    'Jos värien ero on riittävän suuri ne piirretään
                    Picture2.PSet (x, y), RGB(0, 0, 0) 'Piirretään mustalla raja kohta
                End If
            End If
            DoEvents
            kk = Picture1.Point(x, y) 'otetaan väri selaus kohdasta
            kk2 = Picture1.Point(x + 1, y) 'otetaan väri viereisestä kohdasta
            If kk <> kk2 Then
                'Jos väri on sama niin hypätään kohdan yli
                If Abs(kk - kk2) > ero Then
                    'Jos värien ero on riittävän suuri ne piirretään
                    Picture2.PSet (x, y), RGB(0, 0, 0) 'Piirretään mustalla raja kohta
                End If
            End If
            DoEvents
        Next y
    Next x
End Sub

Private Sub Form_Unload(Cancel As Integer)
    End 'Lopetetaan ohjelma vaikka piirto olisi kesken
End Sub

Eli värejä on meilestäni turha jakaa punaseks, vihreeks ja siniseks. Suora väriarvojen vertailu riittää kunhan minimi värieron laittaa "hieman" suuremmaksi.

Ja sitten kun ei laita sitä autoredrawia päälle niin vauhtia tulee reippaasti lisää!

Edit2: Mutta täytyy sanoa, että tämä on pitkästä aikaa sellainen vinkki, että jaksan paneutua siihen vilkaisua syvemmin! :)

Merri [01.08.2005 11:32:59]

Ajattelin hetken, että viitsinkö... mutta viitsin. Tässä siis koodia vähän muuteltuna ja nopeutettuna:

1. tarvitset Picture1, Picture2 ja Command1
2. muuta pictureboxien ScaleMode kohtaan 3 - vbPixels
3. aseta Picture2 taustaväriksi valkoinen

Option Explicit

Private Type VAARIN
    Red As Integer
    Green  As Integer
    Blue As Integer
End Type

Dim Vari As VAARIN
Dim Vari2 As VAARIN
Dim kk As Long
Dim kk2 As Long
Dim Poistu As Boolean
Private Function Varin(Vaari As Long) As VAARIN
    'Functio joka pilkkoo värikoodin RGB arvoiksi
    Dim R As Byte, G As Byte, B As Byte
    Vaari = Vaari And &HFFFFFF
    R = Vaari Mod 256
    G = (Vaari \ 256) Mod 256
    B = Vaari \ 65536
    Varin.Blue = B
    Varin.Green = G
    Varin.Red = R
End Function
Private Sub Command1_Click()
    Dim Ero As Long, X As Long, Y As Long
    Dim Red As Byte, Green As Byte, Blue As Byte
    Ero = 10 'Haluttu minimi ero värien välillä
    Picture2.Width = Picture1.Width ' Muutetaaan laatikot samankokoisiksi
    Picture2.Height = Picture1.Height

    For X = 0 To Picture1.ScaleWidth
        For Y = 0 To Picture1.ScaleHeight
            kk = Picture1.Point(X, Y) 'otetaan väri selaus kohdasta
            kk2 = Picture1.Point(X, Y + 1) 'otetaan väri viereisestä kohdasta
            Vari = Varin(kk) ' laitetaan taulukkoon värien RGB arvot
            Vari2 = Varin(kk2)
            Red = CByte(Abs(Vari.Red - Vari2.Red))
            Green = CByte(Abs(Vari.Green - Vari2.Green))
            Blue = CByte(Abs(Vari.Blue - Vari2.Blue))
            'Jos väri on sama niin hypätään kohdan yli
            If Red > Ero Or Green > Ero Or Blue > Ero Then
                Red = ((CLng(255 - Red) + CLng(255 - Green) + CLng(255 - Blue))) And &HFF
                Green = Red
                Blue = Red
                'Jos värien ero on riittävän suuri ne piirretään
                Picture2.PSet (X, Y), RGB(Red, Green, Blue) 'Piirretään mustalla raja kohta
            ElseIf X < Picture1.ScaleWidth Then
                kk2 = Picture1.Point(X + 1, Y) 'otetaan väri viereisestä kohdasta
                Vari2 = Varin(kk2)
                Red = CByte(Abs(CLng(Vari.Red) - CLng(Vari2.Red)) And &HFF)
                Green = CByte(Abs(CLng(Vari.Green) - CLng(Vari2.Green)) And &HFF)
                Blue = CByte(Abs(CLng(Vari.Blue) - CLng(Vari2.Blue)) And &HFF)
                'Jos väri on sama niin hypätään kohdan yli
                If Red > Ero Or Green > Ero Or Blue > Ero Then
                    Red = ((CLng(255 - Red) + CLng(255 - Green) + CLng(255 - Blue))) And &HFF
                    Green = Red
                    Blue = Red
                    'Jos värien ero on riittävän suuri ne piirretään
                    Picture2.PSet (X, Y), RGB(Red, Green, Blue) 'Piirretään mustalla raja kohta
                End If
            End If
        Next Y
        DoEvents
        If Poistu Then Exit For
    Next X
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Poistu = True
End Sub

Ei varmaan kukaan jaksellut katsella karkeaa jälkeä? Tämä tekee pehmennettyä.

Ai joo... ja kyllähän mistä tahansa koodista saa hitaan kun laittaa sen tekemään tarkistuksen 15 kertaa pikseliä kohden ;) ScaleMode on hyvä muistaa kun käyttelee näitä VB:n omia piirtojuttuja.

Vastaus

Aihe on jo aika vanha, joten et voi enää vastata siihen.

Kirjautuminen

Haku

Tehtävät