Buchempfehlung
Visual Basic 6 Kochbuch
Visual Basic 6 Kochbuch
Viele praktische Tipps zum Programmieren mit Visual Basic 6, die sich oft auch auf FB übertragen lassen. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

Code-Beispiel

Code-Beispiele » Grafik und Fonts

Kaleidoskopeffekt mit Bitmaps

Lizenz:Erster Autor:Letzte Bearbeitung:
k. A.Mitgliedpomme 30.04.2009

Das verwendete Bild (Andy.BMP) gibt es im Attachment (link unten). Bei Interesse, bitte auch den animierten Schredder-Effekt ausprobieren. Es können natürlich auch andere Bilder (*.BMP) verwendet werden.

'COPYRIGHT 2009 D.Pommerening
'Kaleidoscop-Effect
'THIS CODE HAS NO LICENSE, NO WARRANTY; NO BONDING; USE IT AT YOUR OWN RISK; BUT DON´T CLAIM ISTS YOURS !
'Optimization is welcome !

'Kaleidoskop-Effekt
'DIESER CODE DARF LIZENZFREI BENUTZT WERDEN; OHNE JEDE GEWÄHR UND HAFTUNG; BENUTZUNG AUF
'EIGENE GEFAHR; NICHT MIT EIGENEM COPYRIGHT VERSEHEN !

'Dieser Code erzeugt bis zu 8 verschiedene kaleidoskopähnliche Effekte aus Bitmaps.
'Die erzeugten Bilder können überraschend, witzig und manchmal sogar wunderschön sein.

'Hinweis: Die geschweiften Klammern helfen in FbEdit (ab Version 1.0.6.7) Codeteile einzuklappen.
'Optimierungsvorschläge werden gern entgegengenommen!

 #Include "fbgfx.bi"

'{ FB-dialekt-handling
#If  __FB_VERSION__ < "0.20"
 #Error Please compile With FB version 0.20 Or above
#EndIf

#lang "fb"
 Using FB

#Ifdef __FB_LANG__
   #If __FB_LANG__ <> "fb"
   #Error Please compile With -lang fb
#EndIf

#Print __FB_SIGNATURE__
#Print Dialekt:
#Print __FB_LANG__
'}

 #Define  smalerval(val1,val2)  IIf(val1<val2,val1,val2) 'den kleineren zweier werte ermitteln
 #Define  bigerval(val1,val2)   IIf(val1>val2,val1,val2) 'den größeren zweier werte ermitteln

'{ DECLARE SUBS and FUNCTIONS
 Declare Function bmpload(file AS String) AS Any Ptr
 Declare Sub makekaleidoskop(kalbild AS UInteger Ptr,zbuff As UInteger Ptr,kal As Integer)
 Declare Sub message(text As String)
 Declare Sub resizepic(ByVal quelle AS UInteger Ptr,ByVal ziel AS UInteger Ptr,ByVal methode AS Integer)
 Declare Sub setimageplanes(array_ptr As UInteger Ptr,planes As Integer)
'}

'=================================================
Enum bildanpassungs_methoden
   jerked_mth  'unbeschnitten, das quell-bild wird ggf. gezerrt oder gequetscht kopiert
   lopped_mth  'beschnitten, das quell-bild wird ggf. an den rändern zugeschnitten kopiert
End Enum

'{ Dims
 Dim Shared As UInteger  _deskb,_deskh

 Dim As UInteger Ptr  orgpic,minipic,srcpic,dstpic,orgdata
 Dim As UInteger      orgb,orgh,gr,bytpp,bitspp,orgpitch
 Dim As Integer       kalei,minib,minih

 Dim As String  vz=ExePath
 Dim As String  file="\andy.bmp"
'}

   SCREENINFO _deskb,_deskh,bitspp 'Informationen über Desktop abfragen
    If bitspp<>32 Then message("Der Desktop ist nicht im TrueColor-Mode (32 Bit)") : End

   'vorerst unsichtbares fenster erstellen
   ScreenRes 320,240,32,,GFX_NULL

   'bild laden
   orgpic=bmpload(vz+file)
    If orgpic=0 Then End

    imageinfo(orgpic,orgb,orgh,bytpp,orgpitch,orgdata)
    gr=smalerval(_deskb,_deskh)*0.5

    ScreenRes gr,gr,32,,GFX_NO_FRAME

    'quell-bildpuffer erstellen (muß immer quadratisch sein)
    srcpic=ImageCreate(gr,gr)
    resizepic(orgpic,srcpic,lopped_mth)

   'größe des mini-bildes festlegen
   minib=gr*0.33
   minih=minib*(orgh/orgb) 'möglichst nahe am original seitenverhältnis
   If minih>gr/2 Then minih=gr/2 'falls das bild zu hoch ist - kürzen

    'mini-bildpuffer erstellen
    minipic=ImageCreate(minib,minih)
    resizepic(orgpic,minipic,jerked_mth) 'vollständig hineinkopieren

    ImageDestroy orgpic 'wird nicht mehr gebraucht

    'ziel-bildpuffer erstellen (muß immer quadratisch sein)
    dstpic=ImageCreate(gr,gr)

    For kalei=0 To 8
        makekaleidoskop(srcpic,dstpic,kalei)
        ScreenLock
      Put(0,0),dstpic,trans
      Put(0,0),minipic,trans
      If gr>104 Then Locate (gr Shr 4)-1,2 : Print "Variante ";kalei;
      ScreenUnLock
      If MultiKey(SC_ESCAPE) Then Exit For
      Sleep 1200
    Next

   ImageDestroy dstpic
    ImageDestroy srcpic
    ImageDestroy minipic

   While InKey<>"" : Sleep 50 : Wend

End
'=================================================
Function bmpload(file AS String) AS Any Ptr
'{ Dims
 Dim As UInteger     b,h,bytpp,ff,result
 Dim As Any Ptr      sprite
'}

   ff=Freefile
   result=Open(file For Binary Access Read As #ff)
   If result=2 Then Close #ff : message("Bild nicht gefunden.("+file+")") : Return 0
   If result   Then Close #ff : message("Fehler beim Laden des Bildes.")  : Return 0
   Get #ff,19,b
   Get #ff,23,h
   Close #ff

   If (b>4000) Or (h>3000) Then
      message("Das Bild ist zu gross ! ("+Str(b)+" x "+Str(h)+ " = "+Str(b*h)+" Bildpunkte)")
      Return 0
   End If

   sprite=ImageCreate(b,h,,32)
   result=BLoad(file,sprite)
    If imageinfo(sprite,,,bytpp) Then ImageDestroy sprite _
       : message("Falscher Image-Header oder FB-Screen nicht initialisiert.") : Return 0
   If result Then ImageDestroy sprite _
      : message("Fehler beim Laden des Bildes.") : Return 0

    If bytpp<>4 Then ImageDestroy sprite _
       : message("Dieses Bild ist nicht in True-Color (32 Bit)") : Return 0

   Return sprite

End Function

Sub makekaleidoskop(srcpic As UInteger Ptr,dstpic As UInteger Ptr,kalei As Integer)
'beide bildpuffer müssen existieren, gleich groß und quadratisch sein
'{ Dims
 Dim As UInteger Ptr    tdata,dstdata,srcdata
 Dim As UInteger        x,y,srcb,srch,dstb,dsth,srcofs
 Dim As UInteger        srcb1,srch1,dsth1,dstb1,bytpp
 Dim As UInteger        srcpitch,srcpad,dstpad,dstpitch
 Dim As UInteger        pf 'pixelfarbe
'}

   If (kalei<0) Or (kalei>8) Then Exit Sub

   If imageinfo(srcpic,srcb,srch,bytpp,srcpitch,srcdata) Then Exit Sub
   srcpad=srcpitch/bytpp
   srcb1=srcb-1 : srch1=srch-1

   'prüfen, ob das bild in 32bit-farben ist
   If bytpp<>4 Then Exit Sub

    If imageinfo(dstpic,dstb,dsth,bytpp,dstpitch,dstdata) Then Exit Sub
   dstpad=dstpitch/bytpp
   dstb1=dstb-1 : dsth1=dsth-1

   'prüfen, ob beide bilder quadratisch und in 32bit-farben sind
   If (dstb<>srcb) Or (dsth<>srch) Or (dstb<>srch) Or (dsth<>srcb) Or (bytpp<>4) Then Exit Sub

    If kalei=0 Then resizepic(srcpic,dstpic,jerked_mth) : Exit Sub 'das bild wird nur kopiert

   For y=0 To dsth1 Shr 1
      'zur optimierung ließen sich noch einige multiplikationen, additionen und subtraktionen einsparen !
      For x=y To dstb1 Shr 1
           Select Case kalei
           Case 1 'normales bild   vertikalspiegelnsp
              pf=srcdata[(y*srcpad)+x]
           Case 2 'nur gespiegelt   vertikalspiegeln
              pf=srcdata[(y*srcpad)+srcb1-x]
           Case 3 '90 nach links gedreht   linksdrehen
              pf=srcdata[(x*srcpad)+srcb1-y]
           Case 4 '90 nach rechts gedreht und gespiegelt   rechtsdrehensp
              pf=srcdata[((srch1-x)*srcpad)+srcb1-y]
           Case 5 '180 gedreht   kopfstand
              pf=srcdata[((srch1-y)*srcpad)+srcb1-x]
           Case 6 '180 gedreht und gespiegelt   kopfstandsp
              pf=srcdata[((srch1-y)*srcpad)+x]
           Case 7 '90 nach rechts gedreht   rechtsdrehen
              pf=srcdata[((srch1-x)*srcpad)+y]
           Case 8 '90 nach links gedreht und gespiegelt   linksdrehensp
              pf=srcdata[(x*srcpad)+y]

           End Select

         dstdata[(y*dstpad)+x]               = pf   'vertikalspiegelnsp
         dstdata[(y*dstpad)+dstb1-x]         = pf   'vertikalspiegeln
         dstdata[(x*dstpad)+dstb1-y]         = pf   'linksdrehen
         dstdata[((dsth1-x)*dstpad)+dstb1-y] = pf   'rechtsdrehensp

         dstdata[((dsth1-y)*dstpad)+dstb1-x] = pf   'horizontalspiegeln
         dstdata[((dsth1-y)*dstpad)+x]       = pf   'horizontalspiegelnsp
         dstdata[((dsth1-x)*dstpad)+y]       = pf   'rechtsdrehen
         dstdata[(x*dstpad)+y]               = pf   'linksdrehensp
      Next
   Next

End Sub
Sub message(text As String)
   Screen 14
   Print text
   Beep
   GetKey
End Sub
Sub resizepic(ByVal qp As UInteger Ptr,ByVal zp As UInteger Ptr,ByVal methode As Integer)
'{ der zielpuffer muß bereits in der gewünschten größe vorhanden sein
' methode: jerked_mth = nicht beschneiden, das quell-bild wird ggf. gezerrt oder gequetscht kopiert
'          lopped_mth = beschitten, das quell-bild wird ggf. an den rändern zugeschnitten kopiert
'}

'{ Dims
 Dim As UInteger Ptr  srcdata,dstdata
 Dim As Integer       srcb,srch,srcpitch,srcpad
 Dim As Integer       dstb,dsth,dstpitch,dstpad
 Dim As Integer       x,y,xend,k,qlofs,boffs,hoffs,bytpp
 Dim As UInteger      punkt
 Dim As Double        brest,hrest
 Dim As Double        bv,hv,hv2,bv2
'}

'padding berechnen
    imageinfo(qp,srcb,srch,bytpp,srcpitch,srcdata)
   srcpad=srcpitch/bytpp

    imageinfo(zp,dstb,dsth,bytpp,dstpitch,dstdata)
   dstpad=dstpitch/bytpp

   If (srcb<2) Or (srch<2) Or (dstb<2) Or (dsth<2) Or (bytpp<4) Then Beep : Exit Sub

'breite und höhe anpassen
   Select Case methode
    Case jerked_mth
      bv=srcb/dstb : hv=srch/dsth 'größenverhältniss feststellen

    Case  lopped_mth
      If (srcb/srch)<=(dstb/dsth) Then 'das bild ist hoeher als breit oder gleich
         bv=(srcb/dstb) 'größenverhältnisse feststellen
         hv=bv
         hrest=((srch/bv)-dsth)
         hoffs=hrest/2
      Else 'das bild ist breiter als hoch
         hv=(srch/dsth) 'größenverhältnisse feststellen
         bv=hv
         brest=((srcb/hv)-dstb)
         boffs=brest/2
      End If

   Case Else
      Exit Sub
   End Select

   If (dsth<2) Or (dstb<2) Then Exit Sub

'kopieren
   hv2=hv/2 : bv2=bv/2
   xend=dstb-1
   For y=0 To dsth-1
      qlofs=(Fix(((y+hoffs)*hv)+hv2)*srcpad)
      For x=0 To xend
         dstdata[k+x]=srcdata[qlofs+Fix(((x+boffs)*bv)+bv2)]
      Next x
      k+=dstpad
   Next y

End Sub
'=================================================

Attachments zum Code-Beispiel
BilddateiAndy.bmpBeispielbild für Kaleidoskopeffekt.Mitgliedpomme28.03.09

Zusätzliche Informationen und Funktionen
  • Das Code-Beispiel wurde am 28.03.2009 von Mitgliedpomme angelegt.
  • Die aktuellste Version wurde am 30.04.2009 von Mitgliedpomme gespeichert.
  Bearbeiten Bearbeiten  

  Versionen Versionen