Tipp 0038 Grafiken aufrollen lassen
Autor/Einsender:
Datum:
  Yanidog / Detlev Schubert
17.04.2001
Entwicklungsumgebung:   VB 5
Unter vielen Grafik-Methoden ist diese sicherlich eine der interessantesten, und das alles ohne Zuhilfenahme von API-Funktionen. Dieser Tipp lässt der Fantasie freiem Lauf. Eine Grafik wird aufgerollt wie ein Teppich.
Mit der Konstante TubeWidth lässt sich die Rollenstärke einstellen, da bei diesen Berechnungen ein langsamer Rechner ganz schnell noch etwas langsamer wird.
 
Option Explicit

Private Sub Form_Load()
  Picture2.Width = Picture1.Width
  Picture2.Height = Picture1.Height
End Sub

Private Sub Command1_Click()
  Const TubeWidth = 50

  Dim XTube As Long, Offset As Long, XPicture As Long
  Dim Erg As Double

  Picture2.Cls
  Erg = 3.14159265358979 * 2 / (TubeWidth * 2)

  For Offset = 0 To Picture1.ScaleWidth - 1
    If Offset - TubeWidth >= 0 Then
      Picture2.PaintPicture _
            Picture1.Picture, Offset - TubeWidth, 0, 1, _
            Picture1.ScaleHeight, Offset - TubeWidth, _
            0, 1, Picture1.ScaleHeight
    End If

    For XTube = 1 To TubeWidth
      XPicture = ACos(XTube / (TubeWidth / 2)) / Erg
      If Offset + XPicture < Picture1.ScaleWidth Then
        Picture2.PaintPicture Picture1.Picture, Offset + _
        XTube - TubeWidth, 0, 1, Picture1.ScaleHeight, _
        Offset + XPicture, 0, 1, Picture1.ScaleHeight
      Else
        Picture2.PaintPicture Picture1.Picture, Offset + _
        XTube - TubeWidth, 0, 1, Picture1.ScaleHeight, _
        Offset + XTube - TubeWidth, 0, 1, Picture1.ScaleHeight
      End If
    Next XTube
  Next Offset
End Sub

Private Function ACos(X As Double)
  X = X - 1
  If X < 1 And X > -1 Then
    ACos = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
  Else
    ACos = 0
  End If
End Function
 
Weitere Links zum Thema
Grafiken mit GetDIBits und SetDIBits drehen
Grafiken mit verschiedenen Filtern kopieren
Überblendeffekte

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (17,8 kB) Downloads bisher: [ 2407 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Sonntag, 28. August 2011