effects.bas

图像处理

Attribute VB_Name = "Module2"
'Module2: Effects.bas

'PicProc.bas Publics:-

'Public PICW, PICH           ' Display picbox Width & Height (pixels)
'Public PalBGR() As Byte     ' To hold 3 full palettes (12 x PICW x PICH)
'Public chkPIXIndex, chkMoversIndex, chkRotateIndex
'Public chkPALIndex, chkColorXIndex, chkCrazyMirrorsIndex
'Public Increment
'Public zAngle, zMag
'Public iXp, iYp, iX2, iY2, RectWidth, RectHeight
'Public PalLineCopy() As Byte        ' For copying 1 line of PalBGR()
'Public QBRed As Byte, QBGreen As Byte, QBBlue As Byte

Option Base 1
DefLng A-W
DefSng X-Y


Public Sub ApplyMag()

' NB Code similar to Rotation

' zMag = Magnification


If zMag < 1 Then
   zdm = -0.05
Else
   zdm = 0.1
End If


N = 3
zxc = iXp
zyc = PICH - iYp

Do

zMul = 1 / zMag

Select Case chkMagIndex

Case 0      ' SIMPLE MAGNIFICATION

   For iy = PICH To 1 Step -1
   For ix = PICW To 1 Step -1
      'Find Surf 2 point from rotated Surf 3 or Surf 1 point
      
      ixs = zxc + zMul * (ix - zxc)
   
   If ixs < 1 Or ixs > PICW Then
      PalBGR(1, ix, iy, 2) = QBBlue
      PalBGR(2, ix, iy, 2) = QBGreen
      PalBGR(3, ix, iy, 2) = QBRed
      GoTo nexix
   End If
   
   iys = zyc + zMul * (iy - zyc)
   
   If iys < 1 Or iys > PICH Then
      PalBGR(1, ix, iy, 2) = QBBlue
      PalBGR(2, ix, iy, 2) = QBGreen
      PalBGR(3, ix, iy, 2) = QBRed
      GoTo nexix
   End If
   
   PalBGR(1, ix, iy, 2) = PalBGR(1, ixs, iys, N)
   PalBGR(2, ix, iy, 2) = PalBGR(2, ixs, iys, N)
   PalBGR(3, ix, iy, 2) = PalBGR(3, ixs, iys, N)

nexix:
Next ix

Next iy

Case 1      ' ANTI-ALIAS MAGNIFICATION

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

   xs = zxc + zMul * (ix - zxc)
   ys = zyc + zMul * (iy - zyc)

   ' Bottom left coords of bounding rectangle
   ixs0 = Int(xs)
   iys0 = Int(ys)
   
   If ixs0 > 1 And ixs0 < PICW And iys0 > 1 And iys0 < PICH Then
      
      xsf = xs - Int(xs)
      ysf = ys - Int(ys)
      
      'ixs0->ixs0+1, iyso
      culB = (1 - xsf) * PalBGR(1, ixs0, iys0, N)
      culG = (1 - xsf) * PalBGR(2, ixs0, iys0, N)
      culR = (1 - xsf) * PalBGR(3, ixs0, iys0, N)
   
      culB0 = culB + xsf * PalBGR(1, ixs0 + 1, iys0, N)
      culG0 = culG + xsf * PalBGR(2, ixs0 + 1, iys0, N)
      culR0 = culR + xsf * PalBGR(3, ixs0 + 1, iys0, N)
      
      'ixs0->ixs0+1, iys0+1
      culB = (1 - xsf) * PalBGR(1, ixs0, iys0 + 1, N)
      culG = (1 - xsf) * PalBGR(2, ixs0, iys0 + 1, N)
      culR = (1 - xsf) * PalBGR(3, ixs0, iys0 + 1, N)
      
      culB1 = culB + xsf * PalBGR(1, ixs0 + 1, iys0 + 1, N)
      culG1 = culG + xsf * PalBGR(2, ixs0 + 1, iys0 + 1, N)
      culR1 = culR + xsf * PalBGR(3, ixs0 + 1, iys0 + 1, N)
   
      ' Weight along y axis
      culB = (1 - ysf) * culB0 + ysf * culB1
      culG = (1 - ysf) * culG0 + ysf * culG1
      culR = (1 - ysf) * culR0 + ysf * culR1
   
      If culB > 255 Then culB = 255
      If culG > 255 Then culG = 255
      If culR > 255 Then culR = 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
   Else
   
      PalBGR(1, ix, iy, 2) = QBBlue
      PalBGR(2, ix, iy, 2) = QBGreen
      PalBGR(3, ix, iy, 2) = QBRed
   
   End If
   
Next ix

Next iy

End Select


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


DoEvents

If Done = False Then    ' LOOP MAG
   
   If zMag <= 0.1 Then zdm = 0.05
   If zdm > 0 And zMag > 1 Then zdm = 0.1
   If zMag >= 10 Then zdm = -0.1
   If zdm < 0 And zMag <= 1 Then zdm = -0.05
   
   zMag = zMag + zdm * Increment
   If zMag < 0.1 Then zMag = 0.1
   If zMag > 10 Then zMag = 10
   ' Show zMag
   Form1.HSBMag.Value = 10 * zMag
   Form1.txtMag.TEXT = Str$(zMag)

End If


Loop Until Done



End Sub


Public Sub Rotate()


' --s = source

' +/- 180 deg

If Done = True And zAngle = 0 Then Exit Sub

RANG = zAngle + 360  ' 0-360
SgnA = Sgn(zAngle)
If SgnA = 0 Then SgnA = 1

Do

zang = RANG * d2r#

Select Case chkRotateIndex
Case 0, 1   ' ROTATE DISPLAYED
   N = 3    ' 3->2
Case 2, 3   ' ROTATE PERMANENT
   N = 1    ' 1->2
End Select

zCos = Cos(zang)
zSin = Sin(zang)

zxc = iXp
zyc = PICH - iYp

Select Case chkRotateIndex

Case 0, 2   ' SIMPLE ROTATE   0(display) = 3->2, 2(perm) = 1->2
   For iy = PICH To 1 Step -1
   For ix = PICW To 1 Step -1
      'Find Surf 2 point from rotated Surf 3 or Surf 1 point
      ixs = zxc + (ix - zxc) * zCos - (iy - zyc) * zSin
   
   If ixs < 1 Or ixs > PICW Then
      PalBGR(1, ix, iy, 2) = QBBlue
      PalBGR(2, ix, iy, 2) = QBGreen
      PalBGR(3, ix, iy, 2) = QBRed
      GoTo nexix
   End If
   
   iys = zyc + (iy - zyc) * zCos + (ix - zxc) * zSin
   
   If iys < 1 Or iys > PICH Then
      PalBGR(1, ix, iy, 2) = QBBlue
      PalBGR(2, ix, iy, 2) = QBGreen
      PalBGR(3, ix, iy, 2) = QBRed
      GoTo nexix
   End If
   
   PalBGR(1, ix, iy, 2) = PalBGR(1, ixs, iys, N)
   PalBGR(2, ix, iy, 2) = PalBGR(2, ixs, iys, N)
   PalBGR(3, ix, iy, 2) = PalBGR(3, ixs, iys, N)

nexix:
Next ix

Next iy


Case 1, 3   ' ANTI-ALIAS ROTATE   1(display) = 3->2, 3(perm) = 1->2

zMul = 1 'Other values here will rotate AND zoom

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

   xs = zxc + zMul * (ix - zxc) * zCos - zMul * (iy - zyc) * zSin
   ys = zyc + zMul * (iy - zyc) * zCos + zMul * (ix - zxc) * zSin

   ' Bottom left coords of bounding rectangle
   ixs0 = Int(xs)
   iys0 = Int(ys)
   
   If ixs0 > 1 And ixs0 < PICW And iys0 > 1 And iys0 < PICH Then
      
      xsf = xs - Int(xs)
      ysf = ys - Int(ys)
      
      'ixs0->ixs0+1, iyso
      culB = (1 - xsf) * PalBGR(1, ixs0, iys0, N)
      culG = (1 - xsf) * PalBGR(2, ixs0, iys0, N)
      culR = (1 - xsf) * PalBGR(3, ixs0, iys0, N)
   
      culB0 = culB + xsf * PalBGR(1, ixs0 + 1, iys0, N)
      culG0 = culG + xsf * PalBGR(2, ixs0 + 1, iys0, N)
      culR0 = culR + xsf * PalBGR(3, ixs0 + 1, iys0, N)
      
      'ixs0->ixs0+1, iys0+1
      culB = (1 - xsf) * PalBGR(1, ixs0, iys0 + 1, N)
      culG = (1 - xsf) * PalBGR(2, ixs0, iys0 + 1, N)
      culR = (1 - xsf) * PalBGR(3, ixs0, iys0 + 1, N)
      
      culB1 = culB + xsf * PalBGR(1, ixs0 + 1, iys0 + 1, N)
      culG1 = culG + xsf * PalBGR(2, ixs0 + 1, iys0 + 1, N)
      culR1 = culR + xsf * PalBGR(3, ixs0 + 1, iys0 + 1, N)
   
      ' Weight along y axis
      culB = (1 - ysf) * culB0 + ysf * culB1
      culG = (1 - ysf) * culG0 + ysf * culG1
      culR = (1 - ysf) * culR0 + ysf * culR1
   
      If culB > 255 Then culB = 255
      If culG > 255 Then culG = 255
      If culR > 255 Then culR = 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
   Else
   
      PalBGR(1, ix, iy, 2) = QBBlue
      PalBGR(2, ix, iy, 2) = QBGreen
      PalBGR(3, ix, iy, 2) = QBRed
   
   End If
   
Next ix
    
Next iy

End Select



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


DoEvents


'If Done = True And zAngle = 0 Then Exit Sub
'RANG = zAngle + 360  ' 0-360
'SgnA = Sgn(zAngle)
'If SgnA = 0 Then SgnA = 1

If Done = False Then
   
   RANG = RANG + SgnA * Increment
   
   If RANG > 360 Then RANG = RANG - 360
   If RANG < -360 Then RANG = RANG + 360
   
   Form1.HSBAngle.Value = RANG \ 2 + 180
   Form1.txtAngle.TEXT = Str$(RANG \ 2)

End If

Loop Until Done


End Sub


Public Sub Movers()

ReDim PalLineCopy(4, PICW)    ' Zeros - BLACK

Do

Select Case chkMoversIndex

Case 0, 2     ' SCROLL UP  SHIFT UP COLORX
   
   
   For i = 1 To Increment
      
      CopyMemory PalLineCopy(1, 1), PalBGR(1, 1, PICH, 2), 4 * PICW  ' Save top line
      
      For iy = PICH To 2 Step -1
         CopyMemory PalBGR(1, 1, iy, 2), PalBGR(1, 1, iy - 1, 2), 4 * PICW
      Next iy
  
      'CopyMemory PalBGR(1, 1, PICH, 2), PalBGR(1, 1, PICH - 1, 2), 4 * PICW * (PICH - 1)  '??
      
      
      If chkMoversIndex = 0 Then
         CopyMemory PalBGR(1, 1, 1, 2), PalLineCopy(1, 1), 4 * PICW     ' Put top line to bottom
      Else
         For ix = 1 To PICW
            PalBGR(1, ix, 1, 2) = QBBlue
            PalBGR(2, ix, 1, 2) = QBGreen
            PalBGR(3, ix, 1, 2) = QBRed
         Next ix
      End If
   
   Next i

Case 1, 3  ' SCROLL DOWN   SHIFT DOWN COLORX

   For i = 1 To Increment
      
      CopyMemory PalLineCopy(1, 1), PalBGR(1, 1, 1, 2), 4 * PICW  ' Save bottom line
      
      For iy = 2 To PICH
         CopyMemory PalBGR(1, 1, iy - 1, 2), PalBGR(1, 1, iy, 2), 4 * PICW
      Next iy
  
      If chkMoversIndex = 1 Then
         CopyMemory PalBGR(1, 1, PICH, 2), PalLineCopy(1, 1), 4 * PICW  ' Put bottom line to top
      Else
         For ix = 1 To PICW
            PalBGR(1, ix, PICH, 2) = QBBlue
            PalBGR(2, ix, PICH, 2) = QBGreen
            PalBGR(3, ix, PICH, 2) = QBRed
         Next ix
      End If
   
   Next i

Case 4, 6     ' SCROLL LEFT   SHIFT LEFT COLORX

   ReDim PalLineCopy(4, PICH)    ' Zeros - BLACK
   
   For i = 1 To Increment

      For iy = 1 To PICH      ' Save left line
         PalLineCopy(1, iy) = PalBGR(1, 1, iy, 2)
         PalLineCopy(2, iy) = PalBGR(2, 1, iy, 2)
         PalLineCopy(3, iy) = PalBGR(3, 1, iy, 2)
      Next iy
      

      For iy = 1 To PICH
   
         CopyMemory PalBGR(1, 1, iy, 2), PalBGR(1, 2, iy, 2), 4 * PICW - 1
      Next iy
   
      If chkMoversIndex = 4 Then
         For iy = 1 To PICH      ' Put left line to right
            PalBGR(1, PICW, iy, 2) = PalLineCopy(1, iy)
            PalBGR(2, PICW, iy, 2) = PalLineCopy(2, iy)
            PalBGR(3, PICW, iy, 2) = PalLineCopy(3, iy)
         Next iy
      Else     ' Put right line to ColorX,  Shift Left
         For iy = 1 To PICH
            PalBGR(1, PICW, iy, 2) = QBBlue
            PalBGR(2, PICW, iy, 2) = QBGreen
            PalBGR(3, PICW, iy, 2) = QBRed
         Next iy
      End If
   
   Next i
   

Case 5, 7     ' SCROLL RIGHT  SHIFT RIGHT COLORX

   ReDim PalLineCopy(4, PICH)    ' Zeros - BLACK
   
   For i = 1 To Increment

      For iy = 1 To PICH      ' Save Right line
         PalLineCopy(1, iy) = PalBGR(1, PICW, iy, 2)
         PalLineCopy(2, iy) = PalBGR(2, PICW, iy, 2)
         PalLineCopy(3, iy) = PalBGR(3, PICW, iy, 2)
      Next iy