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

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


Anmeldungsdatum: 10.09.2004
Beiträge: 5900
Wohnort: Deutschland

BeitragVerfasst am: 04.03.2018, 19:25    Titel: Antworten mit Zitat

Cool! lächeln
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
nemored



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

BeitragVerfasst am: 04.03.2018, 21:34    Titel: Antworten mit Zitat

Dem kann ich mich nur anschießen. Sehr hübsch!
_________________
Deine Chance beträgt 1:1000. Also musst du folgendes tun: Vergiss die 1000 und konzentriere dich auf die 1.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 27.04.2018, 13:53    Titel: Simple Recursive Tree Generator Antworten mit Zitat

Rekursive Baum Generierung (prozedurale Grafik)



Code:

'coded by UEZ build 2018-04-27
'thanks to dodicat for the DrawThickLine function
'use 64-bit compilation for faster progress

#include "string.bi"
#include "fbgfx.bi"
#if __FB_LANG__ = "fb"
   Using FB '' Scan code constants are stored in the FB namespace in lang FB
#endif

#Define Min(a, b)   Iif(a < b, a, b)

Declare Sub DrawRecTree(x As Single, y As Single, length As Single, angle As Single, col As Ulong)
Declare Sub DrawThickLine(Byval x1 As Integer, Byval y1 As Integer, Byval x2 As Integer, Byval y2 As Integer, Byval size As Integer, Byval c As Uinteger)


Const As Ushort iW = 1200, iH = 800, iCenterX = iW \ 2, iCenterY = iH \ 2
Const As Single fD2R = Acos(-1) / 180, thresholdBloom = 0.03, treeSize = 0.275
Const As Ubyte maxLevel = 14, bloomLevel = Cubyte(maxLevel * 0.75), lineThickness = 10, maxBloomSize = 8
Const As Ulong bloomColor = &h910F66, colorTree = &h800

Screenres iW, iH, 32, , GFX_WINDOWED Or GFX_NO_SWITCH
Color 0, &hA0A0A0
Cls

'======================= maybe needed later
Dim Shared As Integer w, h, depth, bpp, bpsl
ScreenInfo w, h, depth, bpp, bpsl
Dim Shared As Any Ptr pScreen
pScreen = Screenptr()
'=======================

Windowtitle("Simple Recursive Tree Generator v0.90 / " & Format((3^maxLevel) Shr 1, "#,##") & " function calls")
Randomize

Dim Shared As Ulong level
level = 0

DrawRecTree(iCenterX, iH, 90, -90, colorTree)
Draw String(10, 10), "Press space / lmb to regenerate tree", &hFFFFFF

Dim As Single fTimer
Dim As Integer x, y, buttons

Do   
   Getmouse(x, y, , buttons)
   If Multikey(SC_SPACE) Or buttons = 1 Then
      fTimer = Timer()
      Cls
      Screenlock
      DrawRecTree(iCenterX, iH, 90, -90, colorTree)
      Screenunlock
      Draw String(10, iH - 10), Format((Timer() - fTimer) * 1000, "0.0000") & " ms", &hFFFFFF
   End If
    Sleep 50, 1
Loop Until Multikey(SC_ESCAPE)


Sub DrawRecTree(x As Single, y As Single, length As Single, angle As Single, col As Ulong)
   level += 1
   Dim As Single destX, destY, col2
   destX = x + length * Cos(angle * fD2R)
   destY = y + length * Sin(angle * fD2R)
   
   col += 256 * level

   If level > bloomLevel And Rnd() < thresholdBloom Then
      col = bloomColor 'this will overwrite the green color and will change the color of the branches, too.
      Circle (x, y), Min(maxBloomSize, (destX - x)), col, , , 1.25 + Rnd() / 4, F
   Else   
      DrawThickLine(x, y, destX, destY, 1 + lineThickness / level, col)
      'Line (x, y)-(destX, destY), col
   End If
   
   If level < maxLevel Then
       DrawRecTree(destX, destY, length * (1 + 3 * Rnd()) * treeSize, angle + 60 * (Rnd() - Rnd()), col)
       DrawRecTree(destX, destY, length * (1 + 3 * Rnd()) * treeSize, angle + 60 * (Rnd() - Rnd()), col)
       DrawRecTree(destX, destY, length * (1 + 3 * Rnd()) * treeSize, angle + 60 * (Rnd() - Rnd()), col)
   End If
   
   level -= 1
End Sub

Sub DrawThickLine(Byval x1 As Integer, Byval y1 As Integer, Byval x2 As Integer, Byval y2 As Integer, Byval size As Integer, Byval c As Uinteger) 'by dodicat
   If x1 = x2 And y1 = y2 Then
      Circle (x1, y1), size, c, , , , f
   Elseif Abs(x2 - x1) >= Abs(y2 - y1) Then
      Dim K As Single = (y2 - y1) / (x2 - x1)
      For I As Integer = x1 To x2 Step Sgn(x2 - x1)
        Circle (I, K * (I - x1) + y1), size, c, , , , f
      Next I
   Else
      Dim L As Single = (x2 - x1) / (y2 - y1)
      For J As Integer = y1 To y2 Step Sgn(y2 - y1)
        Circle (L * (J - y1) + x1, J), size, c, , , , f
      Next J
   End If
End Sub

_________________
Gruß,
UEZ


Zuletzt bearbeitet von UEZ am 12.10.2018, 13:01, insgesamt einmal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 05.07.2018, 19:59    Titel: GDI+ Star Wars Intro Antworten mit Zitat

GDI+ Star Wars Intro build 2018-07-07 [nur für Windows und als x86]:




Download mit allen nötigen Dateien (Audio + Font): http://www.mediafire.com/file/nncqb4e7ubnqs1x/GDI__Star_Wars_Scroller_v0.6_build_2018-07-07.zip/file


Source Code lauffähig ohne Audio und Font:
Code:

'coded by UEZ build 2018-07-07
'
'WINDOWS and x86 ONLY!!!

#Include "fbgfx.bi"
#include "file.bi"
#Include "win/gdiplus.bi"
Using gdiplus

Using FB

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


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

Const As Ushort iW = 854, iH = iW / 2, iWh = iW \ 2, iHh = iH \ 2

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

Dim As String sTitle = "GDI+ Star Wars Scroller v0.6 / 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))

'Create canvas
Dim Shared As Any Ptr hCanvas, hPen, hBrush, hBrush_Warp, hBitmap, hGfx, hTexture, hFamily, hFamily_Logo, hFamily_Warp, _
                 hStringFormat, hStringFormat_Logo, hStringFormat_Warp, hFont, hFont2, hCollection, hPath_Logo, hPath_Warp, hPath_Temp
Dim As Any Ptr hDC = GetDC(hHWND), _
               hHBitmap = CreateCompatibleBitmap(hDC, iW, iH), _
               hDC_backbuffer = CreateCompatibleDC(hDC), hObjOld

hObjOld = SelectObject(hDC_backbuffer, hHBitmap)

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

Dim As GpPointF StartPoint, EndPoint
StartPoint.x = iWh
StartPoint.y = -iHh * 0.25
EndPoint.x = iWh
EndPoint.y = iH
Dim As ULong iColorTxt1_RGB = &h001367FD, iColorTxt2_RGB = &hF8DA37, i
GdipCreateSolidFill(iColorTxt1_RGB, @hBrush)
GdipCreateSolidFill(&hFFD7A501, @hBrush_Warp)
GdipCreateLineBrush(@StartPoint, @EndPoint, &h00D7A501, &hFFD7A501, 0, @hBrush_Warp)
GdipSetLineGammaCorrection(hBrush_Warp, True)

GdipCreatePen1(iColorTxt2_RGB, 4, UnitPixel, @hPen)
GdipSetPenLineJoin(hPen, LineJoinRound)

'create font
Dim As GpRectF tLayout, tLayout_Logo, tLayout_Warp
tLayout.x = iW * 0.12
tLayout.y = 0
tLayout.Width = iW
tLayout.height = iH
GdipCreateFontFamilyFromName("Times New Roman", Null, @hFamily)
GdipCreateStringFormat(0, 0, @hStringFormat)
GdipCreateFont(hFamily, iH / 12.5, FontStyleBold, UnitPoint, @hFont)
GdipSetStringFormatLineAlign(hStringFormat, StringAlignmentCenter)
'GdipSetStringFormatAlign(hStringFormat, StringAlignmentFar)

'Create 2nd gfx buffer
GdipCreateBitmapFromScan0(iW, iH, 0, PixelFormat32bppARGB, 0, @hBitmap)
GdipGetImageGraphicsContext(hBitmap, @hGfx)
GdipSetPixelOffsetMode(hGfx, PixelOffsetModeHalf)
GdipSetSmoothingMode(hGfx, SmoothingModeAntiAlias)
GdipSetTextRenderingHint(hGfx, TextRenderingHintAntiAliasGridFit)

'create some Random stars
Dim As Ulong aColor(0 To 6) = {&hFFFFFFFF, &hFFDDDDDD, &hFFBBBBBB, &hFF999999, &hFF777777, &hFF555555, &hFF333333}
For i As Ulong = 1 To 2000
   GdipBitmapSetPixel(hBitmap, Rnd() * iW, Rnd() * iH, aColor(Int(Rnd() * 6)))
Next


'create STAR WARS logo
tLayout_Logo.x = -iWh
tLayout_Logo.y = -iHh
tLayout_Logo.Width = iW * 2
tLayout_Logo.height = iH * 2

Dim As Ubyte bFont = 1
If Fileexists(Curdir & "\Death Star.otf") = 0 Then
   GdipCreateFontFamilyFromName("Impact", Null, @hFamily_Logo)
   bFont = 0
Else
   GdipNewPrivateFontCollection(@hCollection)
   GdipPrivateAddFontFile(hCollection, Curdir & "\Death Star.otf")
   GdipCreateFontFamilyFromName("Death Star", hCollection, @hFamily_Logo)
EndIf

GdipCreatePath(FillModeAlternate, @hPath_Logo)
GdipCreateStringFormat(0, 0, @hStringFormat_Logo)
GdipSetStringFormatAlign(hStringFormat_Logo, StringAlignmentCenter)
GdipSetStringFormatLineAlign(hStringFormat_Logo, StringAlignmentCenter)


'create warp
Dim As String aWarpText(26) = {   _
   "It  is  a  period  of civil war.", _
   "Rebel  spaceships,  striking", _
   "from  a  hidden base, have", _
   "won    their   first   victory", _
   "against  the  evil  Galactic", _
   "Empire.", _
   " ", _
   "During   the   battle,  rebel", _
   "spies   managed   to   steal", _
   "secret plans to the Empire's", _
   "ultimate     weapon,      the", _
   "Death Star, an armored space", _
   "station       with       enough", _
   "power  to destroy an entire", _
   "planet.", _
   " ", _
   "Pursued   by  the  Empire's", _
   "sinister   agents,   Princess", _
   "Leia races home aboard her", _
   "starship,  custodian  of the", _
   "stolen  plans that can save", _
   "her   people   and   restore", _
   "freedom  to the  galaxy....", _
   " ", _
   " ", _
   "Intro  coded by  UEZ :-)"}

             
GdipCreatePath(FillModeAlternate, @hPath_Warp)
GdipCreatePath(FillModeAlternate, @hPath_Temp)

GdipCreateStringFormat(0, 0, @hStringFormat_Warp)
GdipSetStringFormatAlign(hStringFormat_Warp, 0)
GdipSetStringFormatLineAlign(hStringFormat_Warp, 0)
GdipCreateFontFamilyFromName("Verdana", 0, @hFamily_Warp)

Dim As GpRectF tRECTF_Bound
Dim As Single fFontSize = iH / 6.6875

For i = 0 To Ubound(aWarpText)
   tLayout_Warp.y = i * (fFontSize + 5)
   GdipAddPathString(hPath_Warp, aWarpText(i), -1, hFamily_Warp, FontStyleRegular, (fFontSize + 5), @tLayout_Warp, hStringFormat_Warp)
Next
         
GdipGetPathWorldBounds(hPath_Warp, @tRECTF_Bound, Null, Null)

tLayout_Warp.X = 0
tLayout_Warp.Y = 0
tLayout_Warp.Width = tRECTF_Bound.Width
tLayout_Warp.Height = tRECTF_Bound.Height


Dim aPoints(3) AS GpPointF
aPoints(0).x = iW * 0.4
aPoints(0).y = iH * 0.33
aPoints(1).x = iW - iW * 0.4
aPoints(1).y = iH * 0.33
aPoints(2).x = -60
aPoints(2).y = iH
aPoints(3).x = iW
aPoints(3).y = iH



Sleep(250)
Dim As Ushort iFPS = 0, iStage = 1
Dim As Single fTimer, fAlpha = 0, fWait, fSize = iH * 1.168, y = iH * 1.45

Do
   GdipGraphicsClear(hCanvas, &hFF000000)
   
   Select Case iStage
      Case 1   
         If fAlpha < 255 Then
            fAlpha += 1
            GdipSetSolidFillColor(hBrush, fAlpha Shl 24 + iColorTxt1_RGB)
         Else
            fAlpha = 255
            fWait = Timer
            iStage += 1
         End If
         GdipDrawString(hCanvas, "A long time ago in a galaxy far," & CrLf & "far away....", -1, hFont, @tLayout, hStringFormat, hBrush)
     
      Case 2
         If Timer - fWait > 2.0 Then
            If fAlpha > 0 Then
               fAlpha -= 1
               GdipSetSolidFillColor(hBrush, fAlpha Shl 24 + iColorTxt1_RGB)
               GdipDrawString(hCanvas, "A long time ago in a galaxy far," & CrLf & "far away....", -1, hFont, @tLayout, hStringFormat, hBrush)
            Else
               iStage += 1
               GdipSetSolidFillColor(hBrush, &hFF000000)
               fAlpha = 255
            End If
         Else
            GdipDrawString(hCanvas, "A long time ago in a galaxy far," & CrLf & "far away....", -1, hFont, @tLayout, hStringFormat, hBrush)   
         End If   
         
      Case 3
         GdipDrawImageRect(hCanvas, hBitmap, 0, 0, iW, iH)
   
         If fSize > 1 And fAlpha > 0 Then
            GdipAddPathString(hPath_Logo, "STAR" & CrLf & "WARS", -1, hFamily_Logo, FontStyleRegular, fSize, @tLayout_Logo, hStringFormat_Logo)
            GdipFillPath(hCanvas, hBrush, hPath_Logo)
            GdipDrawPath(hCanvas, hPen, hPath_Logo)
            GdipResetPath(hPath_Logo)
            'GdipSetSolidFillColor(hBrush, fAlpha Shl 24)
            GdipSetPenColor(hPen, fAlpha Shl 24 + iColorTxt2_RGB)
            fSize -= 1.0
            fAlpha -= 0.475
         EndIf
   
     
         GdipResetPath(hPath_Warp)
         For i = 0 To Ubound(aWarpText)
            GdipResetPath(hPath_Temp)
            tLayout_Warp.Y = i * fFontSize + y
            GdipAddPathString(hPath_Temp, aWarpText(i), -1, hFamily_Warp, FontStyleRegular, fFontSize, @tLayout_Warp, hStringFormat_Warp)
            GdipGetPathWorldBounds(hPath_Temp, @tRECTF_Bound, Null, Null)
            If tRECTF_Bound.Y > -iH And tRECTF_Bound.Y <= iH + 30 Then
               GdipAddPathString(hPath_Warp, aWarpText(i), -1, hFamily_Warp, FontStyleRegular, fFontSize, @tLayout_Warp, hStringFormat_Warp)
            EndIf
         Next
         GdipWarpPath(hPath_Warp, Null, @aPoints(0), 4, 0, 0, iW, iH, WarpModePerspective, FlatnessDefault)
         
         GdipFillPath(hCanvas, hBrush_Warp, hPath_Warp)
         y -= 0.55
         If y < -2100 Then Exit Do
         
   End Select
   

   BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)


     If Timer - fTimer > 0.99 Then
      WindowTitle sTitle & iFPS
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   EndIf

   Sleep(1, 1)   
Loop Until Len(Inkey())


'release resources
GdipDeletePath(hPath_Logo)
GdipDeletePath(hPath_Warp)
GdipDeletePath(hPath_Temp)
If bFont = 1 Then GdipDeletePrivateFontCollection(hCollection)
GdipDeleteFont(hFont)
GdipDeleteFontFamily(hFamily)
GdipDeleteFontFamily(hFamily_Logo)
GdipDeleteFontFamily(hFamily_Warp)
GdipDeleteStringFormat(hStringFormat)
GdipDeleteStringFormat(hStringFormat_Logo)
GdipDeleteStringFormat(hStringFormat_Warp)
GdipDeleteGraphics(hGfx)
GdipDisposeImage(hBitmap)
SelectObject(hDC_backbuffer, hObjOld)
DeleteDC(hDC_backbuffer)
ReleaseDC(hHWND, hDC)
DeleteObject(hHBitmap)
GdipDeleteGraphics(hCanvas)
GdipDeletePen(hPen)
GdipDeleteBrush(hBrush)
GdipDeleteBrush(hBrush_Warp)
GdiplusShutdown(gdipToken)


Möge die Macht mir dir sein. zwinkern
_________________
Gruß,
UEZ


Zuletzt bearbeitet von UEZ am 12.10.2018, 13:00, insgesamt einmal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
UEZ



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

BeitragVerfasst am: 12.10.2018, 12:58    Titel: GDI / GDI+ Matrix Code Rain Antworten mit Zitat

GDI / GDI+ Matrix Code Rain (nur für Windows):



Code:

'Matrix Code Rain coded by UEZ v1.35 build 2018-10-12
'Windows only!

#Include "fbgfx.bi"
#Include "windows.bi"

#Ifdef __Fb_64bit__
    #Inclib "gdiplus"
    #Include Once "win/gdiplus-c.bi"
#Else
    #Include Once "win/gdiplus.bi"
    Using gdiplus
#Endif

Declare Function SetTimerInterval Lib "winmm" Alias "timeBeginPeriod" (As Ulong = 1) As Long ' dodicat snippet
Declare Function EndTimerInterval Lib "winmm" Alias "timeEndPeriod" (As Ulong = 1) As Long ' dodicat snippet

Using FB

Declare Function RandomRange(fStart as Single, fEnd as Single) as Single

#Define unicode

SetTimerInterval

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

Const As Ulong iW = 800, iH = 400

Dim As String sTitle = "The MATRIX v1.35 / FPS: "
Dim As Single fFontSize = 7.5, fPosX
Dim As UShort iFPS = 0, iW_Char = Cushort(fFontSize * 1.6666), iH_Char = Cushort(fFontSize * 1.6666), iAmountChars = 75, iMaxSpeed = 12, iMinSpeed = 4, i

Dim As Double fTime, fTimer

Screencontrol FB.SET_DRIVER_NAME, "GDI"
Screenres iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
Windowtitle sTitle

Dim As HWND hHWND
Screencontrol(FB.GET_WINDOW_HANDLE, Cast(Integer, hHWND))

Dim as GpRectF  tLayout1, tLayout2
tLayout1.x = 0
tLayout1.y = 0
tLayout1.width = iW_Char
tLayout1.height = iH_Char
tLayout2.x = 0
tLayout2.y = 0
tLayout2.width = iW_Char
tLayout2.height = iH_Char

Dim As Any Ptr    hDC = GetDC(hHWND), _
            hHBitmap = CreateCompatibleBitmap(hDC, iW, iH), _
            hDC_backbuffer = CreateCompatibleDC(hDC), _
            hHBitmap2 = CreateCompatibleBitmap(hDC, iW, iH), _
            hDC_backbuffer2 = CreateCompatibleDC(hDC), _
            hCanvas, hCanvas2, hBrush_Clr, hBrush_Char, hBrush_CharGlow, hBrush_Bg, hFamily, hFont, hFont_Glow, hStringFormat, hGfx

Var hDC_obj = SelectObject(hDC_backbuffer, hHBitmap), hDC_obj2 = SelectObject(hDC_backbuffer2, hHBitmap2)
GdipCreateFromHDC(hDC_backbuffer, @hCanvas)
GdipCreateFromHDC(hDC_backbuffer2, @hCanvas2)
GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)
GdipSetTextRenderingHint(hCanvas, TextRenderingHintAntiAlias)
GdipSetSmoothingMode(hCanvas2, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas2, PixelOffsetModeHalf)
GdipSetTextRenderingHint(hCanvas2, TextRenderingHintAntiAlias)
GdipCreateStringFormat(0, 0, @hStringFormat)
GdipCreateFontFamilyFromName("Times New Roman", Null, @hFamily)
GdipCreateFont(hFamily, fFontSize, 1, 3, @hFont)
GdipCreateFont(hFamily, iW_Char, 1, 3, @hFont_Glow)
GdipSetStringFormatAlign(hStringFormat, StringAlignmentCenter)
GdipSetStringFormatLineAlign(hStringFormat, StringAlignmentCenter)
GdipCreateSolidFill(&h0D000000, @hBrush_Clr)
GdipCreateSolidFill(&hE8E8FFE8, @hBrush_Char)
GdipCreateLineBrushFromRectWithAngle(@tLayout2, &h1000FF00, &hE0A0FFA0, 0, False, 1, @hBrush_CharGlow)
GdipSetLineSigmaBlend(hBrush_CharGlow, 0.5, 1)
GdipSetLineGammaCorrection(hBrush_CharGlow, True)
GdipCreateHatchBrush(9, &hF0003800, &hFF000000, @hBrush_Bg)

Type tTable
   x As Single
   y As Single
   vy As Single
   c As integer
End Type

Dim As tTable aTable(0 To iAmountChars)

For i = 0 To iAmountChars - 1
   fPosX = Rnd() * (iW - iW_Char)
   aTable(i).x = fPosX - (fPosX Mod iW_Char)
   aTable(i).y = -fFontSize - RandomRange(10, 200)
   aTable(i).vy = RandomRange(iMinSpeed, iMaxSpeed)
   aTable(i).c = aTable(i).y - iH_Char - 1
Next

GdipGraphicsClear(hCanvas, &hFF000000)

Dim As Ushort iLen = 55, iChar = 0
Dim As Wstring * 2 aChars(iLen)
For i = 0 To iLen
   aChars(i) = WChr(i + 65382)
Next
Dim As WString * 2 sChar = aChars(0)

Type tPrePaintedChars
   hBitmap As Any Ptr
End Type

Dim As tPrePaintedChars aChars_pre(iLen, 2)
For i = 0 To iLen
   GdipCreateBitmapFromScan0(iW_Char, iH_Char, 0, PixelFormat32bppARGB, 0, @aChars_pre(i, 0).hBitmap)
   GdipGetImageGraphicsContext(aChars_pre(i, 0).hBitmap, @hGfx)
   GdipSetPixelOffsetMode(hGfx, PixelOffsetModeHalf)
   GdipSetTextRenderingHint(hGfx, TextRenderingHintAntiAlias)
   GdipSetSmoothingMode(hGfx, SmoothingModeAntiAlias)
   GdipDrawString(hGfx, aChars(i), -1, hFont_Glow, @tLayout1, hStringFormat, hBrush_CharGlow)
   GdipDeleteGraphics(hGfx)
   GdipCreateBitmapFromScan0(iW_Char, iH_Char, 0, PixelFormat32bppARGB, 0, @aChars_pre(i, 1).hBitmap)
   GdipGetImageGraphicsContext(aChars_pre(i, 1).hBitmap, @hGfx)
   GdipSetPixelOffsetMode(hGfx, PixelOffsetModeHalf)
   GdipSetTextRenderingHint(hGfx, TextRenderingHintAntiAlias)
   GdipSetSmoothingMode(hGfx, SmoothingModeAntiAlias)
   GdipDrawString(hGfx, aChars(i), -1, hFont, @tLayout1, hStringFormat, hBrush_Char)
   GdipDeleteGraphics(hGfx)
Next

fTimer = Timer

Do
   GdipFillRectangle(hCanvas2, hBrush_Bg, 0, 0, iW, iH)
   GdipFillRectangle(hCanvas, hBrush_Clr, 0, 0, iW, iH)
   
   For i = 0 To iAmountChars - 1
      If aTable(i).y - aTable(i).c > iH_Char Then
         GdipDrawImageRect(hCanvas, aChars_pre(iChar, 0).hBitmap, aTable(i).x, aTable(i).y, iW_Char, iH_Char)
         aTable(i).c = aTable(i).y
      Endif
      iChar = Cushort(Rnd() * iLen)
      GdipDrawImageRect(hCanvas2, aChars_pre(iChar, 0).hBitmap, aTable(i).x, aTable(i).y, iW_Char, iH_Char)
      GdipDrawImageRect(hCanvas2, aChars_pre(iChar, 1).hBitmap, aTable(i).x, aTable(i).y, iW_Char, iH_Char)
      aTable(i).y += aTable(i).vy
      If aTable(i).y > iH Then
         fPosX = Rnd() * (iW - iW_Char)
         aTable(i).x = fPosX - (fPosX Mod iW_Char)
         aTable(i).y = -fFontSize - 1
         aTable(i).vy = RandomRange(iMinSpeed, iMaxSpeed)
         aTable(i).c = aTable(i).y - iH_Char - 1
      EndIf
   Next
   
   
   BitBlt(hDC_backbuffer2, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCPAINT)
   BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer2, 0, 0, SRCCOPY)
   
   If(Timer - fTimer > 0.99) Then
      Windowtitle (sTitle & iFPS)
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   Endif
   
   Sleep(1)
Loop Until Len(Inkey())

EndTimerInterval

'GDI
SelectObject(hDC_backbuffer, hDC_obj)
DeleteDC(hDC_backbuffer)
DeleteObject(hHBitmap)
SelectObject(hDC_backbuffer2, hDC_obj2)
DeleteDC(hDC_backbuffer2)
DeleteObject(hHBitmap2)
ReleaseDC(hHWND, hDC)

'GDIPlus
For i = 0 To iLen
   GdipDisposeImage(aChars_pre(i, 0).hBitmap)
   GdipDisposeImage(aChars_pre(i, 1).hBitmap)
Next
GdipDeleteBrush(hBrush_Clr)
GdipDeleteBrush(hBrush_Char)
GdipDeleteBrush(hBrush_CharGlow)            
GdipDeleteBrush(hBrush_Bg)            
GdipDeleteFont(hFont)
GdipDeleteFont(hFont_Glow)
GdipDeleteFontFamily(hFamily)
GdipDeleteStringFormat(hStringFormat)
GdipDeleteGraphics(hCanvas)
GdipDeleteGraphics(hCanvas2)
GdiplusShutdown(gdipToken)


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

_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen Alle Zeiten sind GMT + 1 Stunde
Gehe zu Seite Zurück  1, 2, 3, 4
Seite 4 von 4

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

 Impressum :: Datenschutz