Simple :
1) Execute the code below (no external API, no catch, no virus, no bacteria, etc...)
2) Run the program
3) Press [Escape] key to quit the program
Now, it is ready : you cannot execute this source code anymore !!! (bug ? Only on Windows ?)
To be clear :
- no ASM routine !
- code absolutely without external functions !
- only native functions !
- no registers base touch !
- whatever the debugger is !
- even compiled !
- price : $0.00 it is given ! ! !
and thank you pureBasic !
(be careful : no guaranty, my version : 5.73 LTS x64 DEMO version)
To execute it one more time, change the constant starting number from 5555 to another number.
Code: Select all
Enumeration 5555
#pif
EndEnumeration
Procedure screen()
InitSprite()
InitKeyboard()
InitMouse()
ExamineDesktops()
dw = DesktopWidth(0)
dh = DesktopHeight(0)
dd = DesktopDepth(0)
df = DesktopFrequency(0)
OpenScreen(dw, dh, dd, "", #PB_Screen_SmartSynchronization, df)
FlipBuffers()
EndProcedure
Procedure main01()
Define cycle.I
screen()
Repeat
Delay(33)
ExamineKeyboard()
ExamineMouse()
cycle + 1
cycle & 127
If cycle = 0
ClearScreen(0)
FlipBuffers()
EndIf
Until KeyboardPushed(#PB_Key_All) Or MouseDeltaX() Or MouseDeltaY()
CloseScreen()
EndProcedure
Structure win0
wn0.I
x.I
y.I
iw.I
ih.I
name.S{40}
flags.I
ev.I
evMenu.I
scrSaverDelay.I
itemQuit.I
gdt.I
ftTitle.I
ftCode.I
EndStructure
Procedure rect(x.I, y.I, w.I, h.I, c.I)
Define x2.I = x + w - 1
Define y2.I = y + h - 1
LineXY(x, y, x2, y, c)
LineXY(x, y, x, y2, c)
LineXY(x2, y, x2, y2, c)
LineXY(x, y2, x2, y2, c)
EndProcedure
Procedure monofont(*this.win0, x.I, y.I, w.I, h.I)
With *this
Define lineW.I = w
Define lineH.I = 24
Define mfH.I = Int(h / 24) * 24
DrawingFont(FontID(\ftCode) )
For Yi = y To (y + mfH - 1) Step 0
DrawText(x, Yi, Str((Yi - y) / lineH), RGB(0, 0, 0), RGB(255, 255, 255) )
rect(x, Yi, w, lineH, c)
Yi + lineH
Next
rect(x, y, w, h, RGB(0, 0, 0) )
EndWith
EndProcedure
Procedure gdtRedraw(*this.win0)
With *this
If StartDrawing(CanvasOutput(\gdt) )
DrawingFont(FontID(\ftTitle) )
DrawText(0, 0, "This will be read only one time... ", RGB(0, 127, 0), RGB(255, 255, 255) )
DrawingFont(FontID(\ftCode) )
DrawText(0, 64, "10 PRINT 'Bonjour'", RGB(0, 0, 0), RGB(255, 255, 255) )
monofont(*this, 20, 88, \iw - 40, \ih - 88 - 20)
StopDrawing()
EndIf
EndWith
EndProcedure
Procedure wn0save(*this.win0, fname.S)
Define file.I
With *this
file = CreateFile(#PB_Any, fname)
WriteData(file, *this, MemorySize(*this) )
CloseFile(file)
EndWith
EndProcedure
Procedure wn0load(*this.win0, fname.S)
Define file.I
With *this
file = ReadFile(#PB_Any, fname)
ReadData(file, *this, MemorySize(*this) )
CloseFile(file)
EndWith
EndProcedure
Procedure main()
Define cfgFile.S = "C:\VSA\veille.dat"
Define *this.win0 = AllocateMemory(SizeOf(win0) )
With *this
If FileSize(cfgFile) = -1 Or 0
\x = 100
\y = 100
\iw = 800
\ih = 600
\name = "Test"
\scrSaverDelay = 30000
Else
wn0load(*this, cfgFile)
EndIf
\flags = #PB_Window_SystemMenu | #PB_Window_SizeGadget
\wn0 = OpenWindow(#PB_Any, \x, \y, \iw, \ih, \name, \flags)
\gdt = CanvasGadget(#PB_Any, 0, 0, \iw, \ih, #PB_Canvas_Keyboard)
\ftTitle = LoadFont(#PB_Any, "verdana", 24)
\ftCode = LoadFont(#PB_Any, "courier new", 10)
gdtRedraw(*this)
AddWindowTimer(\wn0, 1, \scrSaverDelay)
\itemQuit = #pif
AddKeyboardShortcut(\wn0, #PB_Shortcut_Escape, \itemQuit)
Repeat
\ev = WaitWindowEvent()
If \ev = #PB_Event_SizeWindow
\iw = WindowWidth(\wn0)
\ih = WindowHeight(\wn0)
ResizeGadget(\gdt, 0, 0, \iw, \ih)
gdtRedraw(*this)
EndIf
If \ev = #PB_Event_Timer
RemoveWindowTimer(\wn0, 1)
main01()
AddWindowTimer(\wn0, 1, \scrSaverDelay)
EndIf
If \ev = #PB_Event_Menu
\evMenu = EventMenu()
EndIf
Until \evMenu = \itemQuit
wn0save(*this, cfgFile)
EndWith
EndProcedure
main()
Code: Select all
Structure win0
wn0.I ; window handle
x.I ; window x position
y.I ; window y position
iw.I ; window width
ih.I ; window height
name.S{40} ; window title
flags.I ; window flags
ev.I ; real-time event code
evMenu.I ; real-time menu item code
scrSaverDelay.I ; screen saver delay
itemQuit.I ; item code to quit
gdt.I ; canvas gadget handle
ftTitle.I ; font for title
ftCode.I ; font for code
EndStructure