FANDOM


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

Ad blocker interference detected!


Wikia is a free-to-use site that makes money from advertising. We have a modified experience for viewers using ad blockers

Wikia is not accessible if you’ve made further modifications. Remove the custom ad blocker rule(s) and the page will load as expected.