Attribute VB_Name = "B3D"
Option Explicit

Global VertexBuffer() As Single
Dim matrix4() As Single
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function Polyline Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
'Private Declare Function GrFillTriangle Lib "msimg32" Alias "GradientFill" (ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_TRIANGLE, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
Private Declare Function GrFillTriangle Lib "gdi32" Alias "GdiGradientFill" (ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_TRIANGLE, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

'texturahoz
Private Declare Function GdiTransparentBlt Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Private Declare Function PlgBlt Lib "gdi32" (ByVal hdcDest As Long, _
                                    lpPoint As POINTAPI, _
                                    ByVal hdcSrc As Long, _
                                    ByVal nXSrc As Long, _
                                    ByVal nYSrc As Long, _
                                    ByVal nWidth As Long, _
                                    ByVal nHeight As Long, _
                                    ByVal hbmMask As Long, _
                                    ByVal xMask As Long, _
                                    ByVal yMask As Long) As Long
                                    
Private Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
'***

Const GRADIENT_FILL_TRIANGLE As Long = &H2

Private Type POINTAPI
        X As Long
        Y As Long
End Type


Private Type GRADIENT_TRIANGLE
    Vertex1 As Long
    Vertex2 As Long
    Vertex3 As Long
End Type

Type Rect2D 'shelf
Xmin As Single
Ymin As Single
Xmax As Single
Ymax As Single
End Type

Private Type Point3D 'shelf
X As Single
Y As Single
z As Single
End Type

Private Type Point2D 'shelf
  X As Single
  Y As Single
End Type

Private Type TRIVERTEX
   X As Long
    Y As Long
    Red As Integer 'Ushort value
    Green As Integer 'Ushort value
    Blue As Integer 'ushort value
    Alpha As Integer 'ushort
End Type


Sub Render3dFilled(pic As PictureBox)
On Error Resume Next
    pic.ScaleMode = vbPixels
    pic.AutoRedraw = True
    Dim ret As Single
Dim eltol As Integer
Dim t As Integer
Dim vert(4) As TRIVERTEX
Dim gTRi(1) As GRADIENT_TRIANGLE
Dim kx, ky As Single
kx = pic.ScaleWidth / 2
ky = pic.ScaleHeight / 2
Dim n As Single
Dim Aa As Point3D: Dim Bb As Point3D: Dim Cc As Point3D

For t = 1 To UBound(VertexBuffer, 1)
        
    vert(0).X = VertexBuffer(t, 28) + kx
    vert(0).Y = VertexBuffer(t, 29) + ky
        
    vert(1).X = VertexBuffer(t, 31) + kx
    vert(1).Y = VertexBuffer(t, 32) + ky
        
    vert(2).X = VertexBuffer(t, 34) + kx
    vert(2).Y = VertexBuffer(t, 35) + ky
         
         
         
   'culling
    If Form1.Check5.Value = 1 Then
  n = (vert(0).Y - vert(2).Y) * (vert(1).X - vert(0).X) - (vert(0).X - vert(2).X) * (vert(1).Y - vert(0).Y)
If n < 0 Then GoTo noout
End If

'shading calac
If Form1.Check10.Value = 1 Then
    Aa.X = VertexBuffer(t, 28)
    Aa.Y = VertexBuffer(t, 29)
    Aa.z = VertexBuffer(t, 30)
    Bb.X = VertexBuffer(t, 31)
    Bb.Y = VertexBuffer(t, 32)
    Bb.z = VertexBuffer(t, 33)
    Cc.X = VertexBuffer(t, 34)
    Cc.Y = VertexBuffer(t, 35)
    Cc.z = VertexBuffer(t, 36)
    ret = B3D.NormalCalc(Aa, Bb, Cc) * 255
End If

'If ret = 1 '0 Then ret = 1
Form1.Text7 = (ret * 10) \ 10
'gradientfill
ret = Val(Form1.Text7) * 100


If Form1.Check8.Value = 1 Then
    vert(0).Red = ret 'VertexBuffer(t, 10) / ret'
    vert(0).Green = ret 'VertexBuffer(t, 11) / ret
    vert(0).Blue = ret 'VertexBuffer(t, 12) / ret
    vert(0).Alpha = 0&
    vert(1).Red = ret 'VertexBuffer(t, 13) / ret
    vert(1).Green = ret 'VertexBuffer(t, 14) / ret
    vert(1).Blue = ret 'VertexBuffer(t, 15) / ret
    vert(1).Alpha = 0&
    vert(2).Red = ret 'VertexBuffer(t, 16) / ret
    vert(2).Green = ret 'VertexBuffer(t, 17) / ret
    vert(2).Blue = ret 'VertexBuffer(t, 18) / ret
    vert(2).Alpha = 0&
    
    gTRi(0).Vertex1 = 0
    gTRi(0).Vertex2 = 1
    gTRi(0).Vertex3 = 2
    
Call GrFillTriangle(pic.hdc, vert(0), 4, gTRi(0), 1, GRADIENT_FILL_TRIANGLE)
End If

'fill
If Form1.Check8.Value = 0 Then
ret = ret / 120
pic.FillColor = ret + ret * 255 + (ret * 255 * 255)
pic.ForeColor = pic.FillColor
Dim triangle(2) As POINTAPI
triangle(0).X = vert(0).X
triangle(0).Y = vert(0).Y
triangle(1).X = vert(1).X
triangle(1).Y = vert(1).Y
triangle(2).X = vert(2).X
triangle(2).Y = vert(2).Y
Call Polygon(pic.hdc, triangle(0), 3)
End If

noout:
    
    Next t

End Sub

Sub Render3dWired(pic As PictureBox)
    pic.ScaleMode = vbPixels
    pic.AutoRedraw = True
    pic.FillStyle = 0
    
Dim Pts(0 To 3) As POINTAPI
Dim t As Integer
Dim kx, ky As Single
kx = pic.ScaleWidth / 2
ky = pic.ScaleHeight / 2

Dim n As Single
For t = 0 To UBound(VertexBuffer, 1)
pic.ForeColor = Abs(VertexBuffer(t, 10))
    Pts(0).X = VertexBuffer(t, 28) + kx: Pts(0).Y = VertexBuffer(t, 29) + ky
    Pts(1).X = VertexBuffer(t, 31) + kx: Pts(1).Y = VertexBuffer(t, 32) + ky
    Pts(2).X = VertexBuffer(t, 34) + kx: Pts(2).Y = VertexBuffer(t, 35) + ky
    Pts(3).X = VertexBuffer(t, 28) + kx: Pts(3).Y = VertexBuffer(t, 29) + ky
    
    'culling
    If Form1.Check5.Value = 1 Then
 n = (Pts(0).Y - Pts(2).Y) * (Pts(1).X - Pts(0).X) - (Pts(0).X - Pts(2).X) * (Pts(1).Y - Pts(0).Y)
If n < 0 Then GoTo noout
End If

'out
If Form1.Check9.Value = 1 Then Call Polyline(pic.hdc, Pts(0), 4)
If Form1.Check9.Value = 0 Then
MoveToEx pic.hdc, Pts(0).X, Pts(0).Y, Pts(3)
'Draw a line from the active point to the given point
LineTo pic.hdc, Pts(1).X, Pts(1).Y
LineTo pic.hdc, Pts(2).X, Pts(2).Y
LineTo pic.hdc, Pts(0).X, Pts(0).Y
'pic.Line (Pts(0).X, Pts(0).Y)-(Pts(1).X, Pts(1).Y)
'pic.Line -(Pts(2).X, Pts(2).Y)
'pic.Line -(Pts(0).X, Pts(0).Y)

End If
noout:
Next t

End Sub

Sub Zsorting()
ReDim matrix4(UBound(VertexBuffer, 1), UBound(VertexBuffer, 2))
Dim maxx As Integer
Dim t As Integer
Dim sz As Integer
Dim A, B, C As Single
maxx = UBound(VertexBuffer, 1)

For t = 1 To UBound(VertexBuffer, 1)
'Z sorting**********************************
'z calculate
A = VertexBuffer(t, 30)
B = VertexBuffer(t, 33)
C = VertexBuffer(t, 36)
'If a < b Then a = b
'If c > a Then a = c ' a=a legnyobb Z
VertexBuffer(t, 0) = A + B + C
Next t

'*******************
'sorting
Dim aaa As Single
sz = 1
eleje:
Do Until sz = maxx
aaa = -9998

For t = sz To maxx
If VertexBuffer(t, 0) > aaa Then B = t: aaa = VertexBuffer(t, 0)
Next t


Dim tt As Integer
For tt = 0 To 36
VertexBuffer(0, tt) = VertexBuffer(B, tt)
VertexBuffer(B, tt) = VertexBuffer(sz, tt)
VertexBuffer(sz, tt) = VertexBuffer(0, tt)
'VertexBuffer(sz, 0) = 44
Next tt
sz = sz + 1
'If sz > 9999 Then Exit Sub
Loop




End Sub


Function beolvas()

Dim t, tt, ttt As Integer
Dim A As String
ReDim matrix4(19000, 36)
Open App.Path & "\" & Form1.File1 For Input As #1
t = 1: tt = 1
Do While Not EOF(1)
Line Input #1, A
If Mid(A, 1, 1) <> "#" And Mid(A, 1, 1) <> "*" Then
matrix4(t, tt) = Val(A) / 3: tt = tt + 1
End If
If tt = 10 Then t = t + 1: tt = 1: Form1.Caption = t - 1

Loop
Form1.Caption = t - 1
Close #1
ttt = t
ReDim VertexBuffer(t - 1, 36)
For t = 0 To ttt - 1
For tt = 0 To 36
VertexBuffer(t, tt) = matrix4(t, tt) * Form1.HScroll4
Next tt
Next t

End Function



Function NormalCalc(A As Point3D, B As Point3D, C As Point3D) As Single
'NORMALSZAMOLO 2

'p1x = A.X
'p1y = A.Y
'p1z = A.Z
'p2x = B.X
'p2y = B.Y
'p2z = B.Z
'p3x = C.X
'p3y = C.Y
'p3z = C.Z

'v1x = p1x - p2x
'v1y = p1y - p2y
'v1z = p1z - p2z
'v2x = p2x - p3x
'v2y = p2y - p3y
'v2z = p2z - p3z

'n1 = v1y * v2z - v1z * v2y
'n2 = v1z * v2x - v1x * v2z
'n3 = v1x * v2y - v1y * v2x


Dim n1, n2, n3 As Single
n1 = (A.Y - B.Y) * (B.z - C.z) - (A.z - B.z) * (B.Y - C.Y)
n2 = (A.z - B.z) * (B.X - C.X) - (A.X - B.X) * (B.z - C.z)
n3 = (A.X - B.X) * (B.Y - C.Y) - (A.Y - B.Y) * (B.X - C.X)


Dim HOSSZ As Single
HOSSZ = Sqr(n1 * n1 + n2 * n2 + n3 * n3)

If HOSSZ = 0 Then HOSSZ = 1

n1 = n1 / HOSSZ
n2 = n2 / HOSSZ
n3 = n3 / HOSSZ


NormalCalc = n1 * n1


End Function


 Function Rotate3D(Xan As Single, YAN As Single, ZAN As Single)
Dim xt As Single
Dim yt As Single
Dim zt As Single
Dim X, Y, z As Single
Dim cosxan As Single
Dim coszan As Single
Dim cosyan As Single
Dim sinxan As Single
Dim sinzan As Single
Dim sinyan As Single

Xan = Xan / 57.324
YAN = YAN / 57.324
ZAN = ZAN / 57.324

sinxan = Sin(Xan): sinyan = Sin(YAN): sinzan = Sin(ZAN)
cosxan = Cos(Xan): cosyan = Cos(YAN): coszan = Cos(ZAN)


Dim t As Integer


'a
For t = 0 To UBound(VertexBuffer, 1)
X = VertexBuffer(t, 1)
Y = VertexBuffer(t, 2)
z = VertexBuffer(t, 3)
xt = X * coszan - Y * sinzan
yt = X * sinzan + Y * coszan
X = xt
Y = yt
yt = Y * cosxan - z * sinxan
zt = Y * sinxan + z * cosxan
Y = yt
z = zt
xt = X * cosyan - z * sinyan
zt = X * sinyan + z * cosyan
VertexBuffer(t, 28) = xt
VertexBuffer(t, 29) = yt
VertexBuffer(t, 30) = zt
Next t

'b
For t = 0 To UBound(VertexBuffer, 1)
X = VertexBuffer(t, 4)
Y = VertexBuffer(t, 5)
z = VertexBuffer(t, 6)
xt = X * coszan - Y * sinzan
yt = X * sinzan + Y * coszan
X = xt
Y = yt
yt = Y * cosxan - z * sinxan
zt = Y * sinxan + z * cosxan
Y = yt
z = zt
xt = X * cosyan - z * sinyan
zt = X * sinyan + z * cosyan
VertexBuffer(t, 31) = xt
VertexBuffer(t, 32) = yt
VertexBuffer(t, 33) = zt
Next t

'c
For t = 0 To UBound(VertexBuffer, 1)
X = VertexBuffer(t, 7)
Y = VertexBuffer(t, 8)
z = VertexBuffer(t, 9)
xt = X * coszan - Y * sinzan
yt = X * sinzan + Y * coszan
X = xt
Y = yt
yt = Y * cosxan - z * sinxan
zt = Y * sinxan + z * cosxan
Y = yt
z = zt
xt = X * cosyan - z * sinyan
zt = X * sinyan + z * cosyan
VertexBuffer(t, 34) = xt
VertexBuffer(t, 35) = yt
VertexBuffer(t, 36) = zt
Next t

End Function

Sub Render3dTextured(pic As PictureBox)
    pic.ScaleMode = vbPixels
    pic.AutoRedraw = True
    Dim ret As Single
Dim eltol As Integer
Dim t As Integer
Dim vert(4) As TRIVERTEX
Dim gTRi(1) As GRADIENT_TRIANGLE
Dim kx, ky As Single
kx = pic.ScaleWidth / 2
ky = pic.ScaleHeight / 2
Dim n As Single
Dim Aa As Point3D: Dim Bb As Point3D: Dim Cc As Point3D

For t = 0 To UBound(VertexBuffer, 1)
        
    vert(0).X = VertexBuffer(t, 28) + kx
    vert(0).Y = VertexBuffer(t, 29) + ky
        
    vert(1).X = VertexBuffer(t, 31) + kx
    vert(1).Y = VertexBuffer(t, 32) + ky
        
    vert(2).X = VertexBuffer(t, 34) + kx
    vert(2).Y = VertexBuffer(t, 35) + ky
         
         
         
   'culling
    If Form1.Check5.Value = 1 Then
  n = (vert(0).Y - vert(2).Y) * (vert(1).X - vert(0).X) - (vert(0).X - vert(2).X) * (vert(1).Y - vert(0).Y)
If n < 0 Then GoTo noout
End If

'shading calac
    Aa.X = VertexBuffer(t, 28)
    Aa.Y = VertexBuffer(t, 29)
    Aa.z = VertexBuffer(t, 30)
    Bb.X = VertexBuffer(t, 31)
    Bb.Y = VertexBuffer(t, 32)
    Bb.z = VertexBuffer(t, 33)
    Cc.X = VertexBuffer(t, 34)
    Cc.Y = VertexBuffer(t, 35)
    Cc.z = VertexBuffer(t, 36)
If Form1.Check10.Value = 1 Then
        ret = B3D.NormalCalc(Aa, Bb, Cc) * 120
End If
'ua
'*********************************************
'Form1.Picture2 = Form1.Picture5
'kitakar  kek haromszoggel

Dim Pts(2) As POINTAPI
Dim PPts(2) As POINTAPI
Static kirakva As Integer

If kirakva = 0 Then
'kitakar1
If Form1.Check19.Value = 1 Then
Pts(0).X = Form1.Picture5.ScaleWidth
Pts(0).Y = 0
Pts(1).X = Form1.Picture5.ScaleWidth
Pts(1).Y = Form1.Picture5.ScaleHeight
Pts(2).X = 0
Pts(2).Y = Form1.Picture5.ScaleHeight

5 Call Polygon(Form1.Picture5.hdc, Pts(0), 3)
kirakva = 1
End If
End If


'plgblt
PPts(0).X = vert(1).X ' Put first point into the point array
PPts(0).Y = vert(1).Y
PPts(1).X = vert(2).X  ' Put second point into the point array
PPts(1).Y = vert(2).Y
PPts(2).X = vert(0).X  ' Put third point into the point array
PPts(2).Y = vert(0).Y

Call PlgBlt(Form1.Picture3.hdc, PPts(0), Form1.Picture5.hdc, 0, 0, Form1.Picture5.ScaleWidth, _
Form1.Picture5.ScaleHeight, 0, 0, 0)


If Form1.Check19.Value = 0 Then
'kitakar2
Dim ccx, ccy, kcx, kcy As Single
Pts(0).X = PPts(2).X
Pts(0).Y = PPts(2).Y
Pts(1).X = PPts(1).X
Pts(1).Y = PPts(1).Y
Pts(2).X = PPts(0).X
Pts(2).Y = PPts(0).Y
ccx = (PPts(1).X + PPts(2).X) / 2
ccy = (PPts(1).Y + PPts(2).Y) / 2
kcx = PPts(0).X - ccx
kcy = PPts(0).Y - ccy
Pts(2).X = ccx - kcx
Pts(2).Y = ccy - kcy
Call Polygon(Form1.Picture3.hdc, Pts(0), 3)
End If


'atmasol a kepre
Dim BBox As Rect2D
BBox = B3D.BoxMM(PPts(0), PPts(1), PPts(2))


If BBox.Xmin < 0 Then BBox.Xmin = 0
If BBox.Ymin < 0 Then BBox.Ymin = 0
If BBox.Xmax > pic.ScaleWidth Then BBox.Xmax = pic.ScaleWidth
If BBox.Ymax > pic.ScaleHeight Then BBox.Ymax = pic.ScaleHeight

'Form1.Picture1.Line (BBox.Xmin, BBox.Ymin)-(BBox.Xmax, BBox.Ymax), vbRed, B
GdiTransparentBlt Form1.Picture1.hdc, BBox.Xmin, BBox.Ymin, BBox.Xmax - BBox.Xmin, BBox.Ymax - BBox.Ymin, Form1.Picture3.hdc, BBox.Xmin, BBox.Ymin, BBox.Xmax - BBox.Xmin, BBox.Ymax - BBox.Ymin, vbBlue

noout:
Next t

End Sub



Private Function BoxMM(aw As POINTAPI, bw As POINTAPI, cw As POINTAPI) As Rect2D

BoxMM.Xmax = aw.X
If BoxMM.Xmax < bw.X Then BoxMM.Xmax = bw.X
If BoxMM.Xmax < cw.X Then BoxMM.Xmax = cw.X

BoxMM.Ymax = aw.Y
If BoxMM.Ymax < bw.Y Then BoxMM.Ymax = bw.Y
If BoxMM.Ymax < cw.Y Then BoxMM.Ymax = cw.Y

BoxMM.Xmin = aw.X
If BoxMM.Xmin > bw.X Then BoxMM.Xmin = bw.X
If BoxMM.Xmin > cw.X Then BoxMM.Xmin = cw.X

BoxMM.Ymin = aw.Y
If BoxMM.Ymin > bw.Y Then BoxMM.Ymin = bw.Y
If BoxMM.Ymin > cw.Y Then BoxMM.Ymin = cw.Y

End Function

Sub Perspektive()
Dim t As Integer
Dim z As Single
For t = 0 To UBound(VertexBuffer, 1)
z = VertexBuffer(t, 30) / Form1.HScroll5
VertexBuffer(t, 28) = VertexBuffer(t, 28) / (z + 1)
VertexBuffer(t, 29) = VertexBuffer(t, 29) / (z + 1)
z = VertexBuffer(t, 33) / Form1.HScroll5
VertexBuffer(t, 31) = VertexBuffer(t, 31) / (z + 1)
VertexBuffer(t, 32) = VertexBuffer(t, 32) / (z + 1)
z = VertexBuffer(t, 36) / Form1.HScroll5
VertexBuffer(t, 34) = VertexBuffer(t, 34) / (z + 1)
VertexBuffer(t, 35) = VertexBuffer(t, 35) / (z + 1)
Next t
End Sub

Sub TextureNorm(mode As Integer)
MsgBox "miez"
'If forgat = 1 Then

'PPts(0).X = bx ' Put first point into the point array
'PPts(0).Y = By
'PPts(1).X = cx ' Put second point into the point array
'PPts(1).Y = cy
'PPts(2).X = ax ' Put third point into the point array
'PPts(2).Y = ay
'End If

'If forgat = 2 Then
'PPts(0).X = cx ' Put first point into the point array
'PPts(0).Y = cy
'PPts(1).X = ax ' Put second point into the point array
'PPts(1).Y = ay
'PPts(2).X = bx ' Put third point into the point array
'PPts(2).Y = By
'End If
End Sub
