Zurück zur Homepage

Rotieren von Bildern

Endlich hat man es unter VBA gepackt, die Twain-Schnittstelle für sich arbeiten zu lassen. Das gescannte Bild oder der Schnappschuss einer Webcam existiert nun doch tatsächlich als Hintergrund eines Steuerelementes. Unschön ist aber, dass das Bild etwas schief ist, da man leider das Originalblatt schief in den Scanner eingelegt hat oder die Kamera flasch montiert ist. Sollte man nun das Bild doch erst wieder von Hand scannen, anschließend mit einem Bildbearbeitungsprogramm in die richtige Position drehen, speichern und es schlussendlich per Hand als Hintergrundbild wählen?

Dass das eine eher rhetorische Frage ist, haben sie sicherlich schon geahnt. Und wie man sich denken kann, werden für das Rotieren unter VBA wieder API-Funktionen benutzt.

Rotation

Auch bei diesem Beispiel gilt, dass man den Code frei benutzen kann. Eine Veröffentlichung des Codes oder Teilen davon, womöglich noch unter anderem Namen, sollte aber unterbleiben.

Excel-Dateien zum Download ca. 179 KB: Rot.xlsm oder Rot.xls

Das Klassenmodul des Tabellenblatts “Rotieren“

Ein Klick auf die Schaltfläche cmdRotate löst die entsprechende Ereignisprozedur aus. Erst wird ein Objektverweis auf das Quellbild des Ole-Objektes mit dem Namen “Image1“ in der Objektvariablen objPic gespeichert. Anschließend setzt man die Eigenschaften Picture und Rotate des Klassenobjektes x, welches vom Typ clsPicRotate ist. Die Eigenschaft Picture bekommt das Quellbild, die Eigenschaft Rotate den Winkel aus Zelle J1 zugewiesen. Anders als in der Mathematik üblich, dreht ein positiver Winkel das Bild nach rechts. Man könnte das zwar auch andersherum machen, aber der Laie stellt sich eine Drehung immer im Uhrzeigersinn vor. Das rotierte Bild wird über die Eigenschaft GetPicture des Klassenobjektes x ausgelesen und in der Objektvariablen objDest gespeichert. Anschließend muss noch der Picture-Eigenschaft des Zielobjektes “Image2“ das rotierte Bild zugewiesen werden.

Option Explicit

Private Sub cmdRotate_Click()
   Dim x          As New clsPicRotate
   Dim objPic     As IPictureDisp
   Dim objDest    As IPictureDisp
   
   Set objPic = Me.OLEObjects("Image1").Object.Picture
   With x
      .Picture = objPic
      .Rotate = Me.Range("J1")
      Set objDest = .GetPicture
   End With
   Me.OLEObjects("Image2").Object.Picture = objDest
   
End Sub

Die Klasse clsPicRotate

Die Klasse clsPicRotate ist dafür da, ein beliebiges Bild vom Typ StdPicture (IPictureDisp) um einen Winkel zwischen 0 und 360 Grad nach rechts zu drehen. An die Eigenschaft Picture wird das zu rotierende Bild, an die Eigenschaft Rotate der Winkel übergeben. Die Eigenschaft GetPicture liefert das rotierte Bild.

Option Explicit
Private Type POINTAPI
   x As Long
   y As Long
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 Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type
Private Type PICTDESC
   cbSize As Long
   picType As Long
   hImage As Long
   Data1 As Long
   Data2 As Long
End Type
Private Declare Function BitBlt _
   Lib "gdi32" ( _
   ByVal hDestDC As Long, _
   ByVal x As LongByVal y As Long, _
   ByVal nWidth As LongByVal nHeight As Long, _
   ByVal hSrcDC As Long, _
   ByVal xSrc As LongByVal ySrc As Long, _
   ByVal dwRop As LongAs Long
Private Declare Function PlgBlt _
   Lib "gdi32.dll" ( _
   ByVal hdcDest As Long, _
   ByRef lpPoint As POINTAPI, _
   ByVal hdcSrc As Long, _
   ByVal nXSrc As Long, _
   ByVal nYSrc As Long, _
   ByVal nWidth As Long, _
   ByVal nHeight As Long, _
   ByVal hbmMask As Long, _
   ByVal xMask As Long, _
   ByVal yMask As Long _
   ) As Long
Private Declare Function OleCreatePictureIndirect _
   Lib "olepro32.dll" ( _
   pPictDesc As PICTDESC, _
   RefIID As GUID, _
   ByVal fPictureOwnsHandle As Long, _
   ppvObj As IPicture _
   ) As Long
Private Declare Function DeleteDC _
   Lib "gdi32" ( _
   ByVal hdc As Long _
   ) As Long
Private Declare Function CreateCompatibleDC _
   Lib "gdi32" ( _
   ByVal hdc As Long _
   ) As Long
Private Declare Function SelectObject _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal hObject As Long _
   ) As Long
Private Declare Function CreateCompatibleBitmap _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal nWidth As Long, _
   ByVal nHeight As Long _
   ) As Long
Private Declare Function GetObjectAPI _
   Lib "gdi32" Alias "GetObjectA" ( _
   ByVal hObject As Long, _
   ByVal nCount As Long, _
   lpObject As Any _
   ) As Long
Private Const WHITENESS          As Long = &HFF0062
Private Const SRCCOPY            As Long = &HCC0020
Private Const vbPicTypeBitmap    As Long = 1
Private mobjPicture              As IPictureDisp
Private mdblRotate               As Double

Public Function GetPicture() As IPictureDisp
   Dim objPic              As IPictureDisp
   Dim x                   As Long
   Dim y                   As Long
   Dim lngSourceDC         As Long
   Dim lngDestDC           As Long
   Dim udtBMP              As BITMAP
   Dim lngObjOldSource     As Long
   Dim lngObjOldDest       As Long
   Dim lngDestBMP          As Long
   Dim udtPicdesc          As PICTDESC
   Dim IID_IDispatch       As GUID
   Dim hImage              As Long
   Dim lngRet              As Long
   Dim lngHeight           As Long
   Dim lngWidth            As Long
   Dim dblDegree           As Double
   Dim udtPoint(2)         As POINTAPI
   Dim lngMidXDest         As Long
   Dim lngMidYDest         As Long
   Dim lngMidXSource       As Long
   Dim lngMidYSource       As Long
   Dim lngSourceX          As Long
   Dim lngSourceY          As Long

   If mobjPicture Is Nothing Then
      MsgBox "Kein gültiges Bild!"
      Exit Function
   End If

   ' Winkel in Bogenmaß umwandeln
   dblDegree = -1 * mdblRotate * 3.1415926 / 180

   ' DummyDC zum Blitten vom Quellbild erzeugen
   lngSourceDC = CreateCompatibleDC(0&)

   ' Bitmapstruktur des Bildes ausfüllen lassen, damit
   ' Größe ausgelesen werden kann
   GetObjectAPI mobjPicture.Handle, Len(udtBMP), udtBMP

   ' Größe auslesen
   x = udtBMP.bmWidth
   y = udtBMP.bmHeight

   ' Mittelpunkt Quelle berechnen
   lngMidXSource = x / 2
   lngMidYSource = y / 2

   ' Bitmap ins QuellDC stellen, altes Objekt merken
   lngObjOldSource = SelectObject(lngSourceDC, mobjPicture.Handle)

   ' Zielgröße der Bitmap ermitteln
   lngHeight = Abs(Cos(dblDegree)) * y + Abs(Sin(dblDegree)) * x
   lngWidth = Abs(Cos(dblDegree)) * x + Abs(Sin(dblDegree)) * y

   ' Mittelpunkt Ziel berechnen
   lngMidXDest = lngWidth / 2
   lngMidYDest = lngHeight / 2

   ' Bitmap in der Größe erzeugen, dass rotiertes Bild
   ' komplett hineinpasst
   lngDestBMP = CreateCompatibleBitmap( _
      lngSourceDC, lngWidth, lngHeight)

   ' DummyDC zum Blitten ins Zielbild erzeugen
   lngDestDC = CreateCompatibleDC(0&)

   ' Bitmap ins ZielDC stellen, altes Objekt merken
   lngObjOldDest = SelectObject(lngDestDC, lngDestBMP)

   ' Alle Pixel des Zielbilds auf Weiß setzen
   BitBlt lngDestDC, 0, 0, lngWidth, lngHeight, _
      lngDestDC, 0, 0, WHITENESS

   ' Zielposition vom Mittelpunkt berechnen
   ' Punkt oben links
   lngSourceX = 0 - lngMidXSource
   lngSourceY = 0 - lngMidYSource
   udtPoint(0).x = lngMidXDest + _
      lngSourceX * Cos(dblDegree) + _
      lngSourceY * Sin(dblDegree)
   udtPoint(0).y = lngMidYDest - _
      lngSourceX * Sin(dblDegree) + _
      lngSourceY * Cos(dblDegree)

   ' Punkt oben rechts
   lngSourceX = x - lngMidXSource
   lngSourceY = 0 - lngMidYSource
   udtPoint(1).x = lngMidXDest + _
      lngSourceX * Cos(dblDegree) + _
      lngSourceY * Sin(dblDegree)
   udtPoint(1).y = lngMidYDest - _
      lngSourceX * Sin(dblDegree) + _
      lngSourceY * Cos(dblDegree)

   ' Punkt unten links
   lngSourceX = 0 - lngMidXSource
   lngSourceY = y - lngMidYSource
   udtPoint(2).x = lngMidXDest + _
      lngSourceX * Cos(dblDegree) + _
      lngSourceY * Sin(dblDegree)
   udtPoint(2).y = lngMidYDest - _
      lngSourceX * Sin(dblDegree) + _
      lngSourceY * Cos(dblDegree)

   PlgBlt lngDestDC, udtPoint(0), lngSourceDC, 0, 0, x, y, 0, 0, 0

   ' Schnittstellenkennung kPictureIID (GUID)
   With IID_IDispatch
      .Data1 = &H20400
      .Data4(0) = &HC0
      .Data4(7) = &H46
   End With

   With udtPicdesc
      ' Struktur Picdesc ausfüllen
      .cbSize = Len(udtPicdesc)
      .picType = vbPicTypeBitmap
      .hImage = lngDestBMP
    End With

   ' Picture-Objekt erzeugen
   lngRet = OleCreatePictureIndirect( _
      udtPicdesc, IID_IDispatch, 1&, objPic)

   ' Picture-Objekt zurückgeben
   If lngRet = 0 Then Set GetPicture = objPic

   SelectObject lngSourceDC, lngObjOldSource
   DeleteDC lngSourceDC

   SelectObject lngDestDC, lngObjOldDest
   DeleteDC lngDestDC
End Function

Public Property Let Rotate(ByVal vNewValue As Double)
   mdblRotate = vNewValue
End Property

Public Property Let Picture(ByVal vNewValue As IPictureDisp)
   Set mobjPicture = vNewValue
End Property

Die Funktion GetPicture

Die Funktion GetPicture erledigt die Hauptarbeit der Klasse. Darin wird zunächst einmal ein DC (Gerätekontext) angelegt (lngSourceDC), der das Quellbild aufnehmen soll. Solch ein DC ist im Prinzip eine Zeichenfläche, auf der grafische Operationen ausgeführt werden können. Da man nicht unbedingt mit dem Gerätekontext eines Druckers oder eines ähnlichen grafischen Gerätes arbeiten möchte, erzeugt man mit CreateCompatibleDC einen DC, der kompatibel zum Bildschirm ist. Darauf werden im Allgemeinen ja auch die Bilder ausgegeben. Besitzt man nun einen solchen DC, stellt man mit der API SelectObject das Originalbild dort hinein. An diese API wird das Handle des DCs und das Handle des Quellbildes (mobjPicture.Handle) übergeben. Zuvor lässt man sich noch mit Hilfe der API GetObjectAPI die Struktur BITMAP ausfüllen, die anschließend verschiedene Informationen, wie beispielsweise die Abmessungen und Farbtiefe des Bildes enthält.

Winkelfunktionen arbeiten in Excel und VB(A) im Bogenmaß (360 Grad sind 2*Pi), deshalb wird der gewünschte Rotationswinkel, der in Grad an die Klasse übergeben wurde, in das Bogenmaß umgewandelt. Um eine Rotation im Uhrzeigersinn zu erreichen, multipliziert man den errechneten Wert noch mit -1.

Danach erzeugt man mit der API CreateCompatibleBitmap eine leere, aber mit dem Quellbild kompatible Bitmap in den gewünschten Abmessungen des gedrehten Bildes. Die Zielabmessungen werden mit ein paar Winkelfunktionen berechnet, das Ziel muss aber anschließend so groß sein, dass das gedrehte Originalbild komplett hineinpasst. Dieses vorerst leere Bild wird in einen neu erzeugten DC gestellt. Mit der API BitBlt werden nun alle Pixel des Zielbildes auf Weiß gesetzt, macht man das nicht, erscheinen später alle Pixel, die außerhalb des gedrehten Quellbildes liegen, schwarz.

Nun wird das Quellbild aus dem Quell-DC in das Ziel-DC “geblittet“ und zwar so, dass es im Zielbild bereits gedreht erscheint. Das heißt, an die für solch eine Transformation zuständige Funktion PlgBlt muss man nicht nur die linkere obere Ecke und die Abmessungen des Quellbereichs, sondern auch drei Eckpunkte des Zielbereiches übergeben. Je nachdem, wie man die Zielpunkte setzt, kann man ein Rechteck oder ein Parallelogramm erhalten, gleichzeitig wird damit der Drehwinkel festgelegt und außerdem erhält man die Möglichkeit zu spiegeln.

Die drei Ecken des Zielbereiches müssen als ein Array übergeben werden, beziehungsweise man übergibt die Speicheradresse des ersten Elements des Arrays. Die API-Funktion erwartet an den folgenden Speicheradressen die entsprechenden Informationen. Das Array muss letztendlich im Speicher hintereinander sechs Longwerte enthalten, die ersten beiden Werte (X-, Y-Wert) beschreiben die linke obere Ecke, die nächsten zwei die rechte obere und die letzten zwei die linke untere Ecke. Diese Punkte im Zielbild werden mit ein paar Winkelfunktionen berechnet und im Array gespeichert.

Nun muss man nur noch aus dem Zielbitmap ein Objekt vom Typ StdPicture (IPictureDisp) machen. Der API-Funktion OleCreatePictureIndirect übergibt man dazu den ausgefüllten Datentyp PICTDESC. Dort werden das Bitmaphandle und der Typ der Grafik eingetragen. Außerdem wird noch die Schnittstellenkennung in Form des ausgefüllten Datentyps GUID benötigt, die als Variable mit dem Namen IID_IDispatch übergeben wird. Die Objektvariable objPic vom Typ IPictureDisp nimmt bei Erfolg das Bild auf und wird als Funktionsergebnis zurückgegeben.

Als Aufräumarbeit müssen anschließend die Objekte, die vor dem ersten Aufruf von SelectObjekt im jeweiligen DC gewesen sind, auch wieder dorthin zurückbefördert werden. Ist das mit Hilfe der API SelectObject geschehen, kann man mit DeleteDC die erzeugten DCs löschen.