Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
'
' Case %IDM_RotateLeft : RotateAboutYAxis 0.03 * -1 : PipeLine
' Case %IDM_RotateRight : RotateAboutYAxis 0.03 * +1 : PipeLine
' Case %IDM_RotateUp : RotateAboutXAxis 0.03 * +1 : PipeLine
' Case %IDM_RotateDown : RotateAboutXAxis 0.03 * -1 : PipeLine
' Case %IDM_ZoomIn : ChangeSize +1 : PipeLine
' Case %IDM_ZoomOut : ChangeSize -1 : PipeLine
' Case %IDM_MoveUp : MoveUp : PipeLine
' Case %IDM_MoveDown : MoveDown : PipeLine
' Case %IDM_MoveLeft : MoveLeft : PipeLine
' Case %IDM_MoveRight : MoveRight : PipeLine
' Case %IDM_PGradient, %IDT_Settings : PGradient = PGradient Xor 1 : DrawBlocks : SetMenusAndToolbar
' Case %IDM_ShowLines : ShowLines = ShowLines Xor 1 : DrawBlocks : SetMenusAndToolbar
' Case %IDM_RotateAboutXAxis : RotateX = RotateX Xor 1
' Case %IDM_RotateAboutYAxis : RotateY = RotateY Xor 1
'
#Compile Exe "gbblocks_mini.exe"
#Dim All
#Debug Error On 'catch array/pointer errors - OFF in production
#Debug Display On 'display untrapped errors - OFF in production
%Unicode = 1
#Include "win32api.inc"
#Resource Manifest, 1, "files\xptheme.xml"
Type PointX
X As Single
Y As Single
Z As Single
Xo As Single
Yo As Single
Zo As Single
Xp As Single
Yp As Single
Color As Long
ColorG As Long
End Type
Type TriangleX
p1 As Long
p2 As Long
p3 As Long
ZDepthO As Single
Color As Long
ColorG As Long
ZDepth As Single
DotProduct As Single
End Type
Type Cube
P1 As PointX
P2 As PointX
P3 As PointX
P4 As PointX
P5 As PointX
P6 As PointX
P7 As PointX
P8 As PointX
Color As Long
End Type
Type Polypoints
Count As Long
x1 As Single
y1 As Single
x2 As Single
y2 As Single
x3 As Single
y3 As Single
End Type
Type ImportSceneData
x0 As Long 'coordinates of bottom/upper/left
y0 As Long 'coordinates of bottom/upper/left
z0 As Long 'coordinates of bottom/upper/left
w As Long 'box x length
h As Long 'box y length
z As Long 'height
clr As Long 'color
End Type
Enum Equates Singular
IDC_Graphic = 500
TGradient = 0
TBlocks
TDefault
End Enum
Global hDlg, hGraphic As Dword
Global P(), POnly() As PointX, T() As TriangleX, OriginalPT As String
Global OffsetX, OffsetY, POV, Angle As Single
Global PointSize, RotateX, RotateY, DisplayType, BackFace, DepthSort, HideBlockOne As Long 'flags
Global BColor, BackColor, PGradient, OrigGraphicProc,ShowLines As Long
Global LineColor, PointColor, TriangleColor, TColorScheme, BlockExtCount, AutoScale As Long
Global D() As ImportSceneData, Cubes() As Cube
Global XHigh, XLow, YHigh, YLow, ZHigh, ZLow, THigh, TLow, FarthestPoint As Single
Global xPoints(), yPoints(), zPoints() As Long
Function PBMain()
Dialog New Pixels, 0, "gbMiniBlocks3D ",,, 600,600, %WS_OverlappedWindow Or %WS_ClipChildren, To hDlg
Control Add Graphic, hDlg, %IDC_Graphic, "", 0,0,600,600, %SS_Notify
Control Handle hDlg, %IDC_Graphic To hGraphic
Graphic Attach hDlg, %IDC_Graphic, ReDraw
Dialog Show Modal hDlg, Call DlgProc
End Function
CallBack Function DlgProc() As Long
Local iReturn, XDelta,YDelta As Long, pt As Point
Static SpinInWork,XLast,YLast As Long
Select Case Cb.Msg
Case %WM_InitDialog
RotateX = 1
RotateY = 1
Angle = 0.02
DisplayType = 3 '1dots 2line 3boxes
DepthSort = 1
BackFace = 1
PGradient = 0
BColor = 0
BackColor = %rgb_LightBlue
LineColor = %Yellow
PointColor = %Red
TriangleColor = &H80
ShowLines = 1
AutoScale = 1
PointSize = 5 '1,2,5,10
POV = 1000
TColorScheme = %TBlocks
HideBlockOne = 0
Graphic Color %Black, BColor
LoadDArray
BuildScenePointsTriangles
GetOffSets
CenterModel
ScaleToFit
PipeLine
OrigGraphicProc = SetWindowLong(GetDlgItem(hDlg, %IDC_Graphic), %GWL_WndProc, CodePtr(NewGraphicProc)) 'subclass a control
Case %WM_Destroy
SetWindowLong GetDlgItem(hDlg, %IDC_Graphic), %GWL_WNDPROC, OrigGraphicProc 'un-subclass, restore original window procedure
Case %WM_SetCursor
'monitors the 3 basic splitter bar mouse actions, lbuttondown, mousemose, lbuttonup
Select Case Hi(Word, Cb.LParam)
Case %WM_LButtonDown
iReturn = GetDlgCtrlID (Cb.WParam)
If iReturn = %IDC_Graphic Then
SpinInWork = 1
GetCursorPos pt 'pt has xy screen coordinates
ScreenToClient hGraphic, pt 'pt now has dialog client coordinates
XLast = Pt.x
YLast = Pt.y
End If
Case %WM_MouseMove
If SpinInWork Then
GetCursorPos pt 'pt has xy screen coordinates
ScreenToClient hGraphic, pt 'pt now has dialog client coordinates
XDelta = XLast - Pt.x
YDelta = YLast - Pt.y
If RotateX Then RotateAboutXAxis(YDelta * 0.02) : PipeLine
If RotateY Then RotateAboutYAxis(XDelta * 0.02 * -1) : PipeLine
XLast = pt.x
YLast = pt.y
End If
Case %WM_LButtonUp
SpinInWork = 0
End Select
End Select
End Function
Sub GetOffSets
Local w,h As Long
Control Get Size hDlg, %IDC_Graphic To w,h
OffsetX = w/2 : OffsetY = (h-65)/2
End Sub
Sub PipeLine
Local i As Long
Graphic Clear
If DepthSort = 1 Then
If DisplayType = 1 Then SortPointsByZDepth
If DisplayType = 2 Then SortTrianglesByZDepth
If DisplayType = 3 Then SortTrianglesByZDepth
ElseIf DisplayType = 1 Then
For i = 1 To UBound(P) : POnly(i) = P(i) : Next i
End If
If BackFace = 1 And DisplayType = 3 Then BackFaceCulling
ProjectToScreen
DrawBlocks
Graphic ReDraw
End Sub
Sub RotateAboutXAxis(Ang As Single)
Local i As Long, NewY, NewZ As Single
For i = 1 To UBound(P)
NewY = P(i).Y * Cos(Ang) - P(i).Z * Sin(Ang) 'X rotation
NewZ = P(i).Y * Sin(Ang) + P(i).Z * Cos(Ang) 'X rotation
P(i).Y = NewY : P(i).Z = NewZ
Next i
End Sub
Sub RotateAboutYAxis(Ang As Single)
Local i As Long, NewX, NewZ As Single
For i = 1 To UBound(P)
NewX = P(i).Z * Sin(Ang) + P(i).X * Cos(Ang) 'Y rotation
NewZ = P(i).Z * Cos(Ang) - P(i).X * Sin(Ang) 'Y rotation
P(i).X = NewX : P(i).Z = NewZ
Next I
End Sub
Sub SortPointsByZDepth
Local i As Long
For i = 1 To UBound(P) : POnly(i) = P(i) : Next i
Array Sort POnly(1), Call CustomPointSort 'sort POnly
End Sub
Function CustomPointSort(R As PointX, S As PointX) As Long
'sorts in ascending order by .z element
If R.z < S.z Then Function = -1 : Exit Function
If R.z > S.z Then Function = +1 : Exit Function
End Function
Sub SortTrianglesByZDepth
Local i As Long
If UBound(T) > 0 Then
For i = 1 To UBound(T)
T(i).ZDepth = (P(T(i).p1).Z + P(T(i).p2).Z + P(T(i).p3).Z) / 3
Next i
Array Sort T(1), Call CustomTriangleSort
End If
End Sub
Function CustomTriangleSort(R As TriangleX, S As TriangleX) As Long
'sorts in ascending order by .ZDepth element
If R.ZDepth < S.ZDepth Then Function = -1 : Exit Function
If R.ZDepth > S.ZDepth Then Function = +1 : Exit Function
End Function
Function BackFaceCulling() As Long
Dim i As Long
'use CrossProduct to find normal with (0,0,POV), put in P(0)
'get DotProduct between point of view and normal
If UBound(T) > 0 Then
For i = 1 To UBound(T)
ComputeCrossProduct i
T(i).DotProduct = ComputeDotProduct
Next i
End If
End Function
Sub ComputeCrossProduct(i As Long)
Dim x1 As Single, y1 As Single, z1 As Single, x2 As Single, y2 As Single, z2 As Single
'cross product defines a vector perpendicular to the triangle surface
'uses right-hand rule of thumb rule, sequence of points defines the surface (counter-clockwise)
'create position vectors to use in cross product
'this code uses points P1P2 and P2P3 line segments
'any 2 line segements from the triangle will do
x1 = P(T(i).p2).X - P(T(i).p1).X 'position vector, x component
y1 = P(T(i).p2).Y - P(T(i).p1).Y 'position vector, y component
z1 = P(T(i).p2).Z - P(T(i).p1).Z 'position vector, z component
x2 = P(T(i).p3).X - P(T(i).p1).X 'position vector, x component
y2 = P(T(i).p3).Y - P(T(i).p1).Y 'position vector, y component
z2 = P(T(i).p3).Z - P(T(i).p1).Z 'position vector, z component
'put resulting cross product vector in P(0) - just a conveniently unused position in the array
P(0).X = y1 * z2 - y2 * z1 'cross product vector, x component
P(0).Y = x2 * z1 - x1 * z2 'cross product vector, y component
P(0).Z = x1 * y2 - x2 * y1 'cross product vector, z component
End Sub
Function ComputeDotProduct() As Long
'uses POV vector 0,0,POV as x1,y1,z1
'used cross product that was stored in P(0) as x2, y2, z2
ComputeDotProduct = 0 * P(0).X + 0 * P(0).Y + POV * P(0).Z
End Function
Function ProjectToScreen() As Long
Local i As Long
For i = 1 To UBound(P)
If DisplayType = 1 Then
POnly(i).xp = POnly(i).x
POnly(i).yp = POnly(i).y
Else
P(i).xp = P(i).x
P(i).yp = P(i).y
End If
Next i
End Function
Sub DrawBlocks()
Local i,PColor,LColor,TColor As Long, x,y As Single, PTS As PolyPoints
PTS.Count = 3
Graphic Clear
Select Case DisplayType
Case 1 'points
For i = 1 To UBound(POnly)
If PGradient Then PColor = POnly(i).ColorG Else PColor = PointColor
x = POnly(i).xp + OffsetX : y = POnly(i).yp + OffsetY
Graphic Ellipse (x-PointSize,y-Pointsize)-(x+Pointsize,y+Pointsize), PColor, PColor, 0
Next i
Case 2 'lines
If UBound(T) > 0 Then
For i = 1 To UBound(T)
PTS.x1 = P(T(i).p1).xp + OffsetX : PTS.y1 = P(T(i).p1).yp + OffsetY
PTS.x2 = P(T(i).p2).xp + OffsetX : PTS.y2 = P(T(i).p2).yp + OffsetY
PTS.x3 = P(T(i).p3).xp + OffsetX : PTS.y3 = P(T(i).p3).yp + OffsetY
Graphic Polygon PTS, LineColor, -2, 0, 0 'Graphic Polyline PTS, LineColor
Next i
End If
Case 3 'surface
If UBound(T) > 0 Then
For i = 1 To UBound(T)
Select Case TColorScheme
Case %TGradient : TColor = T(i).ColorG
Case %TBlocks : TColor = T(i).Color
Case %TDefault : TColor = TriangleColor
End Select
' If Gradient Then TColor = T(i).ColorG Else TColor = TriangleColor
If ShowLines Then LColor = LineColor Else LColor = TColor
PTS.x1 = P(T(i).p1).xp + OffsetX : PTS.y1 = P(T(i).p1).yp + OffsetY
PTS.x2 = P(T(i).p2).xp + OffsetX : PTS.y2 = P(T(i).p2).yp + OffsetY
PTS.x3 = P(T(i).p3).xp + OffsetX : PTS.y3 = P(T(i).p3).yp + OffsetY
If (BackFace = 1 And T(i).DotProduct > 0 ) Or BackFace = 0 Then
Graphic Polygon PTS, LColor, TColor, 0, 0
End If
Next i
End If
End Select
Graphic ReDraw
End Sub
Sub SetPointHighLow()
Local i As Long
If UBound(p) = -1 Then
XHigh = 0: XLow = 0: YHigh = 0: YLow = 0: ZHigh = 0: ZLow = 0
Else
XHigh = P(1).xo: XLow = P(1).xo
YHigh = P(1).yo: YLow = P(1).yo
ZHigh = P(1).zo: ZLow = P(1).zo
For i = 2 To UBound(P)
If P(i).xo > XHigh Then XHigh = P(i).xo
If P(i).xo < XLow Then XLow = P(i).xo
If P(i).yo > YHigh Then YHigh = P(i).yo
If P(i).yo < YLow Then YLow = P(i).yo
If P(i).zo > ZHigh Then ZHigh = P(i).zo
If P(i).zo < ZLow Then ZLow = P(i).zo
Next i
End If
End Sub
Sub SetTriangleHighLow()
Local i As Long
If UBound(T) < 1 Then
THigh = 0: TLow = 0
Else
T(1).ZDepthO = (P(T(1).p1).Z + P(T(1).p2).Z + P(T(1).p3).Z) / 3
THigh = T(1).ZDepthO : TLow = T(1).ZdepthO
For i = 2 To UBound(T)
T(i).ZDepthO = (P(T(i).p1).Z + P(T(i).p2).Z + P(T(i).p3).Z) / 3
If T(i).ZDepthO > THigh Then THigh = T(i).ZDepthO
If T(i).ZDepthO < TLow Then TLow = T(i).ZDepthO
Next i
End If
End Sub
Sub ResetModel
Local i As Long
For i = 1 To UBound(P)
P(i).x = P(i).xo : P(i).y = P(i).yo : P(i).z = P(i).zo
POnly(i).x = P(i).xo : POnly(i).y = P(i).yo : POnly(i).z = P(i).zo
Next i
End Sub
Sub CenterModel
Local i As Long, CenterX, CenterY, CenterZ As Single
CenterX = (XHigh + XLow)/2
CenterY = (YHigh + YLow)/2
CenterZ = (ZHigh + ZLow)/2
'move all nodes to center position
For i = 1 To UBound(P)
P(i).x = (P(i).xo - CenterX) : POnly(i).x = P(i).x
P(i).y = (P(i).yo - CenterY) : POnly(i).y = P(i).y
P(i).z = (P(i).zo - CenterZ) : POnly(i).z = P(i).z
Next i
End Sub
Sub ScaleToFit
Local i,w,h As Long, sTemp As Single
Local ScaleFactor, SMargin As Single
SMargin = 0.95
'get farthest point to use for setting scalefactor
FarthestPoint = 0
For i = 1 To UBound(P)
sTemp = Sqr(P(i).x*P(i).x + P(i).y*P(i).y + P(i).z*P(i).z)
If FarthestPoint < Abs(sTemp) Then FarthestPoint = Abs(sTemp)
Next i
Control Get Size hDlg, %IDC_Graphic To w,h
If h < w Then ScaleFactor = h /(2*FarthestPoint)*SMargin Else ScaleFactor = w/(2*FarthestPoint)*SMargin
'scale points to fit within graphic control
For i = 1 To UBound(P)
P(i).x = P(i).x * ScaleFactor : POnly(i).x = P(i).x
P(i).y = P(i).y * ScaleFactor : POnly(i).y = P(i).y
P(i).z = P(i).z * ScaleFactor : POnly(i).z = P(i).z
Next i
End Sub
Sub CreateSampleSphere()
Local i, j, iCount, TCount, iLayers, iDivisions As Long
Local SAngle, Radius, z, zStep, tempS As Single
iLayers = 20 : iDivisions = 20 : Radius = 100 : iCount = 1
ReDim P(iLayers * iDivisions + 2) 'position P(0) is reserved
ReDim POnly(iLayers * iDivisions + 2) 'position P(0) is reserved
ReDim T((iLayers-1)*iDivisions*2 + 4*iDivisions)
SAngle = 6.28 / iDivisions '1 radian = 57.2957 degrees : 1 degree = 0.0174532 radians
zStep = 2 * Radius / (iLayers+1)
'Points
P(iCount).x = 0 : P(iCount).y = 0 : P(iCount).z = Radius
P(UBound(P)).x = 0 : P(UBound(P)).y = 0 : P(UBound(P)).z = -1 * Radius
For i = 1 To iLayers
z = Radius - zStep * i
tempS = Sqr(Radius*Radius - z*z)
For j = 0 To iDivisions - 1
iCount = iCount + 1
P(iCount).x = tempS * Sin(j*SAngle)
P(iCount).y = tempS * Cos(j*SAngle)
P(iCount).z = z
Next j
Next i
For i = 1 To UBound(P)
P(i).xo = P(i).x : POnly(i).x = P(i).x
P(i).yo = P(i).y : POnly(i).y = P(i).y
P(i).zo = P(i).z : POnly(i).z = P(i).z
Next i
'triangles
'top layer
For i = 2 To iDivisions
Incr TCount : T(TCount).p1 = 1 : T(TCount).p2 = i+1 : T(TCount).p3 = i
Next i
Incr TCount : T(TCount).p1 = 1 : T(TCount).p2 = 2 : T(TCount).p3 = iDivisions + 1
'bottom layer
For i = UBound(P)-iDivisions To UBound(P)-1
Incr TCount : T(TCount).p1 = UBound(P) : T(TCount).p2 = i : T(TCount).p3 = i+1
Next i
Incr TCount : T(TCount).p1 = UBound(P) : T(TCount).p2 = UBound(P)-1 : T(TCount).p3 = UBound(P)-iDivisions
'other layers
For i = 1 To iLayers-1
iCount = (i-1)*iDivisions + 1
'most divisions
For j = 1 To iDivisions -1
Incr TCount
T(TCount).p1 = j + iCount
T(TCount).p2 = T(TCount).p1 + iDivisions + 1
T(TCount).p3 = T(TCount).p1 + iDivisions
Incr TCount
T(TCount).p1 = j + iCount
T(TCount).p2 = T(TCount).p1 + 1
T(TCount).p3 = T(TCount).p1 + iDivisions + 1
Next j
'last division
Incr TCount
T(TCount).p1 = iDivisions + iCount
T(TCount).p2 = 1 + iCount + iDivisions
T(TCount).p3 = iCount + iDivisions + iDivisions
Incr TCount
T(TCount).p1 = iDivisions + iCount
T(TCount).p2 = 1 + iCount
T(TCount).p3 = 1 + iCount + iDivisions
Next i
SetPointGradientColors
SetTriangleGradientColors
CreateOriginalPTString
End Sub
Sub CreateOriginalPTString
Local i As Long
OriginalPT = "Points:" 'OriginalPT + $CrLf + $CrLf + "Points:"
For i = 1 To UBound(P)
OriginalPT = OriginalPT + $CrLf + Format$(P(i).x,"00") + Format$(P(i).y," 00") + Format$(P(i).z," 00")
Next i
OriginalPT = OriginalPT + $CrLf + $CrLf + "Triangles:"
For i = 1 To UBound(T)
OriginalPT = OriginalPT + $CrLf + Str$(T(i).p1) + Str$(T(i).p2) + Str$(T(i).p3)
Next i
End Sub
Sub SetTriangleGradientColors
Local i As Long
If UBound(T) < 1 Then THigh = 0: TLow = 0 : Exit Sub
SetTriangleHighLow
If UBound(T) > 0 Then
For i = 1 To UBound(T)
T(i).ColorG = GradientZ(T(i).ZDepthO, THigh, TLow)
Next i
End If
End Sub
Sub SetPointGradientColors
Local i As Long
SetPointHighLow
For i = 1 To UBound(P)
P(i).ColorG = GradientZ(P(i).zo, ZHigh, ZLow) : POnly(i).ColorG = P(i).ColorG
Next i
End Sub
Function GradientZ(ZValue As Single, HiZ As Single, LoZ As Single) As Long
'returns Long color, and RGB components, across the entire spectrum based on position of a number between two limits
Local CRatio As Single, Exponent As Single
Local R,G,B As Long
Exponent = 0.365
If HiZ <> LoZ Then
CRatio = Abs((ZValue - LoZ) / (HiZ - LoZ))
Else
CRatio = 0
End If
If CRatio > 1 Then CRatio = 1
If CRatio < 0 Then CRatio = 0
Select Case CRatio
Case Is < 0.25
r = 0
g = 255 * (((CRatio - 0) * 4) ^ Exponent)
b = 255
Case Is < 0.5
r = 0
g = 255
b = 255 * ((1 - (CRatio - 0.25) * 4) ^ Exponent)
Case Is < 0.75
r = 255 * (((CRatio - 0.5) * 4) ^ Exponent)
g = 255
b = 0
Case Else
r = 255
g = 255 * ((1 - (CRatio - 0.75) * 4) ^ Exponent)
b = 0
End Select
Function = RGB(r, g, b)
End Function
Sub MoveUp
Local i As Long
For i = 1 To UBound(P)
P(i).y = P(i).y - 10 : POnly(i).y = P(i).y
Next i
End Sub
Sub MoveDown
Local i As Long
For i = 1 To UBound(P)
P(i).y = P(i).y + 10 : POnly(i).y = P(i).y
Next i
End Sub
Sub MoveLeft
Local i As Long
For i = 1 To UBound(P)
P(i).x = P(i).x - 10 : POnly(i).x = P(i).x
Next i
End Sub
Sub MoveRight
Local i As Long
For i = 1 To UBound(P)
P(i).x = P(i).x + 10 : POnly(i).x = P(i).x
Next i
End Sub
Sub ChangeSize (Flag As Long)
Local i As Long, Factor As Single
Factor = (1 + 0.2 * Flag)
For i = 1 To UBound(P)
P(i).x = P(i).x * Factor : POnly(i).x = P(i).x
P(i).y = P(i).y * Factor : POnly(i).y = P(i).y
P(i).z = P(i).z * Factor : POnly(i).z = P(i).z
Next i
End Sub
Sub BuildScenePointsTriangles
Local i, iPos, CubeCount, Z As Long
ReDim P(0), POnly(0), T(0), Cubes(0)
CubeCount = UBound(D)
ReDim Cubes(CubeCount)
BuildCubesFromImportScene
'get list of all xyz points
i = UBound(Cubes) * 2 : z = 0
ReDim xPoints(i), yPoints(i), zPoints(i) As Long
For i = 1 To UBound(Cubes)
z = (i-1) * 2 + 1
xPoints(z) = Cubes(i).p1.x
yPoints(z) = Cubes(i).p1.y
zPoints(z) = Cubes(i).p1.z
Incr z
xPoints(z) = Cubes(i).p2.x
yPoints(z) = Cubes(i).p4.y
zPoints(z) = Cubes(i).p5.z
Next i
'sort the arrays
Array Sort xpoints() : Array Sort ypoints() : Array Sort zpoints()
'remove duplicates in xpoints, ypoints, zpoints
iPos = 0
For i = UBound(xpoints) To 2 Step -1
If xpoints(i) = xpoints(i-1) Then Array Delete xpoints(i) : Incr iPos
Next i
ReDim Preserve xpoints(UBound(xpoints)-iPos)
iPos = 0
For i = UBound(ypoints) To 2 Step -1
If ypoints(i) = ypoints(i-1) Then Array Delete ypoints(i) : Incr iPos
Next i
ReDim Preserve ypoints(UBound(ypoints)-iPos)
iPos = 0
For i = UBound(zpoints) To 2 Step -1
If zpoints(i) = zpoints(i-1) Then Array Delete zpoints(i) : Incr iPos
Next i
ReDim Preserve zpoints(UBound(zpoints)-iPos)
'create cubes
BlockExtCount = 0
For i = 1 To UBound(Cubes)
CreateSubDividedCubes Cubes(i), Cubes(i).Color
Next i
SetPointGradientColors
SetTriangleGradientColors
End Sub
Sub BuildCubesFromImportScene
Local i,w,h,z As Long
ReDim Cubes(UBound(D))
For i = 1 To UBound(D)
If i = 1 And HideBlockOne Then Iterate For
w = D(i).w
h = D(i).h
z = D(i).z
Cubes(i).p1.x = D(i).x0
Cubes(i).p1.y = D(i).y0
Cubes(i).p1.z = D(i).z0
Cubes(i).p2.x = D(i).x0 + w
Cubes(i).p2.y = D(i).y0
Cubes(i).p2.z = D(i).z0
Cubes(i).p3.x = D(i).x0 + w
Cubes(i).p3.y = D(i).y0 + h
Cubes(i).p3.z = D(i).z0
Cubes(i).p4.x = D(i).x0
Cubes(i).p4.y = D(i).y0 + h
Cubes(i).p4.z = D(i).z0
Cubes(i).p5.x = D(i).x0
Cubes(i).p5.y = D(i).y0
Cubes(i).p5.z = D(i).z0 + z
Cubes(i).p6.x = D(i).x0 + w
Cubes(i).p6.y = D(i).y0
Cubes(i).p6.z = D(i).z0 + z
Cubes(i).p7.x = D(i).x0 + w
Cubes(i).p7.y = D(i).y0 + h
Cubes(i).p7.z = D(i).z0 + z
Cubes(i).p8.x = D(i).x0
Cubes(i).p8.y = D(i).y0 + h
Cubes(i).p8.z = D(i).z0 + z
Cubes(i).Color = D(i).clr
Next j
End Sub
Sub CreateSubDividedCubes (C As Cube, iColor As Long)
Local i,j,k As Long, tempC As Cube
For i = 1 To UBound(xpoints)
If xpoints(i) < c.p1.x Then Iterate For
If xpoints(i) >= c.p2.x Then Exit For
For j = 1 To UBound(ypoints)
If ypoints(j) < c.p1.y Then Iterate For
If ypoints(j) >= c.p4.y Then Exit For
For k = 1 To UBound(zpoints)
If zpoints(k) < c.p1.z Then Iterate For
If zpoints(k) >= c.p5.z Then Exit For
'create cube with boundaries
tempC.p1.x = xpoints(i)
tempC.p1.y = ypoints(j)
tempC.p1.z = zpoints(k)
tempC.p2.x = xpoints(i+1)
tempC.p2.y = ypoints(j)
tempC.p2.z = zpoints(k)
tempC.p3.x = xpoints(i+1)
tempC.p3.y = ypoints(j+1)
tempC.p3.z = zpoints(k)
tempC.p4.x = xpoints(i)
tempC.p4.y = ypoints(j+1)
tempC.p4.z = zpoints(k)
tempC.p5.x = xpoints(i)
tempC.p5.y = ypoints(j)
tempC.p5.z = zpoints(k+1)
tempC.p6.x = xpoints(i+1)
tempC.p6.y = ypoints(j)
tempC.p6.z = zpoints(k+1)
tempC.p7.x = xpoints(i+1)
tempC.p7.y = ypoints(j+1)
tempC.p7.z = zpoints(k+1)
tempC.p8.x = xpoints(i)
tempC.p8.y = ypoints(j+1)
tempC.p8.z = zpoints(k+1)
CreatePointsTriangleFromSubDividesCubes tempC, iColor
Incr BlockExtCount
Next k
Next j
Next i
End Sub
Sub CreatePointsTriangleFromSubDividesCubes(C As Cube, iColor As Long)
Local i,j,k As Long
j = UBound(P)
ReDim Preserve P(j+8)
ReDim Preserve POnly(j+8)
For i = j+1 To j+8 : P(i).Color = iColor : Next i
P(j+1).x = C.P1.x : P(j+1).y = C.P1.y : P(j+1).z = C.P1.z
P(j+2).x = C.P2.x : P(j+2).y = C.P2.y : P(j+2).z = C.P2.z
P(j+3).x = C.P3.x : P(j+3).y = C.P3.y : P(j+3).z = C.P3.z
P(j+4).x = C.P4.x : P(j+4).y = C.P4.y : P(j+4).z = C.P4.z
P(j+5).x = C.P5.x : P(j+5).y = C.P5.y : P(j+5).z = C.P5.z
P(j+6).x = C.P6.x : P(j+6).y = C.P6.y : P(j+6).z = C.P6.z
P(j+7).x = C.P7.x : P(j+7).y = C.P7.y : P(j+7).z = C.P7.z
P(j+8).x = C.P8.x : P(j+8).y = C.P8.y : P(j+8).z = C.P8.z
k = UBound(T)
ReDim Preserve T(k+12)
For i = k+1 To k+12 : T(i).Color = iColor : Next i
T(k+1).p1 = j+1 : T(k+1).p2 = j+4 : T(k+1).p3 = j+3
T(k+2).p1 = j+1 : T(k+2).p2 = j+3 : T(k+2).p3 = j+2
T(k+3).p1 = j+5 : T(k+3).p2 = j+1 : T(k+3).p3 = j+2
T(k+4).p1 = j+5 : T(k+4).p2 = j+2 : T(k+4).p3 = j+6
T(k+5).p1 = j+8 : T(k+5).p2 = j+5 : T(k+5).p3 = j+6
T(k+6).p1 = j+8 : T(k+6).p2 = j+6 : T(k+6).p3 = j+7
T(k+7).p1 = j+4 : T(k+7).p2 = j+8 : T(k+7).p3 = j+7
T(k+8).p1 = j+4 : T(k+8).p2 = j+7 : T(k+8).p3 = j+3
T(k+9).p1 = j+3 : T(k+9).p2 = j+7 : T(k+9).p3 = j+6
T(k+10).p1 = j+3 : T(k+10).p2 = j+6 : T(k+10).p3 = j+2
T(k+11).p1 = j+4 : T(k+11).p2 = j+1 : T(k+11).p3 = j+5
T(k+12).p1 = j+4 : T(k+12).p2 = j+5 : T(k+12).p3 = j+8
For i = j To UBound(P)
P(i).xo = P(i).x : POnly(i).x = P(i).x
P(i).yo = P(i).y : POnly(i).y = P(i).y
P(i).zo = P(i).z : POnly(i).z = P(i).z
Next i
End Sub
Function NewGraphicProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case Msg
Case %WM_MouseWheel
Select Case Hi(Integer,WParam) 'note the use of Integer
Case > 0
ChangeSize 1
PipeLine
Case < 0
ChangeSize -1
PipeLine
End Select
End Select
Function = CallWindowProc(OrigGraphicProc, hWnd, Msg, wParam, lParam)
End Function
Function CustomAllPointSort(R As PointX, S As PointX) As Long
'sorts in ascending order by xyz elements
If R.z < S.z Then Function = -1 : Exit Function
If R.z > S.z Then Function = +1 : Exit Function
If R.y < S.y Then Function = -1 : Exit Function
If R.y > S.y Then Function = +1 : Exit Function
If R.x < S.x Then Function = -1 : Exit Function
If R.x > S.x Then Function = +1 : Exit Function
End Function
Sub LoadDArray
Local i As Long
Data 0, 0, 0, 420, 400, 20, 16744448
Data 60, 200, 20, 140, 140, 50, 33023
Data 120, 60, 20, 80, 80, 50, 8388863
Data 280, 80, 20, 120, 100, 50, 65408
Data 300, 280, 20, 80, 100, 50, 8421631
ReDim D(5) '0-based
XHigh=0 : YHigh=0 : ZHigh=0 : XLow=0 : YLow=0 : ZLow=0
For i = 1 To 5
D(i).x0 = Val(Read$((i-1)*7+1))
D(i).y0 = Val(Read$((i-1)*7+2))
D(i).z0 = Val(Read$((i-1)*7+3))
D(i).w = Val(Read$((i-1)*7+4))
D(i).h = Val(Read$((i-1)*7+5))
D(i).z = Val(Read$((i-1)*7+6))
D(i).clr = Val(Read$((i-1)*7+7))
XHigh = Max(XHigh,D(i).x0+D(i).w)
XLow = Min(XLow, D(i).x0+D(i).w)
YHigh = Max(YHigh,D(i).y0+D(i).h)
YLow = Min(YLow, D(i).y0+D(i).h)
ZHigh = Max(ZHigh,D(i).z0+D(i).z)
ZLow = Min(ZLow, D(i).z0+D(i).z)
Next i
End Sub
http://www.garybeene.com/sw/gbsnippets.htm