Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0222: 8-Bit-Bitmaps drehen, rotieren

 von 

Beschreibung 

Dieses kleine Beispiel zeigt, wie man Bitmaps rotieren lassen kann.

Dieser Tipp funktioniert entweder nur in kompilierter Form oder benötigt eine DLL/OCX-Datei. Diese Binärdateien sind dem Tipp hinzugefügt worden, um seinen Funktionsumfang darstellen zu können. Vor dem Upload wurden sie auf Viren geprüft.

Schwierigkeitsgrad:

Schwierigkeitsgrad 3

Verwendete API-Aufrufe:

BitBlt, RtlMoveMemory (CopyMemory), GetObjectA (GetObject), VarPtr (VarPtrArray), RtlZeroMemory (ZeroMemory)

Download:

Download des Beispielprojektes [21,89 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Horizontale Scrollbar "HScroll1"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"

Option Explicit

Private Declare Function VarPtrArray Lib "msvbvm50.dll" _
        Alias "VarPtr" (Ptr() As Any) As Long
        
Private Declare Sub CopyMemory Lib "kernel32" Alias _
         "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal _
         ByteLen As Long)

Private Declare Function GetObject Lib "gdi32" Alias _
        "GetObjectA" (ByVal hObject As Long, ByVal nCount _
        As Long, lpObject As Any) As Long

Private Declare Function BitBlt Lib "gdi32" (ByVal _
        hDestDC As Long, ByVal x As Long, ByVal Y As Long, _
        ByVal nWidth As Long, ByVal nHeight As Long, ByVal _
        hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As _
        Long, ByVal dwRop As Long) As Long

Private Declare Sub ZeroMemory Lib "kernel32" Alias _
        "RtlZeroMemory" (dest As Any, ByVal numbytes As _
        Long)

Private Type SAFEARRAYBOUND
  cElements As Long
  lLbound As Long
End Type

Private Type SAFEARRAY1D
  cDims As Integer
  fFeatures As Integer
  cbElements As Long
  cLocks As Long
  pvData As Long
  Bounds(0 To 0) As SAFEARRAYBOUND
End Type

Private Type SAFEARRAY2D
  cDims As Integer
  fFeatures As Integer
  cbElements As Long
  cLocks As Long
  pvData As Long
  Bounds(0 To 1) As SAFEARRAYBOUND
End Type

Private Type BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type

Private Const SRCCOPY = &HCC0020

'255 = 360 Grad
Private Angle As Byte

'Buffer für SIN/COS
Private sin_Ang(255) As Double
Private cos_Ang(255) As Double

Private xStep_r(255) As Integer
Private xStep_c(255) As Integer
Private yStep_r(255) As Integer
Private yStep_c(255) As Integer

Private Sub Form_Load()
  Dim A%
  
    For A = 0 To 255
     '2Pi ist 360 Grad in Radiant
     sin_Ang(A) = Sin(A / 255 * 6.283185)
     cos_Ang(A) = Cos(A / 255 * 6.283185)
    Next A

    Call DoRotate
End Sub

Sub DoImagePro()
  Dim Pict() As Byte, Pict2() As Byte, r%, c%
  Dim SA As SAFEARRAY2D, SA2 As SAFEARRAY2D
  Dim Bmp As BITMAP, Bmp2 As BITMAP
  On Error Resume Next

    'Bitmap informationen auswerten
    'Ziel
    Call GetObject(Picture1.Picture, Len(Bmp), Bmp)
    
    'Quelle
    Call GetObject(Picture2.Picture, Len(Bmp2), Bmp2)
    
    'Es werden nur 8 Bit Bitmaps unterstützt (GIF)
    If Bmp.bmBitsPixel <> 8 Then
      MsgBox "Es werden nur 8-Bit Bitmaps unterstützt"
      Exit Sub
    End If
     
    'Bildmatrix dimensionen
    With SA
      .cbElements = 1
      .cDims = 2
      .Bounds(0).lLbound = 0
      .Bounds(0).cElements = Bmp.bmHeight
      .Bounds(1).lLbound = 0
      .Bounds(1).cElements = Bmp.bmWidthBytes
      .pvData = Bmp.bmBits
    End With
    
    Call CopyMemory(ByVal VarPtrArray(Pict), VarPtr(SA), 4)
        
    With SA2
      .cbElements = 1
      .cDims = 2
      .Bounds(0).lLbound = 0
      .Bounds(0).cElements = Bmp2.bmHeight
      .Bounds(1).lLbound = 0
      .Bounds(1).cElements = Bmp2.bmWidthBytes
      .pvData = Bmp2.bmBits
    End With
    
    Call CopyMemory(ByVal VarPtrArray(Pict2), VarPtr(SA2), 4)
    Call ZeroMemory(ByVal Bmp.bmBits, Bmp.bmWidthBytes * _
                    Bmp.bmHeight)
                    
    'Die Rotation
    For c = 0 To UBound(Pict2, 1)
      For r = 0 To UBound(Pict2, 2)
        'Schwarz nicht mit einbeziehen beschleunigt die Routine
        If Pict2(c, r) < 255 Then
          'Dies ist der entscheidene Algo. Hiermit wird erreicht
          'das keine verzerrungen in der Bitmap entstehen.
          Pict(xStep_c(c) + yStep_r(r), yStep_c(c) _
                                        - xStep_r(r)) = Pict2(c, r)
                                        
          Pict(xStep_c(c) + yStep_r(r) + 1, yStep_c(c) _
                                        - xStep_r(r)) = Pict2(c, r)
        End If
      Next r
    Next c
    
    'Bildmatrix freigeben
    Call CopyMemory(ByVal VarPtrArray(Pict), 0&, 4)
    Call CopyMemory(ByVal VarPtrArray(Pict2), 0&, 4)
End Sub

Sub DoRotate()
  Dim A%, Xs As Double, Ys As Double, Wid%, Hgt%
  
    Wid% = Picture2.ScaleWidth - 1
    Hgt% = Picture2.ScaleHeight - 1
   
    Angle = HScroll1.Value
    Xs = sin_Ang(Angle) * Wid
    Ys = cos_Ang(Angle) * Hgt

    For A = 0 To Wid%
      xStep_c(A) = (Xs / 2) - (Xs * (A / Wid))
      yStep_c(A) = (Ys / 2) - (Ys * (A / Wid)) + (Hgt / 1.3)
    Next
    
    For A% = 0 To Hgt%
      xStep_r(A) = (Xs / 2) - (Xs * (A / Hgt))
      yStep_r(A) = (Ys / 2) - (Ys * (A / Hgt)) + (Hgt / 1.3)
    Next
        
    Call DoImagePro
    Picture1.Refresh
End Sub

Private Sub HScroll1_Scroll()
  Call DoRotate
End Sub

Private Sub HScroll1_Change()
  Call DoRotate
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 6 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Kommentar von Lucky Luke am 10.11.2011 um 19:55

Außerdem funktioniert der Code bei größeren Bildern nicht. Ich finde, dass dieser Tipp sinnlos, sogar destruktiv, ist, da er anscheinend nur bei dem Beispielbild funktioniert. Er ist offensichtlich nicht in der Lage, sich auf ein beliebiges Bild einzustellen. Wenn das nicht möglich ist, bringt das Ganze auch nichts

mfG Lucas

Kommentar von Florian Rittmeier am 21.06.2008 um 18:33

Hallo Felix,

ja Du kannst den Code in deinen eigenen Anwendungen verwenden.

Florian

Kommentar von Felix.S am 21.06.2008 um 18:19

Hallo,
Ic habe diesauch scon bemerkt,
und hab' das Bild um ein
minimum gedreht. Dann ver-
schwanden die grünen
Linien. (Kann sich auch
auf einen Anderen Tipp
beziehen.)

Und ich hätte auch noch
eine Frage:
Kann ich dieses Projekt
in ein Shareware-Programm
einfügen?

Kommentar von Florian Rittmeier am 22.05.2003 um 18:45

Hallo!
Das im Tipp verwendete Algorithmus ist höchstwahrscheinlich fehlerhaft.

Einen korrekten Rotationsalgorithmus findet man im Beispielprojekt vom Tutorial "Safearrays + Bitmaps" unter http://www.activevb.de/tutorials/tut_safearray/safearray.html
.

Dieses funktioniert jedoch so nur für 24-Bit-Bitmaps. Wem das nicht ausreicht, der möge sich einfach bei mir per Mail melden. Es gibt eine relativ einfache Möglichkeit das dortige Beispielprojekt auch für 8-Bit tauglich zumachen. *zumindest einigermaßen*

Gruß Florian

Kommentar von Sven Dannenberg am 22.11.2002 um 20:44

Ich habe das selbe Problem wir Herr Schönberg!! Was muss ich, wenn ich ein anderes Bitmap verwenden will?

Kommentar von Sven Schönberg am 04.10.2001 um 14:23

Wenn ich ein anderen Bitmap einfüge wird dieser mit unbrauchbaren grünen Linen übersäht (Das Beischpiel-Bitmap funktioniert), obwohl ich das als 8 Bit Bitmap abgespeichert habe?? Was muss ich noch beachten?