|
|
Bild bearbeiten mit CreateDIBSection
|
 |
Hier nun ein stark reduziertes Script. Form1 mit PB, Command1 - 4, Class cDIB
Ich brauche ein zentrales Script für verschiedene Anwendungen:Filter(Echtzeit),
Zeichenfunktionen, und vorallem für verschiedene Masken-Funktionen.
Meine Filter- und meine Masken-Funktion funktionieren noch nicht.
Warum es nur mit dem Minus [-] funktioniert habe ich noch nicht
nachvollziehen können.
**************************************************************************
In der Zwischenzeit scheint mein Filter doch zu funktionieren
aber zu langsam. Doch die bearbeitung mit der S/W-Palette macht mir
schwierigkeiten. Ich habe auch noch keine Idee, wie das funktionieren könnte.
Vielleich gibt es dafür ein anderes Script.
Auch die beste Lösung für das Erstellen der Masken habe ich noch nicht.
Zur Zeit verwende ich folgendes Script: MonoMask
**************************************************************************
Das Problem mit dem Minuszeichen konnte gelöst werden. In DoBrush mußte.
der Y-Wert verdreht werden. y = Val(oDIB.Height - y).
Ein vorläufiges Script für S/W-Bild habe ich eingebaut. Vielleicht hat
Jemand eine bessere Routine.
**************************************************************************
In der Zwischenzeit habe ich ein besseres S/W-Filter. Vielen Dank an:
Frank Schüler. So langsam könnte man jetzt mit den Masken beginnen.
Eine Voraussetzung ist, Wenn die Maske im Speicher erstellt wurde, muß
Diese trotzdem Zeichenoperationen wie Line, Circle, Fill oder Gradient
verarbeiten können. Eine Zoom Funktion wäre auch nicht schlecht, damit
man die Masken verkleinert zur Kontrolle auf der Form anzeigen kann.
Vielleicht hat ja Jemand eine zündende Idee?
'**************************************************************************
Jetzt sind die Masken soweit vorbereitet. Die Masken für das Bild
werden auch schon geladen und mit Fit-Mode angezeigt. Die Masken für
den Ausschnitt und für das Bild ohne Ausschnitt müssen noch erstellt
werden. Die Zoom-Funktion funktioniert auch schon. Damit die Übersicht nicht
verloren geht legen wir die Filter in ein Class "cFilter.cls" und die Zeichen-
Funktionen in ein Modul "mDraw.bas". Jetzt brauchen wir die Routienen
für die Zeichenoperationen: Line, Circle, Fill Gradient usw...
|
Tips und Lösungsvorschläge bitte unter:
In den Foren von ActiveVB oder vb@rchiv mit vielen Anregungen.
Oder direkt an den User senden. E-Mail.
|
|
 Quell-Code Form1
|
'Erstellen Sie folgende Steuerelemente:
'CommandButton Command1, CommandButton Command1, CommandButton Command2,
'CommandButton Command3, CommandButton Command4, CommandButton Command5,
'CommandButton Command6, CommandButton btnFitMode, CommonDialog CommonDialog1,
'Form Form1, HScrollBar HScroll1, Label Label1,
'Label Label2, Label Label3, Label Label4,
'Label Label5, Label Label6, PictureBox PicImage,
'PictureBox PicMask, PictureBox PicSelImage, PictureBox PicSelMask,
'PictureBox Picture1,
Option Explicit
'-- ************* Masken ****************
Private Declare Function CreateBitmap Lib "gdi32" ( _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal nPlanes As Long, ByVal nBitCount As Long, _
lpBits As Any) 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 SetBkColor Lib "gdi32" ( _
ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function BitBlt Lib "gdi32" ( _
ByVal hDestDC As Long, ByVal x1 As Long, ByVal y1 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 Function DeleteDC Lib "gdi32" ( _
ByVal hDC As Long) As Long
'-- ************************** Draw *************************
Private Declare Function Ellipse Lib "gdi32" (ByVal hDC As Long, _
ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, _
ByVal y2 As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private CurrentTool As Long
Private m_lColor As Long
Private m_uPtStart As POINTAPI
'***************************** ZOOM ***********************
Private m_Pt As POINTAPI
Private Const RGN_DIFF As Long = 4
'-- Backcolor --
Private Declare Function TranslateColor Lib "olepro32" _
Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, _
ByVal Palette As Long, col As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" ( _
ByVal crColor As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" ( _
ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, _
ByVal y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" ( _
ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, _
ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hDC As Long, _
ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long
Private m_Zoom As Long
Private m_FitMode As Boolean
Private m_Width As Long
Private m_Height As Long
Private m_Left As Long
Private m_Top As Long
Private m_hPos As Long
Private m_hMax As Long
Private m_vPos As Long
Private m_vMax As Long
Private m_lsthPos As Single
Private m_lstvPos As Single
Private m_lsthMax As Single
Private m_lstvMax As Single
Private m_BackColor As OLE_COLOR
Private xSrc As Long
Private ySrc As Long
'*-- ************ Markieren **************
Private PicAutoSel As Boolean
Private PicDrawnSel As Boolean
Private PicMovingSel As Boolean
Private ScaleX1!, ScaleY1!, ScaleX2!, ScaleY2!
Private PPcX!, PcY!, PNx!, PNy!
Private PLW!, PLH!
Private X1Di!, Y1Di!, X2Di!, Y2Di!, sysPic%
Dim pScaleX1!, pScaleY1!, pScaleX2!, pScaleY2!
'-- ***********************************
Private DIB As cDIBPic
Private DIBBuffer As cDIBPic
Private Filter As cFilter
Private DIBImage As cDIBPic 'Masken
Private DIBMask As cDIBPic
Private DIBDummy As cDIBPic
Private DIBSelImage As cDIBPic
Private DIBSelMask As cDIBPic
Private DIBSection As cDIBPic
Private Sub Form_Load()
Picture1.ScaleMode = 3
m_Zoom = 1
Set DIB = New cDIBPic
Set DIBBuffer = New cDIBPic
Set Filter = New cFilter
Set DIBImage = New cDIBPic
Set DIBMask = New cDIBPic
Set DIBDummy = New cDIBPic
Set DIBSelImage = New cDIBPic
Set DIBSelMask = New cDIBPic
Set DIBSection = New cDIBPic
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call DIB.Destroy
Call DIBBuffer.Destroy
Call DIBImage.Destroy
Call DIBMask.Destroy
Call DIBDummy.Destroy
Call DIBSelImage.Destroy
Call DIBSelMask.Destroy
Call DIBSection.Destroy
Set DIB = Nothing
Set DIBBuffer = Nothing
Set Filter = Nothing
Set DIBImage = Nothing
Set DIBMask = Nothing
Set DIBDummy = Nothing
Set DIBSelImage = Nothing
Set DIBSelMask = Nothing
Set DIBSection = Nothing
End Sub
'-- Anwendungen *****************************************
'Bild laden und anzeigen (Beispiel)
Private Sub Command1_Click(index As Integer)
Dim hw!, pth$
Select Case index
Case 0
Call CommonDialog1.ShowOpen
DoEvents
pth = CommonDialog1.FileName
Case 1
pth = App.Path & "\Test.gif"
End Select
'-- Bild Laden
Picture1.Picture = LoadPicture("")
Call DIB.CreateFromStdPicture(VB.LoadPicture(pth), vbWhite)
'-- Masken erstellen.
Call CreateMask
'-- Picture1 Größe anpassen
If m_FitMode Then
If DIB.Width > DIB.Height Then
Picture1.Width = 400
hw = DIB.Width / DIB.Height
Picture1.Height = 400 / hw
Else
Picture1.Height = 400
hw = DIB.Height / DIB.Width
Picture1.Width = 400 / hw
End If
Else
Picture1.Width = DIB.Width
Picture1.Height = DIB.Height
End If
'-- Anzeigen
Call pvResize
Call pvRefresh
End Sub
Private Sub Command6_Click() 'DIB Laden
Picture1.Picture = LoadPicture("")
Call DIB.Create(500, 500, vbWhite)
Picture1.Width = DIB.Width
Picture1.Height = DIB.Height
'-- Masken erstellen.
Call CreateMask
'-- Anzeigen
Call pvResize
Call pvRefresh
End Sub
Private Sub Command5_Click()
'Speicher freigeben
Call DIB.Destroy
Call DIBBuffer.Destroy
Call DIBImage.Destroy
Call DIBMask.Destroy
Call DIBDummy.Destroy
Call DIBSelImage.Destroy
Call DIBSelMask.Destroy
Call DIBSection.Destroy
End Sub
Private Sub Command2_Click() 'Bild laden, Zeichnen und anzeigen
'-- Zeichenfunktion
If DIB.hDC <> 0 Then
Call CreateLUT(DIB.Width, DIB.Height)
'Roter Punkt (Für Brush-Funktion)
Call DoBrush(DIB, 100, 100, 50, 50, vbBlack)
Call DoBrush(DIB, 200, 100, 50, 50, vbRed)
Call DoBrush(DIB, 100, 200, 50, 50, vbBlue)
Call DoBrush(DIB, 200, 200, 50, 50, vbGreen)
DestroyLUT
End If
'-- Masken erstellen.
Call CreateMask
'-- Anzeigen
Call pvResize
Call pvRefresh
End Sub
Private Sub Command3_Click() 'Bild laden, Filter und anzeigen
'-- Bild im Speicher?
If DIB.hDC <> 0 Then
'-- Filter-Funktion
Call Filter.Contour(DIB)
End If
'-- Masken erstellen.
Call CreateMask
'-- Anzeigen
Call pvResize
Call pvRefresh
End Sub
Private Sub Command4_Click() 'In S/W umformen
'-- S/W-Funktion
If DIB.hDC <> 0 Then
'-- Schwellwert Faktor Optional=127
Call Filter.BlackWhite(DIB, 120)
End If
'-- Masken erstellen.
Call CreateMask
'-- Anzeigen
Call pvResize
Call pvRefresh
End Sub
'***************************** -- ZOOM ***************************
Private Sub HScroll1_Scroll()
HScroll1_Change
End Sub
Private Sub HScroll1_Change()
m_Zoom = HScroll1.Value '1 - 15
Call pvResize
Call pvRefresh
End Sub
Private Sub btnFitMode_Click() 'Fit-Mode
Dim hw!
If DIB.Width > 400 Or DIB.Height > 400 Then
m_FitMode = Not (m_FitMode)
If m_FitMode Then
If DIB.Width > DIB.Height Then
Picture1.Width = 400
hw = DIB.Width / DIB.Height
Picture1.Height = 400 / hw
Else
Picture1.Height = 400
hw = DIB.Height / DIB.Width
Picture1.Width = 400 / hw
End If
Else
Picture1.Width = DIB.Width
Picture1.Height = DIB.Height
End If
Picture1.Picture = LoadPicture("")
Call pvResize
Call pvRefresh
Else
m_FitMode = False
End If
End Sub
Private Sub pvRefresh()
Dim xOff As Long, yOff As Long
Dim wDst As Long, hDst As Long
Dim wSrc As Long, hSrc As Long
If (DIB.hDC <> 0) Then
'-- Left und Width von Picture1.festlegen
If (m_hMax And Not m_FitMode) Then
xOff = -m_hPos Mod m_Zoom
wDst = (m_Width \ m_Zoom) * m_Zoom + 2 * m_Zoom
xSrc = m_hPos \ m_Zoom
wSrc = m_Width \ m_Zoom + 2
Else
xOff = m_Left
wDst = m_Width
xSrc = 0
wSrc = DIB.Width
End If
'-- Top und Height von Picture1.festlegen
If (m_vMax And Not m_FitMode) Then
yOff = -m_vPos Mod m_Zoom
hDst = (m_Height \ m_Zoom) * m_Zoom + 2 * m_Zoom
ySrc = m_vPos \ m_Zoom
hSrc = m_Height \ m_Zoom + 2
Else
yOff = m_Top
hDst = m_Height
ySrc = 0
hSrc = DIB.Height
End If
'-- Background Löschen
Call pvEraseBackground
'-- Bereich für Picture1 festlegen
Call DIB.Stretch(Picture1.hDC, xOff, yOff, wDst, _
hDst, xSrc, ySrc, wSrc, hSrc)
Else
'-- Background Löschen
Call pvEraseBackground
End If
End Sub
Private Sub pvResize()
With DIB
If (.hDIB <> 0) Then
If (m_FitMode = False) Then
'-- Neue Breite
If (.Width * m_Zoom > Picture1.ScaleWidth) Then
m_hMax = .Width * m_Zoom - Picture1.ScaleWidth
m_Width = Picture1.ScaleWidth
Else
m_hMax = 0
m_Width = .Width * m_Zoom
End If
'-- Neue Höhe
If (.Height * m_Zoom > Picture1.ScaleHeight) Then
m_vMax = .Height * m_Zoom - Picture1.ScaleHeight
m_Height = Picture1.ScaleHeight
Else
m_vMax = 0
m_Height = .Height * m_Zoom
End If
'-- In die Mitte setzen
m_Left = (Picture1.ScaleWidth - m_Width) \ 2
m_Top = (Picture1.ScaleHeight - m_Height) \ 2
Else
Call .GetBestFitInfo(.Width, .Height, Picture1.ScaleWidth, _
Picture1.ScaleHeight, m_Left, m_Top, m_Width, m_Height)
End If
'-- Alte Position
If (m_lsthMax) Then
m_hPos = (m_lsthPos * m_hMax) \ m_lsthMax
Else
m_hPos = m_hMax \ 2
End If
If (m_lstvMax) Then
m_vPos = (m_lstvPos * m_vMax) \ m_lstvMax
Else
m_vPos = m_vMax \ 2
End If
m_lsthPos = m_hPos: m_lstvPos = m_vPos
m_lsthMax = m_hMax: m_lstvMax = m_vMax
Else
'-- Picture1 nicht darstellen
m_Width = 0: m_Height = 0
End If
End With
End Sub
'***************** -- Background Picture1 ************
Private Sub pvEraseBackground()
Dim hRgn_1 As Long
Dim hRgn_2 As Long
Dim lColor As Long
Dim hBrush As Long
'-- Background-Farbe festlegen
Call TranslateColor(DIB.BackColor, 0, lColor)
hBrush = CreateSolidBrush(lColor)
'-- Region für Picture1.festlegen
hRgn_1 = CreateRectRgn(0, 0, Picture1.ScaleWidth, _
Picture1.ScaleHeight)
hRgn_2 = CreateRectRgn(m_Left, m_Top, m_Left + m_Width, _
m_Top + m_Height)
Call CombineRgn(hRgn_1, hRgn_1, hRgn_2, RGN_DIFF)
'-- füllen
Call FillRgn(Picture1.hDC, hRgn_1, hBrush)
'-- Objekte freigeben
Call DeleteObject(hBrush)
Call DeleteObject(hRgn_1)
Call DeleteObject(hRgn_2)
End Sub
'***************** -- Masken ************
Private Sub CreateMask() 'MonoMask
'Der Source MonoMask stammt von http://www.activevb.de
Dim hDCMask1&, hMask1&, hDCMask2&, hMask2&
Dim hPrevMask1&, hPrevMask2&, W&, H&
W = DIB.Width
H = DIB.Height
'Generieren zweier Bitmaps
hDCMask1 = CreateCompatibleDC(DIBMask.hDC)
hDCMask2 = CreateCompatibleDC(DIBMask.hDC)
hMask1 = CreateBitmap(W, H, 1, 1, ByVal 0&)
hMask2 = CreateBitmap(W, H, 1, 1, ByVal 0&)
hPrevMask1 = SelectObject(hDCMask1, hMask1)
hPrevMask2 = SelectObject(hDCMask2, hMask2)
'-- ******* Masken freigegeben und erstellen ****
Call DIBImage.Create(DIB.Width, DIB.Height)
Call DIBMask.Create(DIB.Width, DIB.Height, vbWhite)
'-- **********************************************
'Maskenfarbe des Originalbildes festlegen
Call SetBkColor(DIB.hDC, DIB.BackColor)
'Monochrome Maske des Originalbildes erstellen
Call BitBlt(hDCMask1, 0, 0, W, H, DIB.hDC, _
0, 0, vbSrcCopy)
'Erstellte monochrome Maske nach PicMask kopieren
Call BitBlt(DIBMask.hDC, 0, 0, W, H, _
hDCMask1, 0, 0, vbSrcCopy)
'Inverse Maske der erstellen Maske generieren
Call BitBlt(hDCMask2, 0, 0, W, H, _
hDCMask1, 0, 0, vbNotSrcCopy)
'Originalbildes in die Schlußmaske kopieren PicImage
Call BitBlt(DIBImage.hDC, 0, 0, W, H, _
DIB.hDC, 0, 0, vbSrcCopy)
'AND der Schlußmaske mit der invertierten Maske
Call BitBlt(DIBImage.hDC, 0, 0, W, H, _
hDCMask2, 0, 0, vbSrcAnd)
'-- *** Masken zur Kontrolle mit FitMode anzeigen. ******
Call DIBImage.GetBestFitInfo(DIBImage.Width, DIBImage.Height, _
PicImage.ScaleWidth, PicImage.ScaleHeight, m_Left, m_Top, _
m_Width, m_Height)
PicImage.Cls
Call DIBImage.Stretch(PicImage.hDC, m_Left, m_Top, m_Width, _
m_Height, 0, 0, DIBImage.Width, DIBImage.Height)
Call DIBMask.GetBestFitInfo(DIBMask.Width, DIBMask.Height, _
PicMask.ScaleWidth, PicMask.ScaleHeight, m_Left, m_Top, _
m_Width, m_Height)
PicMask.Cls
Call DIBMask.Stretch(PicMask.hDC, m_Left, m_Top, m_Width, _
m_Height, 0, 0, DIBMask.Width, DIBMask.Height)
'-- *************************************************
'Erstellte Objekte & DCs wieder freigeben
Call DeleteObject(SelectObject(hDCMask1, hPrevMask1))
Call DeleteObject(SelectObject(hDCMask2, hPrevMask2))
Call DeleteDC(hDCMask1)
Call DeleteDC(hDCMask2)
End Sub
|
 Quell-Code cDIBPic
|
Option Explicit
Private Const OBJ_BITMAP As Long = 7
Private Const DIB_RGB_COLORS As Long = 0
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 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 COLORONCOLOR As Long = 3
Private Const HALFTONE As Long = 4
Public Enum eStretchBltModeCts
[sbmColorOnColor] = COLORONCOLOR
[sbmHalftone] = HALFTONE
End Enum
'Create -- Set backColor *******************************
Private Type RECT
x1 As Long
y1 As Long
x2 As Long
y2 As Long
End Type
Private Declare Function SetRect Lib "user32" ( _
lpRect As RECT, ByVal x1 As Long, _
ByVal y1 As Long, ByVal x2 As Long, _
ByVal y2 As Long) As Long
Private Declare Function FillRect Lib "user32" ( _
ByVal hDC As Long, lpRect As RECT, _
ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" ( _
ByVal crColor As Long) As Long
Private m_BackColor As OLE_COLOR
'**********************************************************
Private Declare Function CreateDIBSection Lib "gdi32" ( _
ByVal hDC As Long, lpBitsInfo As BITMAPINFOHEADER, _
ByVal wUsage As Long, lpBits As Long, _
ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function GetObjectType Lib "gdi32" ( _
ByVal hgdiobj As Long) 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 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 BitBlt Lib "gdi32" (ByVal hDC 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 Function DeleteDC Lib "gdi32" ( _
ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, _
ByVal dwRop As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" ( _
ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" ( _
lpDst As Any, ByVal Length As Long)
Private m_uBIH As BITMAPINFOHEADER
Private m_hDC As Long
Private m_hDIB As Long
Private m_hOldDIB As Long
Private m_lpBits As Long
Public Function CreateFromStdPicture(Image As StdPicture, _
Optional ByVal BackColor As Long = vbBlack) As Long
Dim uBI As BITMAP
Dim lhDC As Long
Dim lhOldBmp As Long
If (Not Image Is Nothing) Then
If (GetObjectType(Image.handle) = OBJ_BITMAP) Then
Call GetObject(Image.handle, Len(uBI), uBI)
If (Create(uBI.bmWidth, uBI.bmHeight, BackColor)) Then
lhDC = CreateCompatibleDC(0)
If (lhDC <> 0) Then
lhOldBmp = SelectObject(lhDC, Image.handle)
'-- Load uBits
Call BitBlt(m_hDC, 0, 0, uBI.bmWidth, _
uBI.bmHeight, lhDC, 0, 0, vbSrcCopy)
'-- Temp. DC freigeben
Call SelectObject(lhDC, lhOldBmp)
Call DeleteDC(lhDC)
'-- ausgeben
CreateFromStdPicture = m_hDIB
End If
End If
End If
End If
End Function
Public Function Create(ByVal NewWidth As Long, _
ByVal NewHeight As Long, _
Optional ByVal BackColor As Long = vbBlack _
) As Long
Dim uRect As RECT
Dim hBrush As Long
'-- BackColor Farbe einlesen
m_BackColor = BackColor
'-- Geladene DIB freigeben
Call Me.Destroy
'-- Header einlesen
With m_uBIH
.biSize = Len(m_uBIH)
.biPlanes = 1
.biBitCount = 32
.biWidth = NewWidth
.biHeight = NewHeight
.biSizeImage = 4 * NewWidth * NewHeight
End With
'-- Create DIB section
m_hDC = CreateCompatibleDC(0)
If (m_hDC <> 0) Then
'-- Create DIB
m_hDIB = CreateDIBSection(m_hDC, m_uBIH, _
DIB_RGB_COLORS, m_lpBits, 0, 0)
If (m_hDIB <> 0) Then
'-- Select DC
m_hOldDIB = SelectObject(m_hDC, m_hDIB)
'-- Set BackColor
Call SetRect(uRect, 0, 0, NewWidth, NewHeight)
hBrush = CreateSolidBrush(BackColor)
Call FillRect(m_hDC, uRect, hBrush)
Call DeleteObject(hBrush)
Else
Call Me.Destroy
End If
End If
'-- Ausgabe
Create = m_hDIB
End Function
Public Function Paint(ByVal hDC As Long, _
Optional ByVal x As Long = 0, _
Optional ByVal y As Long = 0, _
Optional ByVal ROP As RasterOpConstants = vbSrcCopy _
) As Long
With m_uBIH
Paint = StretchBlt(hDC, x, y, .biWidth, .biHeight, _
m_hDC, 0, 0, .biWidth, .biHeight, vbSrcCopy)
End With
End Function
Public Sub LoadBlt(ByVal hSrcDC As Long, _
Optional ByVal x As Long = 0, _
Optional ByVal y As Long = 0)
If (Me.hDIB <> 0) Then
Call BitBlt(m_hDC, 0, 0, m_uBIH.biWidth, _
m_uBIH.biHeight, hSrcDC, x, y, vbSrcCopy)
End If
End Sub
Public Function Stretch(ByVal hDC As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
Optional ByVal xSrc As Long, _
Optional ByVal ySrc As Long, _
Optional ByVal nSrcWidth As Long, _
Optional ByVal nSrcHeight As Long, _
Optional ByVal ROP As RasterOpConstants = vbSrcCopy, _
Optional ByVal StretchBltMode _
As eStretchBltModeCts = [sbmColorOnColor]) As Long
Dim lOldMode As Long
If (m_hDIB <> 0) Then
If (nSrcWidth = 0) Then nSrcWidth = m_uBIH.biWidth
If (nSrcHeight = 0) Then nSrcHeight = m_uBIH.biHeight
lOldMode = SetStretchBltMode(hDC, StretchBltMode)
Stretch = StretchBlt(hDC, x, y, nWidth, nHeight, m_hDC, xSrc, _
ySrc, nSrcWidth, nSrcHeight, ROP)
Call SetStretchBltMode(hDC, lOldMode)
End If
End Function
Public Sub Destroy()
'-- DIB freigeben
If (m_hDC <> 0) Then
If (m_hDIB <> 0) Then
Call SelectObject(m_hDC, m_hOldDIB)
Call DeleteObject(m_hDIB)
End If
Call DeleteDC(m_hDC)
End If
'-- uBIH Structure zurücksetzen
Call ZeroMemory(m_uBIH, Len(m_uBIH))
'-- DIB Variablen zurücksetzen
m_hDC = 0
m_hDIB = 0
m_hOldDIB = 0
m_lpBits = 0
End Sub
'-- Properties
Public Property Get hDC() As Long
hDC = m_hDC
End Property
Public Property Get hDIB() As Long
hDIB = m_hDIB
End Property
Public Property Get Width() As Long
Width = m_uBIH.biWidth
End Property
Public Property Get Height() As Long
Height = m_uBIH.biHeight
End Property
Public Property Get lpBits() As Long
lpBits = m_lpBits
End Property
Public Property Get BackColor() As OLE_COLOR
BackColor = m_BackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
m_BackColor = New_BackColor
End Property
Public Sub GetBestFitInfo(ByVal SrcW As Long, ByVal SrcH As Long, _
ByVal DstW As Long, ByVal DstH As Long, _
bfx As Long, bfy As Long, _
bfW As Long, bfH As Long, _
Optional ByVal StretchFit As Boolean = False)
Dim cW As Single
Dim cH As Single
If ((SrcW > DstW Or SrcH > DstH) Or StretchFit) Then
cW = DstW / SrcW
cH = DstH / SrcH
If (cW < cH) Then
bfW = DstW
bfH = SrcH * cW
Else
bfH = DstH
bfW = SrcW * cH
End If
Else
bfW = SrcW
bfH = SrcH
End If
bfx = (DstW - bfW) \ 2
bfy = (DstH - bfH) \ 2
End Sub
|
Quell-Code cFilter
|
Option Explicit
Private Type RGBQUAD
B As Byte
G As Byte
R As Byte
A As Byte
End Type
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm50" Alias _
"VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (lpDst As Any, lpSrc As Any, _
ByVal ByteLength As Long)
'-- Private Variables
Private t As Long
Private x As Long, xIn As Long
Private y As Long, yIn As Long
Private W As Long
Private H As Long
'-- Public Events
Public Event Progress(ByVal p As Long)
Public Event ProgressEnd()
Public Sub Contour(DIB As cDIBPic)
Dim sDIB As New cDIBPic
Dim sBits() As RGBQUAD
Dim dBits() As RGBQUAD
Dim stSA As SAFEARRAY2D
Dim dtSA As SAFEARRAY2D
Dim v As Long, vMax As Long
If (DIB.hDIB <> 0) Then
Call sDIB.Create(DIB.Width, DIB.Height)
Call sDIB.LoadBlt(DIB.hDC)
Call pvBuildSA(stSA, sDIB)
Call CopyMemory(ByVal VarPtrArray(sBits()), VarPtr(stSA), 4)
Call pvBuildSA(dtSA, DIB)
Call CopyMemory(ByVal VarPtrArray(dBits()), VarPtr(dtSA), 4)
W = DIB.Width - 2
H = DIB.Height - 2
For y = 1 To H
For x = 1 To W
vMax = 0
v = sBits(x - 1, y - 1).B
If (v > vMax) Then vMax = v
v = sBits(x, y - 1).B
If (v > vMax) Then vMax = v
v = sBits(x + 1, y - 1).B
If (v > vMax) Then vMax = v
v = sBits(x - 1, y).B
If (v > vMax) Then vMax = v
v = sBits(x, y).B
If (v > vMax) Then vMax = v
v = sBits(x + 1, y).B
If (v > vMax) Then vMax = v
v = sBits(x - 1, y + 1).B
If (v > vMax) Then vMax = v
v = sBits(x, y + 1).B
If (v > vMax) Then vMax = v
v = sBits(x + 1, y + 1).B
If (v > vMax) Then vMax = v
dBits(x, y).B = 255 Xor (vMax - sBits(x, y).B)
vMax = 0
v = sBits(x - 1, y - 1).G
If (v > vMax) Then vMax = v
v = sBits(x, y - 1).G
If (v > vMax) Then vMax = v
v = sBits(x + 1, y - 1).G
If (v > vMax) Then vMax = v
v = sBits(x - 1, y).G
If (v > vMax) Then vMax = v
v = sBits(x, y).G
If (v > vMax) Then vMax = v
v = sBits(x + 1, y).G
If (v > vMax) Then vMax = v
v = sBits(x - 1, y + 1).G
If (v > vMax) Then vMax = v
v = sBits(x, y + 1).G
If (v > vMax) Then vMax = v
v = sBits(x + 1, y + 1).G
If (v > vMax) Then vMax = v
dBits(x, y).G = 255 Xor (vMax - sBits(x, y).G)
vMax = 0
v = sBits(x - 1, y - 1).R
If (v > vMax) Then vMax = v
v = sBits(x, y - 1).R
If (v > vMax) Then vMax = v
v = sBits(x + 1, y - 1).R
If (v > vMax) Then vMax = v
v = sBits(x - 1, y).R
If (v > vMax) Then vMax = v
v = sBits(x, y).R
If (v > vMax) Then vMax = v
v = sBits(x + 1, y).R
If (v > vMax) Then vMax = v
v = sBits(x - 1, y + 1).R
If (v > vMax) Then vMax = v
v = sBits(x, y + 1).R
If (v > vMax) Then vMax = v
v = sBits(x + 1, y + 1).R
If (v > vMax) Then vMax = v
dBits(x, y).R = 255 Xor (vMax - sBits(x, y).R)
Next x
RaiseEvent Progress(y)
Next y
Call CopyMemory(ByVal VarPtrArray(sBits), 0&, 4)
Call CopyMemory(ByVal VarPtrArray(dBits), 0&, 4)
RaiseEvent ProgressEnd
End If
End Sub
Public Sub BlackWhite(DIB As cDIBPic, Optional ByVal _
lFilterValue As Long = 127)
Dim sDIB As New cDIBPic
Dim sBits() As RGBQUAD
Dim dBits() As RGBQUAD
Dim stSA As SAFEARRAY2D
Dim dtSA As SAFEARRAY2D
Dim bolBlackOrWhite As Boolean
' Filterbereich festlegen
lFilterValue = Abs(lFilterValue)
If lFilterValue > 255 Then lFilterValue = 255
If (DIB.hDIB <> 0) Then
Call sDIB.Create(DIB.Width, DIB.Height)
Call sDIB.LoadBlt(DIB.hDC)
Call pvBuildSA(stSA, sDIB)
Call CopyMemory(ByVal VarPtrArray(sBits()), VarPtr(stSA), 4)
Call pvBuildSA(dtSA, DIB)
Call CopyMemory(ByVal VarPtrArray(dBits()), VarPtr(dtSA), 4)
W = DIB.Width - 2
H = DIB.Height - 2
For y = 1 To H
For x = 1 To W
If sBits(x, y).R _
>= lFilterValue Then
bolBlackOrWhite = True
Else
If sBits(x, y).G _
>= lFilterValue Then
bolBlackOrWhite = True
Else
If sBits(x, y).B _
>= lFilterValue Then
bolBlackOrWhite = True
Else
bolBlackOrWhite = False
End If
End If
End If
' dBits(x, y).A = 255
If bolBlackOrWhite = True Then
dBits(x, y).R = 255
dBits(x, y).G = 255
dBits(x, y).B = 255
Else
dBits(x, y).R = 0
dBits(x, y).G = 0
dBits(x, y).B = 0
End If
Next x
RaiseEvent Progress(y)
Next y
Call CopyMemory(ByVal VarPtrArray(sBits), 0&, 4)
Call CopyMemory(ByVal VarPtrArray(dBits), 0&, 4)
RaiseEvent ProgressEnd
End If
End Sub
Private Sub pvBuildSA(tSA As SAFEARRAY2D, DIB As cDIBPic)
With tSA
.cbElements = IIf(App.LogMode = 1, 1, 4)
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = DIB.Height
.Bounds(1).lLbound = 0
.Bounds(1).cElements = DIB.Width
.pvData = DIB.lpBits
End With
End Sub
|
 Quell-Code mDraw
|
Option Explicit
Private Type RECT2
x1 As Long
y1 As Long
x2 As Long
y2 As Long
End Type
Private Type RGBQUAD
B As Byte
G As Byte
R As Byte
A As Byte
End Type
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(1) As SAFEARRAYBOUND
End Type
Private Declare Function SetRect Lib "user32" (lpRect As RECT2, _
ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, _
ByVal y2 As Long) As Long
Private Declare Function IntersectRect Lib "user32" ( _
lpDestRect As RECT2, lpSrc1Rect As RECT2, _
lpSrc2Rect As RECT2) As Long
Private Declare Function IsRectEmpty Lib "user32" ( _
lpRect As RECT2) As Long
Private Declare Function OffsetRect Lib "user32" ( _
lpRect As RECT2, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function VarPtrArray Lib "msvbvm60" Alias "VarPtr" ( _
Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
Private m_bPainted() As Byte
Public Sub DoBrush(oDIB As cDIBPic, ByVal x As Long, ByVal y As Long, _
ByVal d As Long, ByVal Pressure As Long, ByVal Color As Long)
Dim uBits() As RGBQUAD
Dim uSA As SAFEARRAY2D
Dim uBrushRect As RECT2
Dim uDIBRect As RECT2
Dim i As Long, iOut As Long
Dim j As Long, jOut As Long
Dim bR As Long, bG As Long, bB As Long
Dim rBr As Long
Dim rBrpow2 As Long
Dim cP1 As Single
Dim cP2 As Single
If (oDIB.hDIB <> 0) Then
rBr = d * 0.5
rBrpow2 = rBr * rBr + 1
y = Val(oDIB.Height - y) '[-] Deswegen das verflixte Minus!
bR = (Color And &HFF&)
bG = (Color And &HFF00&) \ 256
bB = (Color And &HFF0000) \ 65536
cP1 = Pressure / 100
cP2 = 1 - cP1
Call SetRect(uBrushRect, x - rBr, y - rBr, _
x + rBr + -(rBr = 0), y + rBr - (rBr = 0))
Call SetRect(uDIBRect, 0, 0, oDIB.Width - 1, oDIB.Height - 1)
Call IntersectRect(uBrushRect, uBrushRect, uDIBRect)
Call OffsetRect(uBrushRect, -x, -y)
If (IsRectEmpty(uBrushRect) = 0) Then
Call pvBuildSA(uSA, oDIB)
Call CopyMemory(ByVal VarPtrArray(uBits()), VarPtr(uSA), 4)
For j = uBrushRect.y1 To uBrushRect.y2
jOut = j + y
For i = uBrushRect.x1 To uBrushRect.x2
If (i * i + j * j < rBrpow2) Then
iOut = i + x
If (m_bPainted(iOut, jOut) = 0) Then
m_bPainted(iOut, jOut) = 1
With uBits(iOut, jOut)
.R = cP1 * bR + cP2 * .R
.G = cP1 * bG + cP2 * .G
.B = cP1 * bB + cP2 * .B
End With
End If
End If
Next i
Next j
Call CopyMemory(ByVal VarPtrArray(uBits), 0&, 4)
End If
End If
End Sub
Public Sub CreateLUT(ByVal W As Long, ByVal H As Long)
On Error GoTo Err
ReDim m_bPainted(W - 1, H - 1) As Byte
Exit Sub
Err:
End Sub
Public Sub DestroyLUT()
On Error GoTo Err
Erase m_bPainted()
Exit Sub
Err:
End Sub
Private Sub pvBuildSA(uSA As SAFEARRAY2D, oDIB As cDIBPic)
With uSA
.cbElements = IIf(App.LogMode = 1, 1, 4)
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = oDIB.Height
.Bounds(1).lLbound = 0
.Bounds(1).cElements = oDIB.Width
.pvData = oDIB.lpBits
End With
End Sub
|
|
|