Topics

1

Developer's Corner / [FBSL] Environment class - for scripting support

« on: October 05, 2006, 03:13 PM »

Hello,

A great FBSL fan (Ferdinand Piatnik) has developped a very nice tool with it.
This is a 'shell' program like that does a lot of nice things.

Here is the whole description + source code + zipped attachement.

I propose class env as a tool to use with FBSL programs in BAT files.
When instance of class env is created it processes the FBSL program command parameters.
Features are:
options - parameters which begin with with "-" are treated as options.
First character after "-" is saved as option identification, the reminder of parameted is saved as option argument.
Options are processed until non option parameter is found.
fileset expansion - parameters which contain "*" or "?" joker characters are considered as fileset definition
and are expanded to list of files.
Joker characters are allowed anywhere in directory path(except for drive specification)
standard input redirection - parameter which starts with "<" defines STDIN file.
Parameter must be enclosed in quotes(") because of standard DOS(cmd.exe) processing.
standard output redirection - parameter which starts with ">" defines STDOUT file.
When parameter starts with >> then standard output is appended to specified file.
Parameter must be enclosed in quotes(") because of standard DOS(cmd.exe) processing.

These features are not enabled by default.
The Initialize method has three parameters:
%flags - sum of following flags is recognized at this time (-1 covers any present or future options):
env.C_OPT - option proccessing is enabled
env.C_FILES - fileset proccessing is enabled
env.C_STDIO - standard input/output proccessing is enabled
env.C_ESC - escaping of any proccessing is enabled(by prefixing parameter by character "/")
%fAllow - specifies file attributes which are allowed for files to be returned in fileset (when fileset expansion is enabled)
Default value is FILE_ATTRIBUTE_ARCHIVE+FILE_ATTRIBUTE_READONLY
%dAllow- specifies file attributes which are allowed for directories to be examined (when fileset expansion is enabled)
Default values is FILE_ATTRIBUTE_DIRECTORY+FILE_ATTRIBUTE_READONLY

Class env exposes following constants:

C_STDIO = 1 'allow redirection of STDIN, STDOUT
C_FILES = 2 'expand parameters with * and ?
C_ESC = 4 'parameters starting with \ are not processed(\ is trimmed off)
C_OPT = 8 'leading parameters starting with - are processed as options

Methods:

Method getFiles - returns array of files
Parameters:
$fname - file search string - it may contain "*" and "?" characters
$dir (default="") - directory string prepended to search string - must end with "\" ,
"*" and "?" characters are not allowed/processed
%fAllow (default=FILE_ATTRIBUTE_ARCHIVE+FILE_ATTRIBUTE_READONLY)
specifies file attributes which are allowed for files to be returned in fileset
%dAllow(default=FILE_ATTRIBUTE_DIRECTORY+FILE_ATTRIBUTE_READONLY)
specifies file attributes which are allowed for directories to be examined

Method redirectStdIn - specifies standard input file. True is returned if redirection succedes, false otherwise.
Parameter:
$p_fileName (default="")- specifies STDIN file. When "" then default STDIN is restored.

Method redirectStdOut - specifies standard output file. True is returned if redirection succedes, false otherwise.
Parameters:
$p_fileName (default="")- specifies STDOUT file.When "" then default STDOUT is restored.
$p_mode (default="w") - specifies write mode. When "w" text is written to new file. If "a" is specified, then text is appended to existing file.

Method printError writes text to FBSL console even if STDOUT is redirected.
Parameters:
$p_message - text to be written
$p_CRLF - (default=CRLF) - text to be appended to p_message

I could not find problems on my computer.
There is a bug/problem with use of _dup2 function for STDIN, but workaround with use of fflush corrected problems.

In Attachment there are files:
env.inc - env class definition
envDemo.fbs - demo FBSL script - called by demo.bat
demo.bat - BAT script to demonstrate uses of env class. If I knew how, I would make it better.

The Class code :

Code: Text [Select]

1. Class env
2.         #DllDeclare crtdll(_dup As myDup, _dup2 As myDup2, _fileno As myFileNo, fopen As myFopen, fflush As myFflush)
3.         #DllDeclare kernel32(GetStdHandle, WriteConsole)
4.         'http://msdn2.microsoft.com/en-us/library/8syseb29.aspx
5.         '
6.         Private
7.         Shared  %d_stdIn = 0, %d_dupStdIn, %d_newStdIn = 0, %d_stdOut = 0, %d_dupStdOut, %d_newStdOut = 0
8.         Shared  %d_errHandle = 0
9.         '
10.         Function redirect_($p_fileName, $p_mode, %p_old, %p_dup, %p_new)
11.                 Const FAIL = -1
12.                 Const NONE = 0
13.                 Dim %d_tmp, d_handle
14.                 If p_mode = "r" Then
15.                         d_handle = STDIN
16.                 Else
17.                         d_handle = STDOUT
18.                 End If
19.                 If p_old = 0 Then 'get file descriptor and its duplicate  
20.                         p_old = myFileNo(d_handle)
21.                         p_dup = myDup(p_old)
22.                 End If
23.                 If p_fileName = "" Then ' restore old
24.                         If p_new <> 0 Then
25.                                 myFflush(d_handle)
26.                                 If myDup2(p_dup, p_old) = -1 Then
27.                                         Return(FALSE)
28.                                 End If
29.                                 p_new = 0
30.                         End If
31.                 Else
32.                          %d_tmp = myFopen(p_fileName, p_mode) ' open new file
33.                         If d_tmp = NONE Then Return(FALSE) 'failed to open file
34.                          %d_tmp = myFileno(d_tmp) ' get file descriptor from file pointer
35.                         If  %d_tmp = FAIL Then ' 'failed to get file descriptor
36.                                 Return(FALSE)
37.                         Else
38.                                 If myDup2(d_tmp, p_old) = FAIL Then Return(FALSE) 'failure
39.                                 p_new = d_tmp
40.                         End If
41.                 End If
42.                 Return(TRUE)
43.         End Function
44.        
45.         Method Initialize(%flags = 0, _
46.                 %fAllow = FILE_ATTRIBUTE_ARCHIVE + FILE_ATTRIBUTE_READONLY, _
47.                 %dAllow = FILE_ATTRIBUTE_DIRECTORY + FILE_ATTRIBUTE_READONLY)
48.                 Dim %f_stdio = flags BAnd C_STDIO
49.                 Dim %f_files = flags BAnd C_FILES
50.                 Dim %f_esc = flags BAnd C_ESC
51.                 Dim %f_opt = flags BAnd C_OPT
52.                 Dim %i, $v, %ok, $fin = "", $fout = "", $mode = ""
53.                 argv[] = Command(1 - STANDALONE)
54.                 For i = 2 - STANDALONE To CommandCount() - 1
55.                         ok = TRUE
56.                         v = Command(i)
57.                         If f_esc Then
58.                                 If v{1} = "/" Then
59.                                         ok = FALSE
60.                                         f_opt = FALSE
61.                                         argv[] = Mid(v, 2)
62.                                 End If
63.                         End If
64.                         If ok Then
65.                                 If f_opt Then
66.                                         If v{1} = "-" Then
67.                                                 If Mid(v, 2, 1) <> "" Then
68.                                                         options = options & Mid(v, 2, 1)
69.                                                         optv[] = Mid(v, 3)
70.                                                 End If
71.                                                 ok = FALSE
72.                                         Else
73.                                                 f_opt = FALSE
74.                                         End If
75.                                 End If
76.                         End If
77.                         If ok Then
78.                                 If f_stdio Then
79.                                         If v{1} = ">" Then
80.                                                 ok = FALSE
81.                                                 If v{2} = ">" Then
82.                                                         fout = Mid(v, 3)
83.                                                         mode = "a"
84.                                                 Else
85.                                                         fout = Mid(v, 2)
86.                                                         mode = "w"
87.                                                 End If
88.                                         ElseIf v{1} = "<" Then
89.                                                 ok = FALSE
90.                                                 fin = Mid(v, 2)
91.                                         End If
92.                                 End If
93.                         End If
94.                         If ok Then
95.                                 If f_files Then
96.                                         If Instr(v, "*") Or Instr(v, "?") Then
97.                                                 argv = Array_Merge(argv, getFiles(v, "", fAllow, dAllow))
98.                                                 ok = FALSE
99.                                         End If
100.                                 End If
101.                         End If
102.                         If ok Then
103.                                 argv[] = v
104.                         End If
105.                 Next
106.                 argc = Count(argv)
107.                 If fin <> "" Then redirectStdIn(fin)
108.                 If fout <> "" Then redirectStdOut(fout, mode)
109.         End Method
110.         '
111.         Public
112.        
113.        
114.         Dim options = "", optv[], argv[], %argc = 0
115.         Begin Const
116.                 C_STDIO = 1 'allow redirection of STDIN,STDOUT
117.                 C_FILES = 2 'expand parameters with * and ?
118.                 C_ESC = 4 'parameters starting with \ are not processed(\ is trimmed off)
119.                 C_OPT = 8 'leading parameters starting with - are processed as options
120.         End Const
121.        
122.         Method getFiles($fname, $dir = "", _
123.                 %fAllow = FILE_ATTRIBUTE_ARCHIVE + FILE_ATTRIBUTE_READONLY, _
124.                 %dAllow = FILE_ATTRIBUTE_DIRECTORY + FILE_ATTRIBUTE_READONLY)
125.                 #DllDeclare crtdll("_findfirst" As myFFirst, "_findnext" As myFNext, "_findclose" As myFClose)
126.                 'http://msdn2.microsoft.com/en-us/library/kda16keh.aspx
127.                 'fname - path string with optional * and ? joker characters at any position
128.                 'dir - optional base directory - no joker characters allowed (must end with \)
129.                
130.                 Dim arr[]
131.                 Dim %p, %pJoker, %pRest = 0
132.                 Dim $path = dir, $search = fname, $rest, $f
133.                 Dim %fMask = BNot fAllow, %dMask = BNot dAllow
134.                 Dim %fStat, %fHandle, %attr, %searchHandle, $fileInfo * MAX_PATH + 41
135.                 'are there any joker characters?
136.                 pJoker = Instr(search, "*")
137.                 p = Instr(search, "?")
138.                 If p And p < pJoker Then pJoker = p
139.                 '
140.                 If pJoker Then 'jokers exist in search
141.                         p = InstrRev(search, "\", pJoker)
142.                         If p Then
143.                                 path = dir & Left(search, p) 'set new base directory
144.                                 search = Mid(search, p + 1)
145.                         End If
146.                         pRest = Instr(search, "\") 'is joker for directory?
147.                         If pRest Then 'directory with joker characters
148.                                 rest = Mid(search, pRest + 1)
149.                                 search = Left(search, pRest - 1)
150.                         End If
151.                 End If
152.                 fHandle = myFFirst(path & search, @fileInfo)
153.                 fStat = fHandle
154.                 While fStat <> -1
155.                         'f =TO_LPSTR( @fileInfo+20)
156.                         If f{1} <> "." Then
157.                                 attr = GetMem(fileInfo, 0, %4)
158.                                 If pRest Then
159.                                         If Not (attr BAnd dMask) And (attr BAnd FILE_ATTRIBUTE_DIRECTORY) Then arr = Array_Merge(arr, getFiles(rest, path & To_Lpstr(@fileInfo + 20) & "\", fAllow, dAllow))
160.                                 Else
161.                                         If Not (attr BAnd fMask) Then arr[] = path & To_Lpstr(@fileInfo + 20)
162.                                 End If
163.                         End If
164.                         fStat = myFnext(fHandle, @fileInfo)
165.                 Wend
166.                 If fHandle <> -1 Then myFClose(fHandle)
167.                 Return arr
168.         End Method
169.        
170.         Method printError($p_message, p_CRLF = CRLF)
171.                 Dim %d_len, d_buf = $p_message & p_CRLF
172.                 If d_errHandle = 0 Then d_errHandle = GetStdHandle(STD_ERROR_HANDLE)
173.                 WriteConsole(d_errHandle, @d_buf, StrLen(d_buf), @d_len, 0)
174.         End Method
175.        
176.         Method redirectStdIn($p_fileName = "")
177.                 Return(redirect_(p_fileName, "r", d_stdIn, d_dupStdIn, d_newStdIn))
178.         End Method
179.        
180.         Method redirectStdOut($p_fileName = "", $p_mode = "w")
181.                 Return(redirect_(p_fileName, p_mode, d_stdOut, d_dupStdOut, d_newStdOut))
182.         End Method
183. End Class

2

Developer's Corner / [FBSL] LZO compressor

« on: October 01, 2006, 08:39 AM »

Hello,

Here is a simple demonstration of native LZO engine compression/decompression implemented into FBSL.
Enjoy!

Code: Text [Select]

1. #Option Explicit
2. #AppType Console
3.  
4. '// ****************************************************************************
5. '// Simple demonstration of native LZO engine compression/decompression implemented into FBSL
6. '// Author : Gerome GUILLEMIN
7. '// Date : 1st of October 2006
8. '// ****************************************************************************
9. Dim buff, fp
10.  
11. Print "LZO compress..."
12. buff = Compress(FileLoad(".\18 - Wedding idea.mp3"))
13.  
14. If buff <> "" Then
15.         fp = FileOpen(".\compressed.lzo", BINARY_NEW)
16.         If fp Then
17.                 FilePut(fp, buff)
18.                 FileClose(fp)
19.         End If
20. End If
21. Clear buff
22. fp = NULL
23. Pause
24.  
25. Print "LZO decompress..."
26. buff = Decompress(FileLoad(".\compressed.lzo"))
27. If buff <> "" Then
28.         fp = FileOpen(".\decompressed.mp3", BINARY_NEW)
29.         If fp Then
30.                 FilePut(fp, buff)
31.                 FileClose(fp)
32.         End If
33. End If
34. Clear buff
35. fp = NULL
36. Pause

3

Developer's Corner / Tiny 'Touch' 32 bits program in C (3 kb)

« on: September 29, 2006, 02:58 PM »

Hello,

For people who are aware of having an Unix like 'Touch' program, here are the sources + into the zipped attachement, a BAT to compile the source, the compiled source (a 3Kb one)

Code: C [Select]

1. // ********************************
2. // Author : Gerome GUILLEMIN
3. // Coded in pure C using LCC Win32
4. // Date : 29 th of September 2006
5. // ********************************
6. #include <windows.h>
7. #include <stdio.h>
8.  
9. BOOL SetFileToCurrentTime(HANDLE);
10.  
11. int main(int argc, char **argv)
12. {
13.         HANDLE lngHandle = NULL;
14.         char szFileName[MAX_PATH+1];
15.         if ( argc == 2 ) {
16.                 strcpy( szFileName, argv[1] );
17.             lngHandle = CreateFile(szFileName, GENERIC_WRITE,
18.                                         FILE_SHARE_READ | FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0);
19.                 if (lngHandle && lngHandle != INVALID_HANDLE_VALUE) {
20.                         SetFileToCurrentTime( lngHandle );
21.                         CloseHandle( lngHandle );
22.                         return 1; // => 1 will be the OK return
23.                 }
24.         }
25. return 0; // => 0 will be the KO return
26. }
27.  
28. BOOL SetFileToCurrentTime(HANDLE hFile)
29. {
30.   FILETIME ft;
31.   SYSTEMTIME st;
32.  
33.   GetSystemTime(&st);                 // gets current time
34.   SystemTimeToFileTime(&st, &ft);     // converts to file time format
35.   return SetFileTime(hFile,           // sets last-write time for file
36.          (LPFILETIME)NULL, (LPFILETIME)NULL, &ft);
37. }

4

Developer's Corner / [FBSL] FARR's Calc tool updated!

« on: September 26, 2006, 04:25 AM »

Hello,

I've improved my FARR's calculator!

Here's the link : http://gedd123.free....C/FBSLCalc_16-09.zip

How to install Fbslcalc.fbs into FARR ?
-1- Copy FBSLCalc.exe into \FindAndRunRobot\Scripts\
-2- Open FARR and edit Option, select the 'calc'item,and replace its regex config with this one :
calc $$1 | Scripts/FBSLCalc.exe "$$1"
-3- Save

That'all folks!
Now you can play with the newest calc

Usage : FBSLCalc.exe expression

Examples :
basic sample :
Calc 2+2
It'll return '4'

graphical sample :
calc /code=FBSL_Control("Button", Me, "Hello", 1000, 10, 10, 75, 23, 0, 0):show(me):begin events:If CBMsg = WM_COMMAND And CBCTL =1000 then msgbox(0, "Button clicked!", "yoo", 0):end events
it'll afx a form with a button, then just click onto the button...

sample sample :
calc /code=ExecLine(FileLoad("./PMem.fbs"))

Enjoy!

Here is the source of the newest FARR's calc :

Code: Text [Select]

1. #Option Explicit
2. '#AppType Console
3.  
4. If Not STANDALONE Then
5.     Fbsl2Exe( Command(1) ): ExitProgram(0)
6. End If
7.  
8. '// -----------------------------------------------------------------
9. '// GEG 26 September 2006
10. '// FBSLCALC.EXE 2.5/56*PI
11. '// FBSLCALC.EXE /code=msgbox(Null,"Hello","Test",MB_ICONINFORMATION)
12. '// -----------------------------------------------------------------
13. Static $code, $resulttext, $result, $cmd = Command(-1), ch34 = Chr(34), ch92 = Chr(92)
14. If cmd = "" Then
15.     MsgBox(NULL, "You need to specify an expression to evaluate, like 2+2." & crlf & _
16.                 "If you encounter any problems, tell'em there : " & crlf & _
17.                 "http://www.fbsl.net/phpbb2/index.php", _
18.                 "Freestyle Basic Script Langage (FBSL) Calculator:", MB_OK +MB_ICONINFORMATION)
19.     ExitProgram(1)
20. End If
21.  
22. cmd = Replace(cmd, ch34 & ch34, "")
23. If Left(cmd, 1) = ch34 AndAlso Right(cmd, 1) = ch34 Then
24.     cmd = Mid(cmd, 2, StrLen(cmd) - 2)
25. End If
26.  
27. If Instr(cmd,"/code=") Then
28.     cmd = Remove(Trim(cmd), "/code=")
29.     code = "result = " & cmd & " : Return result"
30.     resulttext = cmd & " = " & ExecLine(code)
31. Else
32.     cmd = Replace(Trim(cmd), ",", ".")
33.     code = "result = " & cmd & " : Return result"
34.     ExecLine(code)
35.     result = Replace(result, ".", GetLocalSeparator())
36.     resulttext = cmd & " = " & result
37. End If
38.  
39. If StrLen(cmd) = 0 Then ExitProgram(-1)
40.  
41. ClipboardSetText(result)'resulttext)
42. MsgBox(NULL, resulttext, "Freestyle Basic Script Langage (FBSL) Calculator / Executor:", _
43.        MB_OK+MB_ICONINFORMATION)
44.  
45. Function GetLocalSeparator()
46.     Dim $Buffer * 4
47.     ApiCall( "GetNumberFormat", "kernel32", 0, 0, "1.1", 0, @Buffer, Len(Buffer) )
48.     Return Mid(Buffer,2,1)
49. End Function

5

Developer's Corner / [FBSL] Submit your scripts online

« on: September 24, 2006, 04:03 PM »

Hello,

I've made a graphical application 100% with FBSL that is able to submit your scripts onto an online mySQL database.
Your typed (or picked from disk) script can be submitted online via a simple command button.
More than comments, here are two screenshots that show how this tiny application works.

At first type your code / or pick it from your disk :


And then, admire the submitted sample directly from the Web :


Enjoy!

6

Developer's Corner / [FBSL] M3u list generator

« on: September 09, 2006, 05:02 AM »

Hello,

For people who cares about generating rapidly an M3u list, here's a quick tool that will do it for you.

Just compile it with FBSL and place the compiled file into a known path.

Then from any command line or alike (FARR), you just have to change dir and execute M3u.exe.
Nothing else to do, then the M3u list file will be generated into the target dir!

Enjoy it!

Code: vb.net [Select]

1. #Option Explicit
2. #AppType Console
3.  
4. ' ----------------------------
5. ' -- M3u list generator
6. ' -- GEG 09-09-2006
7. ' ----------------------------
8.  
9. M3u(".\*.mp3", ".\_List.m3u")
10.  
11. Sub M3u($what, $where)
12.         CD CurDir()
13.         Dim %fp, $c, $big, $fil = FindFirst(what), $m3u = where
14.  
15.         While fil <> ""
16.                 big = big & fil & CRLF
17.                 fil = FindNext
18.         Wend
19.  
20.         If Len(big) Then
21.                 fp = FileOpen(m3u, OUTPUT)
22.                 If fp Then
23.                         FilePrint(fp, big)
24.                         FileClose(fp)
25.                 Else
26.                         Print "Error while opening ", m3u
27.                 End If
28.         End If
29.  
30.         Print "Do you want to hear the playlist now [Y]es, [N]o ?";
31.         Do
32.                 c = UCase(ReadChar())
33.         Loop While c = CR OrElse c = LF
34.  
35.         If c = "Y" AndAlso FileExist(m3u) Then
36.                 ApiCall("ShellExecute", "Shell32", NULL, "open", m3u, "", "", SW_SHOW)
37.         Else
38.                 Print "See you later!"
39.                 Sleep(1000)
40.         End If
41. End Sub

7

FBSL - Freestyle Basic Script Langage / Your first Console program

« on: August 13, 2006, 08:08 AM »

Hello,

This will be your first FBSL program.
FBSL is scripting like language that is able to run Console programs as well as Graphical ones...

Let's dive into our first Console program...
Here's the code :

Code: Text [Select]

1. #AppType Console
2. Color(14,0): Cls: Print "Hello World!"
3. Print
4. Print
5. Print "                / `._     .       .      _.' \"
6. Print "              '.@ = `.     \     /     .' = @.'"
7. Print "               \ @`.@ `.    \   /    .' @.'@ / "
8. Print "                \;`@`.@ `.   \ /   .' @.'@`;/  "
9. Print "                 \`.@ `.@ `'.(*).'` @.' @.'/   "
10. Print "                  \ '=._`. @ :=: @ .'_.=' /    "
11. Print "                   \ @  '.'..'='..'.'  @ /     "
12. Print "                    \_@_.==.: = :.==._@_/      "
13. Print "                    /  @ @_.: = :._@ @  \      "
14. Print "                   /@ _.-'  : = :  '-._ @\     "
15. Print "                  /`'@ @ .-': = :'-.@ @`'`\    "
16. Print "                  \.@_.=` .-: = :-. `=._@./    "
17. Print "                    \._.-'   '.'   '-._./      "
18. Print
19. Print "... you just run your first FBSL program!"
20. Print
21. Pause

Just copy/paste it onto your favourite notepad, then save it as myfirstprogram.fbs
Double click onto it and you'll see a nice yeallow butterfly appearing onto a console window telling 'Hello world'

If you want to know more about FBSL and its capabilities, I invite you to download the manual that is a 550 CHM help file that comes with tutorials and language help + extras.
You can grab it there : http://gedd123.free.fr/FBSLv3.exe

Enjoy FBSL!

8

Developer's Corner / FBSL - Fbsl Script Factory

« on: May 25, 2006, 01:25 PM »

Dear all,

As you know, Fbsl project evolves, and onto its basket we have a RAD a la VB in progress...
what you are seeing is 100% Fbsl coded!



Enjoy

9

Developer's Corner / FBSL - Vista & RAD

« on: May 05, 2006, 12:43 PM »

Hello,

Good news !
FBSL is supported under Windows Vista!
It has been tested with success under Vista beta 2

As you can see, FBSL is still in progress and it has a complete RAD à la VStudio.NET if you pay attention to the following screen capture...
This Visual Studio like is 100% developped in FBSL and no extra DLL or specific component is used for this Visual studio like !

Any opinions ?

10

Developer's Corner / FBSL - Special visual effects : how to render raindrops onto a JPG

« on: April 14, 2006, 05:31 PM »

Hello,

This script reveals multithreading capabilities of FBSL v3 inspired by Tom Kenny's Water Effect Demo...

Water _Effect_Demo.fbs

[Select]

'###########################################################################
'
'  Original Name: Tears.fbs
'             Author: Mike Lobko-Lobanovsky ([email protected])
' Creation Date: April 13, 2006
'      Description: This script reveals multithreading capabilities of FBSL v3 inspired by Tom Kenny's Water Effect Demo
'
'###########################################################################
#Option Explicit

#DllDeclare User32("GetClientRect")
#DllDeclare Gdi32("CreateDIBSection")
#DllDeclare Kernel32("RtlMoveMemory", "GetModuleHandle", "GetProcessHeap", "HeapAlloc")

Begin Const
Running = 0 'Thread running flag
DropSize = 4 'Strength (weight) of a drop
XOffset = 8 'X-offset from the left margin of the window
YOffset = 12 'Y-offset from the top of the window
SourceBitmap = 16 'Handle to the original 100x100 pixel tile
DropBitmap = 20 'Handle to the watered 100x100 pixel tile
SourceBits = 24 'Pointer to the original tile's RGB data
DropBits = 28 'Pointer to the watered tile's RGB data
FirstMap = 32 'The initial height map
LastMap = 36 'The last computed height map
WaterProc = 40 'Compute the new height map based on the initial and last height maps
FrameProc = 44 'Set drop bitmap bits according to the currently computed height map
TileProc = 48 'Blit the drop bitmap to the window device context
AnimateProc = 52 'Loop the preceding 3 procs for 60 frames
AnimateArgs = 56 'Pointer to the args for the animation proc
End Const 'len=60 bytes

Begin Const
SRCCOPY = &HCC0020
DIB_RGB_COLORS = 0
HORZRES = 8
VERTRES = 10
End Const

Dim $BmpInfo: FillString(BmpInfo, 40, 0) 'BITMAPINFOHEADER
Dim $TileStruct: FillString(TileStruct, 600, 0) 'Array of 10 tile structures
Dim $TileParams: Alloc(TileParams, 28) 'Parameter array for Tile()
Dim $AnimateParams: Alloc(AnimateParams, 8) 'Parameter array for Animate()


'=======================================================================
' This machine code function processes two height maps to compute the new height map for one
' of the 60 animation frames. It  processes 10,000 pixels with a dozen Peeks and Pokes involved.
' Clearly enough, none of the known interpreters can do it in real time fast enough for the animation
' to look natural. This is the reason why it is written in Assembler.
'=======================================================================
Dim $Water = Data( _
&H55, &H8B, &HEC, &H83, &HEC, &H0C, &H53, &H51, &H52, &H56, &H57, &H6A, &H62, &H8F, &H45, &HF8, _
&H6A, &H06, &H8F, &H45, &HF4, &HDB, &H45, &HF4, &H8B, &H75, &H08, &H8B, &H7D, &H08, &H8B, &H76, _
&H20, &H8B, &H7F, &H24, &HB8, &HC8, &H00, &H00, &H00, &H8D, &H3C, &H38, &H6A, &H02, &H8F, &H45, _
&HFC, &HB9, &H02, &H00, &H00, &H00, &H8D, &H14, &H31, &H0F, &HBE, &H02, &H8D, &H52, &H64, &H0F, _
&HB6, &H5A, &HFF, &H03, &HC3, &H0F, &HB6, &H1A, &H03, &HC3, &H0F, &HB6, &H5A, &H01, &H03, &HC3, _
&H8D, &H52, &H64, &H0F, &HBE, &H5A, &HFE, &H03, &HC3, &H0F, &HBE, &H5A, &HFF, &H03, &HC3, &H0F, _
&HBE, &H5A, &H01, &H03, &HC3, &H0F, &HBE, &H5A, &H02, &H03, &HC3, &H8D, &H52, &H64, &H0F, &HBE, _
&H5A, &HFF, &H03, &HC3, &H0F, &HBE, &H1A, &H03, &HC3, &H0F, &HBE, &H5A, &H01, &H03, &HC3, &H8D, _
&H52, &H64, &H0F, &HBE, &H1A, &H03, &HC3, &H48, &H89, &H45, &HF4, &HDB, &H45, &HF4, &HD8, &HF1, _
&HDB, &H5D, &HF4, &H8B, &H45, &HF4, &H0F, &HBE, &H1C, &H39, &H2B, &HC3, &H8B, &HD8, &HC1, &HE8, _
&H04, &H2B, &HD8, &H83, &HFB, &H02, &H7D, &H02, &H33, &HDB, &H88, &H1C, &H39, &H41, &H3B, &H4D, _
&HF8, &H72, &H83, &H83, &HC7, &H64, &H83, &HC6, &H64, &HFF, &H45, &HFC, &H8B, &H4D, &HFC, &H3B, _
&H4D, &HF8, &H0F, &H82, &H69, &HFF, &HFF, &HFF, &HD9, &H5D, &HF4, &H5F, &H5E, &H5A, &H59, &H5B, _
&H83, &HC4, &H0C, &HC9, &HC2, &H10)

'=======================================================================
' This machine code function takes the new height map bytes, combines them with the source bitmap
' bits and saves the result to the destination bitmap. If the given byte is zero then the resulting bit
' is the same as that in the source bitmap, otherwise some other source pixel is chosen to produce a
' refraction-like picture. Reasons for choosing Assembler are the same as above.
'=======================================================================
Dim $Frame = Data( _
&H55, &H8B, &HEC, &H83, &HEE, &H10, &H53, &H51, &H52, &H57, &H56, &H33, &HC0, &H89, &H45, &HF4, _
&H89, &H45, &HF0, &H8B, &H5D, &H08, &H8B, &H43, &H18, &H89, &H45, &HFC, &H8B, &H43, &H1C, &H89, _
&H45, &HF8, &H8B, &H45, &H08, &H8B, &H70, &H20, &H8B, &H7B, &H24, &H89, &H78, &H20, &H89, &H70, _
&H24, &H33, &HC9, &H8B, &HC1, &H8B, &H55, &HF0, &H85, &HC9, &H74, &H13, &H83, &HF9, &H63, &H73, _
&H0E, &H0F, &HBE, &H7C, &H32, &HFF, &H0F, &HBE, &H5C, &H32, &H01, &H2B, &HDF, &H03, &HC3, &H8B, _
&H5D, &HF4, &H85, &HDB, &H74, &H11, &H83, &HFB, &H63, &H73, &H0C, &H0F, &HBE, &H54, &H32, &H9C, _
&H0F, &HBE, &H3E, &H2B, &HFA, &H03, &HDA, &H85, &HC0, &H79, &H02, &H33, &HC0, &H85, &HDB, &H79, _
&H02, &H33, &HDB, &HBA, &H63, &H00, &H00, &H00, &H3B, &HC2, &H7E, &H02, &H8B, &HC2, &H3B, &HDA, _
&H7E, &H02, &H8B, &HDA, &H42, &HC1, &HE3, &H02, &H0F, &HAF, &HD3, &H8D, &H04, &H82, &H8B, &H55, _
&HF0, &H03, &H45, &HFC, &H0F, &HBE, &H14, &H32, &H0F, &HB6, &H18, &H03, &HDA, &H81, &HFB, &HFF, _
&H00, &H00, &H00, &H7C, &H05, &HBB, &HFF, &H00, &H00, &H00, &H8B, &HFB, &H0F, &HB6, &H58, &H01, _
&H03, &HDA, &H81, &HFB, &HFF, &H00, &H00, &H00, &H7C, &H05, &HBB, &HFF, &H00, &H00, &H00, &HC1, _
&HE3, &H08, &H0B, &HFB, &H0F, &HB6, &H58, &H02, &H03, &HDA, &H81, &HFB, &HFF, &H00, &H00, &H00, _
&H7C, &H05, &HBB, &HFF, &H00, &H00, &H00, &HC1, &HE3, &H10, &H0B, &HFB, &H8B, &H45, &HF0, &H8B, _
&H55, &HF8, &H89, &H3C, &H82, &HFF, &H45, &HF0, &H41, &H83, &HF9, &H64, &H0F, &H82, &H41, &HFF, _
&HFF, &HFF, &H8B, &H4D, &HF4, &H41, &H89, &H4D, &HF4, &H83, &HF9, &H64, &H0F, &H82, &H2F, &HFF, _
&HFF, &HFF, &H5E, &H5F, &H5A, &H59, &H5B, &H83, &HC6, &H10, &HC9, &HC2, &H10)

'=======================================================================
' This machine code function blits the destination bitmap to the screen. This function is part of the
' animation loop written in Assembler therefore it has been written in Assembler too.
'=======================================================================
Dim $Tile = Data( _
&H55, &H8B, &HEC, &H83, &HEE, &H0C, &H57, &H56, &H8B, &H7D, &H08, &H8B, &H75, &H0C, &H6A, &H00, _
&HFF, &H16, &H89, &H45, &HFC, &HFF, &H77, &H14, &HFF, &H75, &HFC, &HFF, &H56, &H08, &H89, &H45, _
&HF8, &HFF, &H76, &H18, &HFF, &H56, &H10, &H89, &H45, &HF4, &H68, &H20, &H00, &HCC, &H00, &H6A, _
&H00, &H6A, &H00, &HFF, &H75, &HFC, &H6A, &H64, &H6A, &H64, &HFF, &H77, &H0C, &HFF, &H77, &H08, _
&H50, &HFF, &H56, &H0C, &HFF, &H75, &HF4, &HFF, &H76, &H18, &HFF, &H56, &H14, &HFF, &H75, &HF8, _
&HFF, &H75, &HFC, &HFF, &H56, &H08, &HFF, &H75, &HFC, &HFF, &H56, &H04, &H5E, &H5F, &HC9, &HC2, _
&H10)

'=======================================================================
' This machine code function animates the refraction. It runs 60 loops each of which comprises a call
' to Water() to produce a new height map, a call to Frame() to combine the height map and the
' source bitmap into a current frame of animation, and a call to Tile() to blit the frame to the screen.
' Then the function calls Sleep() to yield control to other running threads for 10 milliseconds and
' resumes control to run another loop. The function incorporates a loop counter, so Assembler was
' chosen to isolate it from the other threads' counters to make looping persistent after the current
' thread resumes control. The function also clears the 'Busy' flag when thread execution is over.
'=======================================================================
Dim $Animate = Data( _
&H55, &H8B, &HEC, &H83, &HEC, &H04, &H57, &H56, &H6A, &H00, &H8F, &H45, &HFC, &H6A, &H00, &H6A, _
&H00, &H6A, &H00, &H8B, &H7D, &H08, &H57, &HFF, &H57, &H28, &H6A, &H00, &H6A, &H00, &H6A, &H00, _
&H8B, &H7D, &H08, &H57, &HFF, &H57, &H2C, &H6A, &H00, &H6A, &H00, &H8B, &H7D, &H08, &H8B, &H7F, _
&H38, &HFF, &H77, &H04, &H8B, &H7D, &H08, &H57, &HFF, &H57, &H30, &H6A, &H0A, &H8B, &H7D, &H08, _
&H8B, &H7F, &H38, &HFF, &H17, &HFF, &H45, &HFC, &H83, &H7D, &HFC, &H3C, &H72, &HBF, &H33, &HC0, _
&H8B, &H7D, &H08, &H89, &H07, &H5E, &H5F, &HC9, &HC2, &H04)

Sub Main()
'===================================================
' Main entry point
'===================================================
Dim %pTStruct
Dim %BmpBits
Dim %BmpDC = CreateCompatibleDC(NULL)
'===================================================
' One bitmapinfo header will be sufficient to create all the bmps we need
'===================================================
SetMem(BmpInfo, 40, 0) 'size of BITMAPINFOHEADER
SetMem(BmpInfo, 100, 4) 'bmp width
SetMem(BmpInfo, 100, 8) 'bmp height
SetMem(BmpInfo, 1, 12) '# of planes
SetMem(BmpInfo, 32, 14) '32-bit color
'===================================================
' Fill in the Tile() function parameter array
'===================================================
Dim %hModule = GetModuleHandle("Gdi32.dll")
SetMem(TileParams, GetProcAddress(hModule, "CreateCompatibleDC"), 0)
SetMem(TileParams, GetProcAddress(hModule, "DeleteDC"), 4)
SetMem(TileParams, GetProcAddress(hModule, "SelectObject"), 8)
SetMem(TileParams, GetProcAddress(hModule, "BitBlt"), 12)
hModule = GetModuleHandle("User32.dll")
SetMem(TileParams, GetProcAddress(hModule, "GetDC"), 16)
SetMem(TileParams, GetProcAddress(hModule, "ReleaseDC"), 20)
SetMem(TileParams, ME, 24)
'===================================================
' Fill in the Animate() function parameter array
'===================================================
hModule = GetModuleHandle("Kernel32.dll")
SetMem(AnimateParams, GetProcAddress(hModule, "Sleep"), 0)
SetMem(AnimateParams, @TileParams, 4)
'===================================================
' Allocate memory for bitmaps, assembler functions, and assembler
' functions' parameter arrays. Copy the assembler procedure code
' to the allocated space to completely isolate each thread from others.
'===================================================
For pTStruct = @TileStruct To  @TileStruct + 540 Step 60
Poke(pTStruct + DropBitmap, CreateDIBSection(BmpDC, @BmpInfo, DIB_RGB_COLORS, @BmpBits, NULL, NULL))
Poke(pTStruct + DropBits, BmpBits)
Poke(pTStruct + SourceBitmap, CreateDIBSection(BmpDC, @BmpInfo, DIB_RGB_COLORS, @BmpBits, NULL, NULL))
Poke(pTStruct + SourceBits, BmpBits)
Poke(pTStruct + FirstMap, HeapAlloc(GetProcessHeap(), 8, 10000))
Poke(pTStruct + LastMap, HeapAlloc(GetProcessHeap(), 8, 10000))
Poke(pTStruct + WaterProc, HeapAlloc(GetProcessHeap(), 8, Len(Water)))
RtlMoveMemory(Peek(pTStruct + WaterProc, 4), @Water, Len(Water))
Poke(pTStruct + FrameProc, HeapAlloc(GetProcessHeap(), 8, Len(Frame)))
RtlMoveMemory(Peek(pTStruct + FrameProc, 4), @Frame, Len(Frame))
Poke(pTStruct + TileProc, HeapAlloc(GetProcessHeap(), 8, Len(Tile)))
RtlMoveMemory(Peek(pTStruct + TileProc, 4), @Tile, Len(Tile))
Poke(pTStruct + AnimateProc, HeapAlloc(GetProcessHeap(), 8, Len(Animate)))
RtlMoveMemory(Peek(pTStruct + AnimateProc, 4), @Animate, Len(Animate))
Poke(pTStruct + AnimateArgs, HeapAlloc(GetProcessHeap(), 8, Len(AnimateParams)))
RtlMoveMemory(Peek(pTStruct + AnimateArgs, 4), @AnimateParams, Len(AnimateParams))
Next
DeleteDC(BmpDC)
'===================================================
' Set the main window style bits and display the picture
'===================================================
SetWindowLong(ME, GWL_STYLE, &H6000000)
SetWindowLong(ME, GWL_EXSTYLE, &H200)
Fbsl_SetText(ME, "Uriah Heep")
Fbsl_Tile(ME, Fbsl_LoadImage(".\Rain.jpg"))
'===================================================
' Set the initial delay. Let the watcher catch a glimpse of the picture...
' The delay will become shorter as the loop progresses.
'===================================================
SetTimer(ME, 1001, 2000)
Resize(ME, 0, 0, 800, 533)
Center(ME)
Show(ME)
'===================================================
' Make drop positions alter each time the program starts
'===================================================
Randomize
'===================================================
' Run the thread launching loop
'===================================================
Begin Events
Select Case CBMSG
Case WM_TIMER
Storm()
Return 0
Case WM_CLOSE, WM_LBUTTONDOWN, WM_RBUTTONDOWN
CleanUp()
End Select
End Events
End Sub

Sub Storm()
Dim %x, %y, %i, %j, %k, %Dummy
'===================================================
' Set the length of time the program runs
'===================================================
Static %Counter = 200
'===================================================
' Don't let tiles go off the window canvas
'===================================================
Dim $rct: Alloc(rct, 16): GetClientRect(ME, rct)
Dim %WinX = GetMem(rct, 8, 4) - 100
Dim %WinY = GetMem(rct, 12, 4) - 100
Clean rct
Static %Delay = 600
For j = 0 To 9
'==============================================
' Exit the loop at a first vacant tile structure
'==============================================
If Not GetMem(TileStruct, j * 60 + Running, 4) Then Exit For
Next
'===================================================
' A vacant tile structure has been found
'===================================================
If j < 10 Then
'==============================================
' Randomize the tile position
'==============================================
x = RandInt(0, WinX)
y = RandInt(0, WinY)
'==============================================
' Check if this position interferes with any running thread.
' If yes, tile interference occurs which prevents proper
' original picture restoration.
'==============================================
For k = 0 To 9
If GetMem(TileStruct, k * 60 + Running, 4) Then
Dummy = k * 60 + XOffset
If (x > GetMem(TileStruct, Dummy, 4) - 100) And (x < GetMem + 100) Then
Dummy = k * 60 + YOffset
If (y > GetMem(TileStruct, Dummy, 4) - 100) And (y < GetMem + 100) Then
'========================
' Interference: skip the rest of sub
'========================
Exit Sub
End If
End If
End If
Next
'==============================================
' No interference: start a new thread
'==============================================
Dummy = j * 60
'==============================================
' Fill in coordinate offsets and drop size
'==============================================
SetMetrics(Dummy, x, y)
Incr(Dummy, @TileStruct)
'==============================================
' Blit the picture into the source bitmap
'==============================================
BlitSource(Dummy)
'==============================================
' Calculate the initial height map for the drop
'==============================================
CalcDrop(Dummy)
'==============================================
' Launch a new thread
'==============================================
Fbsl_ThreadResume(Fbsl_Thread(Peek(Dummy + AnimateProc, 4), Dummy))
End If
KillTimer(ME, 1001)
Decr(Counter)
If Not Counter Then
PostMessage(ME, WM_CLOSE, 0, 0)
Exit Sub
End If
'===================================================
' Shorten the delay to make the drops fall faster
'===================================================
Decr(Delay, IIf(Delay > 50, 10, 0))
SetTimer(ME, 1001, Delay)
End Sub

Sub SetMetrics(%Index, %x, %y)
'===================================================
' Set the 'Busy' flag to notify the Storm() loop that the thread is running
'===================================================
SetMem(TileStruct, TRUE, Index + Running)
'===================================================
' Store positional data
'===================================================
SetMem(TileStruct, x, Index + XOffset)
SetMem(TileStruct, y, Index + YOffset)
'===================================================
' Randomize the drop strength
'===================================================
SetMem(TileStruct, RandInt(50, 200), Index + DropSize)
End Sub

Sub BlitSource(%pTStruct)
'===================================================
' Blit a part of the picture to the tile's original bitmap
'===================================================
Dim %BmpDC = CreateCompatibleDC(NULL)
Dim %pOldBmp = SelectObject(BmpDC, Peek(pTStruct + SourceBitmap, 4))
Dim %hDC = GetDC(ME)
BitBlt(BmpDC, 0, 0, 100, 100, hDC, %Peek(pTStruct + XOffset, 4), %Peek(pTStruct + YOffset, 4), SRCCOPY)
ReleaseDC(ME, hDC)
SelectObject(BmpDC, pOldBmp)
DeleteDC(BmpDC)
End Sub

Sub CalcDrop(%pTStruct)
'===================================================
' CalcDrop() rolls the peripheral bits into the central "drop" which will
' further be unrolled into concentric circles by calls to Water()
'===================================================
Dim %Depth = Peek(pTStruct + DropSize, 4)
Dim %Radius = Depth >> 3
Dim %Distance
Dim %CalcDepth
Dim %i = 50, %j = i - Radius, %k = i + Radius, %l = Peek(pTStruct + FirstMap, 4), %m, %n, %o
For m = j To k
n = (m - i) ^ 2
For o = j To k
Distance = %SqRt((o - i) ^ 2 + n)
If Distance < Radius Then
CalcDepth = Depth * (Radius - Distance) \ Radius
Poke(l + m * 100 + o, Chr(%CalcDepth))
End If
Next
Next
End Sub

Sub CleanUp()
Dim %pTStruct
'===================================================
' No more new threads in case a mouse button has been clicked
'===================================================
KillTimer(ME, 1001)
'===================================================
' Let the last threads complete drawing
'===================================================
Sleep(1500)
'===================================================
' Clean up the GDI stuff. Memory is released automatically when the
' process exits.
'===================================================
For pTStruct = @TileStruct To @TileStruct + 540 Step 60
DeleteObject(Peek(pTStruct + DropBitmap, 4))
DeleteObject(Peek(pTStruct + SourceBitmap, 4))
Next
ExitProgram(0)
End Sub

And it works in combination with this JPG file :


Enjoy multithreading with FBSL!

11

Developer's Corner / FBSL - Process killer

« on: April 07, 2006, 12:00 PM »

' ------------------------------------------------
' // PROCESS KILLER
' // April, 7th 2006
' // By Gerome GUILLEMIN
' // Requires : WSH COM interface installed
' ------------------------------------------------

Process_killer.fbs

[Select]

#Option Explicit

If standalone = false Then
    Fbsl2exe( Command(1) )
    Exitprogram(1)
End If

#DllDeclare kernel32( "GetEnvironmentVariable" )

Sub Main()
    Dim $strProcess = Inputbox("Process name to kill :", "Name :", "Excel.exe" ), %iResult = 0
    iResult = KillProcess( strProcess )
    $AppType CONSOLE
    Print "--------------------------------------------------------"
    If iResult = 0 Then
        Print "No '" & strProcess & "' process to kill was found :/"
    Else
        Print "Found "& iResult & " '" & strProcess & "' processe(s) to kill :)"
    End If
    Print "--------------------------------------------------------"
    Sleep(2000)
End Sub

' ------------------------------------------------
' // PROCESS KILLER
' ------------------------------------------------
Function %KillProcess( Byval $szProcess, Byval $szPassword = "" )
    Dim $strComputer = GetEnvironmentVar("COMPUTERNAME")
    Dim $strDomain   = GetEnvironmentVar("USERDOMAIN")
    Dim $strUser     = GetEnvironmentVar("USERNAME")

    Dim %objSWbemLocator = CreateObject( "WbemScripting.SWbemLocator" )

    Dim %objWMIService   = GetValue( "%o", objSWbemLocator, ".ConnectServer(%s, %s, %s, %s, %s, %s )", _
                           strComputer, "root\CIMV2", strUser, szPassword, "MS_409", "ntlmdomain:" & strDomain )

    Dim %colProcessList  = EnumBegin( objWMIService, ".ExecQuery(%s)", _
                           "SELECT * FROM Win32_Process WHERE Name = '" & szProcess & "'" )

    Dim %objProcess, %iCounter = 0
    While EnumGetNext( colProcessList, objProcess ) = 0
        Print GetValue( "%s", objProcess, ".Name" ) & " killed!"
        Callmethod( objProcess, ".Terminate" )
        Incr(iCounter)
    Wend

    Releaseobject( objSWbemLocator ): Releaseobject( objWMIService )
    Releaseobject( colProcessList ):  Releaseobject( objProcess )
    Return iCounter
End Function

' ------------------------------------------------
' // GETENVIRONMENTVAR
' ------------------------------------------------
Function GetEnvironmentVar( Byval $sName ) As String
    Dim $GetEnvironmentVar: Alloc( GetEnvironmentVar, 255 )
    GetEnvironmentVariable( sName, GetEnvironmentVar, 255 )
    Return GetEnvironmentVar
End Function

12

Developer's Corner / FBSL - Drawing a nice avatar...

« on: March 30, 2006, 12:27 PM »

Hello,

The following snippet will draw a nice avatar onto a form 
You can use the 'online compiler' to see the results...

[Select]

Dim %hdc = GetDC(ME)
Const WM_DRAW = WM_USER + &H100

Fbsl_SetText(ME, "SideshowBob's Special")
Resize(ME, 0, 0, 50, 150)
Center(ME)
Show(ME)
Draw()

Begin Events
Select Case CBMSG
Case WM_DRAW
Draw()
Case WM_PAINT, WM_NCPAINT
PostMessage(ME, WM_DRAW, 0, 0)
Case WM_CLOSE
ReleaseDC(ME, hdc)
ExitProgram(0)
End Select
End Events

Sub Draw()
'=======
' Hair
'=======
Arc(hdc, 25, 41, 8, 56, 0, 3)
Arc(hdc, 8, 56, 20, 27, 0, -0.3)
Arc(hdc, 20, 28, 0, 38, 0, 3)
Arc(hdc, 0, 38, 24, 13, 0, -0.3)
Arc(hdc, 24, 13, 7, 8, 0, 0.3)
Arc(hdc, 7, 9, 42, 9, 0, -2)
Arc(hdc, 41, 9, 64, 2, 0, -0.4)
Arc(hdc, 64, 4, 53, 13, 0, 2)
Arc(hdc, 53, 14, 79, 22, 0, -2)
Arc(hdc, 79, 22, 62, 21, 0, 0.3)
Arc(hdc, 62, 21, 76, 46, 0, -2)
Arc(hdc, 76, 46, 62, 32, 0, 0.5)
Arc(hdc, 62, 32, 66, 62, 0, -3)
Arc(hdc, 66, 62, 60, 51, 0, 0.5)
Arc(hdc, 61, 41, 48, 67, 0, -0.3)
Arc(hdc, 48, 67, 44, 42, 0, 0.2)
Arc(hdc, 46, 35, 40, 49, 0, -0.1)
Arc(hdc, 40, 49, 34, 35, 0, 0.05)
Arc(hdc, 34, 35, 26, 46, 0, -0.05)
Arc(hdc, 26, 46, 20, 35, 0, 0.05)
Fill(hdc, 30, 30, Rgb(196, 0, 52))
'=======
' Face
'=======
Arc(hdc, 46, 49, 41, 60, 0, 7)
Arc(hdc, 39, 61, 38, 66, 0, -2)
Arc(hdc, 40, 66, 38, 84, 0, 7)
Arc(hdc, 24, 43, 22, 54, 0, 3)
Arc(hdc, 27, 49, 20, 63, 0, 5)
Arc(hdc, 20, 63, 26, 62, 0, 3)
Arc(hdc, 26, 62, 19, 65, 0, -1)
Arc(hdc, 20, 66, 16, 69, 0, 3)
Arc(hdc, 16, 69, 35, 68, 0, 4)
Arc(hdc, 22, 69, 29, 85, 0, 0.1)
Arc(hdc, 29, 83, 28, 95, 0, 7)
Arc(hdc, 28, 93, 38, 84, 0, -0.3)
'=======
' Eyes
'=======
Arc(hdc, 30, 48, 40, 48, 0, 1.4)
Arc(hdc, 29, 50, 40, 50, 0, 0.1)
Arc(hdc, 30, 56, 36, 57, 0, 0.3)
Arc(hdc, 21, 50, 26, 50, 0, 0.1)
PSet(hdc, 23, 51)
PSet(hdc, 35, 51)
PSet(hdc, 40, 62)
Fill(hdc, 30, 45, Rgb(250, 215, 0))
'=======
' Shirt
'=======
Arc(hdc, 15, 90, 50, 90, 0, 0.7)
Arc(hdc, 14, 90, 29, 83, 0, -0.3)
Arc(hdc, 39, 84, 50, 90, 0, -3)
Arc(hdc, 23, 92, 29, 83, 0, -0.3)
Arc(hdc, 38, 94, 44, 85, 0, -0.3)
Arc(hdc, 33, 88, 38, 94, 0, -3)
Fill(hdc, 30, 95, Rgb(55, 115, 44))
End Sub

13

Developer's Corner / FBSL - How to do charts

« on: March 29, 2006, 01:51 PM »

Hello,

FBSL has some GUI primitives that allows user to develop simple but efficient 'charts'.
Here's the code that will make random charts...

Charts.fbs

[Select]

Dim %hdc = GetDC(ME)
Const WM_DRAW = WM_USER + &H100

Fbsl_SetText(ME, "Horns & Hoofs, Inc. (left click to redraw)")
BackColor(hdc, Rgb(255, 255, 0))
Resize(ME, 0, 0, 800, 500)
Center(ME)
Show(ME)
Draw()

Begin Events
Select Case CBMSG
Case WM_DRAW
Draw()
Case WM_PAINT, WM_NCPAINT, WM_LBUTTONDOWN
PostMessage(ME, WM_DRAW, 0, 0)
Case WM_CLOSE
ReleaseDC(ME, hdc)
ExitProgram(0)
End Select
End Events

Sub Draw()
Clear(hdc)
FontTransparent(hdc, TRUE)
DrawArrows(10)
CurrentX(hdc, 20): CurrentY(hdc, 40)
DrawLine(Rgb(0, 0, 255), DRAW_DASH)
CurrentX(hdc, 20): CurrentY(hdc, 120)
DrawLine(Rgb(255, 0, 0), DRAW_DASHDOT)
CurrentX(hdc, 20): CurrentY(hdc, 160)
DrawLine(Rgb(0, 255, 0), DRAW_DASHDOTDOT)
DrawText(200, 20)
DrawBoxes()
DrawArrows(250)
CurrentX(hdc, 320): CurrentY(hdc, 250)
Text(hdc, "Production Turnover")
End Sub

Sub DrawLine(ByVal clr, ByVal style)
Dim %stp = 775 \ 12
DrawStyle(style)
ForeColor(hdc, clr)
For i = stp To 775 Step stp
Line(hdc, CurrentX(hdc), CurrentY(hdc), i, RandInt(1, 4) * 40)
Next
End Sub

Sub DrawText(ByVal x, ByVal y)
ForeColor(hdc, Rgb(0, 0, 255)): CurrentX(hdc, x): CurrentY(hdc, y)
Text(hdc, "Income")
ForeColor(hdc, Rgb(255, 0, 0)): CurrentX(hdc, CurrentX(hdc) + 200)
Text(hdc, "Expenses")
ForeColor(hdc, Rgb(0, 255, 0)): CurrentX(hdc, CurrentX(hdc) + 200)
Text(hdc, "Profit")
End Sub

Sub DrawArrows(ByVal y)
Dim %stp = 775 \ 12
ForeColor(hdc, 0)
DrawStyle(DRAW_SOLID)
DrawWidth(2)
Line(hdc, 10, y, 10, y + 190)
Line(hdc, 10, y, 7, y + 5)
Line(hdc, 10, y, 12, y + 5)
Line(hdc, 10, y + 190, 780, y + 190)
Line(hdc, 780, y + 190, 776, y + 187)
Line(hdc, 780, y + 190, 776, y + 192)
DrawWidth(3)
For i = stp To 775 Step stp
PSet(hdc, i, y + 190)
Text(hdc, i * 12 \ 775 + 1)
Next
For i = y + 30 To y + 160 Step 40
PSet(hdc, 10, i)
Text(hdc, (y + 190 - i) \ 40)
Next
CurrentX(hdc, 18): CurrentY(hdc, y)
Text(hdc, "Bln USD")
CurrentX(hdc, 730): CurrentY(hdc, y + 170)
Text(hdc, "Month")
DrawWidth(1)
End Sub

Sub DrawBoxes()
Dim %stp = 775 \ 12
DrawStyle(DRAW_SOLID)
For i = stp To 775 Step stp
FillStyle(RandInt(0, 6))
FillColor(Rgb(%RandInt(0, 255), %RandInt(0, 255), %RandInt(0, 255)))
Line(hdc, i - 3, 400 - %RandInt(0, 3) * 40, i - 47, 438, _
Rgb(%RandInt(0, 255), %RandInt(0, 255), %RandInt(0, 255)), _
TRUE, %RandInt(0, 1))
Next
End Sub

Here's a screnshot of the result:

Enjoy

14

Developer's Corner / FBSL - Newest version with a 525 pages help file available!

« on: March 28, 2006, 04:31 PM »

Hello,

A newest FBSL version with a 525 pages help file are now available!
Check the links below...
Enjoy;)

15

Developer's Corner / FBSL - Pocket URLs

« on: March 18, 2006, 05:02 PM »

Hello,

Here's a little FBSL tool that allows you to have your favourite URLs near from your mouse...


The full script + an URL list can be found there :
http://gedd123.free.fr/Fbsl/DC/Pocket_URLs.zip

The .FBS script can be compiled with the online studio compiler there :
http://gedd123.free.fr/studio

Now you can edit/modify/add/save!

Enjoy

16

Developer's Corner / FBSL - How to use machine code to get your CPU name

« on: March 18, 2006, 06:59 AM »

Hello,

FBSL and machine code are not incompatible...
You can use the FBSL online compiler to see the results : http://gedd123.free..../studio/fbsl2exe.php

[Select]

#Option Explicit

'// The last one is 0 to null-terminate
Dim $CPUName    : Alloc( CPUName, 13 )

'// Set up machine code
Dim MachineCode = Data(&H55,&H8B,&HEC,&H57,&H52,&H51,&H53,&H8B,&H45,&H8,&HF,_
                  &HA2,&H8B,&H7D,&HC,&H89,&H1F,&H8B,&H7D,&H10,&H89,&HF,&H8B,_
                  &H7D,&H14,&H89,&H17,&H58,&H59,&H5A,&H55,&HC9,&HC2,&H10,&H0_
                  )

'// Calls the machine code
CallAbsolute( MachineCode, 0, @CPUName, @CPUName+8, @CPUName+4)
MsgBox(0, CpuName, "You CPU is...", 0)

17

Developer's Corner / FBSL - Bouncing balls

« on: March 18, 2006, 06:13 AM »

Hello,

Wanna see bouncing balls ?
You can compile the following script there : http://gedd123.free..../studio/fbsl2exe.php

[Select]

#Option Explicit
$DllDeclare user32("BeginPaint","EndPaint","GetSystemMetrics","SetWindowPos","GetDC","ReleaseDC",_
"SystemParametersInfoA","ShowCursor","GetClientRect","SetRect","FillRect")
$DllDeclare gdi32("CreateSolidBrush","CreatePen","Ellipse")

Dim %width,%height,$RECT
Dim %hDCgame,%color_pen,%color_brush,%black_pen,%black_brush
Dim %i
Dim %x,%y
Dim %xball = ScNew(),%yball = ScNew()   ,%xspeed = ScNew(),%yspeed = ScNew()
FillString( xball, 40, 0 ): FillString( yball, 40, 0 ): FillString( xspeed, 40, 0 ): FillString( yspeed, 40, 0 )

Dim $PS
FillString(PS,64,0)
Dim %hDWDC,%hMemDC,%hBitmap,%hOldBitmap

Begin Const
   SM_CXSCREEN = 0 'X Size of screen
   SM_CYSCREEN = 1 'Y Size of Screen
   SPI_SETSCREENSAVEACTIVE = 17
   HWND_TOPMOST = -1
   SWP_NOMOVE = 2
   OEM_CHARSET = 255
End Const

Begin Const
   GAME_SPEED = 33 'speed of game (increase to go slower)
   PS_SOLID = 0
   SRCCOPY = &HCC0020
End Const

Sub Main()
   GameInit()
   Begin Events
      Select Case CBMsg
         Case WM_TIMER
            Paint()
         Case WM_LBUTTONDOWN
            GameQuit()
         Case WM_ERASEBKGND
            ' Say we handled it
            Return 1
         Case WM_PAINT
            BeginPaint(Me,PS)
            EndPaint(Me,PS)
            Paint()
      End Select
   End Events
End Sub

Sub Paint()
   GetClientRect(Me,RECT)
   hDCgame = GetDC(Me) 'get the DC
   ' Our hidden buffer to hide the drawing process
  hMemDC = CreateCompatibleDC(hdcgame)
  ' Create a bitmap for that offscreen buffer
  hBitmap = CreateCompatibleBitmap(hdcgame,width,height)
  hOldBitmap = SelectObject(hMemDC,hBitmap)
   'Erase the background
  black_brush = CreateSolidBrush(RGB(0,255,0))
  FillRect(hMemDC,Rect,black_brush)
  DeleteObject(black_brush)
  'Draw the stuff onto the memdc backbuffer
  hDWDC=hMemDC : GameLoop()
  '..and when you are done, blit the final result onto the actual screen buffer
  BitBlt(hdcgame,0,0,width,height,hMemDC,0,0,SRCCOPY)
  SelectObject(hMemDC,hOldBitmap) 'select the old bitmap into hMemDC
  DeleteDC(hMemDC)
  Deleteobject(hBitmap)
  ReleaseDC(me,hdcgame)
End Sub

Sub GameLoop()
   For i = 0 To 36 Step 4
      ' save the x and y position of current ball
            x = GetMem(xball,i,4): y = GetMem(yball,i,4)
            ' then move them
            x = x + GetMem(xspeed,i,4)
            y = y + GetMem(yspeed,i,4)
            ' check if out of range on x axis
            If (x < 0 OR x > width - 32) Then
               ' if so bounce and push back
               SetMem( xspeed, - GetMem(xspeed,i,4), i )
                  x = x + GetMem(xspeed,i,4)
            End If
            ' check if out of range on y axis
            If (y < 0 OR y > HEIGHT - 32) Then
               ' if so bounce and push back
               SetMem( yspeed, - GetMem(yspeed,i,4), i )
                  y = y + GetMem(yspeed,i,4)
            End If
            ' after move redraw them in new position
            SelectObject(hDWDC, color_pen)
            SelectObject(hDWDC, color_brush)
            Ellipse(hDWDC, x, y, x + 32, y + 32)
            ' store the new x and y position
            SetMem( xball, x, i ) : SetMem( yball, y, i )
   Next
End Sub

Sub GameQuit()
    DeleteObject(color_pen)
    DeleteObject(color_brush)
    DeleteObject(black_pen)
    DeleteObject(black_brush)
   ReleaseDC(me, hDCgame)
   ScFinalize(xball):ScFinalize(yball)
   ShowCursor(1)
   ExitProgram(0)
End Sub

Sub GameInit()
   FillString(RECT,20,0)
   Center(Me)
   width  = GetSystemMetrics(SM_CXSCREEN) + 15
   height = GetSystemMetrics(SM_CYSCREEN)
   Resize( Me, 0, 0, width,height )
   SetWindowLong(Me,GWL_STYLE,WS_CHILD+WS_VISIBLE)
   SetWindowPos(Me,HWND_TOPMOST,0,0,width,height,SWP_NOMOVE)
   'ShowCursor(0)
   color_pen = CreatePen(PS_SOLID, 1, RGB(0,0,0))
   color_brush = CreateSolidBrush(RGB(255,0,0))
   'black_pen = CreatePen(PS_SOLID, 1, RGB(0,0,0))
   black_brush = CreateSolidBrush(RGB(0,0,0))
   'set initial position and speed of balls
   Randomize
   For i = 0 To 36 Step 4
      SetMem( xball, randint(0,width), i )
      SetMem( yball, randint(0,height), i )
      SetMem( xspeed, randint(5,30), i )
      SetMem( yspeed, randint(5,30), i )
   Next
   Show(me)
   SetTimer(Me,null,GAME_SPEED)
End Sub

18

Developer's Corner / FBSL - Multithreaded GUI Application

« on: March 15, 2006, 05:49 PM »

Hello,

JFYI, here is a Multithreaded GUI Application that shows FBSL capacities at managing threads...
You can use the Online compiler to see the result onto your machine

[Select]

' ==============================================
' Derived from: SpiralGraph 2.0 by Scott Frick
' ==============================================
'#################################################################################
' COMPILER OPTIONS
'#################################################################################
#Option Explicit

'#################################################################################
' PROTOTYPES
'#################################################################################
#DllDeclare Kernel32("CreateSemaphore", "ReleaseSemaphore", "WaitForSingleObject")
#DllDeclare User32("InvalidateRect", "GetDC")
#DllDeclare Gdi32("SetPixelV")

'#################################################################################
' CONSTANTS
'#################################################################################
Const mt = 10 'Max thread count
Const time2draw = 100 'Max time a thread draws its spiral
Const INFINITE = -1

'#################################################################################
' INITIALIZED DATA
'#################################################################################
Dim %tc = 1 'Initial thread count
Dim %hSpiral = CreateSemaphore(NULL, mt, mt, NULL) 'Create semaphore object used to control the amount of threads

Dim x: Alloc(x, 8 * mt) 'Equation variables, used for drawing spirals
Dim y: Alloc(y, 8 * mt)
Dim a: Alloc(a, 8 * mt)
Dim b: Alloc(b, 8 * mt)
Dim h: Alloc(h, 8 * mt)
Dim t: Alloc(t, 8 * mt)
Dim kol: Alloc(kol, 4 * mt)
Dim toggle: Alloc(toggle, 4 * mt)

Dim #speed = 0.51 'Initial speed setting

Dim %MainMenu = CreateMenu() 'That's not a true menu, just a quick help note
Dim %Max_X = 800, %Max_Y = 600 'Window size, used to calculate spiral size and placement
Dim %PauseSpiral = TRUE 'Pause flag

'#################################################################################
' BEGIN CODE SECTION
'#################################################################################
Fbsl_SetText(ME, "Multi Graph")
Resize(ME, 0, 0, 800, 600) 'Size the form
InsertMenu(MainMenu, 1, MF_STRING, 2, _
"*SPEED* = (+ or - or Mouse Wheel)     *ERASE* = (SpaceBar or Left Click)     *PAUSE* = (0 or Right Click)     *THREAD COUNT* = (1 to 9)")
SetMenu(ME, MainMenu)
SetTimer(ME, 1, 4000) 'Timer to change the spirals' settings every 4 secs
SetTimer(ME, 2, time2draw / tc) 'Timer to set the draw time for each thread
Fbsl_SetFormColor(ME, 0) 'Make the form black
Center(ME)
Show(ME)
ReleaseSemaphore(hSpiral, mt, NULL) 'Release semaphore to initilize
Randomize 'Make sure the spirals are different each time the app starts
ChangeSpiral(tc) 'Modify the variables giving the spirals a random look

'===========================
' Main events loop
'===========================
Begin Events
Dim %i
Select Case CBMSG
Case WM_MOUSEWHEEL
'===========================
' Adjust the drawing speed
'===========================
Select Case CBWPARAM
Case 7864320
'================
' Wheel forward
'================
IncreaseSpeed()
Case - 7864320
'================
' Wheel back
'================
DecreaseSpeed()
End Select
Case WM_KEYDOWN
If CBWPARAM > 48 And CBWPARAM < 58 Then
'======================
' Choose the number of threads
'======================
InvalidateRect(ME, NULL, TRUE)
tc = CBWPARAM - 48
SetTimer(ME, 2, time2draw / tc)
ChangeSpiral(tc)
Else If CBWPARAM = 48 Then
'======================
' 0 pauses the drawing process
'======================
PauseSpiral = Not PauseSpiral
Else If CBWPARAM = 32 Then
'======================
' Space bar clears the form
'======================
InvalidateRect(ME, NULL, TRUE)
ChangeSpiral(tc)
Else If CBWPARAM = 107 Or CBWPARAM = 187 Then
'======================
' Plus key (white and gray)
'======================
IncreaseSpeed()
Else If CBWPARAM = 109 Or CBWPARAM = 189 Then
'======================
' Minus key (white and gray)
'======================
DecreaseSpeed()
End If: End If: End If: End If: End If
Case WM_LBUTTONDOWN
'===========================
' Clear the form
'===========================
InvalidateRect(ME, NULL, TRUE)
ChangeSpiral(tc)
Case WM_RBUTTONDOWN
'===========================
' Pause the drawing process
'===========================
PauseSpiral = Not PauseSpiral
Case WM_PAINT
For i = 1 To tc
'======================
' Wait till semafore is released
'======================
WaitForSingleObject(hSpiral, INFINITE)
'======================
' Launch a new thread
'======================
Fbsl_ThreadResume(Fbsl_Thread(AddressOf CalcSpiral))
Next
Case WM_TIMER
'===========================
' Change or draw a spiral
'===========================
If PauseSpiral Then
Select Case CBWPARAM
Case 1
'===========
' Timer #1
'===========
ChangeSpiral(tc)
Case 2
'===========
' Timer #2
'===========
WaitForSingleObject(hSpiral, INFINITE)
Fbsl_ThreadResume(Fbsl_Thread(AddressOf CalcSpiral))
End Select
End If
Case WM_SIZE
'===========================
' Adjust the variables
'===========================
Max_X = LoWord(CBLPARAM)
Max_Y = HiWord(CBLPARAM)
Case WM_CLOSE
'===========================
' Clean up and terminate
'===========================
KillTimer(ME, 1)
KillTimer(ME, 2)
ExitProgram(0)
End Select
End Events

'===========================
' Increase the speed smoothly
'===========================
Sub IncreaseSpeed()
If speed < 15 And speed > 5 Then
speed = speed + 0.5
SetTimer(ME, 1, 1000)
Else If speed <= 5 And speed > 1 Then
speed = speed + 0.1
SetTimer(ME, 1, 2000)
Else If speed <= 1 And speed > 0.5 Then
speed = speed + 0.05
SetTimer(ME, 1, 4000)
Else If speed <= 0.5 Then
speed = speed + 0.025
End If: End If: End If: End If
End Sub

'===========================
' Decrease the speed smoothly
'===========================
Sub DecreaseSpeed()
If speed > 2 Then
speed = speed - 0.5
Else If speed > 1 And speed <= 2 Then
speed = speed - 0.1
SetTimer(ME, 1, 3000)
Else If speed > 0.5 And speed <= 1 Then
speed = speed - 0.1
SetTimer(ME, 1, 4000)
Else If speed > 0.1 And speed <= 0.5 Then
speed = speed - 0.05
SetTimer(ME, 1, 8000)
End If: End If: End If: End If
End Sub
 
'===========================
' Change the pattern and color
'===========================
Sub ChangeSpiral(ndx)
Dim %k, %kval, %red, %green, %blue, #xval = Max_X / 400 + 0.2
Dim %LocalToggle = -1
For k = 0 To ndx - 1
kval = k << 3
red = Rnd() * 255
blue = Rnd() * 255
green = Rnd() * 255
SetMem(kol, Rgb(red, green, blue), kval >> 1)
SetMem(a, Rnd() * 65 + 3 * k, kval)
SetMem(b, Rnd() * 45 + 3 * k, kval)
SetMem(h, Rnd() * 35 + 3 * k, kval)
SetMem(a, GetMem(a, kval, #8) * xval, kval)
SetMem(b, GetMem(b, kval, #8) * xval, kval)
SetMem(h, GetMem(h, kval, #8) * xval, kval)
SetMem(t, Rnd() * 5 * k + 25, kval)
SetMem(toggle, LocalToggle, kval >> 1)
LocalToggle = -LocalToggle
Next
End Sub

'===========================
' Calculate and draw part of a spiral
'===========================
Sub CalcSpiral()
Static  %counter = 1
Dim %i, %j, %hdc
Dim #aval, #bval, #hval, #tval, #sum, #div
If counter < tc - 1 Then
Incr(counter)
Else
counter = 0
End If
j = counter << 3
aval = GetMem(a, j, #8)
bval = GetMem(b, j, #8)
hval = GetMem(h, j, #8)
sum = aval + bval
div = sum / bval
'===============================
' 1 loop = 1 pixel
'===============================
For i = 1 To 400
SetMem(t, GetMem(t, j, #8) + 0.01132 * speed, j)
tval = GetMem(t, j, #8)
If GetMem(toggle, j >> 1, 4) = 1 Then
SetMem(x, (sum * Cos(tval)) - (hval * (Cos(div * tval))) + (Max_X >> 1), j)
Else
SetMem(x, (sum * Cos(tval)) + (hval * (Cos(div * tval))) + (Max_X >> 1), j)
End If
SetMem(y, (sum * Sin(tval)) - (hval * (Sin(div * tval))) + (Max_Y >> 1), j)
hdc = GetDC(ME)
SetPixelV(hdc, %GetMem(x, j, #8), %GetMem(y, j, #8), GetMem(kol, j >> 1, 4))
ReleaseDC(ME, hdc)
Next
'===============================
' Release semafore to allow a new thread in
'===============================
ReleaseSemaphore(hSpiral, 1, NULL)
End Sub
'#################################################################################
' END PROGRAM CODE
'#################################################################################

I just bet my trousers that Ahk is not capable of this?...

19

Developer's Corner / FBSL - A simple Web browser

« on: March 12, 2006, 04:20 PM »

Hello,

A simple web browser with a mutex that allows to execute more than one instance at a time

[Select]

#Option Explicit

#DllDeclare atl.AtlAxWinInit
Dim %hMutex, $URL, %hDisplay

' // Create a Mutex : only ONE instance is allowed !!
hMutex = ApiCall("CreateMutex", "kernel32", 0, 1, "__MUTEX__Browser__")
If GetLastError() = 183 Then ExitProgram(-1)

Fbsl_SetText(ME, "==FBSL Basic Web Browser==")
Resize(ME, 0, 0, 600, 500)
Center(ME)

Const hURL = Fbsl_Control("Edit", ME, "http://www.fbsl.net", 0, 10, 3, 368, 23, _
WS_CHILD + WS_VISIBLE + WS_TABSTOP + ES_AUTOHSCROLL, WS_EX_CLIENTEDGE)
Const IDB_Go = 1000
Fbsl_Control("Button", ME, "Go", IDB_Go, 380, 3, 75, 23, WS_CHILD + WS_VISIBLE + WS_TABSTOP, 0)
AtlAxWinInit(0)
hDisplay = Fbsl_Control("AtlAxWin", ME, "MSHTML:<HTML></HTML>", _
0, 0, 30, 600, 460, WS_CHILD + WS_VISIBLE, WS_EX_CLIENTEDGE)
Show(ME)
RefreshMe()

Begin Events
    Select Case CBMSG
        Case WM_SIZE
            RefreshMe()
        Case WM_CLOSE
            ExitProgram(0)
        Case WM_COMMAND
            If CBCTL = IDB_Go Then EventGo()
    End Select
End Events

Sub EventGo()
    Fbsl_GetText(hURL, URL)
    If URL = "" Then Return
    If (hDisplay <> 0) Then Destroy(hDisplay)
    hDisplay = Fbsl_Control("AtlAxWin", ME, URL, 0, 0, 30, 600, 460, _
    WS_CHILD + WS_VISIBLE + WS_VSCROLL + WS_HSCROLL, WS_EX_CLIENTEDGE)
    RefreshMe()
End Sub

Sub RefreshMe()
    Dim %Lefti, %Topi, %Righti, %Bottomi
    GetClientRect(ME, Lefti, Topi, Righti, Bottomi)
    Resize(hDisplay, 10, 30, Righti - 25, Bottomi - 70)
End Sub

20

Developer's Corner / Farr's ADDNOTE

« on: March 12, 2006, 03:57 PM »

Hello,

Mouser asked me an addnote tool for his Farr tool...
Here's the beast that can be compiled there : http://gedd123.free..../studio/fbsl2exe.php

[Select]

' // ------------------------------------------------------------------
' // Addnote -clip|-timestamp|-top YOURMESSAGE_UNDERSCORES_MEAN_CRLF :)
' // ------------------------------------------------------------------

Dim $szCmd1, $szCmdFull, %fp, $szTemp
Begin Const
    file = ".\addnote.txt"
    sepa = "------------------------------------"
End Const

If STANDALONE = TRUE Then
    szCmd1 = LCase(Command(1))
    szCmdFull = Remove(Command(-1), szCmd1)
    szCmdFull = Replace(szCmdFull, "_", CRLF)
    szCmdFull = Trim(szCmdFull)
   
    szCmdFull = Replace(szCmdFull, ch34 & ch34, "")
    If Left(szCmdFull, 1) = ch34 AndAlso Right(szCmdFull, 1) = ch34 Then szCmdFull = Mid(szCmdFull, 2, StrLen(szCmdFull) - 2)
    szCmdFull = Trim(szCmdFull)
    If StrLen(szCmdFull) = 0 Then ExitProgram(-1)
   
    Select Case szCmd1
        Case "-clip"
            fp = FileOpen(file, APPEND)
            FilePrint(fp, szCmdFull)
            FilePrint(fp, sepa)
            ClipboardSetText(szCmdFull)
            FileClose(fp)
        Case "-timestamp"
            'March 12, 2006 - 19:35:27 PM
            fp = FileOpen(file, APPEND)
            FilePrint(fp, GetMonth(Time(6)) & " " & Time(7) & ", " & Time(5) & " - " & _
            Time(1) & ":" & Time(2) & ":" & Time(3) & " " & Time(4))
            FilePrint(fp, szCmdFull)
            FilePrint(fp, sepa)
            FileClose(fp)
        Case "-top"
            fp = FileOpen(file, BINARY_INPUT)
            szTemp = FileGet(fp, FileLen(file))
            FileClose(fp)
            fp = FileOpen(file, OUTPUT)
            FilePrint(fp, szCmdFull)
            FilePrint(fp, sepa)
            FilePrint(fp, szTemp)
            FileClose(fp)
    End Select
End If

Function  $GetMonth(ByVal  %iMonth)
    Select Case iMonth
        Case 1
            Return "January"
        Case 2
            Return "February"
        Case 3
            Return "March"
        Case 4
            Return "April"
        Case 5
            Return "May"
        Case 6
            Return "June"
        Case 7
            Return "July"
        Case 8
            Return "August"
        Case 9
            Return "September"
        Case 10
            Return "October"
        Case 11
            Return "November"
        Case 12
            Return "December"
    End Select
End Function

So mouser?

21

Developer's Corner / FBSL - A brand new FBSL code editor

« on: March 09, 2006, 05:59 PM »

Hello!

FBSL v3 has a brand new code editor!

This brand new version is now capable of :
- checking your typos at runtime!
- exporting your script in HTML



Enjoy

22

Developer's Corner / Farr's 'Calc' program completely revisited!

« on: March 07, 2006, 05:17 PM »

Hello!

Mouser can now execute this Fbsl script that is a complete replacement of his 'Calc' tool integrated into his nice Farr program!

With this version you can now use Farr like this :

Calc 1+1
and then it'll give '2' as result : ok classical and same like before...

But, one can also type this :
Calc apicall( "MessageBox", "user32", null, "Fbsl & Farr powah!", "Mouser!", MB_OK )

And then the complete expression will be executed and a messagebox will tell you "Fbsl & Farr powah!"
That is to say that this single executable allows you not only to execute common maths tasks, but you can also execute the whole things that Fbsl allows you to do aka : API, COM, REGEX, MATHS and more than 300 inner functions + your own ones at runtime via Farr!

[Select]

$AppType GUI
' // GEG 07 March 2006
if standalone = false then
fbsl2exe(command(1))
ExitProgram(0)
end if
Dim $cmd = Remove(command(-1), APPEXEPATH & APPEXENAME)
if cmd = "" Then
Msgbox(Null, "You need to specify an expression to evaluate, like 2+2.", "Freestyle Basic Script Langage (FBSL) Calculator:", MB_OK)
ExitProgram(1)
End If
Dim $code = "Dim $result = " & cmd & " : Return result"'
Dim $resulttext = cmd & " = " & Execline(code)
ClipBoardSetText( $resulttext)
Msgbox(Null, $resulttext, "Freestyle Basic Script Langage (FBSL) Calculator / Executor:", MB_OK)

Complete compiled program is located there :
http://gedd123.free.fr/Fbsl/FBSLCalc.zip

And then replace your actual FBSLCalc.exe located into \Program Files\FindAndRunRobot\Scripts
with this brand new one!


Enjoy!
Feedback appreciated

23

Developer's Corner / FBSL - Online XML Database Snippits

« on: February 12, 2006, 07:05 PM »

Hello,

Here's my online XML Database code repository that handles 170 FBSL snippets...


For people who want to know more about this tool, please read this post :
http://www.fbsl.net/.../viewtopic.php?t=636

Enjoy Fbsl !

24

Developer's Corner / FBSL - Xml snippet database

« on: February 11, 2006, 06:46 AM »

Hello,

I've made a simple GUI interface that is able to load an XML database.
It is oriented to hold snippets script code.

Here's a capture of the project :


And now the source code :

[Select]

' ---------------------------------------------
' XML data base reader by Gerome GUILLEMIN
' Cool XML DOM documentation can be found there :
' http://www.devguru.com/Technologies/xmldom/quickref/xmldom_index.html
' ---------------------------------------------
$Apptype GUI
#Option Explicit
ComWarnings(False)
'$Trace On

Dim %obj, %cnodes, %wdrange, $S1, %i, %j, %k, $strerr, %NodeList, %numNodes, %bLoad, %bLastEntity
Dim %TopWin, %leftWin, %RightWin, %BottomWin, %NodeListCount, $fp, %mb

LoadLibrary("Riched20.dll")
Macro CRichEdit( Caption, hWnd, ID, X, Y, Height, Width ) = FBSL_Control (_
         "richedit20a", hWnd, Caption, ID, X, Y, Height, Width,_
         WS_CHILD + WS_CLIPSIBLINGS + WS_VISIBLE + WS_HSCROLL + WS_VSCROLL + ES_MULTILINE + _
         ES_AUTOVSCROLL + ES_AUTOHSCROLL + WS_TABSTOP + ES_WANTRETURN , WS_EX_CLIENTEDGE )

Macro CInput( Caption, hWnd, ID, X, Y, Height, Width ) = FBSL_Control (_
         "edit", hWnd, Caption, ID, X, Y, Height, Width,_
         WS_CHILD + WS_CLIPSIBLINGS + WS_VISIBLE + WS_TABSTOP + ES_LEFT + ES_AUTOHSCROLL + ES_MULTILINE, WS_EX_CLIENTEDGE )

'// Label
Macro CLabel( Caption, hWnd, ID, X, Y, Height, Width ) = FBSL_Control (_
"static", hWnd, Caption, ID, X, Y, Height, Width,_
WS_CHILD + SS_NOTIFY + SS_CENTER + WS_VISIBLE, WS_EX_CLIENTEDGE )

FBSL_SetText(Me, "FBSL XML database")
ReSize(Me, 0, 0, 640, 480)
Center(Me)

Begin Enum
IDB_OPEN = 1000
IDB_PREV
IDB_NEXT
IDB_LBL
IDB_XML
IDB_RICH
End Enum

Begin Const
OUTFILE  = ".\_MySamplesNEW.xml"
    hEdit    = CRichEdit( "", Me, IDB_RICH, 0, 0, 800, 600 )
hStatus  = FBSL_Control("MSCtls_StatusBar32", Me, "", 0, 0, 0, 0, 0, 0, 0)
BUT = 60
CARTOUCH = "XML Files(*.xml)|*.xml"
hBtn1    = FBSL_Control("Button", Me, "&Open", IDB_OPEN, 10, 20, BUT, 20, WS_Child + WS_Visible + WS_TabStop, 0)
hBtn2    = FBSL_Control("Button", Me, "<<", IDB_PREV, 10+BUT*1, 20, BUT, 20, WS_Child + WS_Visible + WS_TabStop, 0)
hBtn3    = FBSL_Control("Button", Me, ">>", IDB_NEXT, 10+BUT*2, 20, BUT, 20, WS_Child + WS_Visible + WS_TabStop, 0)
hBtn4    = FBSL_Control("Button", Me, "&New XML DB", IDB_XML, 10+BUT*8+60, 20, BUT+20, 20, WS_Child + WS_Visible + WS_TabStop, 0)
hLbl1 = CLabel( "Nothing loaded yet...", Me, IDB_LBL, 10+BUT*3+10, 20, BUT+BUT, 20 )
End Const
FBSL_SetFont(hEdit, "Arial", 10, FW_BOLD, 0 ,0 ,0)
EnableWindow( hBtn3, False )
EnableWindow( hBtn2, False )

k = 1: bLastEntity = -1
GoSub ResizeMe
Show(Me)

Begin Events
Select Case CBMsg

Case WM_Close
Gosub MYReleaseObjects
GoSub WriteLastEntity
Exitprogram(0)

Case WM_Command
Select Case CBCTL
Case IDB_OPEN
GoSub LoadXml
If bLoad = True Then GoSub ClickPrevious
Case IDB_PREV
If bLoad = True Then GoSub ClickPrevious
Case IDB_NEXT
If bLoad = True Then GoSub ClickNext
Case IDB_XML
fp = FileLoad( FBSL_GetFileName( "Open", _
"FBSL Files(*.fbs)|*.fbs|Text Files(*.txt)|*.txt|CSV Files(*.csv)|*.csv|All Files(*.*)|*.*", 0 ) )
GoSub FillingXmlDB
End Select

Case WM_Size
GoSub ResizeMe

End Select
End Events

:ClickPrevious
If obj <> 0 Then
If k > 1 Then k = k - 1
If k = 1 Then
EnableWindow( hBtn2, False )
EnableWindow( hBtn3, True )
End If
GoSub GetNodeListCount
GoSub GetNodeListItem
End If
Fbsl_SetText( hLbl1, $k & "/" & $NodeListCount & " entries" )
Return

:ClickNext
If obj <> 0 Then
If k < NodeListCount Then k = k + 1
If k = NodeListCount Then
EnableWindow( hBtn3, False )
EnableWindow( hBtn2, True )
End If
GoSub GetNodeListCount
GoSub GetNodeListItem
End If
Fbsl_SetText( hLbl1, $k & "/" & $NodeListCount & " entry" )
Return

:LoadXml
k = 1: bLoad = False
If obj <> 0 Then GoSub MYReleaseObjects
obj = CreateObject("Microsoft.XMLDOM")
PutValue(obj, ".async(%b)", False)
PutValue( obj, "ValidateOnParse = %b", True )
If StrLen(FBSL_GetFileName( "Open", CARTOUCH, 0 )) > 0 Then
CallMethod( obj, ".Load(%s)", FBSL_GetFileName )
If GetValue( "%d", obj, ".parseError.errorCode" ) <> 0 then
strerr = "Error at line : " & GetValue( "%d", obj, ".parseError.line" ) & _
GetValue( "%s", obj, ".parseError.srcText" )
Msgbox( Null, strerr, "XML ERROR!", MB_OK + MB_ICONSTOP )
Else
bLoad = True
End If
End If
Return

:GetNodeListCount
If NodeList <> 0 Then ReleaseObject(NodeList)
Set NodeList = GetValue( "%o", obj, ".getElementsByTagName(%s)", "Sample")
NodeListCount = GetValue( "%d", NodeList, ".Length" )
If NodeListCount = 0 Then
MsgBox( Me, "Error : bad XML file format !", "Error", MB_ICONWARNING + MB_APPLMODAL )
GoSub MYReleaseObjects
End If
Return

:GetNodeListItem
Fbsl_SetText( hEdit, GetValue( "%s", NodeList, ".item(%d).text", k-1 ) )
Return

:MYReleaseObjects
ReleaseObject(NodeList)
ReleaseObject(obj)
ReleaseObject(cnodes)
Return

:ResizeMe
GetClientRect(Me, TopWin, leftWin, RightWin, BottomWin )
Resize( hEdit, 10, 50, RightWin - 25, BottomWin - 100 )
Resize( hStatus, 10, 10, RightWin-25, 0)
Return

:FillingXmlDB
If Strlen(fp) > 0 Then
fp = Replace( fp, "&", "&amp;" ): fp = Replace( fp, "<", "&lt;" )
fp = Replace( fp, ">", "&gt;" ) : fp = Replace( fp, " ", " " )
mb = MsgBox( Null, "Click NO to just add this sample" & _
Crlf & "Click YES to add this sample and to complete the XML database", _
"Adding ending tag or not...", MB_YESNOCANCEL + MB_APPLMODAL + MB_ICONWARNING + MB_DEFBUTTON2 )
If mb = IDCANCEL Then Return
FileOpen( OUTFILE, Append )
If FileLen(OUTFILE) = 0 Then
FilePrint( FileOpen, "<?xml version=""1.0"" encoding=""ISO-8859-1""?>")
FilePrint( FileOpen, "<Fbsl_Samples>" & CrLf & Tab & "<Content>" )
End If
If Asc(fp{StrLen(fp)}) = 10 Then
If Asc(fp{0}) = 10 Or Asc(fp{0}) = 13 Then
FilePrint( FileOpen, Tab & Tab & "<Sample>" & fp & Tab & Tab & "</Sample>" )
Else
FilePrint( FileOpen, Tab & Tab & "<Sample>" & CrLf & fp & Tab & Tab & "</Sample>" )
End if
Else
If Asc(fp{0}) = 10 Or Asc(fp{0}) = 13 Then
FilePrint( FileOpen, Tab & Tab & "<Sample>" & fp & CrLf & Tab & Tab & "</Sample>" )
Else
FilePrint( FileOpen, Tab & Tab & "<Sample>" & CrLf & fp & CrLf & Tab & Tab & "</Sample>" )
End If
End If
bLastEntity = 0
If mb = IDYES Then
bLastEntity = 1
FilePrint( FileOpen, Tab & "</Content>" & CrLf & "</Fbsl_Samples>")
End if
FileClose(FileOpen)
End If
Return

:WriteLastEntity
If bLastEntity = 0 Then
FileOpen( OUTFILE, Append )
FilePrint( FileOpen, Tab & "</Content>" & CrLf & "</Fbsl_Samples>")
FileClose(FileOpen)
End If
Return

25

Developer's Corner / FBSL - Icon viewer

« on: February 11, 2006, 06:32 AM »

[modified source to avoid crash]
Hello,

Here's a icon viewer developped in Fbsl.


The source code will show you how to :
-use volatile CLASS
-use API calls
-use API structure manipulation

[Select]

'======================================================
' Shell32 Icon Index FBSL
'======================================================
#Option Explicit
#DLLDECLARE user32("GetSystemMetrics","DestroyIcon")
#DLLDECLARE comctl32("ImageList_Create","ImageList_ReplaceIcon")
#DLLDECLARE shell32("ExtractIcon")
DIM $LV_ITEM, %hList, %t, %hIcon, %hImage, $index, %j

' ------------------------------------------------------
'// SysListView Class :: TYPE + MACRO
' ------------------------------------------------------
Class SLV '// volatile class (== without parens() )
    Macro SetValue(param1, param2) = SetMem( LV_ITEM, param1, param2 )
    Static mask  = 0, iItem = 4, iSubItem = 8, state = 12
    Static stateMask = 16, pszText = 20, cchTextMax = 24, iImage = 28
    Static ILC_COLOR32 = 32, ILC_MASK = 1, LVSIL_SMALL = 1, LVSIL_STATE = 2
    Static LVS_LIST = 0x0003, LVIF_TEXT = 1, LVIF_IMAGE = 2, LVS_REPORT = 0x0001
    Static LVS_TYPEMASK = 3, LVS_EX_GRIDLINES = 1, LVS_EX_LABELTIP = 0x00004000
    Static LVIS_STATEIMAGEMASK = 0xF000, SM_CXICON = 11, SM_CYICON = 12
End Class

' ------------------------------------------------------
' // Main Entry point
' ------------------------------------------------------
Sub Main()
    MYCreateSysListView()
    Begin Events
    End Events
End Sub

' ------------------------------------------------------
'// ListView Creation
' ------------------------------------------------------
Sub MYCreateSysListView()
    Fbsl_settext(me,"Shell32 Icon Index")
    Alloc(LV_ITEM,36)

    SLV->SetValue( SLV->LVIF_TEXT + SLV->LVIS_STATEIMAGEMASK + SLV->LVIF_IMAGE, SLV->mask )' set state masks
    SLV->SetValue( 256, SLV->cchTextMax)

    hList = Fbsl_control("SysListView32",me,"",0,0,0,500,294,_
            WS_VISIBLE + WS_CHILD + SLV->LVS_LIST + SLV->LVS_TYPEMASK + SLV->LVS_REPORT, WS_EX_STATICEDGE)

    SendMessage(hList, SLV->LVM_SETBKCOLOR, 0, rgb(255,255,192))
    SendMessage(hList, SLV->LVM_SETTEXTBKCOLOR, 0, rgb(255,255,192))
    SendMessage(hList, SLV->LVM_SETEXTENDEDLISTVIEWSTYLE,0, SLV->LVS_EX_LABELTIP)

    '==========create an image list======================
    hImage = ImageList_Create(GetSystemMetrics(SLV->SM_CXICON),_
             GetSystemMetrics(SLV->SM_CYICON), SLV->ILC_COLOR32 + SLV->ILC_MASK, 1, 1)

    '====Extract the icon then destroy the handle to replace with next icon
    For t = 0 To 237
        hIcon = ExtractIcon(0,"shell32.dll",t)
        ImageList_ReplaceIcon(hImage,-1,hIcon)
        DestroyIcon(hIcon)
        If hIcon <> 0 Then j = t
    Next

    '=====set the image list to the listview=========
    SendMessage(hList,SLV->LVM_SETIMAGELIST,SLV->LVSIL_SMALL,hImage)

    '=====populate the listview======================
    For t = 0 To j
        index = "Icon # : " & t
        SLV->SetValue( t, SLV->iItem) ' item index
        SLV->SetValue( @index, SLV->pszText) ' pointer to text string
        SLV->SetValue( t, SLV->iImage) ' image index
        SendMessage(hList,SLV->LVM_INSERTITEM,0,LV_ITEM)
    Next
    Resize(me, 0, 0, 520, 324)
    Center(me)
    Show(me)
End Sub

Enjoy