effects.bas

图像处理

Case 15  ' BLACK TO WHITE
   Cul = 0
   For PCul = 1 To 3
      If PalBGR(PCul, ix, iy, 2) <> 0 Then ' NO
         Cul = 1
         Exit For
      End If
   Next PCul
   If Cul = 0 Then
      For PCul = 1 To 3
         PalBGR(PCul, ix, iy, 2) = 255
      Next PCul
   End If

Case 16  ' WHITE TO BLACK
   Cul = 0
   For PCul = 1 To 3
      If PalBGR(PCul, ix, iy, 2) <> 255 Then ' NO
         Cul = 1
         Exit For
      End If
   Next PCul
   If Cul = 0 Then
      For PCul = 1 To 3
         PalBGR(PCul, ix, iy, 2) = 0
      Next PCul
   End If

Case 17  ' NON-WHITE TO BLACK
   Cul = 0
   For PCul = 1 To 3
      If PalBGR(PCul, ix, iy, 2) = 255 Then Cul = Cul + 1
   Next PCul
   If Cul <> 3 Then
      For PCul = 1 To 3
         PalBGR(PCul, ix, iy, 2) = 0
      Next PCul
   End If

Case 18  ' NON-BLACK TO WHITE
   Cul = 0
   For PCul = 1 To 3
      If PalBGR(PCul, ix, iy, 2) = 0 Then Cul = Cul + 1
   Next PCul
   If Cul <> 3 Then
      For PCul = 1 To 3
         PalBGR(PCul, ix, iy, 2) = 255
      Next PCul
   End If
   
Case 19     ' BLACK & WHITE

   BWThresh = 180
   
   culB = PalBGR(1, ix, iy, 2)
   culG = PalBGR(2, ix, iy, 2)
   culR = PalBGR(3, ix, iy, 2)
   
   If culB < BWThresh And culG < BWThresh And culR < BWThresh Then
      PalBGR(1, ix, iy, 2) = 0
      PalBGR(2, ix, iy, 2) = 0
      PalBGR(3, ix, iy, 2) = 0
   Else
      PalBGR(1, ix, iy, 2) = 255
      PalBGR(2, ix, iy, 2) = 255
      PalBGR(3, ix, iy, 2) = 255
   End If
   
End Select

Next ix

Next iy

End Sub


Public Sub ColorXEffects()


' For Diffuse ColorX
OffSet = (Increment + 2) \ 2: If OffSet = 5 Then OffSet = 4

' Offset = 1,2,3 or 4

Do

Select Case chkColorXIndex

Case 0   ' Add Random ColorX
   
   For i = 1 To 20 * Increment
      ix = PICW * Rnd + 1: If ix > PICW Then ix = PICW
      iy = PICH * Rnd + 1: If iy > PICH Then iy = PICH
      PalBGR(3, ix, iy, 2) = QBRed
      PalBGR(2, ix, iy, 2) = QBGreen
      PalBGR(1, ix, iy, 2) = QBBlue
   Next i

Case 1   ' Add Horz ColorX lines
   For iy = 1 To PICH Step Increment
   For ix = 1 To PICW
      PalBGR(3, ix, iy, 2) = QBRed
      PalBGR(2, ix, iy, 2) = QBGreen
      PalBGR(1, ix, iy, 2) = QBBlue
   Next ix
   Next iy

Case 2   ' Add Vert ColorX lines
   For iy = 1 To PICH
   For ix = 1 To PICW Step Increment
      PalBGR(3, ix, iy, 2) = QBRed
      PalBGR(2, ix, iy, 2) = QBGreen
      PalBGR(1, ix, iy, 2) = QBBlue
   Next ix
   Next iy

Case 3   ' Add ColorX Dots
   For iy = 1 To PICH Step Increment
   For ix = 1 To PICW Step Increment
      PalBGR(3, ix, iy, 2) = QBRed
      PalBGR(2, ix, iy, 2) = QBGreen
      PalBGR(1, ix, iy, 2) = QBBlue
   Next ix
   Next iy

Case 4   ' Diffuse ColorX
   
   'OffSet = (Increment + 2) \ 2: If OffSet = 5 Then OffSet = 4
   
   For iy = 1 + OffSet To PICH - OffSet
   For ix = 1 + OffSet To PICW - OffSet
      
      LongPal = RGB(PalBGR(3, ix, iy, 2), PalBGR(2, ix, iy, 2), PalBGR(1, ix, iy, 2))
      If LongPal = QBLongColor Then
         
         For OFFY = -OffSet To OffSet
         'A = Abs(OFFY)
         zN = 0.9
         For OFFX = -OffSet To OffSet
            
            A = Abs(OFFY)
            If Abs(OFFX) > A Then A = Abs(OFFX)
            zN = 0.9 - 0.1 * (OffSet - A)
            zm = 1 - zN
            
            Cul = zN * PalBGR(1, ix + OFFX, iy + OFFY, 2) + zm * QBBlue
            If Cul < 255 Then PalBGR(1, ix + OFFX, iy + OFFY, 2) = Cul
            Cul = zN * PalBGR(2, ix + OFFX, iy + OFFY, 2) + zm * QBGreen
            If Cul < 255 Then PalBGR(2, ix + OFFX, iy + OFFY, 2) = Cul
            Cul = zN * PalBGR(3, ix + OFFX, iy + OFFY, 2) + zm * QBRed
            If Cul < 255 Then PalBGR(3, ix + OFFX, iy + OFFY, 2) = Cul
         
         Next OFFX
         Next OFFY
      
      End If
   Next ix
   Next iy

Case 5   ' Diffuse ColorX Up
   
   'OffSet = (Increment + 2) \ 2: If OffSet = 5 Then OffSet = 4
   
   For iy = 1 To PICH - OffSet
   For ix = 1 To PICW
      If PalBGR(1, ix, iy, 2) = QBBlue And PalBGR(2, ix, iy, 2) = QBGreen And PalBGR(3, ix, iy, 2) = QBRed Then
         zN = 0.9
         For OFFY = OffSet To 0 Step -1
            
            zN = zN - 0.1
            zm = 1 - zN
            
            Cul = zN * PalBGR(1, ix, iy + OFFY, 2) + zm * QBBlue
            If Cul < 255 Then PalBGR(1, ix, iy + OFFY, 2) = Cul
            Cul = zN * PalBGR(2, ix, iy + OFFY, 2) + zm * QBGreen
            If Cul < 255 Then PalBGR(2, ix, iy + OFFY, 2) = Cul
            Cul = zN * PalBGR(3, ix, iy + OFFY, 2) + zm * QBRed
            If Cul < 255 Then PalBGR(3, ix, iy + OFFY, 2) = Cul
         
         Next OFFY
      
      End If
   Next ix
   Next iy

Case 6   ' Diffuse ColorX Down
   
   'OffSet = (Increment + 2) \ 2: If OffSet = 5 Then OffSet = 4
   
   For iy = 1 + OffSet To PICH
   For ix = 1 To PICW
      If PalBGR(1, ix, iy, 2) = QBBlue And PalBGR(2, ix, iy, 2) = QBGreen And PalBGR(3, ix, iy, 2) = QBRed Then
         zN = 0.9
         For OFFY = -OffSet To 0
            
            zN = zN - 0.1
            zm = 1 - zN
            
            Cul = zN * PalBGR(1, ix, iy + OFFY, 2) + zm * QBBlue
            If Cul < 255 Then PalBGR(1, ix, iy + OFFY, 2) = Cul
            Cul = zN * PalBGR(2, ix, iy + OFFY, 2) + zm * QBGreen
            If Cul < 255 Then PalBGR(2, ix, iy + OFFY, 2) = Cul
            Cul = zN * PalBGR(3, ix, iy + OFFY, 2) + zm * QBRed
            If Cul < 255 Then PalBGR(3, ix, iy + OFFY, 2) = Cul
         
         Next OFFY
      
      End If
   Next ix
   Next iy

Case 7   ' Diffuse ColorX Left
   
   'OffSet = (Increment + 2) \ 2: If OffSet = 5 Then OffSet = 4

   For iy = 1 To PICH
   For ix = 1 + OffSet To PICW
      If PalBGR(1, ix, iy, 2) = QBBlue And PalBGR(2, ix, iy, 2) = QBGreen And PalBGR(3, ix, iy, 2) = QBRed Then
         zN = 0.9
         For OFFX = -OffSet To 0
            
            zN = zN - 0.1
            
            Cul = zN * (1& * PalBGR(1, ix + OFFX, iy, 2) - QBBlue) + QBBlue
            If Cul < 255 Then PalBGR(1, ix + OFFX, iy, 2) = Cul
            Cul = zN * (1& * PalBGR(2, ix + OFFX, iy, 2) - QBGreen) + QBGreen
            If Cul < 255 Then PalBGR(2, ix + OFFX, iy, 2) = Cul
            Cul = zN * (1& * PalBGR(3, ix + OFFX, iy, 2) - QBRed) + QBRed
            If Cul < 255 Then PalBGR(3, ix + OFFX, iy, 2) = Cul
            
         Next OFFX
      
      End If
   Next ix
   Next iy

Case 8   ' Diffuse ColorX Right
   
   'OffSet = (Increment + 2) \ 2: If OffSet = 5 Then OffSet = 4
   
   For iy = 1 To PICH
   For ix = 1 To PICW - OffSet
      If PalBGR(1, ix, iy, 2) = QBBlue And PalBGR(2, ix, iy, 2) = QBGreen And PalBGR(3, ix, iy, 2) = QBRed Then
         zN = 0.9
         For OFFX = OffSet To 0 Step -1
            
            zN = zN - 0.1
            
            Cul = zN * (1& * PalBGR(1, ix + OFFX, iy, 2) - QBBlue) + QBBlue
            If Cul < 255 Then PalBGR(1, ix + OFFX, iy, 2) = Cul
            Cul = zN * (1& * PalBGR(2, ix + OFFX, iy, 2) - QBGreen) + QBGreen
            If Cul < 255 Then PalBGR(2, ix + OFFX, iy, 2) = Cul
            Cul = zN * (1& * PalBGR(3, ix + OFFX, iy, 2) - QBRed) + QBRed
            If Cul < 255 Then PalBGR(3, ix + OFFX, iy, 2) = Cul
         
         Next OFFX
      
      End If
   Next ix
   Next iy
   
Case 9      ' BRIGHT SPOT & Xp, Yp

For rad = 1 To 24 * Increment
zFrac = (1 - rad / (24 * Increment))
For theta = 0 To 359

   ix = iXp + rad * Sin(theta * d2r#)
   iy = (PICH - iYp) + rad * Cos(theta * d2r#)

   If ix >= 1 And ix <= PICW And iy >= 1 And iy <= PICH Then
      culB = PalBGR(1, ix, iy, 2) + PalBGR(1, ix, iy, 2) * zFrac
      culG = PalBGR(2, ix, iy, 2) + PalBGR(2, ix, iy, 2) * zFrac
      culR = PalBGR(3, ix, iy, 2) + PalBGR(3, ix, iy, 2) * zFrac
   
      If culB > 255 Then culB = QBBlue '255
      If culG > 255 Then culG = QBGreen '255
      If culR > 255 Then culR = QBRed '255
      
      If culB < 0 Then culB = 0
      If culG < 0 Then culG = 0
      If culR < 0 Then culR = 0
      
      PalBGR(1, ix, iy, 2) = culB
      PalBGR(2, ix, iy, 2) = culG
      PalBGR(3, ix, iy, 2) = culR
   
   End If
   
Next theta
Next rad

End Select


   '---------------------
   ShowPalBGR 2
   '---------------------

DoEvents

Loop Until Done

End Sub

Public Sub CrazyMirrors()

Indent = 4 * Increment ' Basic indentation of picture

' Define ellipse for Case 6
A = PICW / 2
B = PICH / 2
If chkCrazyMirrorsIndex = 7 Then B = PICH
      
For iy = 1 To PICH
      ReDim PalLineCopy(4, PICW)    ' Zeros - BLACK
      
      Select Case chkCrazyMirrorsIndex
      Case 0      ' )(
         ixcopy0 = Int(Indent * (1 + Sin(pi# * (3 / 2 + 4 / 2 * iy / PICH))))
      Case 1      ' ()
         ixcopy0 = Int(Indent * (1 + Sin(pi# * (1 / 2 + 4 / 2 * iy / PICH))))
      Case 2      ' {}
         ixcopy0 = Int(Indent * (1 + Sin(pi# * (1 + 3 * iy / PICH))))
      Case 3      ' ()
         ixcopy0 = Int(Indent * (1 + Sin(pi# * (1 + 6 * iy / PICH))))
      Case 4      ' \/
         ixcopy0 = Int(3 * Indent - 3 * Indent * iy / PICH)
      Case 5      ' /\
         ixcopy0 = Int(3 * Indent * iy / PICH)
      Case 6, 7   ' O  U
         zB = (((iy - B) / B) ^ 2)
         If zB > 1 Then zB = 1
         ixcopy0 = Int(A * (1 - Sqr(1 - zB)))
      Case 8
         Exit For    ' GoTo after Next iy
      End Select
      
      zdx = (PICW - 2 * ixcopy0) / PICW
      For ix = 1 To PICW
         
         If ixcopy < 1 Then ixcopy = 1
         If ixcopy > PICW Then ixcopy = PICW
         
         PalLineCopy(1, ixcopy) = PalBGR(1, ix, iy, 2)
         PalLineCopy(2, ixcopy) = PalBGR(2, ix, iy, 2)
         PalLineCopy(3, ixcopy) = PalBGR(3, ix, iy, 2)
         
         ixcopy = ixcopy0 + ix * zdx
      
      Next ix

      CopyMemory PalBGR(1, 1, iy, 2), PalLineCopy(1, 1), 4 * PICW

Next iy


If chkCrazyMirrorsIndex = 7 Then    ' ?
End If


'Case 8       ' 8 VB <-> ASM

ReDim PalLineCopy(1, 1)

End Sub

Public Sub ConvPalDataTo16Bit()

' NB ONLY for displayed picture ie 2

For iy = 1 To PICH
For ix = 1 To PICW

      culB = PalBGR(1, ix, iy, 2)
      Remainder = culB Mod 8
      If Remainder <> 0 And culB <> 255 Then
         culB = culB - Remainder
      End If
      If culB = 8 Then culB = 0
      
      culG = PalBGR(2, ix, iy, 2)
      Remainder = culG Mod 4
      If Remainder <> 0 And culG <> 255 Then
         culG = culG - Remainder
      End If
      If culG = 8 Then culG = 0
   
      culR = PalBGR(3, ix, iy, 2)
      Remainder = culR Mod 8
      If Remainder <> 0 And culB <> 255 Then
         culR = culR - Remainder
      End If
      If culR = 8 Then culR = 0
      
      PalBGR(1, ix, iy, 2) = culB
      PalBGR(2, ix, iy, 2) = culG
      PalBGR(3, ix, iy, 2) = culR

Next ix
Next iy

End Sub

Public Sub ShowPalBGR(N)

' Blit PalBGR(N) to PIC

' N= 1,2 or 3

Form1.PIC.Picture = LoadPicture()
Form1.PIC.Visible = True

PalBGRPtr = VarPtr(PalBGR(1, 1, 1, N))

bm.bmiH.biwidth = PICW
bm.bmiH.biheight = PICH

   If StretchDIBits(Form1.PIC.HDC, _
      0, 0, _
      PICW, PICH, _
      0, 0, _
      PICW, PICH, _
      ByVal PalBGRPtr, bm, _
      1, vbSrcCopy) = 0 Then
         
         Erase PalBGR
         MsgBox ("Blit Error")
         End
   
   End If

Form1.PIC.Refresh

End Sub