Posts by cambalinho

1 - yes i can't assign an object\instance to nothing without test it 1st:

Dim WithEvents tmr As vbAPITimerTools.APITimer 'create a vbAPITimerTools.APITimer instance with an event
Set tmr = New vbAPITimerTools.APITimer 'initializate the instance

If Not tmr Is Nothing Then
        tmr.StopTimer
        Set tmr = Nothing
    End If

    ' free\destroy Brush object:
    ' i used the 'DestroyPenBrush()', but it's the 'DeleteObject()':
    If (FillWall1 <> 0) Then GameBitmap.DestroyPenBrush FillWall1
    If (FillEmpty <> 0) Then GameBitmap.DestroyPenBrush FillEmpty

2 - i can't use 'Unload()' with QueryUnload(), with 'UnloadMode'... just use the 'Unload()' is the best.... seems they aren't good with infinite loops... maybe i did more errors, but, for now, i don't get leak memory problems ;)

3 - don't use the 'stop' button, from IDE, before clear resources!!!! the form have an event for i test if the object was destroyed(speaking about the 'stop' button from IDE)?
thanks for all to all

i did a simple mistake:

Set GameBitmap = Nothing

instead:

If Not GameBitmap Is Nothing Then
        Set GameBitmap = Nothing
    End If

what event is used when i press the 'stop' button on IDE?
yes is give me a memory leak :(

seems that resolve for sometimes and not forever :(

heres my timer class with a module(on a group project for create a DLL):

'Module:
Option Explicit

Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Private mcolItems   As Collection

Public Sub AddTimer(ByRef pobjTimer As APITimer, ByVal plngInterval As Long)
    If mcolItems Is Nothing Then
        Set mcolItems = New Collection
    End If
    pobjTimer.ID = SetTimer(0, 0, plngInterval, AddressOf Timer_CBK)
    mcolItems.Add ObjPtr(pobjTimer), pobjTimer.ID & "K"
End Sub

Public Sub RemoveTimer(ByRef pobjTimer As APITimer)
On Error GoTo ErrHandler
    mcolItems.Remove pobjTimer.ID & "K"
    KillTimer 0, pobjTimer.ID
    pobjTimer.ID = 0
    If mcolItems.Count = 0 Then
        Set mcolItems = Nothing
    End If
    Exit Sub
ErrHandler:

End Sub

Public Sub Timer_CBK(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long)
Dim lngPointer  As Long
Dim objTimer    As APITimer
On Error GoTo ErrHandler
    lngPointer = mcolItems.Item(idEvent & "K")
    Set objTimer = PtrObj(lngPointer)
    objTimer.RaiseTimerEvent
    Set objTimer = Nothing
    Exit Sub
ErrHandler:

End Sub

Private Function PtrObj(ByVal Pointer As Long) As Object
Dim objObject   As Object
    CopyMemory objObject, Pointer, 4&
    Set PtrObj = objObject
    CopyMemory objObject, 0&, 4&
End Function

'class:
Option Explicit

Private Const CLASS_NAME As String = "APITimer"


Public Event Refresh()

Private mlngTimerID      As Long

Friend Property Let ID(ByVal plngValue As Long) …

what make me more crazy is that i'm using a code, converted and works, from VB6 lol

yes i must test more... and, like you see, that vertical bar have another color.... that means the code problem can be here:

'Get  the horizontal Ray Distance:
            HorizDist = Math.Abs((player.PosX - HorizX) / Math.Cos(RayRadians))
'Get the vertical Ray Distance:
            VertDist = Math.Abs((Player.PosX - VertX) / Math.Cos(RayRadians))
'Get the nearst Ray:
            Dim clr As New Pen(Color.Blue, 1)
            Dim ImagePosition As Long = 0

            If VertDist < HorizDist Then
                WallDistance = Math.Floor(VertDist)
                OffSetGrid = VertY Mod ObjectSize
                clr.Color = Color.Blue

            Else
                OffSetGrid = HorizX Mod ObjectSize
                WallDistance = Math.Floor(HorizDist)
                clr.Color = Color.DarkBlue
            End If
'on that vertical bar wrong, the color is another.. maybe i need change that math to hypotenuse formula ;)

tomorrow, i will try test more ;)

maybe you have right... but, for now, i don't understand why and where i'm fail :(
i'm learning from: https://permadi.com/1996/05/ray-casting-tutorial-table-of-contents/
theres several tutorials, but not all are so good :(

will be rounded numbers problem or something?
yes i'm testing more, but no success :(

i can see:
1 - maybe some are too much height(but they are converted to 300 of max);
2 - on some they are repeated... and maybe the problem is there...
i can save the previous Height for test the actual Height.... but i see a problem: if i avoid them, i can lose some height, unless i continue add angle and don't count the rays ;) ... but maybe i found the problem on 'RayHeight' ;)

debug print line height:

Line Height : 1452
Line Height : 1441
Line Height : 1430
Line Height : 1419
Line Height : 1407
Line Height : 1397
Line Height : 1386
Line Height : 1375
Line Height : 1364
Line Height : 1353
Line Height : 1342
Line Height : 1331
Line Height : 1321
Line Height : 1310
Line Height : 1299
Line Height : 1289
Line Height : 1278
Line Height : 1268
Line Height : 1257
Line Height : 1247
Line Height : 1236
Line Height : 1226
Line Height : 1216
Line Height : 1205
Line Height : 1195
Line Height : 1185
Line Height : 1174
Line Height : 1164
Line Height : 1154
Line Height : 1144
Line Height : 1134
Line Height : 1124
Line Height : 1114
Line Height : 1104
Line Height : 1094
Line Height : 1084
Line Height : 1074
Line Height : 1064
Line Height : 1054
Line Height : 1044
Line Height : 1034
Line Height : 1024
Line Height : 1015
Line Height : 1005
Line Height : 995
Line Height : 985
Line Height : 976
Line Height : 966
Line Height : 957
Line Height : 947
Line Height : 937
Line Height : 928
Line Height : 918
Line Height : 909
Line Height : 899
Line Height : 890
Line Height : 880
Line Height : 871
Line Height : 862
Line Height : 852
Line Height : 843
Line Height …

heres my RayCasting code on VB2010(it can be another programming language, i will get the same bug):

Private Function GetPositionMap(ByVal Position As Double) As Integer
        Return fix(Position / ObjectSize)
    End Function

    Private Sub DrawRays()

        Dim StepX As Double
        Dim StepY As Double
        Dim VertX As Double
        Dim VertY As Double
        Dim HorizX As Double
        Dim HorizY As Double
        Dim MapX As Long
        Dim MapY As Long
        Dim HorizDist As Double
        Dim VertDist As Double
        Dim WallDistance As Double
        Dim RayHeight As Double
        Dim RayRadians As Double
        Dim RadiansSteps As Double
        Dim RayCount As Long
        Dim RayCounts As Long = 0
        Dim OffSetGrid As Long
        Dim PreviousRayX As Double = 0
        Dim PreviousRayY As Double = 0
        Dim RayX As Double = 0
        Dim RayY As Double = 0

        'Get viewe Width:
        RayCount = 320



        'Divide the FOV in a Radians steps by level width:
        RadiansSteps = Radian60 / RayCount

        'Get the FOV start radians(player minus half of FOV):
        RayRadians = (player.Radians - Radian30)

        RayCounts = 0
        Do While RayCounts < RayCount
            If (RayRadians > Radian360) Then RayRadians -= Radian360 'correct some Radians
            If (RayRadians < 0) Then RayRadians += Radian360
            'Check for horizontal intersections:
            'and get the 1st horizontal line intersection:
            If RayRadians >= 0 And RayRadians <= Math.PI Then 'Facing down
                HorizY = (fix(player.PosY / ObjectSize) * ObjectSize) + ObjectSize ' Calculate grid position
                HorizX = player.PosX + (HorizY - player.PosY) / Math.Tan(RayRadians)
                StepY = ObjectSize
            Else 'Facing Up
                HorizY = (fix(player.PosY / ObjectSize) * ObjectSize) - 1
                HorizX …

these is the VB6 function for RayCasting:

Private Sub DrawRays()

        Dim StepX As Double
        Dim StepY As Double
        Dim VertX As Double
        Dim VertY As Double
        Dim HorizX As Double
        Dim HorizY As Double
        Dim MapX As Long
        Dim MapY As Long
        Dim HorizDist As Double
        Dim VertDist As Double
        Dim WallDistance As Double
        Dim RayHeight As Double
        Dim RayRadians As Double
        Dim RadiansSteps As Double
        Dim RayCount As Long
        Dim RayCounts As Long
        Dim OffSetGrid As Long


        RayCount = imgverticalline.Width

        MapX = Player.MapX
        MapY = Player.MapY
        RadiansSteps = Radian60 / RayCount

        RayRadians = (Player.Radians - Radian30)
        RayCounts = 0
        Do While RayCounts < RayCount
            If (RayRadians > Radian360) Then RayRadians = 0.001
            'Check for horizontal intersections:

            If RayRadians >= 0 And RayRadians <= Math.PI Then 'Facing down
                HorizY = (Fix(player.PosY / ObjectSize) * ObjectSize) + ObjectSize ' Calculate grid position
                HorizX = player.PosX + (HorizY - player.PosY) / Math.Tan(RayRadians)
                StepY = ObjectSize
            ElseIf RayRadians = 0 Or RayRadians = Math.PI Then
                HorizY = player.PosY
                HorizX = player.PosX
            Else 'Facing Up
                HorizY = (Fix(player.PosY / ObjectSize) * ObjectSize) - 1
                HorizX = player.PosX + (HorizY - player.PosY) / Math.Tan(RayRadians)
                StepY = -ObjectSize
            End If

            StepX = StepY / Math.Tan(RayRadians)
            MapX = GetPositionMap(HorizX)
            MapY = GetPositionMap(HorizY)



            Do
                If MapX < 0 Or MapX > 9 Or MapY < 0 Or MapY > 9 Then Exit Do
                If levelmap0(MapY, MapX) = Color.Black Then Exit Do
                HorizX = HorizX + StepX
                HorizY = HorizY + StepY

                MapX = GetPositionMap(HorizX)
                MapY = GetPositionMap(HorizY)

            Loop …

understood ;)
thanks for all...
using the VB2010 is best use GDI+... if i need change all pixels, we must use lockbits() on a Bitmap

correct me: the Bitmaps.lockbits() and Bitmaps.unlockbits(), for change the pixels(all pixels), are more faster or like DIB's speed or more slow?

that link\tutorial have some errors: VB2010 don't have the 'any' type

How use and declare CopyMemory() API function VB2010?

like i said: is for learning... we can use that images in several places ;)

damn i can't edit.. it's VB2010 and not VB6... but the tags is vb.net...
i'm sorry

how can i convert cursor files to image?
i need see the cur\ani on picturebox?(just for learning)

Private Sub btnChooseImage_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnChooseImage.Click
        If (ofdChooseFile.ShowDialog = Windows.Forms.DialogResult.OK) Then
            If (ofdChooseFile.FilterIndex = 6) Then
                Dim cur As New Cursor(ofdChooseFile.FileName)
                PicShowImage.Image = cur 'error yes
            Else
                PicShowImage.Image = Image.FromFile(ofdChooseFile.FileName)
            End If
            Me.Text = "Image Viewer: " & ofdChooseFile.FileName
        End If
    End Sub

how can i get the image from a cursor?
the Cursor object read cur files and ani?

Reverend Jim: i installed the VS2010.. seems much more faster on my laptop ;)

how can i convert these C line:

(py>>6)<<6)

to VB6?

after several tests i fix it:

Do While RayCounts < RayCount
        If (RayRadians > (2 * PI)) Then RayRadians = 0.001

i have more to update:
1 - win more performance\FPS;
2 - and trying avoid the 'on error resume next'(it's about the array dimensions):

Private Sub DrawRays2()

    Dim AY As Double
    Dim AX As Double
    Dim StepX As Double
    Dim StepY As Double
    Dim VertX As Double
    Dim VertY As Double
    Dim HorizX As Double
    Dim HorizY As Double
    Dim MapX As Long
    Dim MapY As Long
    Dim HorizDist As Double
    Dim VertDist As Double
    Dim WallDistance As Double
    Dim RayHeight As Double
    Dim RayRadians As Double
    Dim RadiansSteps As Double
    Dim RayCount As Integer
    Dim RayCounts As Integer
    RayCount = 320

    MapX = Player.MapX
    MapY = Player.MapY
    RadiansSteps = Radian60 / 320

    On Error Resume Next
    RayRadians = (Player.Radians - Radian30)
    RayCounts = 0
    Do While RayCounts < RayCount
        If (RayRadians > (2 * PI)) Then RayRadians = 0.001
        'Check for horizontal intersections:
        If RayRadians > 0 And RayRadians < PI Then 'Facing down

thanks for all

i fix 1 error:

ElseIf (KeyCode = vbKeyUp) Then
        If (LevelMap0(Fix((Player.PosY + Player.MoveY * Speed) / ObjectSize), Fix((Player.PosX + Player.MoveX * Speed) / ObjectSize)) <> vbBlue) Then

'and:
ElseIf (KeyCode = vbKeyDown) Then
        If (LevelMap0(Fix((Player.PosY - Player.MoveY * Speed) / ObjectSize), Fix((Player.PosX - Player.MoveX * Speed) / ObjectSize)) <> vbBlue) Then

now i see some space between the player and the wall... was the best way.
now see the entire function:

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Const Speed As Double = 4.2
    Const Radians As Double = 0.1
    If (KeyCode = vbKeyEscape) Then
        blnLoop = False
        Set A = Nothing
        Set s = Nothing
        End
    ElseIf (KeyCode = vbKeyLeft) Then
        Player.Radians = Player.Radians - Radians
        If (Player.Radians <= 0) Then Player.Radians = 2 * PI
        Player.MoveX = Cos(Player.Radians) * Speed
        Player.MoveY = Sin(Player.Radians) * Speed
    ElseIf (KeyCode = vbKeyRight) Then
        Player.Radians = Player.Radians + Radians
        If (Player.Radians >= 2 * PI) Then Player.Radians = 0
        Player.MoveX = Cos(Player.Radians) * Speed
        Player.MoveY = Sin(Player.Radians) * Speed
    ElseIf (KeyCode = vbKeyUp) Then
        If (LevelMap0(Fix((Player.PosY + Player.MoveY * Speed) / ObjectSize), Fix((Player.PosX + Player.MoveX * Speed) / ObjectSize)) <> vbBlue) Then
            Player.PosX = Player.PosX + Player.MoveX
            Player.PosY = Player.PosY + Player.MoveY
            Player.MapX = Fix((Player.PosX) / ObjectSize)
            Player.MapY = Fix((Player.PosY) / ObjectSize)
        End If
    ElseIf (KeyCode = vbKeyDown) Then
        If (LevelMap0(Fix((Player.PosY - Player.MoveY * Speed) / ObjectSize), Fix((Player.PosX - Player.MoveX * Speed) / ObjectSize)) <> vbBlue) Then
            Player.PosX = Player.PosX - Player.MoveX
            Player.PosY = Player.PosY - Player.MoveY
            Player.MapX = Fix((Player.PosX) / …

actual code:

Private Sub DrawRays2()
    Dim AY As Double
    Dim AX As Double
    Dim StepX As Double
    Dim StepY As Double
    Dim VertX As Double
    Dim VertY As Double
    Dim HorizX As Double
    Dim HorizY As Double
    Dim MapX As Long
    Dim MapY As Long
    Dim HorizDist As Double
    Dim VertDist As Double
    Dim WallDistance As Double
    Dim RayHeight As Double
    Dim RayRadians As Double
    Dim RadiansSteps As Double
    Dim RayCount As Integer
    Dim RayCounts As Integer
    RayCount = 320

    MapX = Player.MapX
    MapY = Player.MapY
    RadiansSteps = Radian60 / 320
    On Error Resume Next
    RayRadians = Player.Radians - Radian30
    RayCounts = 0
    Do While RayCounts < RayCount

    '    'Check for horizontal intersections:
        If ((RayRadians > 0 And RayRadians < PI)) Then 'Facing down
            AY = (Int(Player.PosY / ObjectSize) * ObjectSize) + ObjectSize ' Calculate grid position
            AX = Player.PosX + (AY - Player.PosY) / Tan(RayRadians)
            StepY = ObjectSize
        ElseIf ((RayRadians = 0 And RayRadians = PI)) Then
            AY = Player.PosY
            AX = Player.PosX
        Else 'Facing Up
            AY = (Int(Player.PosY / ObjectSize) * ObjectSize) - 1
            AX = Player.PosX + (AY - Player.PosY) / Tan(RayRadians)
            StepY = -ObjectSize
        End If


        HorizX = AX
        HorizY = AY
        StepX = StepY / Tan(RayRadians)
        MapX = Fix((HorizX) / ObjectSize)
        MapY = Fix((HorizY) / ObjectSize)
        'A.SetPixel (Fix(HorizX)), (Fix(HorizY)), ColorConstants.vbCyan
        If LevelMap0(MapY, MapX) <> vbBlue Then

            Do

                HorizX = HorizX + StepX
                HorizY = HorizY + StepY

                MapX = Fix((HorizX) / ObjectSize)
                MapY = Fix((HorizY) / ObjectSize)

                If LevelMap0(MapY, MapX) = vbBlue Then
                    Exit Do …

not so easy :(

WallDistance = WallDistance * Cos(Abs(RayRadians - Player.Radians)) 'avoiding the Fish Effect
        RayHeight = (ObjectSize / WallDistance) * 200 '320 is the width screen
        If (RayHeight > 200) Then RayHeight = 200
        A.ForeColor vbBlue
        A.DrawLine 475 + 50 + RayCounts, 200 / 2 - RayHeight / 2, 475 + 50 + RayCounts, 200 / 2 + RayHeight / 2 '200 is the Height screen

because the wall never change if RayHeight is more than 200(moving to front or moving to back) :(

finally i found the problem is on these line:

HorizDist = Sqr(((HorizX - Player.PosX) * (HorizX - Player.PosX)) + ((HorizY - Player.PosY) * (HorizY - Player.PosY))) 'works fine




VertDist = Sqr(((VertX - Player.PosX)) * ((VertX - Player.PosX))) + (((VertY - Player.PosY)) * ((VertY - Player.PosY)))'calculation incorrect

like you see the problem was the calculation order(or signal inverted)...
now works fine...
i need correct another calculation after these:

    WallDistance = WallDistance * Cos(Player.Radians) 'avoiding the Fish Effect.. works correctly
    RayHeight = ObjectSize / WallDistance * 320 '320 is the width screen... is for get the height of vertical line 
    A.ForeColor vbBlue
    A.DrawLine 475 + 50, 200 / 2 - RayHeight / 2, 475 + 50, 200 / 2 + RayHeight / 2 '200 is the Height screen
    '475 + 50 is where it must be drawed

like you see i get the Height vertical line... but theres a problem, because the 200 is the max... but i can get more when i'm too close :(
how can i fix these calculation?

heres my RayCasting function:

Private Sub DrawRays2()
    Dim AY As Double
    Dim AX As Double
    Dim StepX As Double
    Dim StepY As Double
    Dim VertX As Double
    Dim VertY As Double
    Dim HorizX As Double
    Dim HorizY As Double
    Dim MapX As Long
    Dim MapY As Long
    Dim HorizDist As Double
    Dim VertDist As Double
    Dim WallDistance As Double
    Dim RayHeight As Double

    MapX = Player.MapX
    MapY = Player.MapY
    On Error Resume Next

'    'Check for horizontal intersections:
    If ((Player.Radians > 0 And Player.Radians < PI)) Then 'Facing down
        AY = (Int(Player.PosY / ObjectSize) * ObjectSize) + ObjectSize ' Calculate grid position
        AX = Player.PosX + (AY - Player.PosY) / Tan(Player.Radians)
        StepY = ObjectSize
    ElseIf ((Player.Radians = 0 And Player.Radians = PI)) Then
        AY = Player.PosY
        AX = Player.PosX
    Else 'Facing Up
        AY = (Int(Player.PosY / ObjectSize) * ObjectSize) - 1
        AX = Player.PosX + (AY - Player.PosY) / Tan(Player.Radians)
        StepY = -ObjectSize
    End If


    HorizX = AX
    HorizY = AY
    StepX = StepY / Tan(Player.Radians)
    MapX = Fix((HorizX) / ObjectSize)
    MapY = Fix((HorizY) / ObjectSize)
    A.SetPixel (Fix(HorizX)), (Fix(HorizY)), ColorConstants.vbCyan
    If LevelMap0(MapY, MapX) <> vbBlue Then

        Do

            HorizX = HorizX + StepX
            HorizY = HorizY + StepY

            MapX = Fix((HorizX) / ObjectSize)
            MapY = Fix((HorizY) / ObjectSize)
            A.SetPixel (Fix(HorizX)), (Fix(HorizY)), ColorConstants.vbCyan
            If LevelMap0(MapY, MapX) = vbBlue Then
                Exit Do
            End If
            DoEvents
        Loop
    End If


    HorizDist = Sqr(((HorizX - Player.PosX) * (HorizX - Player.PosX)) + ((HorizY - Player.PosY) * (HorizY - Player.PosY)))


    'Check for vertical intersections:
    If ((Player.Radians < PI …

i'm using CreateDIBSection():

Public Function NewImage(ByVal ImageWidth As Long, ByVal ImageHeight As Long, Optional color As ColorConstants = vbBlack) As Long
    If (Width > 0 Or Height > 0 Or hBitmap > 0 Or PointerPixelData > 0) Then DeleteImage
    Width = ImageWidth
    Height = ImageHeight

    'Criar HDC

    MemoryHDC = CreateCompatibleDC(0)

    With bmiInfo.bmiHeader
        .biSize = Len(bmiInfo.bmiHeader)
        .biWidth = Width
        .biHeight = -Height ' is negative for start on top left pixel image
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = BI_RGB
        .biSizeImage = AlignScan(bmiInfo.bmiHeader.biWidth, bmiInfo.bmiHeader.biBitCount) * bmiInfo.bmiHeader.biHeight
    End With
    If MemoryHDC = 0 Then MsgBox "error: HDC not created!!!"
    hBitmap = CreateDIBSection(0&, bmiInfo, DIB_RGB_COLORS, PointerPixelData, 0&, 0&)
    If hBitmap = 0 Then MsgBox "error: " & GetLastError()
    oldBitmap = SelectObject(MemoryHDC, hBitmap)

    'using pointers:
     ' Get the bits in the from DIB section:

    With tSA
        .fFeatures = FADF_FIXEDSIZE Or FADF_AUTO
        .cbElements = 4
        .cDims = 1
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = bmiInfo.bmiHeader.biHeight * bmiInfo.bmiHeader.biWidth
        .pvData = PointerPixelData
    End With
     'Erase bDib
    ' Make the bDib() array point to the memory addresses:
    CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
    CopyMemory ByVal VarPtrArray(bDibBGRA()), VarPtr(tSA), 4
    'Clear color
End Function

why, after 4 IDE executions, using CreateDIBSection(), i get, on GetLastError(), 8 : "Not enough memory resources are available to process this command."?
but on EXE i don't get these problem... but why?

how send parameters on CreateThread()?
on a class:

Option Explicit

Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private hThreadID As Long
Private hThread As Long

Public Sub Execute(FunctionName As Long, Optional parameters As Long = 0)
     hThread = CreateThread(ByVal 0&, 0&, FunctionName, ByVal parameters, 0&, hThreadID)
End Sub

on module:

Option Explicit

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)



Public Sub Test(parameters As Long)
    Dim s As String
    CopyMemory s, ByVal parameters, Len(parameters)
    Debug.Print s
End Sub

on form1:

Option Explicit

Dim s As Multithread

Private Sub Command1_Click()
     Set s = New Multithread
     Dim nome As String
     nome = "Joaquim"
     s.Execute AddressOf Test, StrPtr(nome)
End Sub

my problem is how i send parameters on CreateThread() function and get it.

i was avoiding the overflow.... but the problem is much more than the data type... and it's only on Alpha element... but finally seems fixed:

Public Function ARGB(ByVal alpha As Byte, ByVal red As Byte, ByVal green As Byte, ByVal blue As Byte) As Long
    '1st testing the Alpha element:
    ARGB = (alpha And &H7F) * &H1000000 Or -((alpha And &H80) <> 0) * &H80000000 _
        Or red * &H10000 _
        Or green * &H100& _
        Or blue
End Function

thank you so much for all

i have tried several ways, but i always get an overflow error :(
how can i combine the ARGB color elements?

Public Function ARGB(ByVal alpha As Byte, ByVal red As Byte, ByVal green As Byte, ByVal blue As Byte) As Long


    Dim color As Variant

    color = CDec(alpha) * 256 ' Alpha
    color = (color * 256) + CDec(red) ' Red
    color = (color * 256) + CDec(green) ' Green
    color = CDec((color * 256) + CDec(blue)) ' Blue 

    ARGB = CDec(color) 'overflow error
End Function

i need optimization, because i only have 200FPS for change 1 color.. these is a test for change the Alpha values... i can share all code

see these 'for' loop:

Public Function SetTransparentColor(color As Long)
    Dim X As Integer
    Dim Y As Integer
    Dim c As Long
    Dim h As Long
    Dim w As Long
    Dim temp As BGRAQUAD ' substitua BGRColor pelo tipo de dado correto usado em bDibBGRA


    h = Height - 1
    w = Width - 1


    For c = 0 To h * w ' movendo as operações fora do loop for
        X = c Mod (w + 1)
        Y = Int(c / (w + 1))
        temp = bDibBGRA(c)


        ' modificando apenas a propriedade necessária
        If (RGB(temp.B, temp.G, temp.R) = color) Then
            temp.B = 255
            bDibBGRA(c) = temp
        End If


Next c


End Function

even i comment all the code, inside the 'for', i lose more than 50% of performance\optimization :(
in these case the image is 330X330.

heres the function updated:

Const PI As Double = 3.14159265358979
Private Sub DrawCurve(Destiny As Control, PosX As Double, PosY As Double, Raio As Integer, Optional Color As ColorConstants = vbBlack, Optional StartAngle As Single = 0, Optional EndAngle As Single = 360)
    Dim Angulo As Single
    Dim Radians As Double
    Dim PontoX As Double, PontoY As Double
    Angulo = StartAngle
    Dim Rad As Double
    Rad = PI / 180
    Do While Angulo <= (EndAngle) ' ângulo final da curva
        Radians = Angulo * Rad
        PontoX = PosX + Raio * Cos(Radians) ' coordenada X do ponto na curva
        PontoY = PosY + Raio * Sin(Radians) ' coordenada Y do ponto na curva

        Destiny.PSet (PontoX, PontoY), Color ' desenha o ponto na cor amarela

        Angulo = Angulo + 1 ' incrementa o ângulo para desenhar o próximo ponto
    Loop
End Sub

that's why i did these function:

Private Sub DrawCurve(PosX As Double, PosY As Double, Raio As Integer, StartAngle As Single, EndAngle As Single)
    Dim Angulo As Single
    Dim Radians As Double
    Dim PontoX As Double, PontoY As Double
    Angulo = StartAngle
    Dim Rad As Double
    Rad = PI / 180
    Do While Angulo <= (EndAngle) 
        Radians = Angulo * Rad
        PontoX = PosX + Raio * Cos(Radians) 
        PontoY = PosY + Raio * Sin(Radians)

        MemPic.PSet (PontoX, PontoY), vbYellow 

        Angulo = Angulo + 1 
    Loop
End Sub

these function can be more updated for never use the Circle() method ;)
thanks for all

using the Circle method and knowing the start angle(playerangle-30) and end angle (playerangle+30), in degrees, how can i draw the arc?

heres a sample of using pointers on VB6:

Option Explicit

Private Const BI_RGB = 0
Private Const CBM_INIT = &H4
Private Const DIB_RGB_COLORS = 0
Private Const USE_BITMAP_ALPHA = &H1000000

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors(0 To 255) As RGBQUAD
End Type



'Pointers:
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(0 To 1) As SAFEARRAYBOUND
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type



Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long


' Note for VB5, change the lib name to "msvbvm50.dll"
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" …

finally i speed up my code severy:

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

    'Testing if we have image before we use it:
    If (hBitmap = 0 Or hMemDC = 0) Then Exit Sub

    '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:
    Dim y As Long
    Dim PosX As Long
    Dim PosY As Long

    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 DestinationHDC, OriginPoint.x, OriginPoint.y, DestinationPoint.x - OriginPoint.x, 1, hMemDC, 0, PosY, Width, 1, AC_SRC_ALPHA * &H1000000 + Opacity * &H10000
    Next y
End Sub

now the image can be drawed transparency.... and i can, too, make 1 color transparent, changing the alpha value.
using the image size, i can tile it too ;)
thanks for all

"PS. If the discussion title is changed I must remove some of my answers as they would no longer apply. My vote is to leave the title as-is. My suggestion is that you work on your other post where the code was revealed as well as discuss and reveal what the host PC looks like. Sometimes I've run into developers that are on decade plus old dual core PCs with onboard graphics. We try their app on one of our office dev systems and the performance is fine."
now i can't edit it... moderator maybe see these next message.

"How do you know the U and L bound calls are the speed hits here and not the more usual areas? Did you profile and measure the times spent on each operation?"
i don't know.. but i win severy speed.... but i need more help.... so i will create a new topic ;)

let me ask 2 things:
1 - i never used Directx, but it's best start 8 or 9 version?(yes i can use both on my VB6)
yes Directx seems a little complex, so i must start from begining until i start it ;)
2 - why the GDI and GDI+ functions don't use GPU?
Moderator: please change the topic title to "VB6: how we get more speed on Graphics?"

without use DirectX, how can i get rendering\graphics speed?
i created an Image class that uses DIB's... but something seems wrong for i draw in a pixel way.. too slow, maybe because i'm trying getting the line, 3D, points.
maybe someone can give me more info:

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 …

my problem is graphics.. very slow, even using DIB's... i'm trying win more speed, but isn't easy :(

i have 1 function that give me an array of a line points...
on these array, how can i get the array size without using the UBound() and LBound()?

i need ask more 2 things:
1 - imagine the line starts on X, Y and Z(10, 20, 40) and ends on X, Y and Z(20, 40, 80)...
using the while() or even for(), how can i walk throw the line points? (like walk on hippotenuse);

2 - how can i add the speed on movement? the same way goes for jump(even on a circle jump)?

if it's to much math questions, you can put me on right tutorial ;)

if i have X,Y(10,20) and the speed is 2, will be:
X = X + 2
Y = Y + 2
?
same goes for Z or it depends on direction?(Y or X rotation)

thank you so much, but i was asking if is normal do it for planes(like floor)?

thank you so much
with sometime i will fix my function..
let me ask you 1 thing: the plane, on world 3D, is drawed using several triangles?

yes some languages uses DirectX ou even OpenGL(or others)... the C\C++ have Directx, but OpenGL must be added...
DirectX is for Windows, but OpenGL(i think) can be used on any Operation System.
even API functions are for Windows but never Linux...
to be honest i'm using in Math way for learn.... i even, by me, learned how create a compiler.... it's just a translater: convert the new language to C\C++ and then the free C\C++ compiler make the exe.. isn't finished, but it's in good way ;)

to be honest i'm sorry something... i did that by 1 reason, but not all agree with it :(
i'm trying learning what i can about it, but isn't easy... and i'm not on school\university.... i'm learning these area by me and start(i repeat) start without a big book(hundreds or thousdans pages)... after that i'm more close to understand the book(English... i'm Portuguese.
i'm sorry something but isn't for be rude... sometimes isn't easy

the floor, for exemple is more big than camera... so how can i show the floor using the camera position?
here at least the Z is the same

i'm sorry, but why you said that?