picproc.bas

图像处理

Attribute VB_Name = "Module1"
'Module1: PicProc.bas

' Mainly to hold Publics

Option Base 1
DefLng A-W
DefSng X-Z

' APIs for getting DIB bits to PalBGR

Public Declare Function GetDIBits Lib "gdi32" _
(ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

Public Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal HDC As Long) As Long

Public Declare Function SelectObject Lib "gdi32" _
(ByVal HDC As Long, ByVal hObject As Long) As Long

Public Declare Function DeleteDC Lib "gdi32" _
(ByVal HDC As Long) As Long

'---------------------------------------------------------------

Public Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal HDC As Long, ByVal nIndex As Long) As Long
Public Const HORZRES = 8
Public Const VERTRES = 10
Public Const BITSPIXEL = 12         '  Number of bits per pixel

' Usage
' SysBPP = GetDeviceCaps(PIC.hDC, BITSPIXEL)   ' 16, 32 (24-bit BGR)
' SysW = GetDeviceCaps(PIC.hDC, HORZRES)       ' eg 800
' SysH = GetDeviceCaps(PIC.hDC, VERTRES)       ' eg 600


'------------------------------------------------------------------------------

'To fill BITMAP structure
Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" _
(ByVal hObject As Long, ByVal Lenbmp As Long, dimbmp As Any) As Long

Public Type BITMAP
   bmType As Long              ' Type of bitmap
   bmWidth As Long             ' Pixel width
   bmHeight As Long            ' Pixel height
   bmWidthBytes As Long        ' Byte width = 3 x Pixel width
   bmPlanes As Integer         ' Color depth of bitmap
   bmBitsPixel As Integer      ' Bits per pixel, must be 16 or 24
   bmBits As Long              ' This is the pointer to the bitmap data  !!!
End Type

'NB PICTURE STORED IN MEMORY UPSIDE DOWN
'WITH INCREASING MEMORY GOING UP THE PICTURE
'bmp.bmBits points to the bottom left of the picture

Public bmp As BITMAP
'------------------------------------------------------------------------------

' Structures for StretchDIBits
Public Type BITMAPINFOHEADER ' 40 bytes
   biSize As Long
   biwidth As Long
   biheight As Long
   biPlanes As Integer
   biBitCount As Integer
   biCompression As Long
   biSizeImage As Long
   biXPelsPerMeter As Long
   biYPelsPerMeter As Long
   biClrUsed As Long
   biClrImportant As Long
End Type

Public Type BITMAPINFO
   bmiH As BITMAPINFOHEADER
   'bmiH As RGBTRIPLE            'NB Palette NOT NEEDED for 16,24 & 32-bit
End Type
Public bm As BITMAPINFO

' For transferring drawing in an integer array to Form or PicBox
Public Declare Function StretchDIBits Lib "gdi32" (ByVal HDC As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal DesW As Long, ByVal DesH As Long, _
ByVal SrcX As Long, ByVal SrcY As Long, _
ByVal PICWW As Long, ByVal PICHH As Long, _
lpBits As Any, lpBitsInfo As BITMAPINFO, _
ByVal wUsage As Long, ByVal dwRop As Long) As Long
'------------------------------------------------------------------------------

'To shift cursor out of the way
'Public Declare Sub SetCursorPos Lib "user32" (ByVal IX As Long, ByVal IY As Long)

'Copy one array to another of same number of bytes
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)

Public Declare Function GetPixel Lib "gdi32" _
(ByVal HDC As Long, ByVal X As Long, ByVal Y As Long) As Long

'Public Declare Function SetPixelV Lib "gdi32" _
'(ByVal HDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long

'Public Declare Function StretchBlt Lib "gdi32" _
'(ByVal HDC As Long, _
'ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
'ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nPICWidth As Long, ByVal nPICHeight As Long, ByVal dwRop As Long) As Long

'Used to extract small bitmap from a large one and show shrunken bitmap
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, _
ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

'------------------------------------------------------------------------------

Public SysBPP               ' 16 or 32 (24) bits/pixel

Public PICW, PICH           ' Display picbox Width & Height (pixels)
Public PalBGR() As Byte     ' To hold 3 full palettes (12 x PICW x PICH)
' To save Indexes from Check boxes
Public chkPIXIndex, chkMoversIndex, chkRotateIndex, chkMagIndex
Public chkPALIndex, chkColorXIndex, chkCrazyMirrorsIndex
Public Increment  ' Set by Stepper 1,2,4,8
Public zAngle, zMag
' Variables for Extract & Resize picture
Public iXp, iYp, iX2, iY2, RectWidth, RectHeight

Public YWave()


Public TEXT$

' For effects that need an off-line
Public PalLineCopy() As Byte        ' For copying 1 line of PalBGR()
' General byte RGBs
Public QBRed As Byte, QBGreen As Byte, QBBlue As Byte
Public QBLongColor   '= RGB(QBRed, QBGreen, QBBlue)

Public PalBGRPtr            ' Pointer to PalBGR(1,1,1,1)
Public PalSize              ' Size of 1 palette (4 x PICW x PICH)

Public PicFrameW, PicFrameH ' Size of PIC frame container

Public Done As Boolean      ' For LOOPING
Public ASM As Boolean

Public Const pi# = 3.1415926535898
Public Const d2r# = pi# / 180



Public Sub Quicksort(LongArr(), Param)

'1 dimensional long array sorted in ascending order from k to max
Max = UBound(LongArr)
If Max = 1 Then Exit Sub
k = LBound(LongArr)
If k = Max Then Exit Sub
m = Max \ 2: ReDim sortl(m), sortr(m)
s = 1: sortl(1) = k: sortr(1) = Max
Do While s <> 0
   ll = sortl(s): mm = sortr(s): s = s - 1
   
   Do While ll < mm
      i = ll: j = mm
      p = (ll + mm) \ 2
      X& = LongArr(p)
      
      Do While i <= j
         Do While LongArr(i) < X&: i = i + 1: Loop
         Do While X& < LongArr(j): j = j - 1: Loop
         If i <= j Then
            'SWAP zarr(i), zarr(j)
            Y& = LongArr(i): LongArr(i) = LongArr(j): LongArr(j) = Y&
            i = i + 1: j = j - 1
         End If
      Loop
      
      If i < mm Then
         s = s + 1: sortl(s) = i: sortr(s) = mm
      End If
      mm = j
   Loop

Loop

Erase sortl, sortr
End Sub