Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
 
FAQFAQ   SuchenSuchen   MitgliederlisteMitgliederliste   BenutzergruppenBenutzergruppen  RegistrierenRegistrieren
ProfilProfil   Einloggen, um private Nachrichten zu lesenEinloggen, um private Nachrichten zu lesen   LoginLogin
Zur Begleitseite des Forums / Chat / Impressum
Aktueller Forenpartner:

Gfx Spielereien
Gehe zu Seite Zurück  1, 2, 3, 4, 5, 6  Weiter
 
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1208
Wohnort: Ruhrpott

BeitragVerfasst am: 20.03.2017, 20:58    Titel: Antworten mit Zitat

Kein Problem bei mir (WinXP SP3 / fbc 1.05.0 / 32bit). Programm compiliert und läuft einwandfrei. (Und die Enterprise finde ich echt witzig! lächeln )

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
nemored



Anmeldungsdatum: 22.02.2007
Beiträge: 4594
Wohnort: ~/

BeitragVerfasst am: 20.03.2017, 22:34    Titel: Antworten mit Zitat

Mal sicherheitshalber dazu gesagt, dass man mit
Code:
fbc "Rotating Earth Res v1.7.bas" "Rotating Earth Res v1.7.rc"

compilieren muss. Wenn es Fehler bei der Ausführung der .rc gibt, sollte der Compiliervorgang eigentlich fehlschlagen.
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Elor



Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz

BeitragVerfasst am: 21.03.2017, 12:00    Titel: Antworten mit Zitat

Oh man, nemored, du hast recht, ich hab die Resourcen vergessen peinlich
Ich hab's einfach so mit Geany Kompiliert, also, falscher alarm.

@UEZ:
Sieht gut aus, hast eigentlich was größeres vor oder ist das mit der Enterprise nur Zufall lächeln
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 21.03.2017, 17:30    Titel: Antworten mit Zitat

Elor hat Folgendes geschrieben:
Oh man, nemored, du hast recht, ich hab die Resourcen vergessen peinlich
Ich hab's einfach so mit Geany Kompiliert, also, falscher alarm.

@UEZ:
Sieht gut aus, hast eigentlich was größeres vor oder ist das mit der Enterprise nur Zufall lächeln


Was größeres habe ich eigentlich nicht vor, da die FPS ja sehr limitiert sind - da geht nicht viel mehr. Wenn ich noch die Drehung vom Mond hinzufügen würde, dann hatte man eine Slideshow. zwinkern

Das mit der Enterprise war nur als Gag gedacht, da ein User Raumschiffe und / oder Meteoriten sehen wollte, aber wie gesagt, das Ende der Fahnenstange mit GDI+ erreicht ist.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 14.09.2017, 23:10    Titel: 3D Starfield Rotating Flight Antworten mit Zitat

Nächstes Beispiel "3D Sternen Flug":

Code:
'coded by UEZ build 2017-11-07, faster Sin / Cos ASM code by eukalyptus
#Include "fbgfx.bi"
#Include "string.bi"

Using FB

Declare Function _Sin6th(fX As Double) As Double
Declare Function _Cos6th(fX As Double) As Double


Dim as ulong iW, iH
ScreenControl GET_DESKTOP_SIZE, iW, iH
Dim as ulong iW2 = iW \ 2, iH2 = iH \ 2, iW3 = iW \ 3, iH3 = iH \ 3
screenres iW, iH, 32, 2, GFX_FULLSCREEN or GFX_HIGH_PRIORITY
ScreenSet 1, 0

Type tStar
   as Double v, x, y, z, colour
End Type

Dim as Ulong i, iPhase, iMaxStars = 25000
Dim as Double fNewX, fNewY, fRot = 0, c = -2^32 + 850, fRad = ACos(-1) / 180
Dim as UShort iLimes = 100, iFPS = 0 , iFPS_current = 0
Dim as UByte iColor, iLen
Dim as tStar Stars(iMaxStars)
Dim As Double fTime, fTimer
Dim As String sDrivername, sNumber
ScreenControl FB.GET_DRIVER_NAME, sDrivername

sNumber = Format(iMaxStars, "###,")
iLen = Len(Str(iMaxStars))
iPhase = 10^(iLen - 2)

Randomize

For i = 1 to iMaxStars
   Stars(i).v = 0.00001 + Rnd / 5000
   Stars(i).x = Rnd * (iW + iW2) - iW2
   Stars(i).y = Rnd * (iH + iH2) - iH2
   Stars(i).z = Rnd * 0.02
   Stars(i).colour = CUbyte(Rnd * 255)
Next

fTimer = Timer

do

   Cls
   For i = 1 to iMaxStars
      Stars(i).colour *=  1.0125 + Stars(i).z
      iColor = Iif(Stars(i).colour > 255, 255, Iif(Stars(i).colour < 8, 8, CUbyte(Stars(i).colour)))
     
      Stars(i).x += Stars(i).x * Stars(i).z
      Stars(i).y += Stars(i).y * Stars(i).z
     
      fNewX = Stars(i).x * _Cos6th(fRot * fRad) - Stars(i).y * _Sin6th(fRot * fRad) + iW2
      fNewY = Stars(i).y * _Cos6th(fRot * fRad) + Stars(i).x * _Sin6th(fRot * fRad) + iH2
     
      Stars(i).z += Stars(i).v
     
      circle (fNewX, fNewY), 0.5 + Stars(i).z * 50, Rgb(iColor, iColor, iColor), , , , F
     
      If (fNewX < -iLimes) or (fNewX > iW + iLimes) or (fNewY < -iLimes) or (fNewY > iH + iLimes) Then
         Stars(i).v = 0.00001 + Rnd / 5000
         Stars(i).x = Rnd * (iW + iW3) - iW2
         Stars(i).y = Rnd * (iH + iH3) - iH2
         Stars(i).z = Rnd * 0.000003333
         Stars(i).colour = CUbyte(8 + Rnd * 8)
      End If
      fRot += _Cos6th(c / iPhase) / (2 * iMaxStars)
      c += 0.000125
   Next

   Draw String(0, 0), sDrivername & ": " & sNumber & " stars @ " & iFPS_current & " fps", RGB(&hA0, &hA0, &hA0)
   Draw String(iW - 100, 0), "Coded by UEZ", RGB(&h50, &h50, &h50)
   Draw String(0, iH - 10), iW & " x " & iH, RGB(&h80, &h80, &h80)
   
   If Timer - fTimer > 0.99 Then
      iFPS_current = iFPS
      iFPS = 0
      fTimer = Timer
   End If
   iFPS += 1
   
   ScreenCopy
   
   'Sleep(10)
loop until Inkey = Chr(27)

Function _Sin6th(fX As Double) As Double
   Asm
      jmp _Sin6th_Start
         _Sin6th_Mul: .double 683565275.57643158
         _Sin6th_Div: .double -0.0000000061763971109087229
         _Sin6th_Rnd: .double 6755399441055744.0
       
      _Sin6th_Start:
         movq xmm0, [fX]
         mulsd xmm0, [_Sin6th_Mul]
         addsd xmm0, [_Sin6th_Rnd]
         movd ebx, xmm0
   
         lea  eax, [ebx*2+0x80000000]
         sar  eax, 2
         imul eax
         sar  ebx, 31
         lea  eax, [edx*2-0x70000000]
         lea  ecx, [edx*8+edx-0x24000000]
         imul edx
         xor  ecx, ebx
         lea  eax, [edx*8+edx+0x44A00000]
         imul ecx
         
         cvtsi2sd xmm0, edx
         mulsd xmm0, [_Sin6th_Div]
         movq [Function], xmm0
   End Asm
End Function

Function _Cos6th(fX As Double) As Double
   Asm
      jmp _Cos6th_Start
         _Cos6th_Mul: .double 683565275.57643158
         _Cos6th_Div: .double -0.0000000061763971109087229
         _Cos6th_Rnd: .double 6755399441055744.0
       
      _Cos6th_Start:
         movq xmm0, [fX]
         mulsd xmm0, [_Cos6th_Mul]
         addsd xmm0, [_Cos6th_Rnd]
         movd ebx, xmm0
         
         add ebx, 0x40000000 'SinToCos
   
         lea  eax, [ebx*2+0x80000000]
         sar  eax, 2
         imul eax
         sar  ebx, 31
         lea  eax, [edx*2-0x70000000]
         lea  ecx, [edx*8+edx-0x24000000]
         imul edx
         xor  ecx, ebx
         lea  eax, [edx*8+edx+0x44A00000]
         imul ecx
         
         cvtsi2sd xmm0, edx
         mulsd xmm0, [_Cos6th_Div]
         movq [Function], xmm0
   End Asm
End Function


Keine Ahnung, ob der Code unter Linux läuft.
_________________
Gruß,
UEZ


Zuletzt bearbeitet von UEZ am 29.12.2017, 15:15, insgesamt 2-mal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Marc Bonus



Anmeldungsdatum: 19.11.2016
Beiträge: 43

BeitragVerfasst am: 15.09.2017, 11:34    Titel: Re: 3D Starfield Rotating Flight Antworten mit Zitat

UEZ hat Folgendes geschrieben:
Keine Ahnung, ob der Code unter Linux läuft.


Läuft anstandslos unter Kubuntu 17.04 mit Geany.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 15.09.2017, 12:09    Titel: Re: 3D Starfield Rotating Flight Antworten mit Zitat

Marc Bonus hat Folgendes geschrieben:
UEZ hat Folgendes geschrieben:
Keine Ahnung, ob der Code unter Linux läuft.


Läuft anstandslos unter Kubuntu 17.04 mit Geany.


Cool. lächeln

Was wird unter Linux als Driver_Name angezeigt? Was ist deine FPS?
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Marc Bonus



Anmeldungsdatum: 19.11.2016
Beiträge: 43

BeitragVerfasst am: 15.09.2017, 12:30    Titel: Antworten mit Zitat

Links oben in der Ecke steht "X11: 50,000 stars @ 25 fps"

Die fps schwanken von 17 - 26. Habe hier allerdings nur einen 3 GHz Dual Core mit Onboard Grafik.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 15.09.2017, 12:36    Titel: Antworten mit Zitat

Unter Windows wird anscheinend für x86 DirectX / x64 GDI benutzt.
Ich arbeite zwar nicht direkt mit Linux, aber X11 sagt mir was.

Bei mir sind es ca. 30 FPS bei 1600x900, wobei die FPS steigen würde, wenn man Sleep(10) auskommentiert.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
nemored



Anmeldungsdatum: 22.02.2007
Beiträge: 4594
Wohnort: ~/

BeitragVerfasst am: 15.09.2017, 13:01    Titel: Antworten mit Zitat

Zum verwendeten Treiber steht hier noch was:
https://www.freebasic-portal.de/befehlsreferenz/interne-treiber-463.html
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1208
Wohnort: Ruhrpott

BeitragVerfasst am: 15.09.2017, 13:47    Titel: Antworten mit Zitat

Auf meinem Pentium IV 3,2GHz mit NVIDIA GeForce4 MX440 bei 1280 x 1024 unter WinXP SP3 (32 Bit) läuft das Programm mit stabilen 17 FPS.

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 25.10.2017, 15:43    Titel: Antworten mit Zitat

Und weiter geht's: GDI+ Kaleidoscope v0.9 build 2017-10-25 (nur Windows!)

Gibt es eine bessere Möglichkeit das Mausrad abzufragen? Z.B. über WM_MOUSEWHEEL?

Kann ich die Maus auch außerhalb der GUI abfragen?
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1208
Wohnort: Ruhrpott

BeitragVerfasst am: 25.10.2017, 18:36    Titel: Antworten mit Zitat

Sehr beeindruckend! lächeln

Zitat:
Kann ich die Maus auch außerhalb der GUI abfragen?
Natürlich. Die Abfrage mit GetMouse ist doch außerhalb der GUI. Oder habe ich deine Frage falsch verstanden?

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 25.10.2017, 19:28    Titel: Antworten mit Zitat

Wenn die Maus außerhalb der GUI ist, "schläft" die GUI, d.h. die Rotationen setzten aus, weil die Variablen dx und dy den Wert -1 bekommen.

Aus dem Help File:
"...0 on success, or 1 on error (for example because the mouse is outside the graphic window) or on failure."
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Jojo
alter Rang


Anmeldungsdatum: 12.02.2005
Beiträge: 9736
Wohnort: Neben der Festplatte

BeitragVerfasst am: 26.10.2017, 00:47    Titel: Antworten mit Zitat

Die Mausposition auf dem Bildschirm (statt nur im Grafikfenster) kannst du unter Windows mit GetCursorPos abfragen: https://msdn.microsoft.com/de-de/library/windows/desktop/ms648390(v=vs.85).aspx
_________________
» Die Mathematik wurde geschaffen, um Probleme zu lösen, die es nicht gäbe, wenn die Mathematik nicht erschaffen worden wäre.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden Website dieses Benutzers besuchen
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 26.10.2017, 09:56    Titel: Antworten mit Zitat

Danke Jojo.

Habe den Code aktualisiert.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 15.01.2018, 23:02    Titel: Antworten mit Zitat

Hier eine Portierung eines meiner AutoIt Skripte Zwecks FB Übung: zwinkern

Simple Flame Simulation [Windows only] build 2018-01-15
Code:
'coded by UEZ build 2018-01-15
'thanks to Eukalyptus for the ASM Blur function and the procedural generated AU3 logo

#Define WIN_INCLUDEALL
#Include "fbgfx.bi"
#Include "windows.bi"
#Include "win/gdiplus.bi"

Using FB
Using GDIPLUS

Declare Sub GenFlameParticle(aFlameCoords() as Single, iPos as ushort, iWidth as UShort = 100)
Declare Function RandomRange(fStart as Single, fEnd as Single) as Single
Declare Sub ImageContrast(pImage as any Pointer, contrast as Byte, brightness as Byte = 0)
Declare function ImageBlur(pImage As Any Ptr, iRadius As Long, iExpandEdge As Long = 0) As Any Ptr
Declare Function _GDIPlus_Startup() As Byte
Declare Sub _GDIPlus_Shutdown()
Declare Function _GDIPlus_BitmapCreateFromMemory(aBinImage() As UByte, bBitmap_GDI As Bool = FALSE) As Any Ptr
Declare Function Convert2FBImage(aMemGDIpBitmap() as UByte) as any Ptr

'Generated by *FB File2Bas Code Generator v0.50 build 2017-03-15 beta*
Dim Shared As UByte __Logojpg(0 To ...) = _
   {&hFF, &hD8, &hFF, &hE0, &h00, &h10, &h4A, &h46, &h49, &h46, &h00, &h01, &h01, &h01, &h00, &h48, &h00, &h48, &h00, &h00, &hFF, &hDB, &h00, &h43, &h00, &hFF, &hB7, &hC8, &hE9, &hC8, &hA7, &hFF, &hE9, &hD9, &hE9, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hDB, &h00, &h43, &h01, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hFF, &hC2, &h00, &h11, &h08, &h01, &h8B, &h01, &h8C, &h03, &h01, &h22, &h00, &h02, &h11, &h01, &h03, &h11, &h01, &hFF, &hC4, &h00, &h16, &h00, &h01, &h01, &h01, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h01, &h02, &hFF, &hC4, &h00, &h14, &h01, &h01, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &hFF, &hDA, &h00, &h0C, &h03, &h01, &h00, &h02, &h10, &h03, &h10, &h00, &h00, &h01, &hC8, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h01, &h6D, &h25, &h04, &hA2, &h67, &h63, &h0B, &h00, &h00, &h00, &h00, &h00, &h00, &h01, &hA3, &h2D, &h8C, &hDA, &h00, &h00, &h04, &hA2, &h4D, &h0C, &h37, &h0C, &hAC, &h00, &h6E, &h50, &h00, &h00, &h01, &h28, &hC2, &hC0, &h00, &h00, &h00, &h01, &hA3, &h3A, &hA0, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h32, &hD0, &h01, &h60, &hA8, &h2A, &h0B, &h28, &h80, &h63, &h78, &h00, &h00, &h00, &h0B, &hA0, &h00, &h00, &h10, &hA9, &h0D, &h30, &h34, &hC8, &hD5, &hC0, &hDB, &h03, &h6C, &hD2, &h80, &h00, &h00, &h00, &h52, &h28, &h02, &h01, &h9D, &h64, &h80, &h00, &h05, &h68, &h00, &h01, &h0B, &h24, &h2C, &h00, &h00, &h00, &h00, &h00, &h58, &h36, &hC6, &h8A, &h00, &h00, &h28, &h8A, &h25, &h40, &h06, &h37, &h80, &h00, &h16, &h6C, &h00, &h01, &h92, &hE4, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h01, &hAC, &h8D, &hA5, &h00, &h00, &h00, &h04, &h24, &h00, &h06, &h8A, &h00, &h06, &h44, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h06, &hB2, &h36, &h94, &h00, &h02, &h42, &hE4, &h00, &h01, &hB9, &h40, &h00, &h99, &h00, &h00, &h00, &h00, &h15, &hA0, &h00, &h33, &h37, &h92, &h00, &h00, &h00, &h01, &hBC, &h53, &h40, &h03, &h33, &h78, &h00, &h00, &h53, &h40, &h01, &h9B, &h90, &h00, &h00, &h00, &h01, &hB0, &h00, &h00, &h03, &h0D, &h64, &h00, &h00, &h00, &h03, &h57, &h3A, &h00, &h67, &h43, &h00, &h01, &hAC, &hEC, &h00, &h0C, &hC0, &h00, &h00, &h00, &h14, &hB4, &h00, &h00, &h00, &h19, &hD0, &hC0, &h00, &h00, &h00, &h1B, &hC6, &h8A, &h00, &h33, &h35, &h90, &h0B, &hAC, &hE8, &h01, &h2E, _
    &h48, &h00, &h00, &h00, &h06, &hE5, &h00, &h01, &h19, &h36, &hCE, &h80, &h00, &h99, &hDE, &h48, &h00, &h00, &h00, &h0D, &h80, &h09, &h9D, &hE0, &h03, &h56, &h50, &h06, &h75, &h80, &h00, &h00, &h01, &h66, &hC0, &h00, &h19, &h10, &h1A, &hC8, &hDA, &h50, &h00, &h30, &hDE, &h00, &h00, &h00, &h0D, &h59, &h40, &h18, &hDE, &h48, &h0D, &h59, &h40, &h18, &hDE, &h00, &h00, &h00, &h68, &hA0, &h00, &h41, &h90, &h00, &h06, &hF1, &h4D, &h00, &h04, &hA3, &h0B, &h00, &h00, &h02, &hEB, &h3A, &h00, &h67, &h59, &h20, &h35, &h65, &h00, &h63, &h78, &h00, &h00, &h0B, &hA4, &h2A, &h50, &h06, &h50, &h14, &h8A, &h22, &h88, &hA2, &hDC, &hE8, &h00, &h06, &h37, &h0C, &h80, &h00, &h2E, &hA5, &h00, &h67, &h58, &h00, &hBA, &hCD, &h2A, &h0B, &h8D, &h42, &h00, &h06, &hA5, &h00, &h00, &h64, &h02, &hE9, &h0A, &h82, &hA0, &hA9, &h40, &h00, &h00, &h0C, &hCD, &hE0, &h00, &h0D, &h59, &h40, &h18, &hDE, &h00, &h1A, &hCE, &h80, &h12, &h8C, &h81, &h66, &h8B, &h00, &h01, &h04, &h06, &h80, &h00, &h16, &h0A, &h82, &hA0, &hA8, &h2A, &h0A, &h82, &hC5, &h30, &hB0, &h14, &hD0, &h00, &h99, &hB0, &h01, &h65, &h28, &h00, &hCB, &h59, &h00, &h00, &h00, &h00, &hA8, &h2A, &h0A, &h82, &hA0, &hA8, &h2A, &h0A, &h82, &hA0, &hA8, &h2A, &h0B, &h01, &hAC, &hEC, &h00, &h43, &h20, &h00, &h0D, &h25, &h00, &h67, &h43, &h20, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h01, &h4B, &h40, &h06, &h6E, &h40, &h00, &h01, &hAC, &hD2, &h80, &h09, &h35, &h90, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h1A, &h94, &h58, &h2A, &h09, &h00, &h00, &h00, &h03, &h4C, &hE8, &h00, &h0C, &hB5, &h90, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h01, &h54, &h00, &h06, &h6C, &h00, &h00, &h00, &h00, &h58, &h35, &h73, &h4A, &h80, &h09, &h35, &h08, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h1A, &h00, &h00, &h4B, &h90, &h00, &h00, &h00, &h00, &h00, &h58, &h35, &h73, &h4A, &h00, &h24, &hD0, &hC3, &h50, &h8B, &h00, &h00, &h00, &h01, &h48, &hD0, &h00, &h00, &h11, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &hD3, &h34, &hD2, &h50, &h00, &h12, &h88, &hA3, &h2D, &h0C, &hB5, &h00, &h00, &h00, &h00, &h12, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h05, &h83, &h4C, &hD2, &hD8, &h2A, &h0A, &h82, &hA0, &hA8, &h2A, &h0A, &h82, &hA4, &h2A, &h42, &hC0, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &hA8, &h34, &hC8, &hD3, &h23, &h4C, &h8D, &h48, &h2C, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &hFF, &hC4, &h00, &h1D, &h10, &h00, &h02, &h03, &h00, &h02, &h03, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h01, &h50, &h11, &h20, &h60, &h00, &h30, &h70, &h80, &hA0, &hFF, &hDA, &h00, &h08, &h01, &h01, &h00, &h01, &h05, &h02, &h51, &h14, &h8C, &h54, &h72, &h3A, &h61, &h2C, &h61, &h63, &hDA, &h31, &hA3, &h19, &hD3, &h61, &hE0, &hC1, &h52, &hD8, &h54, &hAD, &h19, &hC0, &hC8, &h32, &h0C, &h83, &h21, &hF0, &hA9, &hFF, &hC4, &h00, &h14, &h11, &h01, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h90, &hFF, &hDA, &h00, &h08, _
    &h01, &h03, &h01, &h01, &h3F, &h01, &h1C, &h7F, &hFF, &hC4, &h00, &h14, &h11, &h01, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h90, &hFF, &hDA, &h00, &h08, &h01, &h02, &h01, &h01, &h3F, &h01, &h1C, &h7F, &hFF, &hC4, &h00, &h14, &h10, &h01, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &hB0, &hFF, &hDA, &h00, &h08, &h01, &h01, &h00, &h06, &h3F, &h02, &h1C, &h4F, &hFF, &hC4, &h00, &h1E, &h10, &h00, &h02, &h02, &h03, &h01, &h01, &h01, &h01, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h01, &h11, &h00, &h20, &h30, &h31, &h40, &h10, &h50, &h21, &h60, &hFF, &hDA, &h00, &h08, &h01, &h01, &h00, &h01, &h3F, &h21, &hF8, &hEB, &hC2, &h13, &hF2, &h21, &hF3, &h40, &h60, &h23, &h95, &h7A, &h21, &h64, &h22, &h1E, &h11, &hE2, &h23, &hE1, &h14, &h54, &h19, &h0E, &h65, &h17, &h29, &h81, &hBC, &hA7, &h28, &h1F, &h18, &hEF, &h10, &h0E, &h6B, &h23, &h8E, &h3E, &h93, &hBC, &h20, &h62, &h71, &hE0, &h71, &hC7, &hC8, &h70, &h01, &h81, &hC7, &h9D, &hF1, &h1D, &hDC, &h0C, &h0F, &h8C, &h1E, &h60, &h2E, &h4F, &h30, &h39, &h8D, &h80, &h77, &h27, &hA4, &h1C, &h66, &hE3, &hF2, &hC4, &hF5, &h83, &h84, &h9B, &h85, &h89, &hED, &h16, &h71, &hE5, &h27, &h28, &h14, &h50, &h85, &h90, &h58, &hF5, &h00, &hB9, &h0B, &h20, &hE2, &h39, &h00, &h7C, &hA3, &h80, &h39, &h75, &h84, &h8C, &h83, &h18, &hD5, &h4E, &h40, &h31, &h91, &hC2, &h77, &hCA, &h06, &h53, &hC8, &h0D, &hD4, &hEB, &h88, &h9B, &h9F, &hDC, &h63, &h75, &h3A, &hE4, &h07, &hE6, &h01, &h72, &h3A, &h07, &h78, &h80, &hB9, &hF4, &h5C, &h85, &h88, &h6A, &hA7, &hD1, &hAC, &hC0, &h3B, &h9C, &h7B, &hCE, &h3B, &hF4, &h6B, &h36, &hAC, &h6C, &h2E, &h46, &h61, &hDF, &hA3, &h59, &h40, &hCC, &h2E, &h46, &h51, &hF4, &h6B, &h20, &h17, &h38, &h47, &h18, &hEF, &hD1, &hC4, &h4F, &hA8, &hC4, &h62, &h31, &h18, &h8C, &h46, &h23, &h11, &hB9, &hC8, &h3E, &h8A, &h9D, &hD8, &h7E, &h61, &h03, &h80, &h8B, &h0D, &h54, &hFA, &h2A, &h6A, &h05, &hCF, &h83, &hF7, &h9C, &h60, &h15, &h34, &h02, &hE7, &h94, &hFE, &hE1, &h3C, &h67, &hD1, &hC8, &h7D, &h15, &h35, &h15, &h39, &h1C, &h71, &hC7, &h1C, &h71, &hC7, &h1C, &h71, &hC7, &h1C, &h71, &hC7, &h1C, &h71, &hC7, &h1F, &hA2, &hA6, &hA2, &hA7, &hE1, &h0F, &hA4, &h2A, &h6E, &h2A, &h7E, &h00, &hE3, &h3F, &h10, &hE1, &h16, &h3D, &hA3, &h80, &h7C, &h10, &h2C, &h7E, &h58, &h16, &h39, &h45, &hC8, &hE7, &h02, &hC7, &h38, &h37, &h5C, &h8A, &hE7, &h84, &h1C, &h0B, &h81, &h45, &hD4, &hF0, &hA8, &hB1, &hA8, &hBE, &h42, &h8A, &h28, &hA2, &h8A, &h2C, &h6F, &hA1, &hFD, &h47, &hC8, &hE3, &hEF, &h71, &hE7, &h71, &hFC, &h47, &h1C, &h76, &h71, &hC7, &h1F, &hF0, &hFF, &h00, &hFF, &hDA, &h00, &h0C, &h03, &h01, &h00, &h02, &h00, &h03, &h00, &h00, &h00, &h10, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h01, &h0C, &hB1, &hC7, &h08, &h00, &h00, &h00, &h00, &h00, &h00, &h21, &h4B, &h0C, &hF3, &hC7, &h0C, &h30, &h00, &h2C, &hF3, &hCF, &h3C, &hB0, &h00, &h00, &h00, &h00, &h00, &hE2, &h00, &h00, &hC3, &h0C, &h30, &hC3, _
    &hCB, &h2C, &hF2, &hC3, &h0C, &h43, &hC3, &h00, &h00, &h00, &h10, &h00, &h00, &h04, &h00, &h8C, &h20, &h10, &hC0, &h10, &hC3, &h0C, &h38, &hC0, &h0F, &h2C, &h00, &h00, &h1C, &h00, &h01, &h00, &h00, &h00, &h00, &h00, &h00, &h30, &h00, &h00, &h14, &hC3, &h09, &h38, &hC0, &h00, &h1C, &hF3, &hC3, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h0D, &h08, &h00, &h00, &h00, &h12, &h00, &h00, &h73, &hCF, &h20, &h00, &h00, &h00, &h00, &h42, &h00, &h00, &h00, &h00, &h00, &h80, &h00, &h21, &h00, &h00, &hD3, &hCE, &h28, &h00, &h00, &h00, &h00, &hC7, &h28, &h20, &h00, &h00, &h00, &h09, &h00, &h02, &h40, &h00, &h10, &h8C, &h28, &h00, &h00, &h00, &h01, &h08, &h00, &h00, &h0A, &h00, &h00, &h00, &h00, &h90, &h84, &h00, &h01, &h00, &h00, &h80, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h10, &h20, &h00, &h00, &h00, &h0F, &h3C, &h00, &h02, &h00, &h10, &h00, &h00, &h00, &h0A, &h00, &h00, &hC0, &h00, &h02, &h40, &h00, &h00, &h04, &h34, &hF2, &h00, &h00, &h00, &h40, &h00, &h00, &h06, &h00, &h00, &h40, &h00, &h20, &h00, &h20, &h00, &h00, &h00, &hD3, &hCE, &h00, &hA0, &h00, &h00, &h00, &h00, &h00, &h00, &h42, &h00, &h02, &h40, &h00, &h00, &h00, &h00, &h02, &hC3, &h28, &h00, &h00, &h00, &h00, &h01, &h04, &h20, &h02, &h00, &h00, &h00, &h08, &h00, &h04, &h00, &h00, &h08, &h00, &h10, &h09, &h0C, &h60, &h00, &h1C, &hF3, &hCB, &h04, &h90, &hC3, &h08, &h00, &h00, &h00, &h90, &h00, &h08, &h01, &h00, &h34, &hF3, &hC0, &h04, &h73, &hCF, &h00, &h53, &hCF, &h2C, &h30, &hC3, &h0C, &h31, &h82, &h10, &h00, &h0A, &h00, &h43, &hCF, &h20, &hC3, &h0C, &h20, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h60, &h01, &h20, &h00, &h0F, &h3C, &hE0, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h1C, &h00, &h00, &h10, &hF3, &hC3, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h01, &hCB, &h08, &h80, &h00, &h00, &h01, &hCF, &h3C, &hB0, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h01, &hCF, &h3C, &hC0, &h00, &h00, &h00, &h00, &h24, &h33, &hC3, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h10, &hCF, &h3C, &hC0, &h00, &h00, &h00, &h00, &h00, &h02, &h40, &h00, &hC0, &hC0, &h00, &h00, &h00, &h08, &h51, &hCF, &h3C, &hE2, &h00, &h00, &h00, &h00, &h00, &h00, &h04, &h14, &h20, &h00, &h10, &h83, &h0D, &h1C, &hF3, &hCF, &h38, &hA0, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h03, &h0E, &h24, &h30, &hC3, &h0C, &h30, &hC3, &h20, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h41, &h00, &h14, &h21, &h04, &h20, &h00, &h00, &h00, &h00, &h00, &h00, &h03, &hFF, &hC4, &h00, &h14, &h11, &h01, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h90, &hFF, &hDA, &h00, &h08, &h01, &h03, &h01, &h01, &h3F, &h10, &h1C, &h7F, &hFF, &hC4, &h00, &h14, &h11, &h01, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h00, &h90, &hFF, &hDA, &h00, &h08, &h01, &h02, &h01, &h01, &h3F, &h10, &h1C, &h7F, &hFF, &hC4, &h00, &h28, &h10, &h01, &h00, &h02, &h01, &h03, &h04, &h01, _
    &h05, &h01, &h01, &h01, &h01, &h00, &h00, &h00, &h00, &h01, &h00, &h11, &h20, &h30, &h31, &h41, &h21, &h40, &h51, &h61, &h10, &h50, &h71, &h81, &h91, &hA1, &hB1, &hF0, &hC1, &hD1, &hFF, &hDA, &h00, &h08, &h01, &h01, &h00, &h01, &h3F, &h10, &hFA, &h38, &hDF, &h50, &h1C, &hCF, &h44, &hAF, &h08, &hB4, &h7C, &h18, &h89, &hBF, &hD2, &h81, &h5E, &h90, &h0F, &h6E, &h7B, &hEF, &h29, &hDB, &hB5, &h13, &hC4, &h17, &h32, &h9E, &h67, &hA2, &h51, &hE2, &h7E, &h3E, &h7A, &h78, &h9E, &h8F, &h89, &hF0, &h62, &h51, &h13, &h7C, &h82, &hDA, &h80, &h05, &h1A, &h5C, &hC7, &h62, &h0B, &hB1, &h0F, &h26, &h00, &h6C, &h4B, &hD5, &hDF, &h78, &h97, &hD4, &h59, &hEF, &h03, &h47, &hB7, &h50, &hD3, &hAC, &h27, &h68, &h13, &h7E, &hBD, &hA2, &h0E, &hE4, &hF0, &h75, &h82, &hFE, &hCD, &h51, &h66, &hA6, &hF3, &hCB, &hFA, &h9F, &h6E, &hF2, &hE5, &hCB, &h97, &h90, &hA5, &hA4, &h90, &h06, &hCF, &hDE, &h9D, &hCA, &h79, &h94, &hF3, &h29, &hE6, &h59, &hE7, &hB0, &hA9, &h52, &hB5, &hEB, &h7A, &hBB, &h4D, &hBA, &h1A, &h0A, &h11, &h3C, &h45, &hCB, &h7C, &hE5, &h70, &h47, &h30, &hF3, &h20, &h1E, &hD1, &hF5, &hD0, &hE7, &h74, &h10, &h45, &h3E, &hB5, &h85, &h36, &h61, &hE7, &h06, &hF3, &hA9, &h52, &hA5, &h4A, &hCB, &hAB, &h37, &h33, &h9A, &h84, &h53, &hD9, &h0D, &h6D, &h3C, &hB9, &h1A, &h2B, &h46, &h77, &h75, &h76, &hCE, &h9D, &hA6, &hFD, &hAA, &h10, &h47, &h6D, &h57, &hC6, &h56, &h26, &hC5, &h19, &h70, &h1D, &hC0, &hD4, &hB3, &h4D, &h51, &h98, &hA6, &h57, &h74, &h36, &hEE, &hB6, &h96, &h7D, &hF4, &h68, &h8B, &h79, &h72, &h7E, &hB2, &hE2, &h35, &hA9, &h78, &h7F, &h51, &h13, &h71, &hD5, &h1A, &h62, &hB3, &h24, &h11, &hF1, &hCC, &h2D, &hA9, &hB1, &h58, &hD4, &h57, &h3A, &hAA, &hF5, &hD8, &h80, &h1B, &h12, &hE5, &hC4, &h3C, &h7E, &hA2, &h7D, &h9E, &h75, &h15, &h30, &hEB, &h89, &hE7, &h40, &h74, &hBC, &h56, &h8B, &h8B, &h6D, &hEA, &h5D, &hD5, &hDB, &hFD, &hCB, &hEF, &h2E, &h7A, &hD4, &h7C, &h63, &h56, &h54, &h4A, &h72, &h3A, &hB3, &h62, &hB1, &h76, &hD6, &hA5, &h8F, &hF7, &h41, &h2C, &hA6, &h25, &h34, &hEA, &h2B, &h31, &h1C, &hE4, &h3A, &hDF, &h8C, &h55, &h1A, &h87, &h58, &h14, &hAF, &hDE, &h8D, &hC5, &h9B, &h9A, &h8E, &h9A, &hF3, &h8A, &h59, &h91, &hAC, &h4F, &hAD, &h6A, &h54, &h5B, &hF8, &hD3, &hA9, &hB3, &h67, &h50, &h6C, &h1C, &h4D, &h60, &h37, &h9C, &h62, &hB6, &hE9, &hDC, &hDB, &hB1, &hA9, &hB9, &h4C, &h14, &hD6, &h9A, &hE3, &h11, &hCE, &h06, &hF1, &h3D, &h30, &h5B, &h52, &hA8, &hA3, &h2A, &h20, &hDE, &h42, &h9E, &hCD, &hB4, &hD5, &h0C, &h45, &hE0, &hDD, &h8A, &hEA, &h1A, &h62, &h9E, &hDC, &h96, &h88, &hB6, &hC7, &h4D, &h67, &hCC, &h7E, &h74, &hCE, &hA6, &h0E, &hD8, &h6C, &h75, &hEE, &h67, &hF1, &h9A, &hB7, &hE5, &hDE, &h76, &h3F, &hCD, &h7B, &h73, &hA1, &h3B, &hBA, &h36, &h3F, &hDC, &hDF, &h18, &h0D, &h30, &h6C, &hC9, &h29, &h5F, &hAD, &h2D, &h8F, &h6B, &h47, &h56, &h05, &h2B, &hF7, &h92, &hA3, &h25, &h4E, &h77, &h16, &h7E, &h74, &h79, &h68, &h5B, &h18, &h3B, &h68, &hD4, &h5B, &hBB, &h92, &hD4, &h5B, &h73, &h7C, &h67, &h53, &hE9, &hD0, &hE5, &h8E, &hFD, &h7A, &hE6, &hDD, &h8C, &hD5, &hF4, _
    &hD1, &h56, &h64, &h96, &h53, &h12, &h9A, &h73, &hE5, &hA1, &h6D, &hC5, &hDF, &h20, &hB6, &hA6, &hC5, &h1A, &h27, &hAB, &hFC, &h9E, &hAF, &hE9, &h3D, &h5F, &hD2, &h7A, &hBF, &hA4, &hF5, &h7F, &h49, &hEA, &hFE, &h93, &hD5, &hFD, &h20, &h0E, &hDF, &hD3, &h33, &h65, &hF2, &h67, &hB1, &hC7, &h77, &hCF, &h3C, &h77, &h32, &h14, &hF6, &hEF, &h92, &hD1, &h1E, &hBF, &h1C, &hCF, &hE3, &hFE, &hFF, &h00, &hBA, &hF6, &h15, &h36, &h6C, &hFF, &h00, &hBA, &h76, &hEF, &h9D, &hF8, &hEF, &hC7, &h99, &hFC, &h7F, &hF7, &h35, &h6F, &hC0, &hB7, &hAE, &h7B, &h1D, &hCA, &h62, &h53, &h58, &hF4, &h06, &h0E, &hD1, &hDF, &hE7, &hA1, &hC7, &h6E, &h16, &h3E, &hB9, &hCD, &h71, &hF0, &h16, &hF4, &h81, &h45, &h7E, &hFB, &h21, &h4F, &h66, &h07, &h57, &h15, &hD3, &h13, &hA9, &h82, &h59, &hF2, &h16, &hC0, &hA2, &h8F, &hCE, &h4B, &hE4, &h51, &h6E, &hFF, &h00, &hF9, &hDA, &h1E, &h4F, &hCF, &hC9, &hEB, &h78, &hBC, &h5F, &h4C, &h45, &h3F, &h03, &h52, &hD9, &h6C, &hB9, &h72, &hE5, &hFC, &h9D, &h1F, &h32, &hD2, &hD2, &hD2, &hD2, &hD2, &hD2, &hDD, &h88, &h00, &h02, &h8C, &h57, &h5C, &h55, &h38, &h8B, &h3E, &hDF, &h42, &h16, &hE2, &hBD, &h33, &h1B, &h31, &h4A, &h7E, &h82, &h68, &hC5, &hE6, &hF8, &hC4, &h59, &hF4, &h01, &h6E, &h2B, &h16, &hDC, &hCE, &h8C, &h1B, &h31, &h1C, &hF7, &hDB, &hC0, &hA3, &h15, &hA2, &hB8, &hC8, &h53, &hDE, &h8A, &hEB, &hCE, &h2B, &h51, &hEB, &hA4, &hAC, &hC5, &h2C, &h89, &h4F, &h77, &hC8, &hE2, &hC5, &h7A, &h63, &h4C, &h1C, &h52, &hE2, &h57, &h73, &hC8, &hE4, &hB5, &h55, &h64, &h97, &h28, &hDB, &h6E, &hDB, &h79, &h46, &hFB, &hE4, &hBB, &h61, &hB6, &hD1, &h2B, &h7E, &hCC, &h4C, &h00, &hC9, &h47, &hAF, &h6E, &h25, &hEF, &h1F, &h19, &h55, &hAE, &h26, &h00, &hF7, &h9A, &hC5, &hBE, &hC8, &h81, &hCF, &h78, &h9E, &h22, &hA5, &h68, &h82, &hF1, &h0F, &h38, &h03, &h41, &h63, &hD7, &hB4, &h1A, &h83, &hA5, &h4F, &h12, &hB3, &hEF, &h9F, &h7C, &hFB, &hE5, &h65, &h3C, &h4A, &h3C, &h68, &hAC, &h7B, &h70, &hD4, &h22, &hFB, &h75, &h8B, &hDD, &h0D, &h42, &h2F, &hB2, &hB8, &hC3, &hDF, &h06, &h10, &h45, &hEA, &hDC, &h61, &hFA, &h1A, &hDC, &h05, &hCB, &h97, &h2E, &h5E, &h21, &h7F, &h4A, &hB9, &h6C, &hB7, &hBA, &hFF, &hD9}


Dim Shared gdipToken As ULONG_PTR
Dim Shared GDIp As GdiplusStartupInput

Const As UShort iW = 700, iH = 700, iW2 = iW \ 2
Const as Ulong iFlameParticles = 200

Screenres(iW, iH, 32, 1, GFX_ALPHA_PRIMITIVES or GFX_HIGH_PRIORITY)
Dim memImage As Any Ptr = ScreenPtr()
WindowTitle("Simple Flame Simulation v2.0")

'center windows by adding the taskbar to the calculation
Dim as Integer iDW, iDH
ScreenControl GET_DESKTOP_SIZE, iDW, iDH
Dim tWorkingArea As RECT
SystemParametersInfo(SPI_GETWORKAREA, null, @tWorkingArea, null)
ScreenControl SET_WINDOW_POS, (tWorkingArea.Right - iW) \ 2, (tWorkingArea.Bottom - iH) \ 2

Dim Shared As Integer w, h, bpp, scanline
ScreenInfo w, h, , bpp, scanline
Color 0, &hFFFFFF
Dim As Any Ptr pImageBlurred, pImage = ImageCreate(iW, iH), pImageBack = ImageCreate(iW, iH, &hFF000000), _
               pImageLogo = Convert2FBImage(__Logojpg())

Dim As Integer wl, hl
Imageinfo(pImageLogo, wl, hl)
   
Put pImageBack, ((iW - wl) / 2, 100), pImageLogo, Alpha

Dim AS Single aFlameCoords(0 to iFlameParticles, 8)

Randomize , 2
Dim as ulong i, iFPS = 0, iFPS_current = 0
For i = 0 to Ubound(aFlameCoords) - 1
   GenFlameParticle(aFlameCoords(), i)
Next

Dim evt As EVENT
Dim As Double fTimer = Timer

Do
   screenlock
   Put pImage, (0, 0), pImageBack, PSet
   
   For i = 0 To iFlameParticles - 1
      If aFlameCoords(i, 1) > -aFlameCoords(i, 4) Then
         Circle pImage, (aFlameCoords(i, 0), aFlameCoords(i, 1)), aFlameCoords(i, 4), aFlameCoords(i, 6), , , 2.5, F
      EndIf
      aFlameCoords(i, 0) -= aFlameCoords(i, 2)
      aFlameCoords(i, 1) -= aFlameCoords(i, 3)
      aFlameCoords(i, 4) -= aFlameCoords(i, 7)
      If aFlameCoords(i, 4) < aFlameCoords(i, 7) Then GenFlameParticle(aFlameCoords(), i)
   Next
   
   pImageBlurred = ImageBlur(pImage, 28)
   ImageContrast(pImageBlurred, 120, 0)
   
   Put (0, 0), pImageBlurred, Pset
   Draw String(0, 0), iFPS_current & " fps", RGB(&hA0, &hA0, &hA0)
   
   screenunlock
   ImageDestroy(pImageBlurred)

   If Timer - fTimer > 0.99 Then
      iFPS_current = iFPS
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   EndIf
   
   Sleep(1, 1)
Loop Until ((InKey = Chr(27)) Or (evt.Type = EVENT_WINDOW_CLOSE))

ImageDestroy(pImageBack)
ImageDestroy(pImage)
ImageDestroy(pImageLogo)

Sub GenFlameParticle(aFlameCoords() as Single, iPos as ushort, iWidth as UShort = 100)
   aFlameCoords(iPos, 4) = RandomRange(3, iWidth) 'size
   aFlameCoords(iPos, 0) = RandomRange(iW2 - iWidth, iW2 + iWidth)
   aFlameCoords(iPos, 1) = iH
   aFlameCoords(iPos, 2) = RandomRange(-8, 8) 'vx
   aFlameCoords(iPos, 3) = RandomRange(10, 25) 'vy (power of flame)
   aFlameCoords(iPos, 5) = CUbyte(RandomRange(&h60, &hFF))
   Dim as Ubyte iYellow = CUbyte(aFlameCoords(iPos, 5) - &hFF * Abs(aFlameCoords(iPos, 0) - iW2) / (2 * iW2))
   aFlameCoords(iPos, 6) = &hE8FF0000 + iYellow Shl 8 + Cubyte(iYellow * 0.6666)
   aFlameCoords(iPos, 7) = RandomRange(2.5, 5) 'min size of flame particle
End Sub

Function RandomRange(fStart as Single, fEnd as Single) as Single
   Return Rnd() * (fEnd - fStart) + fStart
End Function

Sub ImageContrast(pImage as any Pointer, contrast as Byte, brightness as Byte = 0)
   #Define Blue(colour) ((colors Shr 16) And 255)
   #Define Green(colour) ((colors Shr 8) And 255)
   #Define Red(colour) (colors And 255)
   #Define Truncate(colour) (Iif(colour < 0, 0, Iif(colour > 255, 255, CUbyte(colour))))
   Dim as Ulong colors
   Dim As Integer w, h, pitch
   Dim As Any Pointer pixdata
   Imageinfo(pImage, w, h, , pitch, pixdata)
   
   Dim as Single factor, contrastLevel = ((100.0 + contrast) / 100.0) * ((100.0 + contrast) / 100.0)
   
   For y as UShort = 0 to iH - 1
      For x as Ushort = 0 to iW - 1
         colors = *CPtr(ulong ptr, pixdata + y * pitch + x Shl 2)
         *CPtr(ulong ptr, pixdata + y * pitch + x Shl 2) = RGB(Truncate(((((Blue(colour) / 255.0) - 0.5) * contrastLevel) + 0.5) * 255.0 + brightness), _
                                                               Truncate(((((Green(colour) / 255.0) - 0.5) * contrastLevel) + 0.5) * 255.0 + brightness), _
                                                               Truncate(((((Red(colour) / 255.0) - 0.5) * contrastLevel) + 0.5) * 255.0) + brightness)
      Next
   Next
End Sub

Function ImageBlur(pImage As Any Ptr, iRadius As Long, iExpandEdge As Long = 0) As Any Ptr
   'By Eukalyptus
   Dim As Integer iWidth, iHeight, iPX, iPitch, iPitchBlur
   Dim As Any Ptr pData, pDataBlur, pDataTmp
   
   If ImageInfo(pImage, iWidth, iHeight, iPX, iPitch, pData) <> 0 Then Return 0
   If iPX <> 4 Then Return 0
   
   If iRadius < 0 Then
      iRadius = 0
   ElseIf iRadius > 127 Then
      iRadius = 127
   EndIf
   
   Dim As Any Ptr pImgBlur, pImgTmp
   If iExpandEdge <> 0 Then
      iWidth += iRadius * 2
      iHeight += iRadius * 2
   EndIf
   
   pImgBlur = ImageCreate(iWidth, iHeight, 0, 32)
   pImgTmp = ImageCreate(iWidth, iHeight, 0, 32)
   
   ImageInfo(pImgBlur, , , , iPitchBlur, pDataBlur)
   ImageInfo(pImgTmp, , , , , pDataTmp)
   If pImgBlur = 0 Or pImgTmp = 0 Then
      ImageDestroy(pImgBlur)
      ImageDestroy(pImgTmp)
      Return 0
   EndIf
   
   If iExpandEdge <> 0 Then
      Put pImgBlur, (iRadius, iRadius), pImage, Alpha
   Else
      Put pImgBlur, (0, 0), pImage, Alpha
   EndIf
   

   Asm
      mov ecx, [iWidth]
      mov ebx, [iHeight]
      mov edx, [iPitchBlur]

      mov edi, [pDataTmp]
      mov esi, [pDataBlur]
       
      mov eax, [iRadius]
      inc eax
      push ebp
      mov ebp, eax
       
      sub esp, 64

      mov [esp+8], ecx
      mov [esp+12], ebx
      mov [esp+16], edx
      mov [esp+20], ebp
      mov [esp+24], edi
      mov [esp+32], edi
      mov [esp+28], esi
      mov [esp+36], esi

      '       0   4   8   12  16       20  24     28     32      36
      'esp = [X] [Y] [W] [H] [Stride] [R] [pDst] [pSrc] [pDstO] [pSrcO]

      mov eax, 0x47000000 'ByteToFloat MSK
      movd xmm7, eax
      pshufd xmm7, xmm7, 0

      ' ####################################################
      ' # W-Loop
      ' ####################################################

      mov ebx, [esp+12]
      mov [esp+4], ebx
      _Blur_LoopW:
         mov edi, [esp+24]
         mov esi, [esp+28]
         mov edx, [esp+16] 'Stride
         add dword ptr[esp+24], 4 'next RowCol(Transform vertical<->horizontal)
         add [esp+28], edx 'next Row

         mov edx, [esp+12] 'Y-Stride
         shl edx, 2

         pxor xmm6, xmm6 'Reset In-Out
         pxor xmm5, xmm5 'Reset Sum
         /'
         xmm7 = Msk
         xmm6 = [AO][RO][GO][BO][AI][RI][GI][BI]
         xmm5 = [AS][RS][GS][BS]

         eax = (SumDiv)
         ebx = (DivInc)
         ecx = X
         edx = Stride
         esi = Src
         edi = Dst
         ebp = R
         '/

         pxor xmm4, xmm4 'UnPack

         mov eax, 0 'Reset SumDiv
         mov ebx, 0 'Reset DivInc

         ' ----------------------------------------------------
         ' | X-In += Next
         ' ----------------------------------------------------
         mov ebp, 0 'Offset
         mov ecx, [esp+20] 'iR
         _Blur_LoopX_In:
            movd xmm0, [esi+ebp]
            punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][An][Rn][Gn][Bn] Next
            paddw xmm6, xmm0 'IN+=Next
            movdqa xmm0, xmm6
            punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
            paddd xmm5, xmm0 'Stack += IN

            add ebx, 1 'SumDivInc += 1
            add eax, ebx 'SumDiv += Inc

            add ebp, 4
            sub ecx, 1
            jg _Blur_LoopX_In


         ' ----------------------------------------------------
         ' | XIn += Next / XIn -= Mid / XOut += Mid
         ' ----------------------------------------------------
         mov ecx, [esp+20] 'iR
         _Blur_LoopX_InOut:
            cvtsi2ss xmm3, eax
            rcpss xmm3, xmm3
            pshufd xmm3, xmm3, 0 'SumDiv

            movdqa xmm0, xmm5
            paddd xmm0, xmm7 ' UByte -> Float
            subps xmm0, xmm7 '/
            mulps xmm0, xmm3
            addps xmm0, xmm7 ' Float -> UByte
            psubd xmm0, xmm7 '/
            packssdw xmm0, xmm0 '[A][R][G][B][A][R][G][B]
            packuswb xmm0, xmm0 '[ARGB][ARGB][ARGB][ARGB]
            movd [edi], xmm0

            movd xmm0, [esi+ebp]
            movd xmm1, [esi]
            punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][An][Rn][Gn][Bn] Next
            punpcklbw xmm1, xmm4 '[ ][ ][ ][ ][Am][Rm][Gm][Bm] Mid
            movlhps xmm0, xmm1 '[Am][Rm][Gm][Bm][An][Rn][Gn][Bn] = [Mid][Next]
            paddw xmm6, xmm0 'OUT+=Mid / IN+=Next
            psubw xmm6, xmm1 '(OUT-=Last) / IN-=Mid
            movdqa xmm1, xmm6
            movdqa xmm0, xmm6
            punpckhwd xmm1, xmm4 '[AO][RO][GO][BO]
            punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
            psubd xmm5, xmm1 'Stack -= OUT
            paddd xmm5, xmm0 'Stack += IN

            sub ebx, 1 'SumDivInc += 1
            add eax, ebx 'SumDiv += Inc

            add esi, 4
            add edi, edx
            sub ecx, 1
            jg _Blur_LoopX_InOut


         cvtsi2ss xmm3, eax
         rcpss xmm3, xmm3
         pshufd xmm3, xmm3, 0 'SumDiv

         mov ebx, ebp
         neg ebx 'Last Index


         ' ----------------------------------------------------
         ' | XIn += Next / XIn -= Mid / XOut += Mid / XOut -= Last
         ' ----------------------------------------------------
         mov ecx, [esp+8] 'iWidth
         sub ecx, [esp+20]
         sub ecx, [esp+20]
         _Blur_LoopX:
            movdqa xmm0, xmm5
            paddd xmm0, xmm7 ' UByte -> Float
            subps xmm0, xmm7 '/
            mulps xmm0, xmm3
            addps xmm0, xmm7 ' Float -> UByte
            psubd xmm0, xmm7 '/
            packssdw xmm0, xmm0 '[A][R][G][B][A][R][G][B]
            packuswb xmm0, xmm0 '[ARGB][ARGB][ARGB][ARGB]
            movd [edi], xmm0

            movd xmm0, [esi+ebp]
            movd xmm1, [esi]
            movd xmm2, [esi+ebx]
            punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][An][Rn][Gn][Bn] Next
            punpcklbw xmm1, xmm4 '[ ][ ][ ][ ][Am][Rm][Gm][Bm] Mid
            punpcklbw xmm2, xmm4 '[ ][ ][ ][ ][Al][Rl][Gl][Bl] Last
            movlhps xmm0, xmm1 '[Am][Rm][Gm][Bm][An][Rn][Gn][Bn] = [Mid][Next]
            movlhps xmm1, xmm2 '[Al][Rl][Gl][Bl][Ao][Ro][Go][Bo] = [Last][Mid]
            paddw xmm6, xmm0 'OUT+=Mid / IN+=Next
            psubw xmm6, xmm1 'OUT-=Last / IN-=Mid
            movdqa xmm1, xmm6
            movdqa xmm0, xmm6
            punpckhwd xmm1, xmm4 '[AO][RO][GO][BO]
            punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
            psubd xmm5, xmm1 'Stack -= OUT
            paddd xmm5, xmm0 'Stack += IN

            add esi, 4
            add edi, edx
            sub ecx, 1
            jg _Blur_LoopX


         ' ----------------------------------------------------
         ' | XIn -= Mid / XOut += Mid / XOut -= Last
         ' ----------------------------------------------------
         mov ebp, 0 'DivInc
         mov ecx, [esp+20] 'iR
         _Blur_LoopX_Out:
            cvtsi2ss xmm3, eax
            rcpss xmm3, xmm3
            pshufd xmm3, xmm3, 0 'SumDiv

            movdqa xmm0, xmm5
            paddd xmm0, xmm7 ' UByte -> Float
            subps xmm0, xmm7 '/
            mulps xmm0, xmm3
            addps xmm0, xmm7 ' Float -> UByte
            psubd xmm0, xmm7 '/
            packssdw xmm0, xmm0 '[A][R][G][B][A][R][G][B]
            packuswb xmm0, xmm0 '[ARGB][ARGB][ARGB][ARGB]
            movd [edi], xmm0

            movd xmm0, [esi]
            movd xmm1, [esi+ebx]
            punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][Am][Rm][Gm][Bm] Mid
            punpcklbw xmm1, xmm4 '[ ][ ][ ][ ][Al][Rl][Gl][Bl] Last
            movlhps xmm0, xmm1 '[Al][Rl][Gl][Bl][Am][Rm][Gm][Bm] = [Last][Mid]
            psubw xmm6, xmm0 'OUT-=Last / IN-=Mid
            pslldq xmm0, 8
            paddw xmm6, xmm0 'OUT+=Mid / (IN+=Next)
            movdqa xmm1, xmm6
            movdqa xmm0, xmm6
            punpckhwd xmm1, xmm4 '[AO][RO][GO][BO]
            punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
            psubd xmm5, xmm1 'Stack -= OUT
            paddd xmm5, xmm0 'Stack += IN

            add ebp, 1
            sub eax, ebp

            add esi, 4
            add edi, edx
            sub ecx, 1
            jg _Blur_LoopX_Out

         sub dword ptr[esp+4], 1
         jg _Blur_LoopW



      ' ####################################################
      ' # H-Loop
      ' ####################################################


      mov edi, [esp+36]
      mov esi, [esp+32]
      mov [esp+24], edi
      mov [esp+28], esi

      mov ebx, [esp+8]
      mov [esp], ebx
      _Blur_LoopH:
         mov edi, [esp+24]
         mov esi, [esp+28]
         mov edx, [esp+12]
         Shl edx, 2
         Add dword ptr[esp+24], 4 'next Col
         Add [esp+28], edx 'next ColRow

         mov edx, [esp+16] 'Stride

         pxor xmm6, xmm6 'Reset In-Out
         pxor xmm5, xmm5 'Reset Sum

         /'
         xmm7 = Msk
         xmm6 = [AO][RO][GO][BO][AI][RI][GI][BI]
         xmm5 = [AS][RS][GS][BS]

         eax = (SumDiv)
         ebx = (DivInc)
         ecx = X
         edx = Stride
         esi = Src
         edi = Dst
         ebp = R
         '/

         pxor xmm4, xmm4 'UnPack

         mov eax, 0 'Reset SumDiv
         mov ebx, 0 'Reset DivInc

         ' ----------------------------------------------------
         ' | X-In += Next
         ' ----------------------------------------------------
         mov ebp, 0 'Offset
         mov ecx, [esp+20] 'iR
         _Blur_LoopY_In:
            movd xmm0, [esi+ebp]
            punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][An][Rn][Gn][Bn] Next
            paddw xmm6, xmm0 'IN+=Next
            movdqa xmm0, xmm6
            punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
            paddd xmm5, xmm0 'Stack += IN

            Add ebx, 1 'SumDivInc += 1
            Add eax, ebx 'SumDiv += Inc

            Add ebp, 4
            Sub ecx, 1
            jg _Blur_LoopY_In


         ' ----------------------------------------------------
         ' | XIn += Next / XIn -= Mid / XOut += Mid
         ' ----------------------------------------------------
         mov ecx, [esp+20] 'iR
         _Blur_LoopY_InOut:
            cvtsi2ss xmm3, eax
            rcpss xmm3, xmm3
            pshufd xmm3, xmm3, 0 'SumDiv

            movdqa xmm0, xmm5
            paddd xmm0, xmm7 ' UByte -> Float
            subps xmm0, xmm7 '/
            mulps xmm0, xmm3
            addps xmm0, xmm7 ' Float -> UByte
            psubd xmm0, xmm7 '/
            packssdw xmm0, xmm0 '[A][R][G][B][A][R][G][B]
            packuswb xmm0, xmm0 '[ARGB][ARGB][ARGB][ARGB]
            movd [edi], xmm0

            movd xmm0, [esi+ebp]
            movd xmm1, [esi]
            punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][An][Rn][Gn][Bn] Next
            punpcklbw xmm1, xmm4 '[ ][ ][ ][ ][Am][Rm][Gm][Bm] Mid
            movlhps xmm0, xmm1 '[Am][Rm][Gm][Bm][An][Rn][Gn][Bn] = [Mid][Next]
            paddw xmm6, xmm0 'OUT+=Mid / IN+=Next
            psubw xmm6, xmm1 '(OUT-=Last) / IN-=Mid
            movdqa xmm1, xmm6
            movdqa xmm0, xmm6
            punpckhwd xmm1, xmm4 '[AO][RO][GO][BO]
            punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
            psubd xmm5, xmm1 'Stack -= OUT
            paddd xmm5, xmm0 'Stack += IN

            Sub ebx, 1 'SumDivInc += 1
            Add eax, ebx 'SumDiv += Inc

            Add esi, 4
            Add edi, edx
            Sub ecx, 1
            jg _Blur_LoopY_InOut


         cvtsi2ss xmm3, eax
         rcpss xmm3, xmm3
         pshufd xmm3, xmm3, 0 'SumDiv

         mov ebx, ebp
         neg ebx 'Last Index


         ' ----------------------------------------------------
         ' | XIn += Next / XIn -= Mid / XOut += Mid / XOut -= Last
         ' ----------------------------------------------------
         mov ecx, [esp+12] 'iHeight
         Sub ecx, [esp+20]
         Sub ecx, [esp+20]
         _Blur_LoopY:
            movdqa xmm0, xmm5
            paddd xmm0, xmm7 ' UByte -> Float
            subps xmm0, xmm7 '/
            mulps xmm0, xmm3
            addps xmm0, xmm7 ' Float -> UByte
            psubd xmm0, xmm7 '/
            packssdw xmm0, xmm0 '[A][R][G][B][A][R][G][B]
            packuswb xmm0, xmm0 '[ARGB][ARGB][ARGB][ARGB]
            movd [edi], xmm0

            movd xmm0, [esi+ebp]
            movd xmm1, [esi]
            movd xmm2, [esi+ebx]
            punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][An][Rn][Gn][Bn] Next
            punpcklbw xmm1, xmm4 '[ ][ ][ ][ ][Am][Rm][Gm][Bm] Mid
            punpcklbw xmm2, xmm4 '[ ][ ][ ][ ][Al][Rl][Gl][Bl] Last
            movlhps xmm0, xmm1 '[Am][Rm][Gm][Bm][An][Rn][Gn][Bn] = [Mid][Next]
            movlhps xmm1, xmm2 '[Al][Rl][Gl][Bl][Ao][Ro][Go][Bo] = [Last][Mid]
            paddw xmm6, xmm0 'OUT+=Mid / IN+=Next
            psubw xmm6, xmm1 'OUT-=Last / IN-=Mid
            movdqa xmm1, xmm6
            movdqa xmm0, xmm6
            punpckhwd xmm1, xmm4 '[AO][RO][GO][BO]
            punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
            psubd xmm5, xmm1 'Stack -= OUT
            paddd xmm5, xmm0 'Stack += IN

            Add esi, 4
            Add edi, edx
            Sub ecx, 1
            jg _Blur_LoopY


         ' ----------------------------------------------------
         ' | XIn -= Mid / XOut += Mid / XOut -= Last
         ' ----------------------------------------------------
         mov ebp, 0 'DivInc
         mov ecx, [esp+20] 'iR
         _Blur_LoopY_Out:
            cvtsi2ss xmm3, eax
            rcpss xmm3, xmm3
            pshufd xmm3, xmm3, 0 'SumDiv

            movdqa xmm0, xmm5
            paddd xmm0, xmm7 ' UByte -> Float
            subps xmm0, xmm7 '/
            mulps xmm0, xmm3
            addps xmm0, xmm7 ' Float -> UByte
            psubd xmm0, xmm7 '/
            packssdw xmm0, xmm0 '[A][R][G][B][A][R][G][B]
            packuswb xmm0, xmm0 '[ARGB][ARGB][ARGB][ARGB]
            movd [edi], xmm0

            movd xmm0, [esi]
            movd xmm1, [esi+ebx]
            punpcklbw xmm0, xmm4 '[ ][ ][ ][ ][Am][Rm][Gm][Bm] Mid
            punpcklbw xmm1, xmm4 '[ ][ ][ ][ ][Al][Rl][Gl][Bl] Last
            movlhps xmm0, xmm1 '[Al][Rl][Gl][Bl][Am][Rm][Gm][Bm] = [Last][Mid]
            psubw xmm6, xmm0 'OUT-=Last / IN-=Mid
            pslldq xmm0, 8
            paddw xmm6, xmm0 'OUT+=Mid / (IN+=Next)
            movdqa xmm1, xmm6
            movdqa xmm0, xmm6
            punpckhwd xmm1, xmm4 '[AO][RO][GO][BO]
            punpcklwd xmm0, xmm4 '[AI][RI][GI][BI]
            psubd xmm5, xmm1 'Stack -= OUT
            paddd xmm5, xmm0 'Stack += IN

            Add ebp, 1
            Sub eax, ebp

            Add esi, 4
            Add edi, edx
            Sub ecx, 1
            jg _Blur_LoopY_Out


         Sub dword Ptr[esp], 1
         jg _Blur_LoopH

      add esp, 64
       
      pop ebp
   End Asm
   

   ImageDestroy(pImgTmp)
   Return pImgBlur
End Function

Function _GDIPlus_Startup() As Byte
   GDIp.GdiplusVersion = 1
   If GdiplusStartup(@gdipToken, @GDIp, NULL) <> 0 Then
      Return FALSE
   EndIf
   Return TRUE
End Function

Sub _GDIPlus_Shutdown()
   GdiplusShutdown(gdipToken)
End Sub

Function _GDIPlus_BitmapCreateFromMemory(aBinImage() As UByte, bBitmap_GDI As Bool = FALSE) As Any Ptr
   Dim As HGLOBAL hGlobal
   Dim As LPSTREAM hStream
   Dim As Any Ptr hBitmap
   Dim As ULong iLen = UBound(aBinImage) + 1
   Dim As Any Ptr hMemory = GlobalAlloc(GMEM_MOVEABLE, iLen)
   Dim As Any Ptr lpMemory = GlobalLock(hMemory)
   RtlCopyMemory(lpMemory, @aBinImage(0), iLen)
   GlobalUnlock(hMemory)
   
   CreateStreamOnHGlobal(hMemory, 0, @hStream)
   GdipCreateBitmapFromStream(hStream, @hBitmap)
   IUnknown_Release(hStream)
   
   If bBitmap_GDI = TRUE Then
      Dim hBitmap_GDI As Any Ptr
      GdipCreateHBITMAPFromBitmap(hBitmap, @hBitmap_GDI, &hFF000000)
      GdipDisposeImage(hBitmap)
      Return hBitmap_GDI
   EndIf
   Return hBitmap
End Function

Function Convert2FBImage(aMemGDIpBitmap() as UByte) as any Ptr
   _GDIPlus_Startup()
   Dim as any Ptr hImage = _GDIPlus_BitmapCreateFromMemory(aMemGDIpBitmap()), pImageMem
   Dim As Single iW_Img, iH_Img
   GdipGetImageDimension(hImage, @iW_Img, @iH_Img)
   
   pImageMem = ImageCreate(iW_Img, iH_Img)
     
   Dim As Integer w, h, pitchMem
   Dim As Any Pointer pixdataMem
   Imageinfo(pImageMem, w, h, , pitchMem, pixdataMem)
   
   Dim As Rect tRect = Type(0, 0, iW_Img - 1, iH_Img - 1)
   Dim As BitmapData tBitmapData
   GdipBitmapLockBits(hImage, Cast(Any Ptr, @tRect), ImageLockModeRead, PixelFormat32bppARGB, @tBitmapData)
   
   Dim as Ulong iX, iY, iRowOffset
   For iY = 0 To iH_Img - 1
      iRowOffset = iY * iW_Img
      For iX = 0 To iW_Img - 1
         *cptr(ulong ptr, pixdataMem + iY * pitchMem + iX shl 2) = Cast(ulong Ptr, tBitmapData.Scan0)[iRowOffset + iX]
      Next
   Next
   GdipBitmapUnlockBits(hImage, @tBitmapData)
   GdipDisposeImage(hImage)
   _GDIPlus_Shutdown()
   Return pImageMem
End Function


Schade, dass der Code nicht in einem kleinen Fenster angezeigt wird.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 17.01.2018, 16:20    Titel: Antworten mit Zitat

The Zoomquilt [Windows only]:

Code:

'coded by UEZ build 2018-01-15
'inspired by http://zoomquilt.org - thanks to Nikolaus Baumgarten
'thanks to spudw2k for the mouse calculation

#define WIN_INCLUDEALL
#Include "fbgfx.bi"
#Include "file.bi"
#Include "windows.bi"
#Include "win/gdiplus.bi"

Using GDIPLUS
Using FB

#Ifndef Floor
   #Define Floor(x) (((x) * 2.0 - 0.5) Shr 1) '' http://www.freebasic.net/forum/viewtopic.php?p=118633
   #Define Ceiling(x) (-((-(x) * 2.0 - 0.5) Shr 1))
#EndIf
 
declare function RemoteGetFile(url as string, filePath as string) as HRESULT
declare Sub DownloadImages()

DownloadImages() 'download images if not exist, code will end if download fails

Dim as Boolean bMultimonitor = False 'set it to true if you want to extend to your other monitors

Dim GDIPlusStartupInput As GDIPLUSSTARTUPINPUT
Dim As ULONG_PTR GDIPlusToken

GDIPlusStartupInput.GdiplusVersion = 1
If (GdiplusStartup(@GDIPlusToken, @GDIPlusStartupInput, NULL) <> 0) Then
   End 'FAILED TO INIT GDI+!
EndIf

Dim as any Ptr aImages(0 to 46), hImage
Dim as UByte i

'load local images with GDIPlus and convert it to GDI
For i = 0 to Ubound(aImages) - 1
   GdipLoadImageFromFile(CurDir & "\Images\TheZoomquilt" & i & ".jpg", @hImage)
   GdipCreateHBITMAPFromBitmap(hImage, @aImages(i), &hFF000000)
   GdipDisposeImage(hImage)
Next

Dim As String sTitle = "GDI Infinite Image Zoom Flight v1.2"


'get desktop dimension
Dim As Integer iW_Dt, iH_Dt
Dim As RECT tDesktop

If bMultimonitor Then
   Dim As hwnd hHWND_Dt
   hHWND_Dt = FindWindow("Progman","Program Manager")
   GetWindowRect(hHWND_Dt, @tDesktop)
   iW_Dt = Abs(tDesktop.left) + tDesktop.right
   iH_Dt = Abs(tDesktop.top) + tDesktop.bottom
Else
   ScreenInfo iW_Dt, iH_Dt
End If


'get image dimension from GDI image
Dim tBitmap As tagBITMAP
GetObject(aImages(0), Sizeof(tBitmap), @tBitmap)
DIm As Long iW = tBitmap.bmWidth, iH = tBitmap.bmHeight


ScreenControl(SET_DRIVER_NAME, "GDI")
ScreenRes(iW_Dt, iH_Dt, 32, 1, GFX_HIGH_PRIORITY or GFX_NO_FRAME or GFX_ALWAYS_ON_TOP)
WindowTitle(sTitle)

Dim as HWND hHWND
ScreenControl(GET_WINDOW_HANDLE, Cast(Integer, hHWND))

If bMultimonitor Then
   ScreenControl(SET_WINDOW_POS, tDesktop.left, tDesktop.top)
   MoveWindow(hHWND, tDesktop.left, tDesktop.top, iW_Dt, iH_Dt, 1)
End if
   

Dim As Any Ptr hDC = GetDC(hHWND), _
               hHBitmap = CreateCompatibleBitmap(hDC, iW_Dt, iH_Dt), _
               hDC_backbuffer = CreateCompatibleDC(hDC), _
               hMemDC = CreateCompatibleDC(hDC), hFont, DC_obj, hObjOld, hObjOld2

DC_obj = SelectObject(hDC_backbuffer, hHBitmap)

SetStretchBltMode(hDC_backbuffer, STRETCH_DELETESCANS)

hFont = CreateFontW(12, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, _
                    ANTIALIASED_QUALITY, DEFAULT_PITCH, "Arial")
hObjOld2 = SelectObject(hDC_backbuffer, hFont)
SetTextColor(hDC_backbuffer, &hFFFFFF)
SetBkMode(hDC_backbuffer, TRANSPARENT)


Dim evt As EVENT
Dim As ULong iFPS = 0
Dim as String sFPS = "0"
Dim As Double fTimer = Timer

'position FPS text
Dim tRECT as tagRECT
tRECT.Left = 4
tRECT.top = 4
tRECT.Right = 120
tRECT.Bottom = 20

Dim as UByte e, iDepth = 3
Dim as any Ptr a(0 to iDepth)
Dim as Single fPos_z = 1.0, fScale, x, y, w, h, fImg_w, fImg_h, fCenterX, fCenterY

fCenterX = iW_Dt / 2
fCenterY = iH_Dt / 2

If iW_Dt > 1.5 * iH_Dt Then
   fImg_w = iW_Dt
   fImg_h = 0.75 * iW_Dt
Else
   fImg_w = 1.5 * iH_Dt
   fImg_h = 0.75 * iH_Dt
EndIf

Dim as Single iStep = 0.025, iOutMin = 1.0, iOutMax = -1.0
Dim as UShort iInMin = 0, iInMax = iH_Dt
Dim As Integer iMPosX, iMPosY, iMPos

Do
   
   For e = 0 to iDepth - 1
      a(e) = aImages((Floor(fPos_z) + e) Mod Ubound(aImages))
   Next
   
   fScale = 2^(Frac(fPos_z))
 
   For e = 0 to iDepth - 1
      x = fCenterX - fImg_w / 2 * fScale
      y = fCenterY - fImg_h / 2 * fScale
      w = fImg_w * fScale
      h = fImg_h * fScale     
      hObjOld = SelectObject(hMemDC, a(e))
      StretchBlt(hDC_backbuffer, Floor(x), Floor(y), Ceiling(w), Ceiling(h), hMemDC, 0, 0, iW, iH, SRCCOPY)
      fScale *= 0.5
   Next
   
   iMPos = GetMouse (iMPosx, iMPosY)
   
   fPos_z += ((iMPosY - iInMin) * (iOutMax - iOutMin) / (iInMax - iInMin) + iOutMin) * iStep
   IF fPos_z < 0 Then fPos_z = UBound(aImages) - fPos_z
   
   DrawTextW(hDC_backbuffer, "FPS: " & sFPS & " @ " & iW_Dt & "x" & iH_Dt & " px", -1, @tRECT, 0)
   
   BitBlt(hDC, 0, 0, iW_Dt, iH_Dt, hDC_backbuffer, 0, 0, SRCCOPY)
   
   If Timer - fTimer > 0.99 Then
      sFPS = str(iFPS)
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   EndIf
   
   'Sleep(1, 1)
Loop Until ((InKey = Chr(27)) Or (evt.Type = EVENT_WINDOW_CLOSE))

'Release resources
For i = 0 to Ubound(aImages) - 1
   DeleteObject(aImages(i))
Next
SelectObject(hDC_backbuffer, hObjOld2)
DeleteObject(hFont)
SelectObject(hMemDC, hObjOld)
DeleteDC(hMemDC)
SelectObject(hDC_backbuffer, DC_obj)
DeleteDC(hDC_backbuffer)
ReleaseDC(hHWND, hDC)
GdiplusShutdown(GDIPlusToken)



Sub DownloadImages()
   If FileExists(CurDir & "\Images") = 0 Then
      MkDir(CurDir & "\Images")
   End If
   Dim as String sURL, A(0 to ...) = {"FUjD9hf", "gbHhxTR", "8YyzJdR", "xP3aNkR", "2Qi4fQr", "E6pW5Ky", "zmtWIBF", "Af7LtYp", "TuXy30d", "3nKGLr2", "hNoWscB", "mSBvv3K", "f4wJ70e", "mIt9XmM", "M4TkAyh", "P4L4qhd", "hNM6bTv", "VoT8JXM", "jqcGH0B", "DYVoN8n", "bOPQkOI", "NeaTfJ1", "18ppMNr", "FZ3d8Jv", "HsoX2RP", "mjv4kzI", "6rpJbef", "pySKauq", "WjNQYRV", "Ffooo8y", "Xei5XfD", "T5A415r", "LiV0VNB", "nGcwiO4", "b1Gdjjy", "GE828iy", "eSQ7SLe", "1mPyGgL", "GNtwJIr", "KxBlU7E", "aKXhms5", "9Quu2wu", "Y07quDf", "r0yC5Qa", "273fCkD", "2wMyCUw", "FUjD9hf"}

   For i as UShort = 0 to UBound(A) - 1
      If FileExists(CurDir & "\Images\TheZoomquilt" & i & ".jpg") = 0 Then
         sURL = "http://imgur.com/" & A((20 + i) mod 46) & ".jpg"
         ? "Downloading " & i + 1 & " / " & UBound(A)
         If RemoteGetFile(sURL, CurDir & "\Images\TheZoomquilt" & i & ".jpg") < 0 Then End
      End If
   Next
End Sub

'https://www.freebasic.net/forum/viewtopic.php?f=6&t=24197&p=214027&hilit=URLDownloadToFile#p214324
function RemoteGetFile(url as string, filePath as string) as HRESULT '0 = success
   var hLib = Dylibload("urlmon.dll")
   if hLib = null then
      return -1
   end if

   dim pURLDownloadToFile as function _
       ( _
         byval as LPUNKNOWN, _
         byval as LPCSTR, _
         byval as LPCSTR, _
         byval as DWORD, _
         byval as LPBINDSTATUSCALLBACK _
       ) as HRESULT

   pURLDownloadToFile = Dylibsymbol( hLib, "URLDownloadToFileA" )
   if pURLDownloadToFile = null then
      dylibfree(hLib)
      return -2
   end if

   var result = pURLDownloadToFile(0, url, filePath, 0, 0)

   Dylibfree(hLib)
   return result
end function]


Die benötigten Bilder werden beim ersten Start heruntergeladen.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 08.02.2018, 22:31    Titel: Antworten mit Zitat

GDI+ Polar Clock v1.3 [nur Windows]




Code:
'coded by UEZ v1.3 build 2018-02-08
'WINDOWS ONLY!!!

#include "fbgfx.bi"
#include "string.bi"
#include "vbcompat.bi"

#Ifdef __FB_64BIT__
    #inclib "gdiplus"
    #include once "win/gdiplus-c.bi"
#Else
    #include once "win/gdiplus.bi"
    using gdiplus
#Endif

Using FB

Dim Shared gdipToken As ULONG_PTR
Dim Shared GDIp As GdiplusStartupInput
GDIp.GdiplusVersion = 1
If GdiplusStartup(@gdipToken, @GDIp, NULL) <> 0 Then End

Const As Single iW = 600, iH = iW, iWh = iW \ 2, iHh = iH \ 2, iRadiusS = iWh * 0.8, iRadiusM = iWh * 0.65, iRadiusH = iWh * 0.5, _
                iPenWO = iW / 15, iPenWI = iW / 15 - 4, iHoleSize = iPenWI / 2, iHoleRadius = iHoleSize / 2
Const as Single fPi = Acos(-1), fRad = fPi / 180, fSize = iW / 75

ScreenControl SET_DRIVER_NAME, "GDI"
ScreenRes iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH

Dim As String sTitle = "GDI+ Polar Clock v1.3 / FPS: "
WindowTitle sTitle

'center windows by adding the taskbar to the calculation
Dim as Integer iDW, iDH
ScreenControl GET_DESKTOP_SIZE, iDW, iDH
Dim tWorkingArea As RECT
SystemParametersInfo(SPI_GETWORKAREA, null, @tWorkingArea, null)
ScreenControl SET_WINDOW_POS, (iDW - iW) \ 2, _
                              ((tWorkingArea.Bottom - iH) - (iDH - tWorkingArea.Bottom)) \ 2


'init GDI / GDI+ canvas, pens, brushes, etc. for drawing
Dim as HWND hHWND
ScreenControl(FB.GET_WINDOW_HANDLE, Cast(Integer, hHWND))

Dim As Any Ptr hDC = GetDC(hHWND), _
               hHBitmap = CreateCompatibleBitmap(hDC, iW, iH), _
               hDC_backbuffer = CreateCompatibleDC(hDC), _
               hCanvas, hPen1, hPen2, hPen3, hPen4, hPen5, hPen6, hBrush, hBrushTxt, hPath, hPath2, hFamily, hStringFormat, hMatrix, hRegion
Var hObjOld = SelectObject(hDC_backbuffer, hHBitmap)

GdipCreateFromHDC(hDC_backbuffer, @hCanvas)
GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)

GdipCreatePen1(&h40101010, iPenWO, 2, @hPen1)
GdipCreatePen1(&hC0F04040, iPenWI, 2, @hPen2)
GdipCreatePen1(&hC040F040, iPenWI, 2, @hPen3)
GdipCreatePen1(&hC04040F0, iPenWI, 2, @hPen4)
GdipCreatePen1(&h80101010, 3, 2, @hPen5)
GdipCreatePen1(&h18101010, 2, 2, @hPen6)

GdipSetPenLineCap197819(hPen1, 2, 2, 2)
GdipSetPenLineCap197819(hPen2, 2, 2, 2)
GdipSetPenLineCap197819(hPen3, 2, 2, 2)
GdipSetPenLineCap197819(hPen4, 2, 2, 2)
GdipSetPenLineCap197819(hPen5, 2, 2, 2)

Dim As GpPointF StartPoint, EndPoint
StartPoint.x = 0
StartPoint.y = 0
EndPoint.x = iW
EndPoint.y = iH
GdipCreateLineBrush(@StartPoint, @EndPoint, &hFF808080, &hFF282828, 0, @hBrush)
GdipSetLineSigmaBlend(hBrush, 0.5, 0.8)
GdipSetLineLinearBlend(hBrush, 0.4, 0.9)
GdipSetLineGammaCorrection(hBrush, True)
GdipCreateSolidFill(0, @hBrushTxt)

GdipCreatePath(0, @hPath)
GdipCreatePath(0, @hPath2)
GdipCreateMatrix(@hMatrix)


'init string to draw text
GdipCreateFontFamilyFromName("Impact", Null, @hFamily)
GdipCreateStringFormat(0, 0, @hStringFormat)
GdipSetStringFormatAlign(hStringFormat, StringAlignmentCenter)
GdipSetStringFormatLineAlign(hStringFormat, StringAlignmentCenter)
GdipSetTextRenderingHint(hCanvas, PixelOffsetModeHalf)
GdipSetTextRenderingHint(hCanvas, TextRenderingHintAntiAliasGridFit)

'string positions
Dim as GpRectF  tLayout,  tLayout2, tLayout3, tLayout4, tLayout5, tLayout6, tLayout0
tLayout.width = iRadiusM
tLayout.height = iRadiusM
tLayout.x = iWh - tLayout.width \ 2
tLayout.y = iHh - tLayout.height \ 2

tLayout2.width = iRadiusM shL 1
tLayout2.height = iRadiusM ShR 1
tLayout2.x = iWh - iRadiusM
tLayout2.y = iHh + iWh * 0.5 / 10

tLayout3.width = iRadiusM shL 1
tLayout3.height = iRadiusM ShR 1
tLayout3.x = iWh - iRadiusM
tLayout3.y = iHh - iWh / 2 * 0.75

tLayout4.width = fSize * Len("seconds") * 1.66666
tLayout4.height = fSize * 2
tLayout4.x = iWh - tLayout4.width / 2
tLayout4.y = iHh - tLayout4.height / 2

tLayout5.width = fSize * Len("minutes") * 1.66666
tLayout5.height = fSize * 2
tLayout5.x = iWh - tLayout5.width / 2
tLayout5.y = iHh - tLayout5.height / 2
   
tLayout6.width = fSize * Len("hours") * 1.66666
tLayout6.height = fSize * 2
tLayout6.x = iWh - tLayout6.width / 2
tLayout6.y = iHh - tLayout6.height / 2
   
tLayout0.x = 0
tLayout0.y = iH - 8
tLayout0.width = 34
tLayout0.height = 10

Dim As UByte iSec, iMin, iHr
Dim as SYSTEMTIME tTime

Dim As ULong iFPS = 0
Dim As Double fTimer = Timer, iMS, d
Dim As Single calc1, calc2, calc3, calc4

Do
   GdipFillRectangle(hCanvas, hBrush, 0, 0, iW, iH)
   
   GdipDrawEllipse(hCanvas, hPen6, iWh - iRadiusS, iHh - iRadiusS, 2 * iRadiusS, 2 * iRadiusS)
   GdipDrawEllipse(hCanvas, hPen6, iWh - iRadiusM, iHh - iRadiusM, 2 * iRadiusM, 2 * iRadiusM)
   GdipDrawEllipse(hCanvas, hPen6, iWh - iRadiusH, iHh - iRadiusH, 2 * iRadiusH, 2 * iRadiusH)

   d = Now()
   GetSystemTime(@tTime)
   iMS = tTime.wMilliseconds / 1000
   iSec = tTime.wSecond
   iMin = tTime.wMinute
   iHr = CUbyte(Format(d, "h")) 'tTime.wHour
   If iHr > 11.0 Then iHr -= 12.0   ' more efficient than mod
   
   'draw second
   calc1 = 6 * (iSec + iMS)
   calc2 = -90 + calc1
   calc3 = iWh + Cos(calc2 * fRad) * iRadiusS - iHoleRadius
   calc4 = iHh + Sin(calc2 * fRad) * iRadiusS - iHoleRadius
   GdipAddPathArc(hPath, iWh - iRadiusS, iHh - iRadiusS, iRadiusS Shl 1, iRadiusS Shl 1, -90, calc1)
   GdipAddPathEllipse(hPath2, calc3, calc4, iHoleSize, iHoleSize)
   GdipSetClipPath(hCanvas, hPath2, 4)
   GdipDrawPath(hCanvas, hPen1, hPath)
   GdipDrawPath(hCanvas, hPen2, hPath)
   GdipDrawEllipse(hCanvas, hPen5, calc3, calc4, iHoleSize, iHoleSize)
   GdipResetPath(hPath)
   GdipResetPath(hPath2)
   GdipResetClip(hCanvas)
   
   'draw minute
   calc1 = 6 * (iMin + iSec / 60)
   calc2 = -90 + calc1
   calc3 = iWh + Cos(calc2 * fRad) * iRadiusM - iHoleRadius
   calc4 = iHh + Sin(calc2 * fRad) * iRadiusM - iHoleRadius
   GdipAddPathArc(hPath, iWh - iRadiusM, iHh - iRadiusM, iRadiusM Shl 1, iRadiusM Shl 1, -90, calc1)
   GdipAddPathEllipse(hPath2, calc3, calc4, iHoleSize, iHoleSize)
   GdipSetClipPath(hCanvas, hPath2, 4)
   GdipDrawPath(hCanvas, hPen1, hPath)
   GdipDrawPath(hCanvas, hPen3, hPath)
   GdipDrawEllipse(hCanvas, hPen5, calc3, calc4, iHoleSize, iHoleSize)
   GdipResetPath(hPath)
   GdipResetPath(hPath2)
   GdipResetClip(hCanvas)

   'draw hour
   calc1 = 30 * (iHr + iMin / 60)
   calc2 = -90 + calc1
   calc3 = iWh + Cos(calc2 * fRad) * iRadiusH - iHoleRadius
   calc4 = iHh + Sin(calc2 * fRad) * iRadiusH - iHoleRadius
   GdipAddPathArc(hPath, iWh - iRadiusH, iHh - iRadiusH, iRadiusH Shl 1, iRadiusH Shl 1, -90, calc1)
   GdipAddPathEllipse(hPath2, calc3, calc4, iHoleSize, iHoleSize)
   GdipSetClipPath(hCanvas, hPath2, 4)
   GdipDrawPath(hCanvas, hPen1, hPath)
   GdipDrawPath(hCanvas, hPen4, hPath)
   GdipDrawEllipse(hCanvas, hPen5, calc3, calc4, iHoleSize, iHoleSize)
   GdipResetPath(hPath)
   GdipResetPath(hPath2)
   GdipResetClip(hCanvas)
   
   'display clock
   GdipSetSolidFillColor(hBrushTxt, &hF0F0F0F0)
   GdipAddPathString(hPath, Left(Format(d, "hh:mm a/p"), 5), -1, hFamily, 0, iWh / 2 * 0.45, @tLayout, hStringFormat)
   GdipFillPath(hCanvas, hBrushTxt, hPath)
   GdipResetPath(hPath)
   
   'display date
   GdipSetSolidFillColor(hBrushTxt, &h80F0F0F0)
   GdipAddPathString(hPath, Format(d, "mmm d") & "  " & WeekdayName(Weekday(d)), -1, hFamily, 0, iWh / 2 * 0.1, @tLayout2, hStringFormat)
   GdipFillPath(hCanvas, hBrushTxt, hPath)
   GdipResetPath(hPath)

   'display AM/PM
   GdipAddPathString(hPath, Format(d, "AM/PM"), -1, hFamily, 0, iWh / 2 * 0.2, @tLayout3, hStringFormat)
   GdipFillPath(hCanvas, hBrushTxt, hPath)
   GdipResetPath(hPath)
   
   'label seconds
   GdipSetSolidFillColor(hBrushTxt, &hFFF0F0F0)
   GdipAddPathString(hPath, "seconds", -1, hFamily, 0, fSize, @tLayout4, hStringFormat)
   GdipTranslateMatrix(hMatrix, iWh, iHh, False) 'rotate letter
   GdipRotateMatrix(hMatrix, 6 * (-1 + iSec + iMS), False)
   GdipTranslateMatrix(hMatrix, -iWh, -iHh, False)
   GdipTransformPath(hPath, hMatrix)
   GdipSetMatrixElements(hMatrix, 1, 0, 0, 1, 0, 0)
   calc1 = (-90 + 6 * (-1.25 + iSec + iMS)) * fRad
   GdipTranslateMatrix(hMatrix, Cos(calc1) * iRadiusS, Sin(calc1) * iRadiusS, False) 'position letter
   GdipTransformPath(hPath, hMatrix)
   GdipSetMatrixElements(hMatrix, 1, 0, 0, 1, 0, 0)
   GdipFillPath(hCanvas, hBrushTxt, hPath) 'draw letter
   GdipResetPath(hPath)
   
   'label minutes
   GdipSetSolidFillColor(hBrushTxt, &hFFF0F0F0)
   GdipAddPathString(hPath, "minutes", -1, hFamily, 0, fSize, @tLayout5, hStringFormat)
   GdipTranslateMatrix(hMatrix, iWh, iHh, False) 'rotate letter
   GdipRotateMatrix(hMatrix, 6 * (-1 + iMin + iSec / 60), False)
   GdipTranslateMatrix(hMatrix, -iWh, -iHh, False)
   GdipTransformPath(hPath, hMatrix)
   GdipSetMatrixElements(hMatrix, 1, 0, 0, 1, 0, 0)
   calc1 = (-90 + 6 * (-1.5 + iMin + iSec / 60)) * fRad
   GdipTranslateMatrix(hMatrix, Cos(calc1) * iRadiusM, Sin(calc1) * iRadiusM, False) 'position letter
   GdipTransformPath(hPath, hMatrix)
   GdipSetMatrixElements(hMatrix, 1, 0, 0, 1, 0, 0)
   GdipFillPath(hCanvas, hBrushTxt, hPath) 'draw letter
   GdipResetPath(hPath)   

   'label hours
   GdipSetSolidFillColor(hBrushTxt, &hFFF0F0F0)
   GdipAddPathString(hPath, "hours", -1, hFamily, 0, fSize, @tLayout6, hStringFormat)
   GdipTranslateMatrix(hMatrix, iWh, iHh, False) 'rotate letter
   GdipRotateMatrix(hMatrix, 30 * (-0.25 + iHr + iMin / 60), False)
   GdipTranslateMatrix(hMatrix, -iWh, -iHh, False)
   GdipTransformPath(hPath, hMatrix)
   GdipSetMatrixElements(hMatrix, 1, 0, 0, 1, 0, 0)
   calc1 = (-90 + 30 * (-0.35 + iHr + iMin / 60)) * fRad
   GdipTranslateMatrix(hMatrix, Cos(calc1) * iRadiusH, Sin(calc1) * iRadiusH, False) 'position letter
   GdipTransformPath(hPath, hMatrix)
   GdipSetMatrixElements(hMatrix, 1, 0, 0, 1, 0, 0)
   GdipFillPath(hCanvas, hBrushTxt, hPath) 'draw letter
   GdipResetPath(hPath)
   
   GdipAddPathString(hPath, "code by UEZ", -1, hFamily, 0, 6.5, @tLayout0, hStringFormat)
   GdipFillPath(hCanvas, hBrushTxt, hPath)
   GdipResetPath(hPath)
   BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)
   Sleep(50, 1)

     If Timer - fTimer > 0.99 Then
      WindowTitle sTitle & iFPS
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   EndIf
Loop Until InKey = Chr(27)

'release resources
GdipDeleteMatrix(hMatrix)
GdipDeleteFontFamily(hFamily)
GdipDeleteStringFormat(hStringFormat)
GdipDeletePath(hPath)
GdipDeletePath(hPath2)
GdipDeletePen(hPen1)
GdipDeletePen(hPen2)
GdipDeletePen(hPen3)
GdipDeletePen(hPen4)
GdipDeletePen(hPen5)
GdipDeletePen(hPen6)
GdipDeleteBrush(hBrush)
GdipDeleteBrush(hBrushTxt)
SelectObject(hDC_backbuffer, hObjOld)
DeleteDC(hDC_backbuffer)
ReleaseDC(hHWND, hDC)
DeleteObject(hHBitmap)
GdipDeleteGraphics(hCanvas)
GdiplusShutdown(gdipToken)

_________________
Gruß,
UEZ


Zuletzt bearbeitet von UEZ am 04.03.2018, 11:58, insgesamt einmal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 129
Wohnort: Opel Stadt

BeitragVerfasst am: 04.03.2018, 11:57    Titel: GDI+ Swiss Railway Clock v1.29 build 2024-01-17 Antworten mit Zitat

Hilfiker / MobaTime Schweizer Bahnhofsuhr build 2024-01-17 [nur für Windows]



Code:

'Coded by UEZ build 2019-07-04
'Thanks To Mattias Fagerlund for the FastBoxBlur code
'
'WINDOWS ONLY!!!

#Include Once "fbgfx.bi"
#Include Once "String.bi"
#Include Once "vbcompat.bi"
#Define WIN_INCLUDEALL
#Include Once "windows.bi"
#Include Once "/win/commctrl.bi"

#Define WM_TRAYICON WM_APP + 1

#Ifdef __Fb_64bit__
   #Inclib "gdiplus"
   #Include Once "win/gdiplus-c.bi"
   #Define GCL_HICON (-14)
   #Define GCL_HICONSM (-34)
#Else
   #Include Once "win/gdiplus.bi"
   Using gdiplus
#Endif


Using FB

Declare Sub Update()
Declare Function GenerateClockBg(fDiameter As Ushort) As Any Ptr
Declare Function Base91Decode(sString As String, Byref iBase91Len As Ulong) As Ubyte Ptr
Declare Function _GDIPlus_BitmapCreateFromMemory2(aBinImage As Ubyte Ptr, iLen As Ulong, bBitmap_GDI As Bool = False) As Any Ptr
Declare Function WndProc(hWnd As HWND, uMsg As UINT, wParam As WPARAM, lParam As LPARAM) As Integer
Declare Function _GDIPlus_GraphicsGetDPIRatio(iDPIDef As Ushort = 96) As Single
Declare Sub _GDIPlus_BitmapApplyFilter_FastBoxBlur(Byval hImage As Any Ptr, range As Ulong)
Declare Sub FastBoxBlurH(hImage As Any Ptr, range As Ulong)
Declare Sub FastBoxBlurV(hImage As Any Ptr, range As Ulong)
Declare Sub CreateTransparentSettingWindow()
Declare Sub CreateTransparentBgSettingWindow()
Declare Sub CreateGUISizeSettingWindow()
Declare Function _WinAPI_IniRead(sIniFile As String, sSection As String, sKey As String, sDefault As String = "default") As String
Declare Function _WinAPI_IniWrite(sIniFile As String, sSection As String, sKey As String, sValue As String = "default") As Integer
Declare Function _WinAPI_CreateToolTip(hDlg As HWND, sToolTipText As String, bBalloon As Ubyte = 1) As HWND
Declare Function _WinAPI_SetProcessDpiAware() As UByte
Declare Function _WinAPI_SetProcessDpiAwareness(DPIAwareFlag As Integer) As UByte
Declare Sub SetGUISize(iSliderPos As Long)

Enum PROCESS_DPI_AWARENESS
    DPI_AWARENESS_INVALID = -1
    PROCESS_DPI_UNAWARE = 0
    PROCESS_SYSTEM_DPI_AWARE = 1
    PROCESS_PER_MONITOR_DPI_AWARE = 2
End Enum

#Define CRLF  Chr(13) + Chr(10)

Dim Shared As OSVERSIONINFO tOSVERSIONINFO
ZeroMemory(@tOSVERSIONINFO, Sizeof(OSVERSIONINFO))
tOSVERSIONINFO.dwOSVersionInfoSize = Sizeof(OSVERSIONINFO)
GetVersionEx(@tOSVERSIONINFO)
If tOSVERSIONINFO.dwBuildNumber < 2600 Then
   MessageBox(NULL, "This operating system is not supported!", "ERROR", MB_ICONERROR)
   End
End If
Dim As UByte iReturn
Select Case tOSVERSIONINFO.dwBuildNumber
    Case 6000 To 9199
        iReturn = _WinAPI_SetProcessDpiAware()
    Case 9200 To 20000
        iReturn = _WinAPI_SetProcessDpiAwareness(PROCESS_PER_MONITOR_DPI_AWARE)
End Select

Dim Shared gdipToken As ULONG_PTR
Dim Shared GDIp As GdiplusStartupInput
GDIp.GdiplusVersion = 1
If GdiplusStartup(@gdipToken, @GDIp, NULL) <> 0 Then End

SetPriorityClass(GetCurrentProcess(), BELOW_NORMAL_PRIORITY_CLASS)

Dim As Integer sW, sH
Screeninfo(sW, sH)
Dim Shared As Ushort iW, iH
Dim Shared As Short ScreenW_old, ScreenH_old, ScreenL_old, ScreenT_old

iW = CUShort(_WinAPI_IniRead(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "WinSize", Str(200)))
iW = Iif(iW < 64, 64, Iif(iW > 800, 800, iW))
iH = iW
Dim Shared As Single fDefaultPosX, fDefaultPosY
fDefaultPosX = (sW - iW) / 2
fDefaultPosY = (sH - iH) / 2
Dim As Short xPos = CShort(_WinAPI_IniRead(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "x", Str(fDefaultPosX)))
Dim As Short yPos = CShort(_WinAPI_IniRead(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "y", Str(fDefaultPosY)))
Dim Shared As Byte iAutostart, iAlwaysOnTop, iClickThru
Dim Shared As UByte iAlpha, iBgTransparency
iAutostart = CByte(_WinAPI_IniRead(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "Autostart", "-1"))
iAutostart = IIf(iAutostart < -1 Or iAutostart > 1 Or iAutostart = 0, -1, iAutostart)
iAlwaysOnTop = CByte(_WinAPI_IniRead(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "AlwaysOnTop", "1"))
iAlwaysOnTop = IIf(iAlwaysOnTop < -1 Or iAlwaysOnTop > 1 Or iAlwaysOnTop = 0, 1, iAlwaysOnTop)
iAlpha = CUByte(_WinAPI_IniRead(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "Transparency", "255"))
iClickThru = Cbyte(_WinAPI_IniRead(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "ClickThru", "-1"))
iBgTransparency = Cubyte(_WinAPI_IniRead(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "BgTransparency", "255"))
ScreenW_old = CShort(_WinAPI_IniRead(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "ScreenW", Str(0)))
ScreenH_old = CShort(_WinAPI_IniRead(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "ScreenH", Str(0)))
ScreenL_old = CShort(_WinAPI_IniRead(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "ScreenL", Str(0)))
ScreenT_old = CShort(_WinAPI_IniRead(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "ScreenT", Str(0)))

Dim Shared As Single fPi, fRad, fDeg
fPi = Acos(-1)
fRad = fPi / 180
fDeg = 180 / fPi

'Region Windows GUI
Dim Shared WinClass As WNDCLASSEX
Dim Msg As MSG
Dim Shared As UByte bGUITrans, bGUISize, bGUIMsgbox
bGUITrans = 0
bGUISize = 0
bGUIMsgbox = 0
Dim Shared As String sTitle
sTitle = "GDI+ Swiss Railway Clock v1.27"

With WinClass
   .style         = CS_HREDRAW Or CS_VREDRAW
   .lpfnWndProc   = @WndProc
   .cbClsExtra    = NULL
   .cbWndExtra    = NULL
   .hInstance     = GetModuleHandle(NULL)
   .hIcon         = LoadIcon(NULL, "FB_PROGRAM_ICON")
   .hCursor       = LoadCursor(NULL, IDC_ARROW)
   .hbrBackground = GetStockObject(WHITE_BRUSH)
   .lpszMenuName  = NULL
   .lpszClassName = Strptr(sTitle)
   .cbSize         = Sizeof(WNDCLASSEX)
End With

Dim Shared As Integer iStyleEx = 0
If iAlwaysOnTop = 1 Then iStyleEx = WS_EX_TOPMOST
If iClickThru = 1 Then iStyleEx = iStyleEx Or WS_EX_TRANSPARENT

Dim Shared As HWND hGUI, hGUI_TransparentSettings, hSlider_TransparentSettings, hLabel_TransparentSettings, hButton_TransparentSettings, _
              hGUI_GUISizeSettings, hSlider_GUISizeSettings, hLabel_GUISizeSettings, hButton_GUISizeSettings, _
              hGUI_TransparentBgSettings, hSlider_TransparentBgSettings, hLabel_TransparentBgSettings, hButton_TransparentBgSettings
Dim Shared As Long iSliderPos, iSliderPosPrev
Dim Shared As PAINTSTRUCT tPaintStruct

RegisterClassEx(@WinClass)
hGUI = CreateWindowEx(   WS_EX_LAYERED Or WS_EX_TOOLWINDOW Or iStyleEx, _
                  WinClass.lpszClassName, sTitle, _
                  WS_POPUP Or WS_VISIBLE, _
                  xPos, yPos, _
                  0, 0, _
                  NULL, NULL, WinClass.hInstance, NULL)

Dim Shared As HCURSOR CustomCursor
CustomCursor = LoadCursor(Null, IDC_SIZEALL)

'Region Tray Menu
Dim Shared As NOTIFYICONDATA SystrayIcon
Dim HICON As hIcon = ExtractIcon(Getmodulehandle(0), Command(0), 0)
Const WM_SHELLNOTIFY = WM_USER + 5

With SystrayIcon
    .cbSize = Len(SystrayIcon)
    .hWnd = hGUI
    .uId = 1&
    .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    .uCallbackMessage = WM_SHELLNOTIFY
    .hIcon = hIcon
    .szTip = sTitle + Chr(0)
End With

Const ID_About = 1000, ID_Exit = 1001, ID_Reset = 1002, ID_Autostart = 1003, ID_AlwaysOnTop = 1004, ID_SetGUISize = 1005, _
      ID_SetGUITransLevel = 1006, ID_ClickThru = 1007, ID_SetGUIBgTransLevel = 1008
Dim Shared As HANDLE MainMenu, AppMenu, SettingsMenu

MainMenu = CreateMenu()
AppMenu = CreateMenu()
SettingsMenu = CreateMenu()

AppendMenu(AppMenu, MF_STRING, ID_About, "&About")
AppendMenu(AppMenu, MF_SEPARATOR, 0, 0)
AppendMenu(AppMenu, MF_STRING, ID_AlwaysOnTop, "Always on &Top")
AppendMenu(AppMenu, MF_SEPARATOR, 0, 0)
AppendMenu(AppMenu, MF_STRING, ID_Autostart, "Auto&start with Windows")
AppendMenu(AppMenu, MF_SEPARATOR, 0, 0)
AppendMenu(AppMenu, MF_STRING, ID_ClickThru, "Click T&hru")
AppendMenu(AppMenu, MF_SEPARATOR, 0, 0)
AppendMenu(AppMenu, MF_STRING, ID_Reset, "&Reset Windows Position")
AppendMenu(AppMenu, MF_SEPARATOR, 0, 0)

AppendMenu(AppMenu, MF_POPUP, Cast(Integer, SettingsMenu), "Settings")
AppendMenu(SettingsMenu, MF_STRING, ID_SetGUISize, "Set &Clock Size")
AppendMenu(SettingsMenu, MF_SEPARATOR, 0, 0)
AppendMenu(SettingsMenu, MF_STRING, ID_SetGUITransLevel, "Set Clock UI Transparency &Level")
AppendMenu(SettingsMenu, MF_SEPARATOR, 0, 0)
AppendMenu(SettingsMenu, MF_STRING, ID_SetGUIBgTransLevel, "Set Clock Background Transparency &Level")
AppendMenu(AppMenu, MF_SEPARATOR, 0, 0)
AppendMenu(AppMenu, MF_STRING, ID_Exit, "E&xit")

InsertMenu(MainMenu, 0, MF_POPUP, Cptr(UINT_PTR, AppMenu), 0)
       
Shell_NotifyIcon(NIM_ADD, @SystrayIcon)

If iAutostart = 1 Then CheckMenuItem(AppMenu, ID_AutoStart, MF_CHECKED)
If iAlwaysOnTop = 1 Then CheckMenuItem(AppMenu, ID_AlwaysOnTop, MF_CHECKED)
If iClickThru = 1 Then CheckMenuItem(AppMenu, ID_ClickThru, MF_CHECKED)

'---------------------

'Region registry
Dim As Any Ptr hReg
Dim As String * 2048 sRegValue
Dim As ZString Ptr sNewRegValue
Dim As DWORD iRegValueLength
Dim As String sRegPath = Chr(34) & Command(0) & Chr(34) & Chr(0)

sNewRegValue = Allocate(Len(sRegPath) + 1)
*sNewRegValue = sRegPath

'open
RegOpenKeyEx(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Run", 0, KEY_ALL_ACCESS, @hReg)

If iAutostart = 1 Then
   RegSetValueEx(hReg, "SwissRailwayClock", NULL, REG_SZ, Cast(Byte Ptr, @sNewRegValue[0]), Len(*sNewRegValue))
ElseIf iAutostart = -1 Then
   RegDeleteValue(hReg, "SwissRailwayClock")   
EndIf

RegFlushKey(hReg)

'---------------------


Dim Shared As Any Ptr hBitmap, hHBitmap, hCanvas, hBitmap_Clock, hBrush_Shadow, hBrush_Update, hPen_Update, hScrDC, hMemDC, hOld

Dim Shared As Point pSize
Dim Shared As Point pSource
Dim Shared As BLENDFUNCTION pBlend
pSize.X = iW
pSize.Y = iH
With pBlend
      .BlendOp = AC_SRC_OVER
      .BlendFlags = 0
      .SourceConstantAlpha = iAlpha
      .AlphaFormat = AC_SRC_ALPHA
End With

hScrDC = GetDC(hGUI)
hMemDC = CreateCompatibleDC(hScrDC)

GdipCreateBitmapFromScan0(iW, iH, 0, PixelFormat32bppARGB, 0, @hBitmap)
GdipGetImageGraphicsContext(hBitmap, @hCanvas)
GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)

Dim Shared As Ulong iShadowColor, iShadowColor2 = &h90000000
iShadowColor = &h20A0A0A0
GdipCreateSolidFill(iShadowColor, @hBrush_Shadow)
GdipCreateSolidFill(0, @hBrush_Update)
GdipCreatePen1(&hFFA02020, 1, 2, @hPen_Update)


'String positions
Dim As RectF tLayout

Dim Shared As Ushort fDiameter, fMin_next
Dim Shared As Single fShadowAngle, fRadius, fMSec
fDiameter = iW
fRadius = fDiameter / 2

hBitmap_Clock = GenerateClockBg(fDiameter)

Dim Shared As Single fSec, fHr, fAmplitude = 3
Dim Shared As Ubyte iSec, iMin, iHr, iHr_Delta, bProcessShutdown = 0

Dim Shared As SYSTEMTIME tTime

GetSystemTime(@tTime)
iMin = tTime.wMinute
fMin_next = iMin
iHr_Delta = CUByte(Format(Now(), "hh")) - tTime.wHour

SetTimer(hGUI, 1, 30, Cast(Any Ptr, @Update))

Dim As Double fTimer = Timer
Dim As RECT tDesktop
Dim As hwnd hHWND_Dt
Dim as Integer dx, dy, dw, dh, ScreenL, ScreenT, ScreenR, ScreenB, ScreenW, ScreenH
Dim tPos As RECT

hHWND_Dt = FindWindow("Progman","Program Manager")
GetWindowRect(hHWND_Dt, @tDesktop)
ScreenL = tDesktop.left
ScreenR = tDesktop.right
ScreenT = tDesktop.top
ScreenB = tDesktop.bottom
ScreenW = tDesktop.right + Abs(ScreenL)
ScreenH = tDesktop.bottom + Abs(ScreenT)

SetProcessShutdownParameters(&h3FF, 0)

While GetMessage(@Msg, 0, 0, 0)
   TranslateMessage(@Msg)
   DispatchMessage(@Msg)
   If Timer - fTimer > 1 Then
      hHWND_Dt = FindWindow("Progman","Program Manager")
      GetWindowRect(hHWND_Dt, @tDesktop)
      dx = tDesktop.left
      dy = tDesktop.top
      dw = tDesktop.right + Abs(dx)
      dh = tDesktop.bottom + Abs(dy)
      GetWindowRect(hGUI, @tPos)
      If tPos.Left < (dx - iW) Or tPos.Left > dw Or tPos.Top < (dy - iW) Or tPos.Top > dh Then
         'SetWindowPos(hGUI, 0, Abs((ScreenW - ScreenR + xPos) / ScreenW * dw - dx - iW), Abs((ScreenH - ScreenB + yPos) / ScreenH * dh - dy - iH), 0, 0, 0)
         SetWindowPos(hGUI, 0, (xPos + Abs(ScreenL_old)) / ScreenW_old * dw - fDiameter * 0.70, (yPos + Abs(ScreenT_old)) / ScreenH_old * dh, 0, 0, 0)
      End If
      fTimer = Timer
   End If
   If bProcessShutdown = 1 Then Exit While
Wend

Killtimer(hGUI, 1)
GetWindowRect(hGUI, @tPos)

_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "x", Str(tPos.Left))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "y", Str(tPos.Top))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "WinSize", Str(iW))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "Autostart", Str(iAutostart))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "AlwaysOnTop", Str(iAlwaysOnTop))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "Transparency", Str(iAlpha))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "BgTransparency", Str(iBgTransparency))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "ClickThru", Str(iClickThru))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "ScreenL", Str(dx))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "ScreenT", Str(dy))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "ScreenR", Str(tDesktop.right))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "ScreenB", Str(tDesktop.bottom))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "ScreenW", Str(dw))
_WinAPI_IniWrite(Exepath & "\GDI+ Swiss Railway Clock.ini", "Settings", "ScreenH", Str(dh))

If iAutostart = 1 Then
   RegSetValueEx(hReg, "SwissRailwayClock", NULL, REG_SZ, Cast(Byte Ptr, @sNewRegValue[0]), Len(*sNewRegValue))
ElseIf iAutostart = -1 Then
   RegDeleteValue(hReg, "SwissRailwayClock")   
EndIf

RegFlushKey(hReg)

'close registry
RegCloseKey(hReg)
DeAllocate(sNewRegValue)


'release resources
Shell_NotifyIcon(NIM_DELETE, @SystrayIcon)
DestroyIcon(hIcon)
ReleaseDC(0, hScrDC)
DeleteDC(hMemDC)
GdipDeleteBrush(hBrush_Shadow)
GdipDeleteBrush(hBrush_Update)
GdipDeletePen(hPen_Update)
GdipDisposeImage(hBitmap_Clock)
GdipDisposeImage(hBitmap)
GdipDeleteGraphics(hCanvas)
GdiplusShutdown(gdipToken)


Function WndProc(hWnd As HWND, uMsg As UINT, wParam As WPARAM, lParam As LPARAM) As Integer
   Select Case hWnd
      Case hGUI
         Select Case uMsg
            Case WM_QUERYENDSESSION
               bProcessShutdown = 1
             Case WM_DESTROY
               PostQuitMessage(0)   
               Return 0
             Case WM_NCHITTEST
               Return HTCAPTION
             Case WM_SETCURSOR
                 If LoWord(lParam) = HTCAPTION And HiWord(lParam) = WM_LBUTTONDOWN Then
                     SetCursor(CustomCursor)
                     Return 1
                 EndIf
             Case WM_KEYDOWN
               If wParam = VK_ESCAPE Then
               DestroyWindow(hGUI)
               Return 0
               EndIf
             Case WM_SHELLNOTIFY
               If lParam = WM_RBUTTONDOWN Then
                  Dim tPOINT As Point
                  GetCursorPos(@tPOINT)
                  SetForegroundWindow(hWnd)
                  TrackPopupMenuEx(AppMenu, TPM_LEFTALIGN Or TPM_RIGHTBUTTON, tPOINT.x, tPOINT.y, hWnd, NULL)
                  PostMessage(hWnd, WM_NULL, 0, 0)
               End If
             Case WM_COMMAND
               Select Case Loword (wParam)
                  Case ID_About
                     If bGUIMsgbox = 0 Then
                        bGUIMsgbox = 1
                        Messagebox(0, sTitle & CRLF & CRLF & "Coded by UEZ" & CRLF & CRLF & CRLF & CRLF & "This program is freeware under Creative Commons License" & CRLF & "by-nc-nd 3.0'!", "About", 0)
                        bGUIMsgbox = 0
                     EndIf
                  Case ID_Exit
                     DestroyWindow(hGUI)
                     Return 0
                  Case ID_Reset
                     SetWindowPos(hGUI, 0, fDefaultPosX, fDefaultPosY, 0, 0, 0)
                  Case ID_Autostart
                     If iAutostart = -1 Then
                        CheckMenuItem(AppMenu, ID_AutoStart, MF_CHECKED)
                     Else
                        CheckMenuItem(AppMenu, ID_AutoStart, MF_UNCHECKED)
                     EndIf
                     iAutostart *= -1
                   Case ID_SetGUITransLevel
                     If bGUITrans = 0 Then
                        bGUITrans = 1
                        CreateTransparentSettingWindow()
                     EndIf
                  Case ID_SetGUIBgTransLevel
                       CreateTransparentBgSettingWindow()
                  Case ID_SetGUISize
                     If bGUISize = 0 Then
                        bGUISize = 1
                        CreateGUISizeSettingWindow()
                     End If                  
                  Case ID_AlwaysOnTop
                     If iAlwaysOnTop = -1 Then
                        CheckMenuItem(AppMenu, ID_AlwaysOnTop, MF_CHECKED)
                     SetWindowPos(hGUI, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
                     Else
                        CheckMenuItem(AppMenu, ID_AlwaysOnTop, MF_UNCHECKED)
                     SetWindowPos(hGUI, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
                     EndIf
                     iAlwaysOnTop *= -1
                Case ID_ClickThru
                     If iClickThru = -1 Then
                        CheckMenuItem(AppMenu, ID_ClickThru, MF_CHECKED)
                     SetWindowLongPtr(hGUI, GWL_EXSTYLE, GetWindowLongPtr(hGUI, GWL_EXSTYLE) Or WS_EX_TRANSPARENT)
                     Else
                        CheckMenuItem(AppMenu, ID_ClickThru, MF_UNCHECKED)
                     SetWindowLongPtr(hGUI, GWL_EXSTYLE, GetWindowLongPtr(hGUI, GWL_EXSTYLE) Xor WS_EX_TRANSPARENT)                   
                     EndIf
                     iClickThru *= -1
               End Select
         End Select
      Case hGUI_TransparentSettings
         Select Case uMsg
            Case WM_CREATE
            Case WM_PAINT
               Dim As HBRUSH hBrush = CreateSolidBrush(&hF0F0F0)
               BeginPaint(hGUI_TransparentSettings, @tPaintStruct)
               FillRect(tPaintStruct.hdc, @tPaintStruct.rcPaint, hBrush)
               EndPaint(hGUI_TransparentSettings, @tPaintStruct)
               DeleteObject(hBrush)
             Case WM_COMMAND
               Select Case lParam 
                  Case hButton_TransparentSettings   
                     DestroyWindow(hGUI_TransparentSettings)
                     bGUITrans = 0
                     Return 0
               End Select
            Case WM_CLOSE
                    DestroyWindow(hGUI_TransparentSettings)
                    bGUITrans = 0
                    pBlend.SourceConstantAlpha = iSliderPosPrev
                    iAlpha = iSliderPosPrev
                  Return 0
            Case WM_KEYDOWN
               If wParam = VK_ESCAPE Then
                  DestroyWindow(hGUI_TransparentSettings)
                  bGUITrans = 0
                    pBlend.SourceConstantAlpha = iSliderPosPrev
                    iAlpha = iSliderPosPrev
                  Return 0
               EndIf
            Case WM_HSCROLL
               Select Case lParam
                  Case hSlider_TransparentSettings
                     iSliderPos = SendMessage(hSlider_TransparentSettings, TBM_GETPOS, 0, 0)
                     SetWindowText(hLabel_TransparentSettings, Str(iSliderPos))
                     pBlend.SourceConstantAlpha = iSliderPos
                     iAlpha = iSliderPos
               End Select
         End Select
      Case hGUI_TransparentBgSettings
         Select Case uMsg
            Case WM_CREATE
            Case WM_PAINT
               Dim As HBRUSH hBrush = CreateSolidBrush(&hF0F0F0)
               BeginPaint(hGUI_TransparentBgSettings, @tPaintStruct)
               FillRect(tPaintStruct.hdc, @tPaintStruct.rcPaint, hBrush)
               EndPaint(hGUI_TransparentBgSettings, @tPaintStruct)
               DeleteObject(hBrush)
             Case WM_COMMAND
               Select Case lParam 
                  Case hButton_TransparentBgSettings   
                     DestroyWindow(hGUI_TransparentBgSettings)
                     bGUITrans = 0
                     Return 0
               End Select
            Case WM_CLOSE
                    DestroyWindow(hGUI_TransparentBgSettings)
                    bGUITrans = 0
                    iBgTransparency = iSliderPosPrev
                    Killtimer(hGUI, 1)
                    GdipDisposeImage(hBitmap_Clock)
                    hBitmap_Clock = GenerateClockBg(fDiameter)
                    SetTimer(hGUI, 1, 30, Cast(Any Ptr, @Update))
               Return 0
            Case WM_KEYDOWN
               If wParam = VK_ESCAPE Then
                  DestroyWindow(hGUI_TransparentBgSettings)
                  bGUITrans = 0
                    iBgTransparency = iSliderPosPrev
                    Killtimer(hGUI, 1)
                    GdipDisposeImage(hBitmap_Clock)
                    hBitmap_Clock = GenerateClockBg(fDiameter)
                    SetTimer(hGUI, 1, 30, Cast(Any Ptr, @Update))
                  Return 0
               EndIf
            Case WM_HSCROLL
               Select Case lParam
                  Case hSlider_TransparentBgSettings
                     iSliderPos = SendMessage(hSlider_TransparentBgSettings, TBM_GETPOS, 0, 0)
                     SetWindowText(hLabel_TransparentBgSettings, Str(iSliderPos))
                     iBgTransparency = iSliderPos
                     Killtimer(hGUI, 1)
                     GdipDisposeImage(hBitmap_Clock)
                         hBitmap_Clock = GenerateClockBg(fDiameter)
                         SetTimer(hGUI, 1, 30, Cast(Any Ptr, @Update))
               End Select
         End Select
      Case hGUI_GUISizeSettings
         Select Case uMsg
             Case WM_CREATE
            Case WM_PAINT
               Dim As HBRUSH hBrush = CreateSolidBrush(&hF0F0F0) 'GUI background color
               BeginPaint(hGUI_GUISizeSettings, @tPaintStruct)
               FillRect(tPaintStruct.hdc, @tPaintStruct.rcPaint, hBrush)
               EndPaint(hGUI_GUISizeSettings, @tPaintStruct)
               DeleteObject(hBrush)
             Case WM_COMMAND
               Select Case lParam 
                  Case hButton_GUISizeSettings   
                     DestroyWindow(hGUI_GUISizeSettings)
                     bGUISize = 0
                     Return 0
               End Select
            Case WM_CLOSE
               DestroyWindow(hGUI_GUISizeSettings)
               bGUISize = 0
               SetGUISize(iSliderPosPrev)
               Return 0
            Case WM_KEYDOWN
               If wParam = VK_ESCAPE Then
                  DestroyWindow(hGUI_GUISizeSettings)
                  bGUISize = 0
                  SetGUISize(iSliderPosPrev)
                  Return 0
               EndIf
      Case WM_HSCROLL
               Select Case lParam
                  Case hSlider_GUISizeSettings
                     iSliderPos = SendMessage(hSlider_GUISizeSettings, TBM_GETPOS, 0, 0)
                     SetWindowText(hLabel_GUISizeSettings, Str(iSliderPos) & " px")
                         SetGUISize(iSliderPos)
               End Select
         End Select
   End Select
   Return DefWindowProc(hWnd, uMsg, wParam, lParam)
End Function

Sub SetGUISize(iSliderPos As Long)
    Killtimer(hGUI, 1)
    iW = iSliderPos
    iH = iW
    fDiameter = iW
    fRadius = fDiameter / 2
    pSize.X = iW
    pSize.Y = iW
    GdipDisposeImage(hBitmap_Clock)
    GdipDisposeImage(hBitmap)
    GdipDeleteGraphics(hCanvas)
    GdipCreateBitmapFromScan0(iW, iH, 0, PixelFormat32bppARGB, 0, @hBitmap)
    GdipGetImageGraphicsContext(hBitmap, @hCanvas)
    GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
    GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)                   
    hBitmap_Clock = GenerateClockBg(fDiameter)
    SetTimer(hGUI, 1, 30, Cast(Any Ptr, @Update))
End Sub

Sub CreateTransparentBgSettingWindow()
   Dim As Short iW = 275, iH = 115, iDesktopPosX = GetSystemMetrics(SM_CXSCREEN) - iW, iDesktopPosY
   Dim As HWND hTaskbar = FindWindow("Shell_TrayWnd", Null)
   Dim As RECT tRECT
   GetWindowRect(hTaskbar, @tRECT)
   iDesktopPosY = tRECT.top - iH
   hGUI_TransparentBgSettings = CreateWindowEx(WS_EX_APPWINDOW Or WS_EX_DLGMODALFRAME, _
                                             WinClass.lpszClassName, _ 'Class name
                                             "Transparency Background Setting", _ 'GUI name
                                             (WS_SYSMENU Or WS_CAPTION Or WS_VISIBLE), _
                                             iDesktopPosX - 4, _ 'x
                                             iDesktopPosY - 4, _ 'y
                                             iW, iH, _ 'w, h
                                             hGUI, _ 'hParent
                                             NULL, _ 'hMenu
                                             NULL, _ 'hInstance
                                             NULL) 'lpParam
   hSlider_TransparentBgSettings = CreateWindowEx(NULL, TRACKBAR_CLASS, "Trackbar Control", _
                                                WS_VISIBLE Or WS_CHILD Or TBS_NOTICKS Or TBS_ENABLESELRANGE Or TBS_TOOLTIPS Or TBS_BOTH, _
                                                4, 4, 200, 40, hGUI_TransparentBgSettings, NULL, NULL, NULL)
   SendMessage(hSlider_TransparentBgSettings, TBM_SETRANGE,TRUE, MAKELONG(0, 255))
   SendMessage(hSlider_TransparentBgSettings, TBM_SETPOS, TRUE, iBgTransparency)
   iSliderPosPrev = iBgTransparency
   hLabel_TransparentBgSettings = CreateWindowEx(NULL, "static", "", WS_VISIBLE Or WS_CHILD Or SS_CENTER Or SS_CENTERIMAGE Or SS_SUNKEN, 207, 9, 50, 18, hGUI_TransparentBgSettings, NULL, NULL, NULL)
   SetWindowText(hLabel_TransparentBgSettings, Str(iBgTransparency))
   hButton_TransparentBgSettings = CreateWindowEx(NULL, "Button", "Ok", WS_VISIBLE Or WS_CHILD, 4, 50, 260, 30, hGUI_TransparentBgSettings, NULL, NULL, NULL)
   'DestroyIcon(Cast(HANDLE, GetClassLong(hGUI_TransparentSettings, GCL_HICON)))
   'SetClassLong(hGUI_TransparentSettings, GCL_HICON, 0)
   'SetClassLong(hGUI_TransparentSettings, GCL_HICONSM, 0)
   _WinAPI_CreateToolTip(hSlider_TransparentBgSettings, "255 is opaque, 0 is full transparent") 
End Sub

Sub CreateTransparentSettingWindow()
   Dim As Short iW = 275, iH = 115, iDesktopPosX = GetSystemMetrics(SM_CXSCREEN) - iW, iDesktopPosY
   Dim As HWND hTaskbar = FindWindow("Shell_TrayWnd", Null)
   Dim As RECT tRECT
   GetWindowRect(hTaskbar, @tRECT)
   iDesktopPosY = tRECT.top - iH
   hGUI_TransparentSettings = CreateWindowEx(WS_EX_APPWINDOW Or WS_EX_DLGMODALFRAME, _
                                             WinClass.lpszClassName, _ 'Class name
                                             "Transparency Setting", _ 'GUI name
                                             (WS_SYSMENU Or WS_CAPTION Or WS_VISIBLE), _
                                             iDesktopPosX - 4, _ 'x
                                             iDesktopPosY - 4, _ 'y
                                             iW, iH, _ 'w, h
                                             hGUI, _ 'hParent
                                             NULL, _ 'hMenu
                                             NULL, _ 'hInstance
                                             NULL) 'lpParam
   hSlider_TransparentSettings = CreateWindowEx(NULL, TRACKBAR_CLASS, "Trackbar Control", _
                                                WS_VISIBLE Or WS_CHILD Or TBS_NOTICKS Or TBS_ENABLESELRANGE Or TBS_TOOLTIPS Or TBS_BOTH, _
                                                4, 4, 200, 40, hGUI_TransparentSettings, NULL, NULL, NULL)
   SendMessage(hSlider_TransparentSettings, TBM_SETRANGE,TRUE, MAKELONG(0, 255))
   SendMessage(hSlider_TransparentSettings, TBM_SETPOS, TRUE, iAlpha)
   iSliderPosPrev = iAlpha
   hLabel_TransparentSettings = CreateWindowEx(NULL, "static", "", WS_VISIBLE Or WS_CHILD Or SS_CENTER Or SS_CENTERIMAGE Or SS_SUNKEN, 207, 9, 50, 18, hGUI_TransparentSettings, NULL, NULL, NULL)
   SetWindowText(hLabel_TransparentSettings, Str(iAlpha))
   hButton_TransparentSettings = CreateWindowEx(NULL, "Button", "Ok", WS_VISIBLE Or WS_CHILD, 4, 50, 260, 30, hGUI_TransparentSettings, NULL, NULL, NULL)
   'DestroyIcon(Cast(HANDLE, GetClassLong(hGUI_TransparentSettings, GCL_HICON)))
   'SetClassLong(hGUI_TransparentSettings, GCL_HICON, 0)
   'SetClassLong(hGUI_TransparentSettings, GCL_HICONSM, 0)
   _WinAPI_CreateToolTip(hSlider_TransparentSettings, "255 is opaque, 0 is full transparent") 
End Sub

Sub CreateGUISizeSettingWindow()
   Dim As Short iW_size = 275, iH_size = 115, iDesktopPosX = GetSystemMetrics(SM_CXSCREEN) - iW_size, iDesktopPosY
   Dim As HWND hTaskbar = FindWindow("Shell_TrayWnd", Null)
   Dim As RECT tRECT
   GetWindowRect(hTaskbar, @tRECT)
   iDesktopPosY = tRECT.top - iH_size
   hGUI_GUISizeSettings = CreateWindowEx(WS_EX_APPWINDOW Or WS_EX_DLGMODALFRAME, _
                                             WinClass.lpszClassName, _ 'Class name
                                             "GUI Size Setting", _ 'GUI name
                                             (WS_SYSMENU Or WS_CAPTION Or WS_VISIBLE), _
                                             iDesktopPosX - 4, _ 'x
                                             iDesktopPosY - 4, _ 'y
                                             iW_size, iH_size, _ 'w, h
                                             hGUI, _ 'hParent
                                             NULL, _ 'hMenu
                                             NULL, _ 'hInstance
                                             NULL) 'lpParam
   hSlider_GUISizeSettings = CreateWindowEx(NULL, TRACKBAR_CLASS, "Trackbar Control", _
                                                WS_VISIBLE Or WS_CHILD Or TBS_NOTICKS Or TBS_ENABLESELRANGE Or TBS_TOOLTIPS Or TBS_BOTH, _
                                                4, 4, 200, 40, hGUI_GUISizeSettings, NULL, NULL, NULL)
   SendMessage(hSlider_GUISizeSettings, TBM_SETRANGE,TRUE, MAKELONG(64, 800))
   SendMessage(hSlider_GUISizeSettings, TBM_SETPOS, TRUE, fDiameter)
   iSliderPosPrev = fDiameter
   hLabel_GUISizeSettings = CreateWindowEx(NULL, "static", "", WS_VISIBLE Or WS_CHILD Or SS_CENTER Or SS_CENTERIMAGE Or SS_SUNKEN, 205, 9, 52, 18, hGUI_GUISizeSettings, NULL, NULL, NULL)
   SetWindowText(hLabel_GUISizeSettings, Str(fDiameter) & " px")
   hButton_GUISizeSettings = CreateWindowEx(NULL, "Button", "Ok", WS_VISIBLE Or WS_CHILD, 4, 50, 260, 30, hGUI_GUISizeSettings, NULL, NULL, NULL)
   _WinAPI_CreateToolTip(hSlider_GUISizeSettings, "Choose a size from 64 to 800 pixels!")
End Sub

'https://msdn.microsoft.com/en-us/library/windows/desktop/hh298368(v=vs.85).aspx
Function _WinAPI_CreateToolTip(hDlg As HWND, sToolTipText As String, bBalloon As Ubyte = 1) As HWND
   If hDlg = 0 Or Len(sToolTipText) = 0 Then Return 0
   If Len(sToolTipText) > 79 Then Left(sToolTipText, 79)
   Dim hToolTip As HWND
   
   bBalloon = Iif(bBalloon > 1, 1, bBalloon)
   Dim As Long iStyle = bBalloon * TTS_BALLOON
   hToolTip = CreateWindowEx(Null, TOOLTIPS_CLASS, NULL, _
                       WS_POPUP Or TTS_NOPREFIX Or TTS_ALWAYSTIP Or iStyle, _
                       CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
                       hDlg, Null, Null, Null)

   If hToolTip = 0 Then Return 0

   Dim tToolInfo As TOOLINFO
   With tToolInfo
      .cbSize = Sizeof(tToolInfo)
      .uFlags = TTF_SUBCLASS
      .hwnd = hDlg
      .hinst = Null
      .lpszText = Strptr(sToolTipText)
      .uId = 0
   End With
   GetClientRect(hDlg, @tToolInfo.rect)

   SendMessage(hToolTip, TTM_ADDTOOL, 0, Cast(LPARAM, @tToolInfo) )
   Return hToolTip
End Function

Sub Update()
   GdipGraphicsClear(hCanvas, &h00000000)
   GdipDrawImageRect(hCanvas, hBitmap_Clock, 0, 0, fDiameter, fDiameter)
   
   Static As Ulong bBounce = 0, f = 0
   GetSystemTime(@tTime)
   fMSec = tTime.wMilliseconds / 1000
   iSec = tTime.wSecond
   iMin = tTime.wMinute
   'iHr = tTime.wHour + iHr_Delta
   iHr = CUByte(Format(Now(), "hh"))

   
   Dim As Single iWidth1 = fDiameter * 0.0375, _
           iHeight1 = fDiameter / 2.5, _
           iWidth12 = iWidth1 / 2, _
           fPosY = fDiameter * 0.2, iWidth2, iWidth22, fPosY2, _
           m1 = fDiameter * 0.015, fMin_
             
   'Draw Hour needle
   fHr = 30 * (iHr + iMin / 60)
   GdipTranslateWorldTransform(hCanvas, fRadius, fRadius, MatrixOrderPrepend)
   GdipRotateWorldTransform(hCanvas, fHr, MatrixOrderPrepend)
   GdipTranslateWorldTransform(hCanvas, -fRadius, -fRadius, MatrixOrderPrepend)
   GdipSetSolidFillColor(hBrush_Update, &hFF101010)
   GdipFillRectangle(hCanvas, hBrush_Shadow, _
                 fRadius - iWidth12 + Cos((fShadowAngle - fHr) * fRad) * m1, _
                 fPosY + Sin((fShadowAngle - fHr) * fRad) * m1, _
                 iWidth1, iHeight1)
   GdipFillRectangle(hCanvas, hBrush_Update, _
                 fRadius - iWidth12, _
                 fPosY, _
                 iWidth1, iHeight1)
   GdipResetWorldTransform(hCanvas)
   
   'Draw Minute needle
   If fMin_next <> iMin Then bBounce = 1
   If bBounce = 1 Then
      fMin_ = (6 * ((fMin_next + 1) Mod 60)) + Sin(f * 1.9) * fAmplitude
      If fAmplitude = 0 Then
         fMin_next = iMin
         f = 0
         fAmplitude = 3
         bBounce = 0
      Else
         fAmplitude -= 0.5
         fAmplitude = Iif(fAmplitude <= 0, 0, fAmplitude)
         f += 1
      End If
   Else
      fMin_ = (6 * iMin)
   End If
   GdipTranslateWorldTransform(hCanvas, fRadius, fRadius, MatrixOrderPrepend)
   GdipRotateWorldTransform(hCanvas, fMin_, MatrixOrderPrepend)
   GdipTranslateWorldTransform(hCanvas, -fRadius, -fRadius, MatrixOrderPrepend)      
   iWidth1 = fDiameter * 0.03
   iHeight1 = fRadius
   iWidth12 = iWidth1 / 2
   fPosY = fDiameter * 0.1               
   GdipFillRectangle(hCanvas, hBrush_Shadow, _
                 fRadius - iWidth12 + Cos((fShadowAngle - fMin_) * fRad) * m1, _
                 fPosY + Sin((fShadowAngle - fMin_) * fRad) * m1, _
                 iWidth1, iHeight1)
   GdipFillRectangle(hCanvas, hBrush_Update, _
                 fRadius - iWidth12, _
                 fPosY, _
                 iWidth1, iHeight1)
   GdipResetWorldTransform(hCanvas)
   
   'Draw Second needle
   fSec = 6 * (iSec * 1.02564 + fMSec)
   If fSec >= 360 Then fSec = 0
   GdipTranslateWorldTransform(hCanvas, fRadius, fRadius, MatrixOrderPrepend)
   GdipRotateWorldTransform(hCanvas, fSec, MatrixOrderPrepend)
   GdipTranslateWorldTransform(hCanvas, -fRadius, -fRadius, MatrixOrderPrepend)      
   fPosY = fDiameter * 0.27
   fPosY2 = fDiameter * 0.19
   iWidth1 = fDiameter * 0.0095
   iHeight1 = fRadius * 1.3 - fPosY
   iWidth12 = iWidth1 / 2
   iWidth2 = fDiameter * 0.083333
   iWidth22 = iWidth2 / 2   
   
   'Draw shadow of Second needle
   GdipFillRectangle(hCanvas, hBrush_Shadow, _
                 fRadius + Cos((fShadowAngle - fSec) * fRad) * m1, _
                 fPosY + Sin((fShadowAngle - fSec) * fRad) * m1, _
                 iWidth1 + fDiameter * 0.006667, iHeight1 + fDiameter * 0.006667)
   GdipFillEllipse(hCanvas, hBrush_Shadow, _
                 fRadius - iWidth22 + Cos((fShadowAngle - fSec) * fRad) * m1, _
                 fPosY2 + Sin((fShadowAngle - fSec) * fRad) * m1, _
                 iWidth2, iWidth2)
   
   'Draw Second needle
   GdipSetSolidFillColor(hBrush_Update, &hFFC01010)
   GdipFillRectangle(hCanvas, hBrush_Update, _
                 fRadius - iWidth12, _
                 fPosY, _
                 iWidth1, iHeight1)
   GdipFillEllipse(hCanvas, hBrush_Update, _
                 fRadius - iWidth22, _
                 fPosY2, _
                 iWidth2, iWidth2)                     
   GdipResetWorldTransform(hCanvas)
   
   'button in the center
   GdipFillEllipse(hCanvas, hBrush_Update, _
                 fRadius - iWidth1, _
                 fRadius - iWidth1, _
                 2 * iWidth1, 2 * iWidth1)   
   GdipDrawEllipse(hCanvas, hPen_Update, _
                 fRadius - iWidth1, _
                 fRadius - iWidth1, _
                 2 * iWidth1, 2 * iWidth1)
   'Draw To Screen
   GdipCreateHBITMAPFromBitmap(hBitmap, @hHBitmap, &hFF000000)
   
   hOld = SelectObject(hMemDC, hHBitmap)
   UpdateLayeredWindow(hGUI, hScrDC, NULL, Cast(Any Ptr, @pSize), hMemDC, Cast(Any Ptr, @pSource), 0, Cast(Any Ptr, @pBlend), ULW_ALPHA)
   SelectObject(hMemDC, hOld)
   DeleteObject(hHBitmap)
End Sub

Function GenerateClockBg(fDiameter As Ushort) As Any Ptr
   Dim As Any Ptr hBitmap_Logo, hBitmap_tmp, hGfx, hGfx2
   
   'decompress base91 encoded image
   Dim As Ulong iLines, bCompressed, iFileSize, iCompressedSize
   Dim As String sBaseType, sBase91, aB91(1)

   Restore __fblogopng:
   Read iLines
   Read bCompressed
   Read iFileSize
   Read iCompressedSize
   Read sBaseType
   For i As Ushort = 0 To iLines - 1
      Read aB91(0)
      sBase91 &= aB91(0)
   Next

   Dim As Ulong iLenB91
   Static As Ubyte Ptr aBinary
   aBinary = Base91Decode(sBase91, iLenB91)
   
   Dim As Any Ptr hBitmap, hBrush, hBrushL, hBrushLB, hPen, hPenL, hFamily, hStringFormat, hFont, hMatrix
   Dim As Single fBorderSize = fDiameter * 0.03333
   GdipCreatePen1(iShadowColor2, fBorderSize, 2, @hPen)
   Dim As Single fSize = fDiameter * 0.9475 - fBorderSize / 2, fRadius = fDiameter / 2, fShadow_vx = fDiameter * 0.0095, fShadow_vy = fDiameter * 0.01
   Dim As GpPointF tPoint1, tPoint2
   
   GdipCreateBitmapFromScan0(fDiameter, fDiameter, 0, PixelFormat32bppARGB, 0, @hBitmap)
   GdipGetImageGraphicsContext(hBitmap, @hGfx)
   GdipSetSmoothingMode(hGfx, 4)
   GdipSetPixelOffsetMode(hGfx, 4)
   GdipSetTextRenderingHint(hGfx, 4)

   tPoint1.x = fBorderSize
   tPoint1.y = fBorderSize
   tPoint2.x = fSize
   tPoint2.y = fSize
   GdipCreateLineBrush(@tPoint1, @tPoint2, iBgTransparency Shl 24 Or &hE8E8E8, iBgTransparency Shl 24 Or &hFFFFFF, 3, @hBrushLB)
   'GdipSetLineGammaCorrection(hBrushLB, TRUE)   
   GdipSetLineSigmaBlend(hBrushLB, 0.5, 0.85)
   
   GdipCreateMatrix(@hMatrix)
   GdipTranslateMatrix(hMatrix, fSize * 2, fSize * 2, 1)
   GdipRotateMatrix(hMatrix, 90, 1)
   GdipTranslateMatrix(hMatrix, -fSize * 2, -fSize * 2, 1)
   GdipMultiplyLineTransform(hBrushLB, hMatrix, 0)
   GdipDeleteMatrix(hMatrix)
   
   GdipFillEllipse(hGfx, hBrushLB, fBorderSize, fBorderSize, fSize, fSize)
   
   fShadowAngle = Atn(fShadow_vy / fShadow_vx) * fDeg
   If fShadow_vx < 0 And fShadow_vy >= 0 Then fShadowAngle += 180
   If fShadow_vx < 0 And fShadow_vy < 0 Then fShadowAngle -= 180
   GdipDrawEllipse(hGfx, hPen, fBorderSize + fShadow_vx, fBorderSize + fShadow_vy, fSize, fSize)
   _GDIPlus_BitmapApplyFilter_FastBoxBlur(hBitmap, fDiameter * 0.015)
   
   
   tPoint1.x = 0
   tPoint1.y = 0
   tPoint2.x = fSize
   tPoint2.y = fSize
   GdipCreateLineBrush(@tPoint1, @tPoint2, &hAFFFFFFF, &hFF000000, 3, @hBrushL)
   GdipSetLineSigmaBlend(hBrushL, 0.6, 1.0)
   GdipSetLineGammaCorrection(hBrushL, TRUE)   
   GdipCreatePen2(hBrushL, fBorderSize, UnitPixel, @hPenL)
   GdipDrawEllipse(hGfx, hPenL, fBorderSize, fBorderSize, fSize, fSize)
   
    GdipCreateSolidFill(&hFF000000, @hBrush)
   'GdipSetSolidFillColor(hBrush, &hFF000000)
   
   GdipTranslateWorldTransform(hGfx, fRadius, fRadius, 0)
   GdipRotateWorldTransform(hGfx, -6.0, MatrixOrderPrepend)
   GdipTranslateWorldTransform(hGfx, -fRadius, -fRadius, 0)
   
   Dim As Single iWidth1 = fDiameter * 0.026667, iHeight1 = fDiameter / 10, iWidth12 = iWidth1 / 2, fPosY = fDiameter * 0.083333, _
        iWidth2 = fDiameter * 0.013333, iHeight2 = fDiameter * 0.0416667, iWidth22 = iWidth2 / 2
       
   For i As Ubyte = 0 To 59
      GdipTranslateWorldTransform(hGfx, fRadius, fRadius, 0)
      GdipRotateWorldTransform(hGfx, 6.0, MatrixOrderPrepend)
      GdipTranslateWorldTransform(hGfx, -fRadius, -fRadius, 0)   
      If (i Mod 5) = 0 Then
         GdipFillRectangle(hGfx, hBrush, fRadius - iWidth12, fPosY, iWidth1, iHeight1)
      Else
         GdipFillRectangle(hGfx, hBrush, fRadius - iWidth22, fPosY, iWidth2, iHeight2)
      End If
   Next
   GdipResetWorldTransform(hGfx)
   
   Dim As GpRectF tLayout
   
   tLayout.Width = fRadius * 0.4
   tLayout.height = fRadius * 0.4
   tLayout.x = fRadius - fRadius * 0.2
   tLayout.y = fRadius + fRadius * 0.225
   
   If tOSVERSIONINFO.dwBuildNumber < 6000 Then
       GdipCreateFontFamilyFromName("Comic Sans MS", Null, @hFamily)
   Else
       GdipCreateFontFamilyFromName("Segoe Script", Null, @hFamily)
   End If
   GdipCreateStringFormat(0, 0, @hStringFormat)
   GdipCreateFont(hFamily, fDiameter * 0.025, FontStyleBold, UnitPoint, @hFont)
   GdipSetStringFormatAlign(hStringFormat, StringAlignmentCenter)
   GdipSetStringFormatLineAlign(hStringFormat, StringAlignmentCenter)
   GdipSetTextRenderingHint(hCanvas, TextRenderingHintAntiAliasGridFit)
   GdipDrawString(hGfx, "Clock by" & CrLf & "UEZ", -1, hFont, @tLayout, hStringFormat, hBrush)
   
   Dim As Single fLogoSize = fDiameter * 15, fLogoW, fLogoH, fTmp
   hBitmap_tmp = _GDIPlus_BitmapCreateFromMemory2(@aBinary[0], iFileSize)
   GdipGetImageDimension(hBitmap_tmp, @fLogoW, @fLogoH)
   fTmp = fLogoW
   fLogoW = fLogoSize / fLogoH
   fLogoH = fLogoSize / fTmp
   GdipCreateBitmapFromScan0(fLogoW, fLogoH, 0, PixelFormat32bppARGB, 0, @hBitmap_Logo)
   GdipGetImageGraphicsContext(hBitmap_Logo, @hGfx2)
   GdipSetInterpolationMode(hGfx2, 7)
   GdipDrawImageRect(hGfx2, hBitmap_tmp, 0, 0, fLogoW, fLogoH)
   GdipDrawImageRect(hGfx, hBitmap_Logo, fRadius - fLogoW / 2, fRadius / 1.75, fLogoW, fLogoH)
    GdipDisposeImage(hBitmap_tmp)

   GdipDisposeImage(hBitmap_Logo)
   GdipDeleteFont(hFont)
   GdipDeleteFontFamily(hFamily)
   GdipDeleteStringFormat(hStringFormat)
   GdipDeleteBrush(hBrush)
   GdipDeleteBrush(hBrushL)
   GdipDeleteBrush(hBrushLB)
   GdipDeletePen(hPen)
   GdipDeletePen(hPenL)
   GdipDeleteGraphics(hGfx)
   GdipDeleteGraphics(hGfx2)
   Return hBitmap
End Function

Function _GDIPlus_BitmapCreateFromMemory2(aBinImage As Ubyte Ptr, iLen As Ulong, bBitmap_GDI As Bool = False) As Any Ptr
   Dim As HGLOBAL hGlobal
   Dim As LPSTREAM hStream
   Dim As Any Ptr hBitmap_Stream
   Dim As Any Ptr hMemory = GlobalAlloc(GMEM_MOVEABLE, iLen)
   Dim As Any Ptr lpMemory = GlobalLock(hMemory)
   RtlCopyMemory(lpMemory, @aBinImage[0], iLen)
   GlobalUnlock(hMemory)
   CreateStreamOnHGlobal(hMemory, 0, @hStream)
   GdipCreateBitmapFromStream(hStream, @hBitmap_Stream)
   IUnknown_Release(hStream)

   If bBitmap_GDI = TRUE Then
      Dim hBitmap_GDI As Any Ptr
      GdipCreateHBITMAPFromBitmap(hBitmap_Stream, @hBitmap_GDI, &hFF000000)
      GdipDisposeImage(hBitmap_Stream)
      Return hBitmap_GDI
   EndIf

   Return hBitmap_Stream
End Function

Function _GDIPlus_GraphicsGetDPIRatio(iDPIDef As Ushort = 96) As Single
   Dim As Any Ptr hGfx
   Dim As Single fDPI = 0.0
   GdipCreateFromHWND(0, @hGfx)
   GdipGetDpiX(hGfx, @fDPI)
   GdipDeleteGraphics(hGfx)
   Return iDPIDef / fDPI
End Function


'https://lotsacode.wordpress.com/2010/12/08/fast-blur-box-blur-With-accumulator/
Sub _GDIPlus_BitmapApplyFilter_FastBoxBlur(Byval hImage As Any Ptr, range As Ulong)
   If (range Mod 2) = 0 Then range += 1
   FastBoxBlurH(hImage, range)
   FastBoxBlurV(hImage, range)
End Sub

Sub FastBoxBlurH(hImage As Any Ptr, range As Ulong)
   Dim As Single w, h
   GdipGetImageDimension(hImage, @w, @h)
   
   Dim As BitmapData tBitmapData
   Dim As Rect tRect = Type(0, 0, w, h)
   
   Dim As Long halfRange = range \ 2, index = 0, NewColors(0 To w), hits, a, r, g, b, oldPixel, col, newPixel
   
   GdipBitmapLockBits(hImage, Cast(Any Ptr, @tRect), ImageLockModeRead Or ImageLockModeWrite, PixelFormat32bppARGB, @tBitmapData)
   For y As Uinteger = 0 To h - 1
      a = 0
      r = 0
      g = 0
      b = 0
      hits = 0
      For x As Integer = -halfRange To w - 1
         oldPixel = x - halfRange - 1
         If oldPixel >= 0 Then
            col = Cast(Ulong Ptr, tBitmapData.Scan0)[index + oldPixel]
            If col <> 0 Then
               a -= Cubyte(col Shr 24)
               r -= Cubyte(col Shr 16)
               g -= Cubyte(col Shr 8)
               b -= Cubyte(col)
            End If
            hits -= 1
         End If
         newPixel = x + halfRange
         If newPixel < w Then
            col = Cast(Ulong Ptr, tBitmapData.Scan0)[index + newPixel]
            If col <> 0 Then
               a += Cubyte(col Shr 24)
               r += Cubyte(col Shr 16)
               g += Cubyte(col Shr 8)
               b += Cubyte(col)
            End If
            hits += 1
         End If
         If x >= 0 Then
            NewColors(x) = (Cubyte(a / hits) Shl 24) Or (Cubyte(r / hits) Shl 16) Or (Cubyte(g / hits) Shl 8) Or Cubyte(b / hits)
         End If
      Next
      For x As Uinteger = 0 To w - 1
         Cast(Ulong Ptr, tBitmapData.Scan0)[index + x] = NewColors(x)
      Next
      index += w
   Next
   GdipBitmapUnlockBits(hImage, @tBitmapData)
End Sub

Sub FastBoxBlurV(hImage As Any Ptr, range As Ulong)
   Dim As Single w, h
   GdipGetImageDimension(hImage, @w, @h)
   
   Dim As BitmapData tBitmapData
   Dim As Rect tRect = Type(0, 0, w, h)
   
   Dim As Long halfRange = range \ 2, index, NewColors(0 To h), hits, a, r, g, b, oldPixel, col, newPixel, _
            oldPixelOffset = -(halfRange + 1) * w, newPixelOffset = (halfRange) * w
   
   GdipBitmapLockBits(hImage, Cast(Any Ptr, @tRect), ImageLockModeRead Or ImageLockModeWrite, PixelFormat32bppARGB, @tBitmapData)
   For x As Uinteger = 0 To w - 1
      hits = 0
      a = 0
      r = 0
      g = 0
      b = 0
      index = -halfRange * w + x
      For y As Integer = -halfRange To h - 1
         oldPixel = y - halfRange - 1
         If oldPixel >= 0 Then
            col = Cast(Ulong Ptr, tBitmapData.Scan0)[index + oldPixelOffset]
            If col <> 0 Then
               a -= Cubyte(col Shr 24)
               r -= Cubyte(col Shr 16)
               g -= Cubyte(col Shr 8)
               b -= Cubyte(col)
            End If
            hits -= 1
         End If
         newPixel = y + halfRange
         If newPixel < h Then
            col = Cast(Ulong Ptr, tBitmapData.Scan0)[index + newPixelOffset]
            If col <> 0 Then
               a += Cubyte(col Shr 24)
               r += Cubyte(col Shr 16)
               g += Cubyte(col Shr 8)
               b += Cubyte(col)
            End If
            hits += 1
         End If
         If y >= 0 Then
            NewColors(y) = (Cubyte(a / hits) Shl 24) Or (Cubyte(r / hits) Shl 16) Or (Cubyte(g / hits) Shl 8) Or Cubyte(b / hits)
         End If
         index += w
      Next
      For y As Uinteger = 0 To h - 1
         Cast(Ulong Ptr, tBitmapData.Scan0)[y * w + x] = NewColors(y)
      Next
   Next
   GdipBitmapUnlockBits(hImage, @tBitmapData)
End Sub

'https://msdn.microsoft.com/en-us/library/ms724353.aspx
Function _WinAPI_IniRead(sIniFile As String, sSection As String, sKey As String, sDefault As String = "default") As String
   Dim As Zstring * 1024 Buffer
   Dim As Integer iResult = GetPrivateProfileString(sSection, sKey, sDefault, @Buffer, Sizeof(Buffer), sIniFile)
   Return Buffer
End Function

'https://msdn.microsoft.com/en-us/library/ms725500(v=vs.85).aspx
Function _WinAPI_IniWrite(sIniFile As String, sSection As String, sKey As String, sValue As String = "default") As Integer
   Dim As Zstring * 1024 Buffer
   Dim As Integer iResult = WritePrivateProfileString(sSection, sKey, sValue, sIniFile)
   Return iResult
End Function

'https://docs.microsoft.com/en-us/windows/desktop/api/winuser/nf-winuser-setprocessdpiaware
Function _WinAPI_SetProcessDpiAware() As UByte
    Dim As Any Ptr hLib = Dylibload("user32.dll")
    Dim pSetProcessDPIAware As Function() As UByte
    pSetProcessDPIAware = Dylibsymbol(hLib, "SetProcessDPIAware")
    Dim As UByte iReturn = pSetProcessDPIAware()
    Dylibfree(hLib)
    If iReturn = 0 Then Return 0
    Return 1
End Function

'https://docs.microsoft.com/en-us/windows/desktop/api/shellscalingapi/nf-shellscalingapi-setprocessdpiawareness
Function _WinAPI_SetProcessDpiAwareness(DPIAwareFlag As Integer) As UByte
    Dim As Any Ptr hLib = Dylibload("Shcore.dll")
    Dim pSetProcessDpiAwareness As Function(Byval DPIAwareFlag as Integer) As UByte
    pSetProcessDpiAwareness = Dylibsymbol(hLib, "SetProcessDpiAwareness")
    Dim As Ulong iReturn = pSetProcessDpiAwareness(DPIAwareFlag)
    Dylibfree(hLib)
    If iReturn <> 0 Then Return 0
    Return 1
End Function


Function Base91Decode(sString As String, Byref iBase91Len As Ulong) As Ubyte Ptr
   Dim As String sB91, sDecoded
   sB91 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!#$%&()*+,./:;<=>?@[]^_`{|}~´" '´ instead of "
   Dim As Long i, n = 0, c, b = 0, v = -1

   Dim aChr(0 To Len(sString) - 1) As String
   For i = 0 To Ubound(aChr)             
      aChr(i) = Mid(sString, i + 1, 1)
   Next
   
   For i = 0 To Ubound(aChr)
      c = Instr(sB91, aChr(i)) - 1
      If v < 0 Then
         v = c
      Else
         v += c * 91
         b = b Or (v Shl n)
         n += 13 + (((v And 8191) <= 88) * -1)
         Do Until  (n > 7)=0
            sDecoded &= Chr(b And 255)
            b = b Shr 8
            n -= 8
         Loop
         v = -1
      EndIf
   Next
   If (v + 1) Then
      sDecoded &= Chr((b Or (v Shl n)) And 255)
   End If
   iBase91Len = Len(sDecoded)

    'workaround for multiple embedded file other crash will occure
    Static As Ubyte aReturn(0 To iBase91Len - 1)
    Redim aReturn(0 To iBase91Len - 1) As Ubyte
     
    For i = 0 To iBase91Len - 1 'convert result String To ascii code values
        aReturn(i) = Asc(sDecoded, i + 1)
    Next
   Return @aReturn(0)
End Function

'Generated by FB File2Bas Code Generator v0.75 build 2018-02-22 beta by UEZ

__fblogopng:
Data 2,0,1153,1414,"Base91"
Data "vuk:eJs4+BAAN/<MCG4DAA´]BABt;LMAAA7f9(}mAABtHOyc:[rn<AAAAAAAAAAAAAAAAAAAAAAAuWV´9,AAC´kUNU8DII#}#~Slo5wT5|AA$AjzLH:OVl|gjw#J1D?vIyB|~~d+josXA#3?:G!q&|O1H5dJ?`5FN^g~q?<V@)Zq1~NzdZ`cB~je:_p1IVdVE<Gv`Bc>t^8hvX_/oC@k~}:Zd{2{[_+!i8(>f]4^[52>q=Rs&zcF#r49<R&@Bkonle8lyBRZp}51[^hHOw3s0D?40,~QAn_{VvkkTT+SB,_IL*:o&T.^?Uf(aqd*Wu$.C&YS%)mT<!Zy%(:GhWT2?M0Y^gL@Tgr$rG%E/38g~k?){JS´!+GL;;.5XiJ`t^YdDcl69,/3)X0Lmb~V.uaZhB*XiVN/{b}=^%/m4B0/?UY9BClk*[=u7Q2pe||>Bma<Xo,@K9w&D0]Y]fL.m{^q6fo#o?s|!5n28B5v4_K{S$|^40VRNi&M9Lj0E{`m#oTm{0Q+EO3k´U%2Jf)CP.v0(&L(BvuJ[p?<52bp|Ix2´Zx2D%kRW8Hqb.pG{=%p61&5dz485;vdo/RK3]yb´Z:n2gOm?M7`htJXUt+K@1FmGD7OGQ´DC|/oG@j+LxT)[+}1_+A~4n4i|k8Nid`}Y>u=2?5[%],{BAufOdTByv$c3tK$Pa=xL;rEQ;)<.m_BBA~AUglG*)7Q`]pA^[&%c].zx973mnRu7sJCj^mc_Raruk]g.´.s$%UuQX`yf_z@,n:%&BT43VNNsc5,>G62yFjQS)v5Vc&BjTHA%;kup+|$$)m_!&´Cx>bPCkb^kz=VTWsF}RB.aa/2z!5y)vz_$>Alt~5a}+LI2$4Bk$DN2Hn6*}r{eu!7,O5O[BAJ|0_g>^=n/pPO"
Data "I0[4{>@]SV<Ujeuoa>t`Pwh.oy.j@iJd1T&:nmpq[lW:VL}KPBu,bICM0aj&&)SL=T0qd7MKk#C``}x.f,`p%9i}[|GZ]b6Cy:5?(+`bGE)cl!a896/E9db3:Xl|%DWqh+<2_?7[*]~lLbl;)W/77fax=B3J!WLi_PJb%MW$O*r2N@}_$LB$cTl.4*Hy&<I&BJE?nm8M0Ku>Yz^vP?nCPcq!&WNfqW}CF/3x/t2:Y=mt6!c(Ct|m&uZbXb2]qCy$d$u$B5u|{*{_m4|2/*]+@`*&.zG^oQX:OEn53]Qs´2<~4p5|@!=cPvA&Q<gm|V$>RViL/o_G´9ZA5Um@=;Um@,vukV2O.HI:^*{Qxg(//5VfJ(O&nU}[[U2+/9A?A2yFie@^%+?MLn041;*NWtCf}y/d3Y]_prkVI/&:?T8]fR&S?o1[vgR@L4c4Cr8hETG46Pk]´y3U/c=fKsZFT´b9n/=$*4)ASiZ+5m0_v|9xpid!xAqoSg%BAAC´nHpwZ9)´&F"


Ressourcen inkl. kompilierte Exe Dateien können hier heruntergeladen werden: GDI+ Swiss Railway Clock v1.29 build 2024-01-17.zip
_________________
Gruß,
UEZ


Zuletzt bearbeitet von UEZ am 24.01.2024, 19:04, insgesamt 13-mal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen Alle Zeiten sind GMT + 1 Stunde
Gehe zu Seite Zurück  1, 2, 3, 4, 5, 6  Weiter
Seite 3 von 6

 
Gehe zu:  
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.

 Impressum :: Datenschutz