Die Community zu .NET und Classic VB.

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

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

 von Dirk Lietzow

Schwierigkeitsgrad:

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 --------------

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.