| Download | |
| Edit | |
| Compatibility: | |
| VB4 | Yes |
| VB5 | untested |
| VB6 | untested |
| VB.NET | untested |
The main form that contains most of the code.B9A171
License[]
Version 3 of the GNU General Public LicenseB9A171
Code[]
VERSION 4.00
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "CGA"
ClientHeight = 7440
ClientLeft = 1140
ClientTop = 1620
ClientWidth = 9600
Height = 7890
Icon = "CGADither.frx":0000
KeyPreview = -1 'True
Left = 1080
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 496
ScaleMode = 3 'Pixel
ScaleWidth = 640
Top = 1230
Width = 9720
Begin VB.PictureBox Picture1
BackColor = &H00000000&
BorderStyle = 0 'None
Height = 420
Left = 1185
ScaleHeight = 28
ScaleMode = 3 'Pixel
ScaleWidth = 28
TabIndex = 4
Top = 480
Visible = 0 'False
Width = 420
End
Begin VB.Timer Timer2
Enabled = 0 'False
Interval = 100
Left = 645
Top = 480
End
Begin VB.Timer Timer1
Interval = 5000
Left = 240
Top = 480
End
Begin VB.HScrollBar HScroll2
Height = 240
Left = 7380
Max = 3
TabIndex = 1
Top = 0
Width = 2220
End
Begin VB.HScrollBar HScroll1
Height = 240
Left = 0
Max = 15
TabIndex = 0
Top = 0
Width = 7380
End
Begin ComctlLib.Slider Slider1
Height = 360
Left = 240
TabIndex = 3
Top = 6480
Visible = 0 'False
Width = 9120
_ExtentX = 16087
_ExtentY = 635
_Version = 327682
LargeChange = 100
SmallChange = 10
Max = 250
SelStart = 230
TickFrequency = 10
Value = 230
End
Begin ComctlLib.ProgressBar ProgressBar1
Height = 360
Left = 240
TabIndex = 2
Top = 6840
Visible = 0 'False
Width = 9120
_ExtentX = 16087
_ExtentY = 635
_Version = 327682
Appearance = 1
Max = 64
End
Begin VB.Image Image1
Height = 7200
Left = 0
Picture = "CGADither.frx":000C
Stretch = -1 'True
Top = 240
Width = 9600
End
Begin VB.Menu ContextMenu
Caption = ""
Visible = 0 'False
Begin VB.Menu Pause
Caption = "Pauze"
End
Begin VB.Menu Back
Caption = "Vorige"
End
Begin VB.Menu Forward
Caption = "Volgende"
End
Begin VB.Menu S0
Caption = "-"
End
Begin VB.Menu NextFolder
Caption = "Volgende map"
End
Begin VB.Menu FixPalette
Caption = "Palet fixeren"
End
Begin VB.Menu DiffFactor
Caption = "Diffusiefactor"
End
Begin VB.Menu AutoPalette
Caption = "Autopalet"
End
Begin VB.Menu S1
Caption = "-"
End
Begin VB.Menu Copy
Caption = "Kopiëren"
End
Begin VB.Menu Paste
Caption = "Plakken"
End
Begin VB.Menu S2
Caption = "-"
End
Begin VB.Menu SelDelay
Caption = "Interval"
Begin VB.Menu FiveSeconds
Caption = "5 seconden"
End
Begin VB.Menu TenSeconds
Caption = "10 seconden"
End
Begin VB.Menu FifteenSeconds
Caption = "15 seconden"
End
Begin VB.Menu ThirtySeconds
Caption = "30 seconden"
End
Begin VB.Menu FortyFiveSeconds
Caption = "45 seconden"
End
Begin VB.Menu OneMinute
Caption = "1 minuut"
End
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Private Const strCannotFindPixels = "Kan de pixels van de afbeelding niet vinden."
Private Const strCannotPasteImage = "Kan de afbeelding niet plakken." & vbCrLf & "De opgegeven fout was:"
Private Const strCannotPasteImageTitle = "Fout bij plakken"
Private Const strHelpOptions = "Beschikbare opties:" & vbCrLf & "a - autopalet uitschakelen" & _
vbCrLf & "b - achtergrondkleur" & _
vbCrLf & "c - kleurenpalet" & _
vbCrLf & "d - donkere paletten altijd proberen" & _
vbCrLf & "e - diffusiefactor" & _
vbCrLf & "f - volledig scherm" & _
vbCrLf & "h - aantal afbeeldingen in geschiedenis" & _
vbCrLf & "i - interval in milliseconden" & _
vbCrLf & "p - start gepauzeerd" & _
vbCrLf & "s - afsluiten bij muisbeweging of toetsaanslag in volledig scherm"
Private Const strHelpOptionsTitle = "Opdrachtregelopties"
Private Const strNotWideEnough = "De afbeelding moet tenminste 320 pixels breed zijn."
Private Const strNotHighEnough = "De afbeelding moet tenminste 200 pixels hoog zijn."
Private Const strWrongBPP = "Alleen ware-kleurafbeeldingen worden ondersteund."
Private Type SafeArrayBound
cElements As Long 'number of elements here
lLbound As Long 'lower bound (usually zero)
End Type
Private Type SafeArray1D
cDims As Integer 'number of dimensions (always one)
fFeatures As Integer 'special flags
cbElements As Long 'size of each element
cLocks As Long 'used to keep track of locking...not important for us
pvData As Long 'pointer to the data this array uses
Bounds(0 To 0) As SafeArrayBound 'bounds (see above)
End Type
Private Type Bitmap
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long 'a pointer to bitmap information
End Type
Private Declare Function GetBitmap Lib "GDI32" Alias "GetObjectA" (ByVal Handle As Long, ByVal Size As Long, Bitmap As Bitmap) As Long
Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (ByVal pDest As Long, pSrc As SafeArray1D, ByVal ByteLen As Long)
Private Declare Function GetSafeArrayAddress Lib "Kernel32" Alias "RtlMoveMemory" ( _
Dest As Long, Source() As Byte, ByVal Size As Long) As Long
Private Declare Function GetArrayDataAddress Lib "Kernel32" Alias "RtlMoveMemory" ( _
Dest As Long, ByVal SafeArrayAdressPlus12 As Long, ByVal Size As Long) As Long
Const aborting = vbObjectError
Dim Pict(0 To 0) As Byte
Dim LowR(0 To 191999) As Byte
'Dim Dest(0 To 191999) As Byte
Dim Dest(0 To 0) As Byte
Dim BPal(0 To 47) As Byte
Dim Pal(0 To 11) As Byte
Dim PicO As Picture
Dim Files As New Collection
Dim Folders As New Collection
Dim Repeat As Collection
Dim Prv As New Collection
Dim Nxt As New Collection
Dim CurPath As String
Dim PrvCount As Long
Dim Abort As Boolean
Dim Delay As Long
Dim UseDarkPalettes As Boolean
Dim ScreenSaverMode As Boolean 'Experimenteel
Dim CurBG As Long
Dim CurPal As Long
Private Sub AutoPalette_Click()
Timer2.Enabled = True
End Sub
Private Sub Back_Click()
Dim C As Long
If Not Pause.Checked Then Pause_Click
Nxt.Add CurPath
C = Prv.Count
CurPath = Prv(C)
Prv.Remove C
On Error GoTo ignore
SelectNewPicture LoadPicture(CurPath)
Dither False
On Error GoTo 0
Repaint
ignore:
End Sub
Private Sub ContextMenu_Click()
NextFolder.Enabled = Files.Count
NextFolder.Checked = Files.Count = 0
AutoPalette.Enabled = Pause.Checked And Not AutoPalette.Checked
If Clipboard.GetFormat(vbCFText) Then
Paste.Enabled = Dir(Clipboard.GetText) <> vbNullString
Else
Paste.Enabled = False
End If
FiveSeconds.Checked = Delay = 5000
TenSeconds.Checked = Delay = 10000
FifteenSeconds.Checked = Delay = 15000
ThirtySeconds.Checked = Delay = 30000
FortyFiveSeconds.Checked = Delay = 45000
OneMinute.Checked = Delay = 60000
Back.Enabled = Prv.Count
Forward.Enabled = Nxt.Count
End Sub
Private Sub Copy_Click()
Clipboard.Clear
Picture1.Width = 320
Picture1.Height = 200
Picture1.AutoRedraw = True
Picture1.PaintPicture Image1.Picture, 0, 0
Clipboard.SetData Picture1.Image
Picture1.AutoRedraw = False
End Sub
Private Sub DiffFactor_Click()
Dim C As Boolean
C = Not DiffFactor.Checked
DiffFactor.Checked = C
Slider1.Visible = C
End Sub
Private Sub FifteenSeconds_Click()
SetDelay 15000
End Sub
Private Sub FiveSeconds_Click()
SetDelay 5000
End Sub
Private Sub FixPalette_Click()
FixPalette.Checked = Not FixPalette.Checked
End Sub
Public Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyUp: NextFolder_Click
Case vbKeyDown: Pause_Click
Case vbKeyLeft: If Prv.Count Then Back_Click
Case vbKeyRight: If Nxt.Count Then Forward_Click
End Select
End Sub
Private Sub Form_Load()
Dim bmp As Bitmap, W As Long, F As String
Dim sa As SafeArray1D
Randomize Timer
'ZWART
BPal(3) = 176 'BLAUW
BPal(7) = 176 'GROEN
BPal(9) = 176: BPal(10) = 176 'CYAAN
BPal(14) = 176 'ROOD
BPal(15) = 176: BPal(17) = 176 'MAGENTA
BPal(19) = 85: BPal(20) = 176 'BRUIN
BPal(21) = 176: BPal(22) = 176: BPal(23) = 176 'WIT
BPal(24) = 85: BPal(25) = 85: BPal(26) = 85 'GRIJS
BPal(27) = 255: BPal(28) = 85: BPal(29) = 85 'FBLAUW
BPal(30) = 85: BPal(31) = 255: BPal(32) = 85 'FGROEN
BPal(33) = 255: BPal(34) = 255: BPal(35) = 85 'FCYAAN
BPal(36) = 85: BPal(37) = 85: BPal(38) = 255 'FROOD
BPal(39) = 255: BPal(40) = 85: BPal(41) = 255 'FMAGENTA
BPal(42) = 85: BPal(43) = 255: BPal(44) = 255 'GEEL
BPal(45) = 255: BPal(46) = 255: BPal(47) = 255 'FWIT
'Hier komen alle standaardwaarden
Delay = Timer1.Interval
PrvCount = 8
SetBG 0
SetPal 0
'Die we hier kunnen overschrijven met de argumenten
Do
W = W + 1
Select Case Mid(Command, W, 1)
Case "/"
Do
W = W + 1
Select Case Mid(Command, W, 1)
Case "a": FixPalette_Click
Case "b": SetBG EatNum(Command, W): HScroll1 = CurBG
Case "c": SetPal EatNum(Command, W): HScroll2 = CurPal
Case "d": UseDarkPalettes = True
Case "e": Slider1.Value = EatNum(Command, W)
Case "f": Image1_DblClick
Case "h": PrvCount = EatNum(Command, W)
Case "i": Delay = EatNum(Command, W)
Case "p": Pause_Click
Case "s": ScreenSaverMode = True
If Forms.Count > 1 Then Form2.ScreenSaverMode = True
Case " ": Exit Do
Case vbNullString: W = W - 1: Exit Do
Case "?", "h"
MsgBox strHelpOptions, vbInformation, strHelpOptionsTitle
End Select
Loop
Case vbNullString: Exit Do
Case " ", """"
Case Else
If Right(Command, 1) = """" Then
F = Mid(Command, W, Len(Command) - W)
Else
F = Mid(Command, W)
End If
If GetAttr(F) And vbDirectory Then
WalkFolders F
If Folders.Count < 2 Then NextFolder.Enabled = False
Set Repeat = New Collection
Else
Files.Add F
Pause.Enabled = False
Pause.Checked = True
FixPalette.Enabled = False
End If
Exit Do
End Select
Loop
GetBitmap Image1.Picture, Len(bmp), bmp
sa.cbElements = 1
sa.cDims = 1
sa.Bounds(0).cElements = bmp.bmHeight * bmp.bmWidthBytes
sa.pvData = bmp.bmBits
GetSafeArrayAddress W, Dest, 4
If W = 0 Then Stop
CopyMemory W, sa, Len(sa)
Left = Screen.Width
Show
If Forms.Count > 1 Then Form2.ZOrder
'Align form just above the center of the screen
Top = (Screen.Height - Height) \ 3
Left = (Screen.Width - Width) \ 2
On Error Resume Next
ShowNextPicture True
End Sub
Private Sub AutoDetectPal(ByVal SI As Boolean, ByVal DP As Boolean)
Dim G As Long, B As Long, K As Long, Y As Long, X As Long, R As Long, P As Long
MousePointer = vbHourglass
'Form1.Enabled = False
DoEvents: If Abort Then Err.Raise aborting
ProgressBar1.Value = 0
ProgressBar1.Max = (1 - DP) * 26
ProgressBar1.Visible = True
G = &H7FFFFFFF
B = 0
K = 0
For Y = 0 To 3 Step 2 + DP
SetPal Y
For X = 0 To 15
SetBG X
Select Case True
Case Pal(0) <> Pal(3), Pal(1) <> Pal(4), Pal(2) <> Pal(5)
Select Case True
Case Pal(0) <> Pal(6), Pal(1) <> Pal(7), Pal(2) <> Pal(8)
Select Case True
Case Pal(0) <> Pal(9), Pal(1) <> Pal(10), Pal(2) <> Pal(11)
R = Dither(True)
P = P + 1
ProgressBar1.Value = P
If R < G Then
If SI Then Repaint
G = R
B = X
K = Y
End If
End Select
End Select
End Select
Next
Next
SetBG B
SetPal K
Dither True
Repaint
ProgressBar1.Visible = False
HScroll1 = B
HScroll2 = K
MousePointer = vbDefault
End Sub
Private Sub Repaint()
Image1.Refresh
If Forms.Count = 2 Then Form2.Image1.Refresh
End Sub
Private Sub Form_Unload(Cancel As Integer)
Abort = True
End Sub
Private Sub FortyFiveSeconds_Click()
SetDelay 45000
End Sub
Private Sub Forward_Click()
Dim C As Long
If Not Pause.Checked Then Pause_Click
Prv.Add CurPath
C = Nxt.Count
CurPath = Nxt(C)
Nxt.Remove C
On Error GoTo ignore
SelectNewPicture LoadPicture(CurPath)
Dither False
On Error GoTo 0
Repaint
ignore:
End Sub
Private Sub HScroll1_Change()
If CurBG = HScroll1 Then Exit Sub
SetBG HScroll1
Dither False
Repaint
End Sub
Private Sub HScroll2_Change()
If CurPal = HScroll2 Then Exit Sub
SetPal HScroll2
Dither False
Repaint
End Sub
Private Function SetBG(ByVal B As Long)
CurBG = B
B = B * 3
Pal(0) = BPal(B)
Pal(1) = BPal(B + 1)
Pal(2) = BPal(B + 2)
End Function
Private Function SetPal(ByVal P As Long)
Dim I(1 To 3) As Long, J As Long, K As Long, L As Long
CurPal = P
Select Case P
Case 0: I(1) = 11: I(2) = 13: I(3) = 15
Case 1: I(1) = 3: I(2) = 5: I(3) = 7
Case 2: I(1) = 10: I(2) = 12: I(3) = 14
Case 3: I(1) = 2: I(2) = 4: I(3) = 6
End Select
For J = 1 To 3
K = K + 3
L = I(J) * 3
Pal(K) = BPal(L)
Pal(K + 1) = BPal(L + 1)
Pal(K + 2) = BPal(L + 2)
Next
End Function
Private Function Dither(ByVal DE As Boolean) As Long
Dim J As Long, K As Long, L As Long, F(0 To 965) As Long, EDC As Single
Dim R As Long, G As Long, B As Long, P As Long, TF As Long, TFoverflow As Boolean
Dim UR As Long, UG As Long, UB As Long
Dim X As Long, Y As Long
If PicO Is Nothing Then Exit Function
EDC = Slider1 / 1000
K = 0
For Y = 0 To 199
L = 0
For X = 0 To 319
B = F(L + 3) * EDC + LowR(K)
G = F(L + 4) * EDC + LowR(K + 1)
R = F(L + 5) * EDC + LowR(K + 2)
P = ClosestColorIndex(R, G, B)
UB = Pal(P)
UG = Pal(P + 1)
UR = Pal(P + 2)
Dest(K) = UB
Dest(K + 1) = UG
Dest(K + 2) = UR
B = B - UB
G = G - UG
R = R - UR
F(L) = F(L) + B
F(L + 1) = F(L + 1) + G
F(L + 2) = F(L + 2) + R
F(L + 3) = B
F(L + 4) = G
F(L + 5) = R
F(L + 6) = F(L + 6) + B * 2
F(L + 7) = F(L + 7) + G * 2
F(L + 8) = F(L + 8) + R * 2
K = K + 3
L = L + 3
Next
If DE Then DoEvents: If Abort Then Err.Raise aborting
Next
P = 0: J = 960: K = 1920: L = 2880
For Y = 0 To 199 Step 4
For X = 0 To 319 Step 4
B = CLng(Dest(P)) + Dest(P + 3) + Dest(P + 6) + Dest(P + 9) + _
Dest(J) + Dest(J + 3) + Dest(J + 6) + Dest(J + 9) + _
Dest(K) + Dest(K + 3) + Dest(K + 6) + Dest(K + 9) + _
Dest(L) + Dest(L + 3) + Dest(L + 6) + Dest(L + 9)
G = CLng(Dest(P + 1)) + Dest(P + 4) + Dest(P + 7) + Dest(P + 10) + _
Dest(J + 1) + Dest(J + 4) + Dest(J + 7) + Dest(J + 10) + _
Dest(K + 1) + Dest(K + 4) + Dest(K + 7) + Dest(K + 10) + _
Dest(L + 1) + Dest(L + 4) + Dest(L + 7) + Dest(L + 10)
R = CLng(Dest(P + 2)) + Dest(P + 5) + Dest(P + 8) + Dest(P + 11) + _
Dest(J + 2) + Dest(J + 5) + Dest(J + 8) + Dest(J + 11) + _
Dest(K + 2) + Dest(K + 5) + Dest(K + 8) + Dest(K + 11) + _
Dest(L + 2) + Dest(L + 5) + Dest(L + 8) + Dest(L + 11)
TF = TF + Abs(16& * LowR(J + 3) - B) * 6 + _
Abs(16& * LowR(J + 4) - G) * 19 + _
Abs(16& * LowR(J + 5) - R) * 11
P = P + 12: J = J + 12: K = K + 12: L = L + 12
Next
P = P + 2880: J = J + 2880: K = K + 2880: L = L + 2880
If DE Then DoEvents: If Abort Then Err.Raise aborting
Next
Dither = TF
End Function
Private Function ClosestColor(ByVal R As Long, ByVal G As Long, ByVal B As Long) As Long
Dim I As Long
I = ClosestColorIndex(R, G, B)
ClosestColor = RGB(Pal(I + 2), Pal(I + 1), Pal(I))
End Function
Private Function ClosestColorIndex(ByVal R As Long, ByVal G As Long, ByVal B As Long) As Long
Dim I As Long, MinDist As Long, MinIndex As Long, RD As Long, GD As Long, BD As Long
MinDist = &H7FFFFFFF '4718592
For I = 0 To 9 Step 3
BD = Pal(I) - B
GD = Pal(I + 1) - G
RD = Pal(I + 2) - R
RD = Abs(RD) * 11 + Abs(GD) * 19 + Abs(BD) * 6
If RD < MinDist Then
MinDist = RD
MinIndex = I
End If
Next
ClosestColorIndex = MinIndex
End Function
Private Sub Image1_DblClick()
Form2.ScreenSaverMode = ScreenSaverMode
Set Form2.Image1.Picture = Image1.Picture
Form2.Show
End Sub
Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbRightButton Then PopupMenu ContextMenu
End Sub
Private Sub NextFolder_Click()
Set Files = New Collection
End Sub
Private Sub OneMinute_Click()
SetDelay 60000
End Sub
Private Sub Paste_Click()
Dim P As String
If Not Clipboard.GetFormat(vbCFText) Then Exit Sub
If Not Pause.Checked Then Pause_Click
P = Clipboard.GetText
On Error GoTo ohno
SelectNewPicture LoadPicture(P)
Dither False
On Error GoTo 0
SetCurPath P
Repaint
Exit Sub
ohno:
MsgBox strCannotPasteImage & vbCrLf & Err.Description, vbExclamation, strCannotPasteImageTitle
End Sub
Private Sub Pause_Click()
If Pause.Checked Then
Pause.Checked = False
Timer1.Enabled = True
Else
Pause.Checked = True
If Not Timer1.Enabled Then
'AutoDetectPal zet dit aan
ProgressBar1.Visible = False
MousePointer = vbDefault
Repaint
Abort = True
Else
Timer1.Enabled = False
End If
End If
End Sub
Private Sub Slider1_Change()
SetBG HScroll1
SetPal HScroll2
Dither False
Repaint
End Sub
Private Sub Slider1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbRightButton Then PopupMenu ContextMenu
End Sub
Private Sub TenSeconds_Click()
SetDelay 10000
End Sub
Private Sub ThirtySeconds_Click()
SetDelay 30000
End Sub
Private Sub Timer1_Timer()
ShowNextPicture False
End Sub
Private Sub ShowNextPicture(ByVal SI As Boolean)
Dim FC As Long, tijd As Single, P As String
Timer1.Enabled = False
tijd = Timer
retry: 'Yuck yuck yuck
DoEvents: If Abort Then Err.Raise aborting
FC = Files.Count
If FC Then
FC = Int(FC * Rnd) + 1
P = Files(FC)
Files.Remove FC
Caption = P
On Error GoTo ohno
SelectNewPicture LoadPicture(P)
If FixPalette.Checked Then
On Error GoTo 0
Dither False
Repaint
Else
On Error GoTo ohno2
AutoDetectPal SI, UseDarkPalettes
On Error GoTo 0
End If
SetCurPath P
Else
FC = Folders.Count
If FC Then
FC = Int(FC * Rnd) + 1
LoadFolder Folders(FC)
Folders.Remove FC
GoTo retry 'Yuck yuck yuck
ElseIf Repeat Is Nothing Then
Timer1.Enabled = False
Else
Set Folders = Repeat
Set Repeat = New Collection
End If
End If
FC = 1000 * (Timer - tijd)
If FC < 0 Then FC = FC + 86400000
FC = Delay - FC
If FC < 1000 Then FC = 1000
Timer1.Interval = FC
Timer1.Enabled = True
Exit Sub
ohno:
Select Case Err
Case 1, 481
'Files.Remove FC
Resume retry
Case aborting
Exit Sub
End Select
Stop
Resume
ohno2:
Select Case Err
Case aborting
Abort = False
Exit Sub
End Select
Stop
Resume
End Sub
Private Sub SelectNewPicture(ByVal NP As Picture)
Dim bmp As Bitmap, WB As Long, W As Long, H As Long, sa As SafeArray1D, Stride As Long
Dim X As Long, Y As Long, I As Long, J As Long, K As Long
Dim XP(0 To 320) As Long, YP(0 To 200) As Long
Dim XPA As Long, XPB As Long, YPA As Long, YPB As Long
Dim IM As Long, JMD As Long, JM As Long, R As Long, G As Long, B As Long, N As Long
Set PicO = NP
GetBitmap NP, Len(bmp), bmp
If bmp.bmBits = 0 Then Err.Raise 1, , strCannotFindPixels
Select Case bmp.bmBitsPixel
Case 24: Stride = 3
Case 32: Stride = 4
Case Else: Err.Raise 1, , strWrongBPP
End Select
sa.cbElements = 1 'each element is a byte
sa.cDims = 1 'one dimensional
sa.Bounds(0).cElements = bmp.bmHeight * bmp.bmWidthBytes
sa.pvData = bmp.bmBits 'points to the data in bitmap
GetSafeArrayAddress W, Pict, 4
If W = 0 Then Stop
CopyMemory W, sa, Len(sa)
WB = bmp.bmWidthBytes
W = bmp.bmWidth
H = bmp.bmHeight
Select Case W * 3 - H * 4
Case 0
Case Is > 0 'Te breed
YPB = H * 4 \ 3
I = (W - YPB) \ 2
W = YPB
XP(0) = I
Case Else 'Te hoog
YPB = W * 3 \ 4
J = (H - YPB) \ 2
H = YPB
YP(0) = J
End Select
If W < 320 Then Err.Raise 1, , strNotWideEnough
If H < 200 Then Err.Raise 1, , strNotHighEnough
XP(320) = W + I
YP(200) = H + J
For X = 1 To 319
XP(X) = X * W \ 320 + I
Next
For Y = 1 To 199
YP(Y) = Y * H \ 200 + J
Next
YPB = YP(0)
For Y = 0 To 199
YPA = YPB
YPB = YP(Y + 1)
XPB = XP(0)
For X = 0 To 319
XPA = XPB
XPB = XP(X + 1)
JMD = XPB - XPA
N = (YPB - YPA) * JMD
JMD = JMD * Stride
R = 0
G = 0
B = 0
I = WB * YPA + XPA * Stride
IM = WB * YPB
While I < IM
J = I
JM = I + JMD
While J < JM
R = R + Pict(J)
G = G + Pict(J + 1)
B = B + Pict(J + 2)
J = J + Stride
Wend
I = I + WB
Wend
LowR(K) = R \ N
LowR(K + 1) = G \ N
LowR(K + 2) = B \ N
K = K + 3
Next
Next
End Sub
Private Sub WalkFolders(P As String)
Dim F As String, SF As New Collection
If Right(P, 1) <> "\" Then P = P & "\" 'Don't care if there's a trailing \ on the commandline
Folders.Add P
F = Dir(P, vbDirectory)
While F <> vbNullString
Select Case F
Case ".", ".."
Case Else
F = P & F
If GetAttr(F) And vbDirectory Then SF.Add F
End Select
F = Dir
Wend
While SF.Count
P = SF(1)
SF.Remove 1
WalkFolders P
Wend
End Sub
Private Sub LoadFolder(P As String)
Dim F As String
F = Dir(P)
While F <> vbNullString
Files.Add P & F
F = Dir
Wend
End Sub
Private Sub Timer2_Timer()
Timer2.Enabled = False
DoEvents
AutoPalette.Checked = True
On Error GoTo ohno2
AutoDetectPal True, False
On Error GoTo 0
AutoPalette.Checked = False
Exit Sub
ohno2:
Select Case Err
Case aborting
Abort = False
Exit Sub
End Select
Stop
Resume
End Sub
Private Sub SetDelay(ByVal D As Long)
Dim I As Long
I = Timer1.Interval - Delay + D
If I < 100 Then I = 100
Timer1.Interval = I
Delay = D
End Sub
Private Function EatNum(S As String, P As Long) As Long
Dim Q As Long
P = P + 1 'Sla het optiesymbool over
Q = P
Do
Select Case Mid(S, Q, 1)
Case "0" To "9"
Case Else: Exit Do
End Select
Q = Q + 1
Loop
EatNum = Val(Mid(S, P, Q - P))
P = Q - 1
End Function
Private Function SetCurPath(P As String)
If CurPath <> vbNullString Then
Prv.Add CurPath
If Prv.Count > PrvCount Then Prv.Remove 1
End If
CurPath = P
End Function
B9A171