ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1837
Wohnort: [JN58JR]
|
 Verfasst am: 21.02.2007, 11:09 Titel: [VB6] cDIB-Class & Rotation |
 |
|
Hallöle!
Ich habe ein Problem bei einer Rotationsfunktion in meiner cDIB Klasse. (Letzte Funktion)
| Code: |
Option Explicit
Option Base 0
Private Const BMP_MAGIC_COOKIE As Integer = 19778
Private Const BI_RGB As Long = 0&
Private Const HEAP_ZERO_MEMORY As Long = &H8
Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD
Red As Byte
Green As Byte
Blue As Byte
Reserved As Byte
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 Declare Function GetProcessHeap Lib "kernel32.dll" () As Long
Private Declare Function HeapAlloc Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef dest As Any, ByRef src As Any, ByVal dwLen As Long)
Private m_memBitsRot() As Byte
Private m_memBits() As Byte
Private m_memBitmapInfo() As Byte
Private m_bih As BITMAPINFOHEADER
Private m_bfh As BITMAPFILEHEADER
Public Function CheckErr() As Long
CheckErr = Err.Number
Err.Clear
End Function
Public Function CreateFromFile(ByVal V_FilePathName As String) As Boolean
On Error Resume Next
CreateFromFile = False
If ExistFile(V_FilePathName) = True Then
Dim FID As Long
Dim EID As Long
FID = FreeFile
Open V_FilePathName For Binary Access Read As FID
EID = CheckErr
Select Case EID
Case 0
Get FID, , m_bfh
If m_bfh.bfType = BMP_MAGIC_COOKIE Then
Get FID, Len(m_bfh) + 1, m_bih
ReDim m_memBits(0 To m_bih.biSizeImage - 1)
Get FID, m_bfh.bfOffBits + 1, m_memBits
ReDim m_memBitmapInfo(0 To m_bfh.bfOffBits - 14)
Get FID, Len(m_bfh) + 1, m_memBitmapInfo
CreateFromFile = True
Else: Debug.Print "File is not a supported bitmap format"
End If
Close FID
Case 70: Debug.Print "File is locked - cannot access"
Case Else: Debug.Print "Unknow Error"
End Select
Else: Debug.Print "File does not exist"
End If
End Function
Public Function CreateFromPackedDIBPointer(ByRef V_DIBPointer As Long) As Boolean
On Error Resume Next
CreateFromPackedDIBPointer = False
If V_DIBPointer <> 0 Then
Call CopyMemory(ByVal VarPtr(m_bih.biSize), ByVal V_DIBPointer, Len(m_bih))
If m_bih.biBitCount >= 16 Then
If m_bih.biSizeImage > 0 Then
ReDim m_memBits(0 To m_bih.biSizeImage - 1)
Call CopyMemory(m_memBits(0), ByVal V_DIBPointer + 40, m_bih.biSizeImage)
ReDim m_memBitmapInfo(0 To 39)
Call CopyMemory(m_memBitmapInfo(0), m_bih, Len(m_bih))
With m_bfh
.bfType = BMP_MAGIC_COOKIE
.bfSize = 55 + m_bih.biSizeImage
.bfReserved1 = 0&
.bfReserved2 = 0&
.bfOffBits = 54
End With
CreateFromPackedDIBPointer = True
End If
Else: Debug.Print "Error! DIB was less than 16 colors."
End If
End If
End Function
Public Function WriteToFile(ByVal V_FilePathName As String, Optional RotatetBits As Boolean = False) As Boolean
On Error Resume Next
WriteToFile = False
If ExistFile(V_FilePathName) = False Then
Dim FID As Integer
FID = FreeFile()
Open V_FilePathName For Binary As FID
Put FID, 1, m_bfh
Put FID, Len(m_bfh) + 1, m_memBitmapInfo
If RotatetBits = False Then
Put FID, , m_memBits
Else: Put FID, , m_memBitsRot
End If
Close FID
WriteToFile = True
End If
End Function
Private Function ExistFile(ByVal V_FilePathName As String) As Boolean
On Error Resume Next
ExistFile = False
If Dir(V_FilePathName) <> "" Then
If (GetAttr(V_FilePathName) And vbDirectory) <> vbDirectory Then ExistFile = True
End If
End Function
Public Property Get BitCount() As Long
BitCount = m_bih.biBitCount
End Property
Public Property Get Height() As Long
Height = m_bih.biHeight
End Property
Public Property Get Width() As Long
Width = m_bih.biWidth
End Property
Public Property Get Compression() As Long
Compression = m_bih.biCompression
End Property
Public Property Get SizeInfoHeader() As Long
SizeInfoHeader = m_bih.biSize
End Property
Public Property Get SizeImage() As Long
SizeImage = m_bih.biSizeImage
End Property
Public Property Get Planes() As Long
Planes = m_bih.biPlanes
End Property
Public Property Get ClrImportant() As Long
ClrImportant = m_bih.biClrImportant
End Property
Public Property Get ClrUsed() As Long
ClrUsed = m_bih.biClrUsed
End Property
Public Property Get XPPM() As Long
XPPM = m_bih.biXPelsPerMeter
End Property
Public Property Get YPPM() As Long
YPPM = m_bih.biYPelsPerMeter
End Property
Public Property Get FileType() As Long
FileType = m_bfh.bfType
End Property
Public Property Get SizeFileHeader() As Long
SizeFileHeader = m_bfh.bfSize
End Property
Public Property Get BitOffset() As Long
BitOffset = m_bfh.bfOffBits
End Property
Public Property Get PointerToBits() As Long
PointerToBits = VarPtr(m_memBits(0))
End Property
Public Property Get PointerToBitsRotate() As Long
PointerToBitsRotate = VarPtr(m_memBitsRot(0))
End Property
Public Property Get PointerToBitmapInfo() As Long
PointerToBitmapInfo = VarPtr(m_memBitmapInfo(0))
End Property
Public Property Get SizeBitmapInfo() As Long
SizeBitmapInfo = UBound(m_memBitmapInfo()) + 1
End Property
Public Function Rotate_Pic(V_Angel As Double)
On Error Resume Next
'===
'=== Zentral Drehen
'===
DoEvents
Dim RotX As Long
Dim RotY As Long
Dim ASin As Double
Dim ACos As Double
Dim X As Long
Dim Y As Long
Dim XS As Long
Dim YS As Long
Dim XX As Long
Dim YX As Long
Dim srcR As Byte
Dim srcG As Byte
Dim srcB As Byte
Dim Tot As Double
ReDim m_memBitsRot(UBound(m_memBits)) As Byte
RotX = m_bih.biWidth / 2
RotY = m_bih.biHeight / 2
ASin = Sin(V_Angel)
ACos = Cos(V_Angel)
XX = 0
YX = 0
For Y = 0 To m_bih.biHeight - 1
For X = 0 To m_bih.biWidth
' XS = RotX + (XX - RotX) * ASin - (YX - RotY) * ACos
' YS = RotY + (YX - RotY) * ASin + (XX - RotX) * ACos
XS = RotX + XX * ASin - YX * ACos
YS = RotY + YX * ASin + XX * ACos
If (XS >= 0 And XS < m_bih.biWidth) Then
If (YS >= 0 And YS < m_bih.biHeight) Then
srcR = m_memBits((((Y * m_bih.biWidth) + X) * 3 + 0))
srcG = m_memBits((((Y * m_bih.biWidth) + X * 3) + 1))
srcB = m_memBits((((Y * m_bih.biWidth) + X * 3) + 2))
m_memBitsRot((((YS * m_bih.biWidth) + XS) * 3 + 0)) = srcR
m_memBitsRot((((YS * m_bih.biWidth) + XS) * 3 + 0)) = srcG
m_memBitsRot((((YS * m_bih.biWidth) + XS) * 3 + 0)) = srcB
End If
End If
XX = XX + 1
If Tot < Timer Then: DoEvents: Tot = Timer
Next
XX = 0
YX = YX + 1
If Tot < Timer Then: DoEvents: Tot = Timer
Next
End Function
|
Ich Lade eine BMP in die Klasse, mit CreateFromFile, und möchte dann das Bild im Speicher m_memBits() Rotiert in m_memBitsRot() kopieren.
Leider erhalte ich nach dem Speichern der BMP und dem Laden in die PictureBox nur nen grünen Strich, der sich n bissi chaotisch durch die gegend dreht.
Hab auch schon so ziemlich alle kombinationen ausprobiert, die man da irgend wie mit XX / XY / RotX / ROTY / Sin / Cos / ...) zusammen setzen kann, aber irgend wie kommt da entweder garnix bei raus, nur n weißer strich ganz unten links, oder n grüner, der sich dreht. Hatte auch schon 3 symetrische nebeneinander, die syncron Bockmisst machen.
Sieht da event Irgend jemand den Feher? .. (Wäre ziemlich wichtig, muss da noch n haufen code drum rum haun  )
PS: Sind 24Bit-Bitmaps
MfG
TPM
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
