|
Das deutsche QBasic- und FreeBASIC-Forum Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
Autor |
Nachricht |
grindstone
Anmeldungsdatum: 03.10.2010 Beiträge: 1215 Wohnort: Ruhrpott
|
Verfasst am: 20.03.2017, 21:58 Titel: |
|
|
Kein Problem bei mir (WinXP SP3 / fbc 1.05.0 / 32bit). Programm compiliert und läuft einwandfrei. (Und die Enterprise finde ich echt witzig! )
Gruß
grindstone _________________ For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen! |
|
Nach oben |
|
|
nemored
Anmeldungsdatum: 22.02.2007 Beiträge: 4603 Wohnort: ~/
|
Verfasst am: 20.03.2017, 23:34 Titel: |
|
|
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 |
|
|
Elor
Anmeldungsdatum: 12.07.2013 Beiträge: 205 Wohnort: Konstanz
|
Verfasst am: 21.03.2017, 13:00 Titel: |
|
|
Oh man, nemored, du hast recht, ich hab die Resourcen vergessen
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 |
|
Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 129 Wohnort: Opel Stadt
|
Verfasst am: 21.03.2017, 18:30 Titel: |
|
|
Elor hat Folgendes geschrieben: | Oh man, nemored, du hast recht, ich hab die Resourcen vergessen
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 |
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.
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 129 Wohnort: Opel Stadt
|
Verfasst am: 15.09.2017, 00:10 Titel: 3D Starfield Rotating Flight |
|
|
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, 16:15, insgesamt 2-mal bearbeitet |
|
Nach oben |
|
|
Marc Bonus
Anmeldungsdatum: 19.11.2016 Beiträge: 43
|
Verfasst am: 15.09.2017, 12:34 Titel: Re: 3D Starfield Rotating Flight |
|
|
UEZ hat Folgendes geschrieben: | Keine Ahnung, ob der Code unter Linux läuft. |
Läuft anstandslos unter Kubuntu 17.04 mit Geany. |
|
Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 129 Wohnort: Opel Stadt
|
Verfasst am: 15.09.2017, 13:09 Titel: Re: 3D Starfield Rotating Flight |
|
|
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.
Was wird unter Linux als Driver_Name angezeigt? Was ist deine FPS? _________________ Gruß,
UEZ |
|
Nach oben |
|
|
Marc Bonus
Anmeldungsdatum: 19.11.2016 Beiträge: 43
|
Verfasst am: 15.09.2017, 13:30 Titel: |
|
|
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 129 Wohnort: Opel Stadt
|
Verfasst am: 15.09.2017, 13:36 Titel: |
|
|
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 |
|
|
nemored
Anmeldungsdatum: 22.02.2007 Beiträge: 4603 Wohnort: ~/
|
|
Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010 Beiträge: 1215 Wohnort: Ruhrpott
|
Verfasst am: 15.09.2017, 14:47 Titel: |
|
|
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 129 Wohnort: Opel Stadt
|
Verfasst am: 25.10.2017, 16:43 Titel: |
|
|
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 |
|
|
grindstone
Anmeldungsdatum: 03.10.2010 Beiträge: 1215 Wohnort: Ruhrpott
|
Verfasst am: 25.10.2017, 19:36 Titel: |
|
|
Sehr beeindruckend!
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 129 Wohnort: Opel Stadt
|
Verfasst am: 25.10.2017, 20:28 Titel: |
|
|
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 |
|
|
Jojo alter Rang
Anmeldungsdatum: 12.02.2005 Beiträge: 9736 Wohnort: Neben der Festplatte
|
Verfasst am: 26.10.2017, 01:47 Titel: |
|
|
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 129 Wohnort: Opel Stadt
|
Verfasst am: 26.10.2017, 10:56 Titel: |
|
|
Danke Jojo.
Habe den Code aktualisiert. _________________ Gruß,
UEZ |
|
Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 129 Wohnort: Opel Stadt
|
Verfasst am: 16.01.2018, 00:02 Titel: |
|
|
Hier eine Portierung eines meiner AutoIt Skripte Zwecks FB Übung:
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 129 Wohnort: Opel Stadt
|
Verfasst am: 17.01.2018, 17:20 Titel: |
|
|
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 |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 129 Wohnort: Opel Stadt
|
Verfasst am: 08.02.2018, 23:31 Titel: |
|
|
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, 12:58, insgesamt einmal bearbeitet |
|
Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016 Beiträge: 129 Wohnort: Opel Stadt
|
Verfasst am: 04.03.2018, 12:57 Titel: GDI+ Swiss Railway Clock v1.29 build 2024-01-17 |
|
|
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, 20:04, insgesamt 13-mal bearbeitet |
|
Nach oben |
|
|
|
|
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.
|
|