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

[joaquim]

heres my actual function for draw between line points:

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:

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

[wqweto]

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>

[reexre]

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)

[joaquim]

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

[xiaoyao]

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

[joaquim]

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

[xiaoyao]

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.

[joaquim]

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

[xiaoyao]

Do you have a complete test example to upload?

[xiaoyao]

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

[Niya]

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.

[joaquim]

heres the function updated for use the result in memory:

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:

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

[joaquim]

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:

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?

[joaquim]

finally i speed up my function using the AlphaBlend():

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

[joaquim]

i belive that i have a memory leak on my function..
i tryied

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?

[joaquim]

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:

'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?