mesh.frm

 VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1
   Caption         =   "Tanner's 3D Mesh Creator"
   ClientHeight    =   5160
   ClientLeft      =   165
   ClientTop       =   450
   ClientWidth     =   8595
   FillColor       =   &H000000FF&
   FillStyle       =   0  'Solid
   ForeColor       =   &H00000000&
   LinkTopic       =   "Form1"
   ScaleHeight     =   344
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   573
   StartUpPosition =   2  'CenterScreen
   Begin MSComDlg.CommonDialog CommonDialog1
      Left            =   7200
      Top             =   1200
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      DefaultExt      =   ".msh"
      DialogTitle     =   "Open/Save Mesh File"
      Filter          =   "Mesh Files | *.msh"
   End
   Begin VB.PictureBox Picture3
      AutoRedraw      =   -1  'True
      BackColor       =   &H0000FF00&
      DrawWidth       =   4
      Height          =   2535
      Left            =   6000
      ScaleHeight     =   43.656
      ScaleMode       =   6  'Millimeter
      ScaleWidth      =   43.656
      TabIndex        =   15
      Top             =   2520
      Width           =   2535
   End
   Begin VB.CommandButton CmdReset
      Caption         =   "Reset the Matrix"
      Height          =   1815
      Left            =   4680
      TabIndex        =   14
      Top             =   120
      Width           =   2055
   End
   Begin VB.Frame FrameStuff
      Caption         =   "Preset Terrain Algorithms"
      Height          =   1935
      Left            =   0
      TabIndex        =   4
      Top             =   0
      Width           =   4575
      Begin VB.OptionButton Option2
         Caption         =   "Valley"
         Height          =   315
         Left            =   960
         TabIndex        =   19
         Top             =   1440
         Width           =   975
      End
      Begin VB.OptionButton Option1
         Caption         =   "Mountain"
         Height          =   255
         Left            =   960
         TabIndex        =   18
         Top             =   1200
         Value           =   -1  'True
         Width           =   1455
      End
      Begin VB.CommandButton CmdRandomize
         Caption         =   "Randomize "
         Height          =   375
         Left            =   120
         TabIndex        =   10
         Top             =   240
         Width           =   2295
      End
      Begin VB.TextBox TxtRandomize
         Height          =   375
         Left            =   3480
         TabIndex        =   9
         Text            =   "5"
         Top             =   240
         Width           =   975
      End
      Begin VB.CommandButton cmdRndFractal
         Caption         =   "Randomize w/fractal algorithm"
         Height          =   375
         Left            =   120
         TabIndex        =   8
         Top             =   720
         Width           =   2295
      End
      Begin VB.TextBox TxtRnd
         Height          =   285
         Left            =   3000
         TabIndex        =   7
         Text            =   "3"
         Top             =   720
         Width           =   375
      End
      Begin VB.TextBox TxtLoops
         Height          =   285
         Left            =   4080
         TabIndex        =   6
         Text            =   "15"
         Top             =   720
         Width           =   375
      End
      Begin VB.CommandButton CmdMountain
         Caption         =   "Create:"
         Height          =   495
         Left            =   120
         TabIndex        =   5
         Top             =   1200
         Width           =   735
      End
      Begin VB.Label Label1
         Caption         =   "Rnd Value:"
         Height          =   255
         Left            =   2520
         TabIndex        =   13
         Top             =   240
         Width           =   855
      End
      Begin VB.Label Label2
         Caption         =   "Rnd:"
         Height          =   255
         Left            =   2520
         TabIndex        =   12
         Top             =   720
         Width           =   375
      End
      Begin VB.Label Label3
         Caption         =   "Loops:"
         Height          =   375
         Left            =   3480
         TabIndex        =   11
         Top             =   720
         Width           =   495
      End
   End
   Begin VB.PictureBox Picture2
      Height          =   2535
      Left            =   0
      ScaleHeight     =   165
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   237
      TabIndex        =   1
      Top             =   2520
      Width           =   3615
   End
   Begin VB.PictureBox Picture1
      FillColor       =   &H000000FF&
      ForeColor       =   &H00000000&
      Height          =   2535
      Left            =   3720
      ScaleHeight     =   165
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   141
      TabIndex        =   0
      Top             =   2520
      Width           =   2175
   End
   Begin VB.Label Label6
      Caption         =   "Lowest point:"
      Height          =   255
      Left            =   6840
      TabIndex        =   22
      Top             =   480
      Width           =   1095
   End
   Begin VB.Label Label5
      Caption         =   "Highest point:"
      Height          =   255
      Left            =   6840
      TabIndex        =   21
      Top             =   120
      Width           =   1095
   End
   Begin VB.Label Label4
      Alignment       =   2  'Center
      Caption         =   "COLORFORM"
      BeginProperty Font
         Name            =   "Times New Roman"
         Size            =   18
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   2
      Left            =   6000
      TabIndex        =   20
      Top             =   2040
      Width           =   2535
   End
   Begin VB.Label LblHigh
      Caption         =   "0"
      Height          =   255
      Left            =   7920
      TabIndex        =   17
      Top             =   480
      Width           =   495
   End
   Begin VB.Label LblLow
      Caption         =   "0"
      Height          =   255
      Left            =   7920
      TabIndex        =   16
      Top             =   120
      Width           =   495
   End
   Begin VB.Label Label4
      Alignment       =   2  'Center
      Caption         =   "AERIAL VIEW"
      BeginProperty Font
         Name            =   "Times New Roman"
         Size            =   18
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   1
      Left            =   0
      TabIndex        =   3
      Top             =   2040
      Width           =   3615
   End
   Begin VB.Label Label4
      Alignment       =   2  'Center
      Caption         =   "TOP VIEW"
      BeginProperty Font
         Name            =   "Times New Roman"
         Size            =   18
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   0
      Left            =   3720
      TabIndex        =   2
      Top             =   2040
      Width           =   2175
   End
   Begin VB.Menu mnufile
      Caption         =   "&File"
      Begin VB.Menu mnusave
         Caption         =   "&Save mesh file"
      End
      Begin VB.Menu mnuload
         Caption         =   "&Load mesh file"
      End
      Begin VB.Menu mnusepbar1
         Caption         =   "-"
      End
      Begin VB.Menu mnuexit
         Caption         =   "&Exit"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'3D Mesh example by Tanner Helland

'Here is an awesome example of how a little bit of ingenuity and a
'little bit of math can create incredible graphic effects.  This
'project uses simulated terraforming to create the effect of a
'3D landscape.  The code is mostly a lot of line drawing, and is
'somewhat complex, but after a while it should make some sense.

'Feel free to use this code however you want, but please give
'me some credit and let me know how you use it.  E-mail me with
'comments or questions at tannerhelland@hotmail.com.

'Also, if you like graphic-based programming, look for some
'of my other projects at www.planet-source-code.com.  Also, feel
'free to e-mail me with any graphic-related (or VB in general)
'questions you may have.


'Keeps track of x and y coordinates
Dim CurX, CurY As Integer
'Array of points
Dim Pointarray() As Integer
'Constants make code easier to read
Const XDist = 1
Const YDist = 0
'size of the array
Const SizeOfArray = 11
'randomness of the terrain
Dim Randomness As Single
'number of loops to refine terrain
Dim Loops As Integer
'more symbolic constants
Const RandLimit = 10
Const Draw = 10

Private Sub CmdMountain_Click()
'Build a mountain

'variables for calculation
Dim Corner1
Dim Corner2
Dim Corner3
Dim Corner4
Dim Average

'get values from text boxes and store them to variables (faster)
Randomness = TxtRnd
Loops = TxtLoops

'resize the array according to size variables
ReDim Pointarray(0 To SizeOfArray, 0 To SizeOfArray)

'basically, randomize the array completely
Randomize
For X = 0 To SizeOfArray
Pointarray(X, 0) = Int(Rnd * 5)
Next X
For Y = 0 To SizeOfArray
Pointarray(0, Y) = Int(Rnd * 5)
Next Y
Randomize

'start running the mixing loops
For z = 1 To Loops
For X = 1 To SizeOfArray - 1
For Y = 1 To SizeOfArray - 1
'get the values of all the points around the current one
Corner1 = Pointarray(X, Y + 1)
Corner2 = Pointarray(X + 1, Y)
Corner3 = Pointarray(X - 1, Y)
Corner4 = Pointarray(X, Y - 1)
'build a mountain (add values) or valley (subtract values) plus a random amount (non-random creates perfect domes)
If Option1 = True Then
Average = Int((Corner1 + Corner2 + Corner3 + Corner4) \ 4) + Int(Rnd * Randomness)
Else
Average = Int((Corner1 + Corner2 + Corner3 + Corner4) \ 4) - Int(Rnd * Randomness)
End If
'set the new point and continue through the loop
Pointarray(X, Y) = Average
Next Y
Next X
Next z

'call the sub to draw the new terrain
DrawMesh

End Sub

Private Sub CmdRandomize_Click()
'very simple - randomize all the terrain points
For a = 0 To 10 Step 1
For b = 0 To 10 Step 1
Randomize
Pointarray(a, b) = Int(Rnd * TxtRandomize.Text)
Next b
Next a

Call DrawMesh

End Sub

Private Sub CmdReset_Click()
'very simple - reset all the terrain points to zero
For a = 0 To 11
For b = 0 To 11
Pointarray(a, b) = 0
Next b
Next a
Call DrawMesh

End Sub

Private Sub CmdRndFractal_Click()

'calculation variables
Dim Corner1
Dim Corner2
Dim Corner3
Dim Corner4
Dim Average

'get text box values
Randomness = TxtRnd
Loops = TxtLoops

'resize array
ReDim Pointarray(0 To SizeOfArray, 0 To SizeOfArray)

'start out with a random terrain set
Randomize
For X = 0 To SizeOfArray
Pointarray(X, 0) = Int(Rnd * 5)
Next X
For Y = 0 To SizeOfArray
Pointarray(0, Y) = Int(Rnd * 5)
Next Y
Randomize

'run fractal randomization loop
Dim temp As Integer
For z = 1 To Loops
For X = 1 To SizeOfArray - 1
For Y = 1 To SizeOfArray - 1
'get values of all points around current one
Corner1 = Pointarray(X, Y + 1)
Corner2 = Pointarray(X + 1, Y)
Corner3 = Pointarray(X - 1, Y)
Corner4 = Pointarray(X, Y - 1)
'get the average value plus a random amount
Average = Int((Corner1 + Corner2 + Corner3 + Corner4) \ 4) + Int(Rnd * Randomness)
'raise or lower the point randomly
temp = Int(Rnd * 2)
If temp = 1 Then Average = -Average
'set the new point and continue through the loop
Pointarray(X, Y) = Average
Next Y
Next X
Next z

'draw the new terrain
DrawMesh

End Sub

Private Sub Form_Load()
'draw the base terrain and resize the array to its default values
ReDim Pointarray(0 To 11, 0 To 11) As Integer
Form1.Show
Call DrawMesh
End Sub

Public Sub DrawMesh()
'draws the top view
Dim temp As Integer
temp = (SizeOfArray - 1) * Draw
Picture1.Cls
'draw a grid with points raised or lowered according to their imaginary height
For a = 0 To temp Step Draw
For b = 0 To temp Step Draw
Picture1.Line (a + Pointarray(a / Draw, b / Draw), b + Pointarray(a / Draw, b / Draw))-(a + Draw + Pointarray(a / Draw + 1, b / Draw), b + Pointarray(a / Draw + 1, b / Draw))
Picture1.Line (a + Pointarray(a / Draw, b / Draw), b + Pointarray(a / Draw, b / Draw))-(a + Pointarray(a / Draw, b / Draw + 1), b + Draw + Pointarray(a / Draw, b / Draw + 1))
Next b
Next a

Dim StartPoint As Integer
Picture2.Cls

'isometric (aerial) view
For X = 0 To 50 Step 5
For Y = 0 To 50 Step 5
StartPoint = 55 - X + Y
'Picture1.PSet ((x + y + (XDist * y + x)), StartPoint), RGB(0, 0, 0)
'same as top view in theory, but drawn from a much more difficult angle
Picture2.Line ((X + Y + (XDist * Y + X)), StartPoint - Pointarray(X / 5, Y / 5))-((X + Y + (XDist * Y + X + 10)), 5 - X + 50 - 5 + Y - Pointarray((X / 5) + 1, Y / 5))
Picture2.Line ((X + Y + (XDist * Y + X)), StartPoint - Pointarray(X / 5, Y / 5))-((X + Y + (XDist * Y + X + 10)), 5 - X + 50 + 5 + Y - Pointarray(X / 5, (Y / 5) + 1))
Next Y
Next X

'color view
Dim TmpHigh As Integer
Dim TmpLow As Integer
TmpHigh = 0
TmpLow = 0

'rebuild the array so that the maximum lowness is 0 (you don't want negative color values)
For X = 0 To 10
For Y = 0 To 10
If Pointarray(X, Y) < TmpLow Then TmpLow = Pointarray(X, Y)
Next Y
Next X

For X = 0 To 10
For Y = 0 To 10
Pointarray(X, Y) = Pointarray(X, Y) + Abs(TmpLow)
Next Y
Next X

For X = 0 To 10
For Y = 0 To 10
If Pointarray(X, Y) > TmpHigh Then TmpHigh = Pointarray(X, Y)
Next Y
Next X
LblLow = TmpLow
LblHigh = TmpHigh

'calculation variables
Dim MagicNum As Double
Dim Color As Integer
Dim TempArray(0 To 10, 0 To 10) As Integer
Picture3.Cls
On Error Resume Next
'TmpHigh = 256 - TmpHigh
MagicNum = 256 / TmpHigh
'start color loop
For X = 0 To 10
For Y = 0 To 10
'set the color according to the height of the terrain point
Color = Int(Pointarray(X, Y) * MagicNum)
Picture3.PSet (X, Y), RGB(Color, Color, Color)
Next Y
Next X

End Sub

Private Sub mnuexit_Click()
'when exit is pressed, shut down
End
End Sub

Private Sub mnuload_Click()
'show commondialog box
CommonDialog1.ShowOpen
'if no filename is specified, exit
If CommonDialog1.FileName = "" Then Exit Sub
'put the array in the commondialog file
Open CommonDialog1.FileName For Binary As #1
Get #1, 1, Pointarray
Close #1
'redraw the mesh
DrawMesh
End Sub

Private Sub mnusave_Click()
'show commondialog box
CommonDialog1.ShowSave
'if no filename is specified, exit
If CommonDialog1.FileName = "" Then Exit Sub
On Error Resume Next
'put the array in the commondialog file
Kill CommonDialog1.FileName
Open CommonDialog1.FileName For Binary As #1
Put #1, 1, Pointarray
Close #1
'redraw the mesh
DrawMesh
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'get drawing variable points
CurX = Int(X / Draw)
CurY = Int(Y / Draw)
On Error Resume Next
'raise or lower the array depending on what mouse button is pressed
If Button = 1 Then
Pointarray(CurX, CurY) = Pointarray(CurX, CurY) + 1
End If
If Button = 2 Then
Pointarray(CurX, CurY) = Pointarray(CurX, CurY) - 1
End If
'redraw terrain
DrawMesh
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'same as picture1_mousedown statement (see above)
CurX = Int(X / Draw)
CurY = Int(Y / Draw)
On Error Resume Next
If Button = 1 Then
Pointarray(CurX, CurY) = Pointarray(CurX, CurY) + 1
Call DrawMesh
End If
If Button = 2 Then
Pointarray(CurX, CurY) = Pointarray(CurX, CurY) - 1
Call DrawMesh
End If

End Sub

Project Homepage: