Fandom

Visual Basic Wiki

CGA Dither/CGADither.frm

< CGA Dither

70pages on
this wiki
Add New Page
Talk0 Share
Download
Edit
Compatibility:
VB4Yes
VB5untested
VB6untested
VB.NETuntested
The main form that contains most of the code.B9A171

LicenseEdit

Version 3 of the GNU General Public LicenseB9A171

CodeEdit

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

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.