Results 1 to 16 of 16

Thread: VB6: how can i speed up my draw pixel function DIB's?

  1. #1

    Thread Starter
    PowerPoster joaquim's Avatar
    Join Date
    Apr 2007
    Posts
    3,904

    VB6: how can i speed up my draw pixel function DIB's?

    heres my actual function for draw between line points:
    Code:
    Friend Sub DrawImageRectanglePoints(DestinationHDC As Long, Points() As Position3D, WorldSize As Size3D, Optional ByVal Opacity As Long = 255)
        'Points(1) is the Upper-Right
        'Points(2) is the Low-Right
        'Points(3) is the Low-Left
        Dim x As Long
        Dim y As Long
        Dim PosX As Long
        Dim PosY As Long
        Dim DestinationBitmap As Long
        Dim lpBitsDestination As Long
        Dim DestuHdr          As BITMAPINFOHEADER
        Dim bm As BITMAP
        Dim bi As BITMAPINFO
        Dim desthDib As Long, destlpBits As Long
        Dim desthPrevBmp As Long
        If (hBitmap = 0 Or hMemDC = 0) Then Exit Sub
        'Get actual hBitmap from Destination HDC:
        DestinationBitmap = GetCurrentObject(DestinationHDC, OBJ_BITMAP)
        GetObject DestinationBitmap, Len(bm), bm
        
        'Get all pixels from that hBitmap:
        Dim ImageData() As Byte
        ReDim ImageData(0 To (bm.bmBitsPixel \ 8) - 1, 0 To bm.bmWidth - 1, 0 To bm.bmHeight - 1)
    
        GetBitmapBits DestinationBitmap, bm.bmWidthBytes * bm.bmHeight, ImageData(0, 0, 0)
        
        'Get left and right vertical line points:
        Dim PointsUpperDownLeft() As Position3D
        PointsUpperDownLeft = GetLinePoints(Points(0), Points(3))
        Dim PointsUpperDownRight() As Position3D
        PointsUpperDownRight = GetLinePoints(Points(1), Points(2))
        
        'Between the left and right vertical line points we get the horizontal line points:
        Dim DrawPixelPoints() As Position3D
        Dim OriginPoint As POINTAPI
        Dim Point As POINTAPI
        Dim color As COLORQUAD
        Dim OriginPosX As Long, OriginPosY As Long
        Dim OriginWidth As Long, OriginHeight As Long
        Point = ConvertPositon3DTo2D(Points(3), WorldSize)
        OriginPosX = Point.x
        Point = ConvertPositon3DTo2D(Points(0), WorldSize)
        OriginPosY = Point.y
        Point = ConvertPositon3DTo2D(Points(2), WorldSize)
        OriginWidth = Point.x
        OriginHeight = Point.y
        
        'Move from horizontal line dots and draw the pixel:
        For y = 0 To UBound(PointsUpperDownLeft) - 1
            'Get the horizontal line points:
            DrawPixelPoints = GetLinePoints(PointsUpperDownRight(y), PointsUpperDownLeft(y))
            'OriginPoint = ConvertPositon3DTo2D(DrawPixelPoints(0), WorldSize)
            For x = 0 To UBound(DrawPixelPoints) - 1
                
                PosX = x
                PosY = y
                
                'Test the image size for we tiled the image:
                If (PosX > (Width - 1)) Then
                    While (PosX > (Width - 1))
                        PosX = PosX - Width
                    Wend
                End If
                
                If (PosY > (Height - 1)) Then
                    While (PosY > (Height - 1))
                        PosY = PosY - Height
                    Wend
                End If
                
                'Get the pixel color(ARGB):
                
            On Error Resume Next
                
                'Convert the 3D point to 2D point:
                Point = ConvertPositon3DTo2D(DrawPixelPoints(x), WorldSize)
                
                'changing the RGB pixel:
                ImageData(0, Point.x, Point.y) = Pixels(PosX, PosY).B
                ImageData(1, Point.x, Point.y) = Pixels(PosX, PosY).G
                ImageData(2, Point.x, Point.y) = Pixels(PosX, PosY).R
                
            Next x
            
        Next y
        
        'Show the new image:
        SetBitmapBits DestinationBitmap, bm.bmWidthBytes * bm.bmHeight, ImageData(0, 0, 0)
        If destHDC <> 0 Then
            Call SelectObject(destHDC, prevbit)
            Call DeleteDC(destHDC)
        End If
    End Sub
    i need more speed, but i don't know how
    heres the functions for get line points and convert the 3D point to 2D point:
    Code:
    Public Function ConvertPositon3DTo2D(Position As Position3D, World3DSize As Size3D) As POINTAPI
        
        Dim ConvertedPosition As POINTAPI
        Dim PosZZDepth As Long
        
        Dim Width As Double
        Dim Height As Double
        
        'sum Z position with cam world distance:
        PosZZDepth = Position.Z + World3DSize.distance
        If (PosZZDepth = 0) Then PosZZDepth = 1 'avoiding division by zero
        
        'getting center of the screen center:
        If (World3DSize.Width = 0) Then World3DSize.Width = 1 'avoiding division by zero
        Width = World3DSize.Width / 2
        If (World3DSize.Height = 0) Then World3DSize.Height = 1 'avoiding division by zero
        Height = World3DSize.Height / 2
        
        
        'avoid drawing on back of the camera:
        If (PosZZDepth <= World3DSize.distance) Then
             PosZZDepth = 1
             'World3DSize.distance = 1
        End If
        
        'convert 3D(X, Y, Z) to 2D(X,Y):
        'ConvertedX = (ActualX * CamDistance /(CamDistance + ZPosition)) + HalfCenterOfWidth
        'ConvertedY = (ActualY * CamDistance /(CamDistance + ZPosition)) + HalfCenterOfHeight
        ConvertedPosition.x = (Position.x * World3DSize.distance / PosZZDepth) + Width
        ConvertedPosition.y = (Position.y * World3DSize.distance / PosZZDepth) + Height
        
        ConvertPositon3DTo2D = ConvertedPosition
    End Function
    
    Public Function GetLinePoints(ByRef Origin As Position3D, ByRef Destiny As Position3D) As Position3D()
        Dim Steps As Double
        Dim Points() As Position3D
        
        'Get the points line count:
        Steps = Math.Sqr(Math.Abs(Destiny.x - Origin.x) ^ 2 + Math.Abs(Destiny.y - Origin.y) ^ 2 + Math.Abs(Destiny.Z - Origin.Z) ^ 2)
        Steps = Ceil(Steps)
        If (Steps = 0) Then Steps = 1 'void division by zero
        
        'Get the line increment step:
        Dim increment As Position3D
        increment.x = (Destiny.x - Origin.x) / Steps
        increment.y = (Destiny.y - Origin.y) / Steps
        increment.Z = (Destiny.Z - Origin.Z) / Steps
        
        Dim nextpoint As Position3D
        nextpoint = Origin
        Dim i As Integer
        Dim inter As Position3D
        Dim size As Size3D
        ReDim Points(Steps)
        
        'Get all step points:
        For i = 1 To Steps
            nextpoint.x = nextpoint.x + increment.x
            nextpoint.y = nextpoint.y + increment.y
            nextpoint.Z = nextpoint.Z + increment.Z
            inter.x = Math.Round(nextpoint.x)
            inter.y = Math.Round(nextpoint.y)
            inter.Z = Math.Round(nextpoint.Z)
            Points(i).x = inter.x
            Points(i).y = inter.y
            Points(i).Z = inter.Z
            'Debug.Print "X: " + CStr(inter.X) + vbTab + "Y: " + CStr(inter.Y) + vbTab + "Z: " + CStr(inter.Z)
        Next i
        GetLinePoints = Points
    End Function
    maybe it's these 2 functions that are kill my speed work, because i'm using divisions too.
    i need advices for speed up my code.. the image is drawed normaly, but slow
    VB6 2D Sprite control

    To live is difficult, but we do it.

  2. #2
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    Re: VB6: how can i speed up my draw pixel function DIB's?

    I wouldn't worry that much about divisions when VB6 is bounds checking array access everywhere else. For instance here

    ImageData(0, Point.x, Point.y) = Pixels(PosX, PosY).B

    there are 5 bounds checks -- 3 on ImageData and 2 on Pixels arrays. Each bounds check calls UBound and LBound for each array dimension. This cannot be fast in any language.

    Also, division is nothing compared to square root in calculation effort (not sure if this is a non-issue nowadays in FPU terms).

    But you have to only measure performance of the compiled executable with bounds checking turned off. Everything else is travesty and does not deserve any discussion here IMO.

    cheers,
    </wqw>

  3. #3
    Fanatic Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    678

    Re: VB6: how can i speed up my draw pixel function DIB's?

    In addition to following wqweto's advice regarding bounds checking,
    Surely some speed can be gained by avoiding (reducing):
    - Power functions
    - and Divisions

    Steps = Math.Sqr(Math.Abs(Destiny.x - Origin.x) ^ 2 + Math.Abs(Destiny.y - Origin.y) ^ 2 + Math.Abs(Destiny.Z - Origin.Z) ^ 2)
    - Since you make power of 2 no need for Abs()

    - Use MUL (*) instead of POW (^):
    Dx = Destiny.x - Origin.x
    Dy = Destiny.y - Origin.y
    Dz = Destiny.z - Origin.z
    Steps = Math.Sqr(Dx * Dx + Dy * Dy + Dz * Dz)


    Reduce the number of divisions (EG: ) (1 vs 3)
    invSteps = 1 / Steps
    increment.x = (Destiny.x - Origin.x) * invSteps ' Dx * invSteps
    increment.y = (Destiny.y - Origin.y) * invSteps ' Dy * invSteps
    increment.Z = (Destiny.Z - Origin.Z) * invSteps ' Dz * invSteps


    BTW: Sure that division is not comparable to SQR but it takes very long time compared to Multiplication. (Division is Evil)
    Get into the habit of not using divisions:
    EG: habit to use * 0.5 instead of / 2

    With these tips, you gain some speed ... (not much though)

  4. #4

    Thread Starter
    PowerPoster joaquim's Avatar
    Join Date
    Apr 2007
    Posts
    3,904

    Re: VB6: how can i speed up my draw pixel function DIB's?

    wqweto: the 'Remove Array Bounds Checks" is checked.
    for the arrays i need another topic\question.

    reexre: thank you so much for all.. changed... i think that you tell me 2 ways for avoiding divisions(inverting the factors and the division by 2 is the multiplication by 0.5)... and avoiding double math that i was using.. thanks
    Last edited by joaquim; Dec 23rd, 2020 at 04:59 PM.
    VB6 2D Sprite control

    To live is difficult, but we do it.

  5. #5
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6: how can i speed up my draw pixel function DIB's?

    YOU CAN USE CREATETHREAD API,
    FOR I=1 TO 1024
    FOR B=1 TO 768
    ***
    NEXT
    NEXT

    YOU CAN USE 10 THREAD TO DO:
    FOR I=1 TO 1024 STEP 100
    CREATETHREAD addressof ThreadDoPic,i
    NEXT

    sub ThreadDoPic(byval i as long)
    '
    end sub

  6. #6

    Thread Starter
    PowerPoster joaquim's Avatar
    Join Date
    Apr 2007
    Posts
    3,904

    Re: VB6: how can i speed up my draw pixel function DIB's?

    xiaoyao: make a new thread is more for speed?(correct me these)
    i get 3 seconds by frame(more or less)
    VB6 2D Sprite control

    To live is difficult, but we do it.

  7. #7
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6: how can i speed up my draw pixel function DIB's?

    Of course, when it comes to the calculation of large amounts of data in length and width, a good algorithm can increase the efficiency and speed by several times with 100% CPU or as much as possible.
    If you are a 8 core CPU, open 8 multithreading, CPU occupies 60%, then you open 16 multithreading, CPU may occupy 90%, find a maximum number of threads, let CPU run at full speed.

  8. #8

    Thread Starter
    PowerPoster joaquim's Avatar
    Join Date
    Apr 2007
    Posts
    3,904

    Re: VB6: how can i speed up my draw pixel function DIB's?

    Quote Originally Posted by xiaoyao View Post
    Of course, when it comes to the calculation of large amounts of data in length and width, a good algorithm can increase the efficiency and speed by several times with 100% CPU or as much as possible.
    If you are a 8 core CPU, open 8 multithreading, CPU occupies 60%, then you open 16 multithreading, CPU may occupy 90%, find a maximum number of threads, let CPU run at full speed.
    i must review the multithread code on VB6.. on VB6 it's more hard for don't get crashes or something.
    maybe you can send me a link for i start
    VB6 2D Sprite control

    To live is difficult, but we do it.

  9. #9
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6: how can i speed up my draw pixel function DIB's?

    Do you have a complete test example to upload?

  10. #10
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6: how can i speed up my draw pixel function DIB's?

    vb6 Multithreading is very stable.
    I used it for years and never had a crash.

  11. #11
    Angel of Code Niya's Avatar
    Join Date
    Nov 2011
    Posts
    8,598

    Re: VB6: how can i speed up my draw pixel function DIB's?

    A minor point about optimizing math intensive calculations. You can utilize bit shits to perform multiplications and divisions by powers of 2. Historically, bit shift instructions have been faster than multiplication and division instructions on CPUs. I don't know how relevant it is today though. I've heard of compilers making this optimization themselves and I can't say if the VB6 compiler does this. Also, for all I know modern CPUs could have closed the performance gap between bit shifting and multiplication/division. It's not something I've studied to any great depth but you might want to look into if you find yourself doing a lot of divisions and multiplications by powers of 2.
    Treeview with NodeAdded/NodesRemoved events | BlinkLabel control | Calculate Permutations | Object Enums | ComboBox with centered items | .Net Internals article(not mine) | Wizard Control | Understanding Multi-Threading | Simple file compression | Demon Arena

    Copy/move files using Windows Shell | I'm not wanted

    C++ programmers will dismiss you as a cretinous simpleton for your inability to keep track of pointers chained 6 levels deep and Java programmers will pillory you for buying into the evils of Microsoft. Meanwhile C# programmers will get paid just a little bit more than you for writing exactly the same code and VB6 programmers will continue to whitter on about "footprints". - FunkyDexter

    There's just no reason to use garbage like InputBox. - jmcilhinney

    The threads I start are Niya and Olaf free zones. No arguing about the benefits of VB6 over .NET here please. Happiness must reign. - yereverluvinuncleber

  12. #12

    Thread Starter
    PowerPoster joaquim's Avatar
    Join Date
    Apr 2007
    Posts
    3,904

    Re: VB6: how can i speed up my draw pixel function DIB's?

    heres the function updated for use the result in memory:
    Code:
    Friend Sub DrawImageRectanglePoints(DestinationHDC As Long, Points() As Position3D, WorldSize As Size3D, Optional ByVal Opacity As Long = 255)
        'Points(1) is the Upper-Right
        'Points(2) is the Low-Right
        'Points(3) is the Low-Left
        
        'creating a memory image result from same class(these class):
        Dim ResultImage As image
        Set ResultImage = New image
        
        Dim x As Long
        Dim y As Long
        Dim PosX As Long
        Dim PosY As Long
        Dim DestinationBitmap As Long
        Dim lpBitsDestination As Long
        Dim DestuHdr          As BITMAPINFOHEADER
        Dim bm As BITMAP
        Dim bi As BITMAPINFO
        Dim desthDib As Long, destlpBits As Long
        Dim desthPrevBmp As Long
        If (hBitmap = 0 Or hMemDC = 0) Then Exit Sub
        'Get actual hBitmap from Destination HDC:
        DestinationBitmap = GetCurrentObject(DestinationHDC, OBJ_BITMAP)
        GetObject DestinationBitmap, Len(bm), bm
        ResultImage.NewImage bm.bmWidth, bm.bmHeight
        Dim s As Long
        s = BitBlt(ResultImage.hMemDC, 0, 0, ResultImage.Width, ResultImage.Height, DestinationHDC, 0, 0, vbSrcCopy)
        If s = 0 Then
            MsgBox CStr(GetLastError())
        End If
        s = Rectangle(ResultImage.hMemDC, 100, 100, 200, 200)
        If s = 0 Then
            MsgBox CStr(GetLastError())
        End If
        s = BitBlt(DestinationHDC, 0, 0, ResultImage.Width, ResultImage.Height, ResultImage.hMemDC, 0, 0, vbSrcCopy)
        If s = 0 Then
            MsgBox CStr(GetLastError())
        End If
        Exit Sub
        Dim PixelsResult() As COLORQUAD
        Dim array2d As SAFEARRAY
        ResultImage.GetPixelArray PixelsResult, array2d, ResultImage.lpBits, ResultImage.Width, ResultImage.Height
        
        
        'Get left and right vertical line points:
        Dim PointsUpperDownLeft() As Position3D
        
        PointsUpperDownLeft = GetLinePoints(Points(0), Points(3))
        Dim PointsUpperDownRight() As Position3D
        PointsUpperDownRight = GetLinePoints(Points(1), Points(2))
        
        'Between the left and right vertical line points we get the horizontal line points:
        Dim DrawPixelPoints() As Position3D
        Dim OriginPoint As POINTAPI
        Dim Point As POINTAPI
        Dim color As COLORQUAD
        Dim OriginPosX As Long, OriginPosY As Long
        Dim OriginWidth As Long, OriginHeight As Long
        Point = ConvertPositon3DTo2D(Points(3), WorldSize)
        OriginPosX = Point.x
        Point = ConvertPositon3DTo2D(Points(0), WorldSize)
        OriginPosY = Point.y
        Point = ConvertPositon3DTo2D(Points(2), WorldSize)
        OriginWidth = Point.x
        OriginHeight = Point.y
        
        'Move from horizontal line dots and draw the pixel:
        For y = 0 To UBound(PointsUpperDownLeft) - 1
            'Get the horizontal line points:
            
            DrawPixelPoints = GetLinePoints(PointsUpperDownRight(y), PointsUpperDownLeft(y))
            'OriginPoint = ConvertPositon3DTo2D(DrawPixelPoints(0), WorldSize)
            PosY = y
            If (PosY >= (Height)) Then
                While (PosY > (Height - 1))
                    PosY = PosY - Height
                Wend
            End If
            For x = 0 To UBound(DrawPixelPoints) - 1
                
                PosX = x
                
                
                'Test the image size for we tiled the image:
                If (PosX > (Width - 1)) Then
                    While (PosX > (Width - 1))
                        PosX = PosX - Width
                    Wend
                End If
                
                
                
                'Get the pixel color(ARGB):
                
            On Error Resume Next
                
                'Convert the 3D point to 2D point:
                Point = ConvertPositon3DTo2D(DrawPixelPoints(x), WorldSize)
                
                'changing the RGB pixel:
                
                PixelsResult(Point.x, Point.y) = Pixels(Width - PosX, PosY)
                'pvChangeAlphaRGBA ImageData(2, Point.x, Point.y), ImageData(1, Point.x, Point.y), ImageData(0, Point.x, Point.y), ImageData(3, Point.x, Point.y), Opacity
                
                
            Next x
            
        Next y
        'AlphaBlend DestinationHDC, Point.x, Point.y, 1, 1, ResultImage.hMemDC, Width - PosX, PosY, 1, 1, AC_SRC_ALPHA * &H1000000 + 255 * &H10000
        ResultImage.DrawImage DestinationHDC, 0, 0
     
    End Sub
    by some reason i don't get results
    at least seems faster...
    heres the entire class:
    Code:
    Public hMemDC          As Long
    Dim uHdr            As BITMAPINFOHEADER
    Public hDib As Long, lpBits As Long
    Public Width As Long, Height As Long
    Private Pixels() As COLORQUAD
    Private uArray2D          As SAFEARRAY
    Dim hBitmap         As Long
    Dim hPrevBmp        As Long
    
    Private Sub DestroyObjects()
        If hMemDC <> 0 Then
            Call SelectObject(hMemDC, hPrevBmp)
            Call DeleteDC(hMemDC)
        End If
        If hBitmap <> 0 Then
            GdipDisposeImage hBitmap
        End If
        
    End Sub
    
    Public Function pvCreateDib(ByVal lWidth As Long, ByVal lHeight As Long) As Boolean
        hMemDC = CreateCompatibleDC(0)
        If hBitmap = 0 Then
            hBitmap = CreateCompatibleBitmap(hMemDC, lWidth, lHeight)
        End If
        With uHdr
            .biSize = Len(uHdr)
            .biPlanes = 1
            .biBitCount = 32
            .biWidth = lWidth
            .biHeight = -lHeight
            .biSizeImage = 4 * lWidth * lHeight
        End With
        hDib = CreateDIBSection(hMemDC, uHdr, DIB_RGB_COLORS, lpBits, 0, 0)
        hPrevBmp = SelectObject(hMemDC, hDib)
        If hDib = 0 Then
            GoTo QH
        End If
        '--- success
        pvCreateDib = True
    QH:
    End Function
    
    Public Sub NewImage(ImageWidth As Long, ImageHeight As Long)
        DestroyObjects
        pvCreateDib ImageWidth, ImageHeight
    End Sub
    
    Public Function LoadFromFile(sFileName As String) As Boolean
       
        Dim aInput(0 To 3)  As Long
        
        Dim sngWidth        As Single
        Dim sngHeight       As Single
        Dim uData           As BitmapData
        DestroyObjects 'for destroy all objects
        If GetModuleHandle("gdiplus") = 0 Then
            aInput(0) = 1
            Call GdiplusStartup(0, aInput(0))
        End If
        If GdipLoadImageFromFile(StrPtr(sFileName), hBitmap) <> 0 Then
            GoTo QH
        End If
        If GdipGetImageDimension(hBitmap, sngWidth, sngHeight) <> 0 Then
            GoTo QH
        End If
        If Not pvCreateDib(sngWidth, sngHeight) Then
            GoTo QH
        End If
        Width = sngWidth
        Height = sngHeight
        uData.Stride = sngWidth * 4
        uData.Scan0 = lpBits
        GetPixelArray Pixels, uArray2D, lpBits, Width, Height
        If GdipBitmapLockBits(hBitmap, ByVal 0, ImageLockModeRead Or ImageLockModeUserInputBuf, PixelFormat32bppPARGB, uData) <> 0 Then
            GoTo QH
        End If
        '--- success
        LoadFromFile = True
    QH:
        If uData.PixelFormat <> 0 Then
            Call GdipBitmapUnlockBits(hBitmap, uData)
        End If
    End Function
    
    Public Function pvGetDibDimension(lWidth As Long, lHeight As Long) As Boolean
        
        Call GetObject(hDib, Len(uHdr), uHdr)
        If uHdr.biWidth = 0 Or uHdr.biHeight = 0 Then
            GoTo QH
        End If
        lWidth = uHdr.biWidth
        lHeight = Abs(uHdr.biHeight)
        '--- success
        pvGetDibDimension = True
    QH:
    End Function
    
    Public Function DrawImage(ByVal hdc As Long, ByVal lX As Long, ByVal lY As Long, Optional ByVal Opacity As Long = 255) As Boolean
        If (hBitmap = 0 Or hMemDC = 0) Then MsgBox "erro"
        If AlphaBlend(hdc, lX, lY, Width, Height, hMemDC, 0, 0, Width, Height, AC_SRC_ALPHA * &H1000000 + Opacity * &H10000) = 0 Then
            GoTo QH
        End If
        '--- success
        DrawImage = True
    QH:
    End Function
    
    Friend Sub GetPixelArray( _
                abuffer() As COLORQUAD, _
                uArray As SAFEARRAY, _
                ByVal lDataPtr As Long, _
                ParamArray Bounds() As Variant)
        Dim lIdx            As Long
        
        Debug.Assert UBound(Bounds) <= UBound(uArray.Bounds)
        With uArray
            .cDims = UBound(Bounds) + 1
            .fFeatures = 1 ' FADF_AUTO
            .cbElements = 4 ' sizeof COLORQUAD
            .cLocks = 1
            .pvData = lDataPtr
            If .cDims = 0 Then
                .cDims = 1
                .Bounds(0).cElements = &H40000000
            Else
                For lIdx = 0 To UBound(Bounds)
                    .Bounds(lIdx).cElements = Bounds(UBound(Bounds) - lIdx)
                Next
            End If
        End With
        Call CopyMemory(ByVal ArrPtr(abuffer), VarPtr(uArray), 4)
    End Sub
    
    
    Friend Sub pvChangeAlpha(Pixel As COLORQUAD, AlphaValue As Long)
        If Pixel.A <> 0 Then
            If Pixel.R <= Pixel.A Then Pixel.R = Pixel.R * AlphaValue / Pixel.A Else Pixel.R = AlphaValue
            If Pixel.G <= Pixel.A Then Pixel.G = Pixel.G * AlphaValue / Pixel.A Else Pixel.G = AlphaValue
            If Pixel.B <= Pixel.A Then Pixel.B = Pixel.B * AlphaValue / Pixel.A Else Pixel.B = AlphaValue
        End If
        Pixel.A = AlphaValue
    End Sub
    
    Public Function pvChangeAlphaRGBA(ByRef R As Byte, ByRef G As Byte, ByRef B As Byte, ByRef A As Byte, ByRef AlphaValue As Long)
        If A <> 0 Then
            If R <= A Then R = R * AlphaValue / A Else R = AlphaValue
            If G <= A Then G = G * AlphaValue / A Else G = AlphaValue
            If B <= A Then B = B * AlphaValue / A Else B = AlphaValue
        End If
        A = AlphaValue
    End Function
    
    
    Friend Function pvGetPixel(PointX As Long, PointY As Long) As COLORQUAD
        
        Dim Pixel As COLORQUAD
        If (PointX >= Width Or PointX < 0) Then Exit Function
        If (PointY >= Height Or PointY < 0) Then Exit Function
        Pixel = Pixels(PointX, PointY)
        
        pvGetPixel = Pixel
    End Function
    
    Friend Sub pvSetPixel(Pixel As COLORQUAD, PointX As Long, PointY As Long)
        
        If (PointX >= Width And PointX < 0) Then Exit Sub
        If (PointY >= Height And PointY < 0) Then Exit Sub
        
        Pixels(PointX, PointY) = Pixel
    End Sub
    yes the 'friend function is from the class too.
    i must test more for see why i don't get results
    VB6 2D Sprite control

    To live is difficult, but we do it.

  13. #13

    Thread Starter
    PowerPoster joaquim's Avatar
    Join Date
    Apr 2007
    Posts
    3,904

    Re: VB6: how can i speed up my draw pixel function DIB's?

    after more tests i find the error, and using the my own class(using a memory graphics DIB's), i win much more speed... now i get 1 frame per second:
    Code:
    Friend Sub DrawImageRectanglePoints(DestinationHDC As Long, Points() As Position3D, WorldSize As Size3D, Optional ByVal Opacity As Long = 255)
        'Points(1) is the Upper-Right
        'Points(2) is the Low-Right
        'Points(3) is the Low-Left
        
        'creating a memory image result from same class(these class):
        Dim ResultImage As image
        Set ResultImage = New image
        
        Dim x As Long
        Dim y As Long
        Dim PosX As Long
        Dim PosY As Long
        Dim DestinationBitmap As Long
        Dim lpBitsDestination As Long
        Dim DestuHdr          As BITMAPINFOHEADER
        Dim bm As BITMAP
        Dim bi As BITMAPINFO
        Dim desthDib As Long, destlpBits As Long
        Dim desthPrevBmp As Long
        If (hBitmap = 0 Or hMemDC = 0) Then Exit Sub
        'Get actual hBitmap from Destination HDC:
        DestinationBitmap = GetCurrentObject(DestinationHDC, OBJ_BITMAP)
        GetObject DestinationBitmap, Len(bm), bm
        
        ResultImage.NewImage bm.bmWidth, bm.bmHeight
        'Debug.Print CStr(ResultImage.Width) + vbTab + CStr(ResultImage.Height)
        Dim s As Long
        s = BitBlt(ResultImage.hMemDC, 0, 0, ResultImage.Width, ResultImage.Height, DestinationHDC, 0, 0, vbSrcCopy)
        Dim PixelsResult() As COLORQUAD
        Dim array2d As SAFEARRAY
        ResultImage.GetPixelArray PixelsResult, array2d, ResultImage.lpBits, ResultImage.Width, ResultImage.Height
        
        
        'Get left and right vertical line points:
        Dim PointsUpperDownLeft() As Position3D
        
        PointsUpperDownLeft = GetLinePoints(Points(0), Points(3))
        Dim PointsUpperDownRight() As Position3D
        PointsUpperDownRight = GetLinePoints(Points(1), Points(2))
        
        'Between the left and right vertical line points we get the horizontal line points:
        Dim DrawPixelPoints() As Position3D
        Dim OriginPoint As POINTAPI
        Dim Point As POINTAPI
        Dim color As COLORQUAD
        Dim OriginPosX As Long, OriginPosY As Long
        Dim OriginWidth As Long, OriginHeight As Long
        Point = ConvertPositon3DTo2D(Points(3), WorldSize)
        OriginPosX = Point.x
        Point = ConvertPositon3DTo2D(Points(0), WorldSize)
        OriginPosY = Point.y
        Point = ConvertPositon3DTo2D(Points(2), WorldSize)
        OriginWidth = Point.x
        OriginHeight = Point.y
        
        'Move from horizontal line dots and draw the pixel:
        For y = 0 To UBound(PointsUpperDownLeft) - 1
            'Get the horizontal line points:
            
            DrawPixelPoints = GetLinePoints(PointsUpperDownRight(y), PointsUpperDownLeft(y))
            'OriginPoint = ConvertPositon3DTo2D(DrawPixelPoints(0), WorldSize)
            PosY = y
            If (PosY >= (Height)) Then
                While (PosY > (Height - 1))
                    PosY = PosY - Height
                Wend
            End If
            For x = 0 To UBound(DrawPixelPoints) - 1
                
                PosX = x
                
                
                'Test the image size for we tiled the image:
                If (PosX > (Width - 1)) Then
                    While (PosX > (Width - 1))
                        PosX = PosX - Width
                    Wend
                End If
                
                
                
                'Get the pixel color(ARGB):
                
            On Error Resume Next
                
                'Convert the 3D point to 2D point:
                Point = ConvertPositon3DTo2D(DrawPixelPoints(x), WorldSize)
                
                'changing the RGB pixel:
                
                PixelsResult(Point.x, Point.y) = Pixels(Width - PosX, PosY)
                'pvChangeAlphaRGBA ImageData(2, Point.x, Point.y), ImageData(1, Point.x, Point.y), ImageData(0, Point.x, Point.y), ImageData(3, Point.x, Point.y), Opacity
                
                
            Next x
            
        Next y
        'AlphaBlend DestinationHDC, Point.x, Point.y, 1, 1, ResultImage.hMemDC, Width - PosX, PosY, 1, 1, AC_SRC_ALPHA * &H1000000 + 255 * &H10000
        ResultImage.DrawImage DestinationHDC, 0, 0, 100
    End Sub
    i have 1 question: i only use 1 part of the image(from the form).... if i only get the image\pixels and change only that part, it will be much more faster?
    is like change the PixelsResult()... instead be 1366X768... be less than half.... it will be much more faster?
    VB6 2D Sprite control

    To live is difficult, but we do it.

  14. #14

    Thread Starter
    PowerPoster joaquim's Avatar
    Join Date
    Apr 2007
    Posts
    3,904

    Re: VB6: how can i speed up my draw pixel function DIB's?

    finally i speed up my function using the AlphaBlend():
    Code:
    Friend Sub DrawImagePlanePoints(DestinationHDC As Long, Points() As Position3D, WorldSize As Size3D, Optional ByVal Opacity As Long = 255)
        'Points(0) is the Upper-Left
        'Points(1) is the Upper-Right
        'Points(2) is the Low-Right
        'Points(3) is the Low-Left
        
        'creating a memory image result from same class(these class):
        Dim ResultImage As image
        Set ResultImage = New image
        
        Dim x As Long
        Dim y As Long
        Dim PosX As Long
        Dim PosY As Long
        Dim DestinationBitmap As Long
        Dim lpBitsDestination As Long
        Dim DestuHdr          As BITMAPINFOHEADER
        Dim bm As BITMAP
        Dim bi As BITMAPINFO
        Dim desthDib As Long, destlpBits As Long
        Dim desthPrevBmp As Long
        If (hBitmap = 0 Or hMemDC = 0) Then Exit Sub
        'Get actual hBitmap from Destination HDC:
        DestinationBitmap = GetCurrentObject(DestinationHDC, OBJ_BITMAP)
        GetObject DestinationBitmap, Len(bm), bm
        ResultImage.NewImage bm.bmWidth, bm.bmHeight
        
        'Get left and right vertical line points:
        Dim PointsUpperDownLeft() As Position3D
        PointsUpperDownLeft = GetLinePoints(Points(0), Points(3))
        Dim PointsUpperDownRight() As Position3D
        PointsUpperDownRight = GetLinePoints(Points(1), Points(2))
        
        'Between the left and right vertical line points we get the horizontal line points:
        Dim OriginPoint As POINTAPI
        Dim DestinationPoint As POINTAPI
        
        'Draw Horizontal image line from vertical plane lines:
        For y = 0 To UBound(PointsUpperDownLeft) - 1
            OriginPoint = ConvertPositon3DTo2D(PointsUpperDownLeft(y), WorldSize)
            DestinationPoint = ConvertPositon3DTo2D(PointsUpperDownRight(y), WorldSize)
            PosY = y
            If (PosY >= (Height)) Then
                While (PosY > (Height - 1))
                    PosY = PosY - Height
                Wend
            End If
            AlphaBlend ResultImage.hMemDC, OriginPoint.x, OriginPoint.y, DestinationPoint.x - OriginPoint.x, 1, hMemDC, 0, PosY, Width, 1, AC_SRC_ALPHA * &H1000000 + Opacity * &H10000
        Next y
        'Draw the result on destination HDC:
        ResultImage.DrawImage DestinationHDC, 0, 0
    End Sub
    the draw style is stretched.. but i can update for tiles.... at least, i win speed and very
    VB6 2D Sprite control

    To live is difficult, but we do it.

  15. #15

    Thread Starter
    PowerPoster joaquim's Avatar
    Join Date
    Apr 2007
    Posts
    3,904

    Re: VB6: how can i speed up my draw pixel function DIB's?

    i belive that i have a memory leak on my function..
    i tryied
    Code:
    ResultImage.DrawImage DestinationHDC, 0, 0
       ResultImage.DestroyObjects
    '...........
    Public Sub DestroyObjects()
        If hMemDC <> 0 Then
            Call SelectObject(hMemDC, hPrevBmp)
            Call DeleteDC(hMemDC)
        End If
        If hBitmap <> 0 Then
            GdipDisposeImage hBitmap
        End If
        
    End Sub
    but the program is freezed and terminated without an error message.. so i belive it's a memory leak....
    how can i avoid these memory leak?
    VB6 2D Sprite control

    To live is difficult, but we do it.

  16. #16

    Thread Starter
    PowerPoster joaquim's Avatar
    Join Date
    Apr 2007
    Posts
    3,904

    Re: VB6: how can i speed up my draw pixel function DIB's?

    i fixed just creating the ResultImage class variable on global section and just set and NewImage() on DrawImagePlanePoints().
    thank you so much
    now i need another update that i'm failling: the plane have 4 3d points:
    Code:
    'Points(0) is the Upper-Left
        'Points(1) is the Upper-Right
        'Points(2) is the Low-Right
        'Points(3) is the Low-Left
    0------1
    | |(i'm sorry, but i can't control the empty spaces)
    3------2

    i'm getting trouble for get the distance between 3 and 2 and between 0 and 3.. these seems simple math, but i don't get the right ResultImage size(the image size is the form control size)
    can anyone advice me more?
    VB6 2D Sprite control

    To live is difficult, but we do it.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width