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...
Projekt - Download
 
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.

FienauBerlin   Web-ComputerEcke.de


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
 

Ihre Angaben

*User-Name:

*eMail:

Homepage URL:

 

   Nach Oben

Computer.Net-Berlin