Vos p'tites nurmites se sentent seul sur leur pauvre terrain tout plat? Ben voila de quoi leur remonter leur moral en leur offrant un vrai terrain avec du relief! Sisisi j'vous jure!
Nécessite 2 PictureBox... c tout
Source / Exemple :
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) _
As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal _
nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As _
Any, ByVal nCount As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn _
As Long, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As _
Long
Private Type COORD
X As Long
Y As Long
End Type
Const DRAW3DSKELETON = 0
Const DRAW3DSKELETONAREAS = 1
Const DRAW3DSHADE = 2
Const DRAW3DSHADEnSKELETON = 3
Const ALTERNATE = 1
Const XSize = 30
Const YSize = 30
Const HFactor = 50
' Sélection du mode de rendus parmis la liste plus haut
' DRAW3DSKELETON -> Mode squelette
' DRAW3DSKELETONAREAS -> Mode Squelette avec zones
' DRAW3DSHADE -> Mode "ombré"
' DRAW3DSHADEnSKELETON -> Ombré et squelette, le plus lourd...
Const iDRAWMODE = DRAW3DSHADEnSKELETON
Dim CountTripLength As Integer
Dim poly(1 To 4) As COORD
Dim UnPoint As COORD
Dim PathMatrix(XSize, YSize) As Integer
Dim MyWay(100, 2) As Integer
Sub InitControles()
Picture2.Appearance = 0: Picture2.AutoRedraw = True
Picture2.Visible = False
Picture2.Width = Me.Width - 120: Picture2.Height = Me.Height - 400
Picture1.Appearance = 0: Picture1.AutoRedraw = True
Picture1.Top = 0: Picture1.Left = 0
Picture1.Width = Me.Width - 120: Picture1.Height = Me.Height - 400
Picture1.Cls
Me.Caption = "Initialising..."
Randomize Timer
Call ClearMatrix
Call InitPath
Call PutBigPoints(25)
Call SmoothPath
If iDRAWMODE = DRAW3DSKELETON Then Call Draw3DPath
If iDRAWMODE = DRAW3DSKELETONAREAS Then Call DrawAreas
If iDRAWMODE = DRAW3DSHADE Then Call RasterPath
If iDRAWMODE = DRAW3DSHADEnSKELETON Then Call RasterPath: Call Draw3DPath
Picture2.Picture = Picture1.Image
Me.Caption = "Let's rock... [ Max Alt =" + Str$(FindHightestPoint(UnPoint)) _
+ " ]"
Call StartTrip
End Sub
Sub ClearMatrix()
For i = 0 To XSize
For j = 0 To YSize
PathMatrix(i, j) = 0
Next j
Next i
End Sub
Sub InitPath()
For i = 0 To XSize
For j = 0 To YSize
PathMatrix(i, j) = Int(Rnd * 10)
Next j
Next i
End Sub
Sub PutBigPoints(NumberOfPics)
For i = 1 To NumberOfPics
X = Int(Rnd * XSize)
Y = Int(Rnd * YSize)
H = Int(Rnd * 20) + 40
PathMatrix(X, Y) = H
Next i
End Sub
Sub SmoothPath()
For i = 0 To XSize
For j = 0 To YSize
SmoothHeight = 0: Normalize = PathMatrix(i, j)
For XParse = i - 1 To i + 1
For YParse = j - 1 To j + 1
done = False
If XParse < 0 Then iHeight = Normalize: done = True
If XParse > XSize Then iHeight = Normalize: done = True
If YParse < 0 Then iHeight = Normalize: done = True
If YParse > YSize Then iHeight = Normalize: done = True
If done = False Then iHeight = PathMatrix(XParse, YParse)
SmoothHeight = SmoothHeight + iHeight
Next YParse
Next XParse
SmoothHeight = Int(SmoothHeight / 9)
PathMatrix(i, j) = SmoothHeight
Next j
Next i
End Sub
Sub Draw3DPath()
xStep3D = Me.Width / XSize
yStep3D = Me.Height / YSize
For i = 1 To XSize - 1
For j = 1 To YSize - 1
Picture1.Line ((i - 1) * xStep3D, ((j - 1) * yStep3D) - (PathMatrix(i - 1, _
j - 1) * HFactor))-(i * xStep3D, (j * yStep3D) - (PathMatrix(i, j) * _
HFactor)), RGB(0, 0, 0)
Picture1.Line ((i - 1) * xStep3D, ((j + 1) * yStep3D) - (PathMatrix(i - 1, _
j + 1) * HFactor))-(i * xStep3D, (j * yStep3D) - (PathMatrix(i, j) * _
HFactor)), RGB(0, 0, 0)
Picture1.Line (i * xStep3D, (j * yStep3D) - (PathMatrix(i, j) * HFactor))- _
((i + 1) * xStep3D, ((j - 1) * yStep3D) - (PathMatrix((i + 1), (j - _
1)) * HFactor)), RGB(0, 0, 0)
Picture1.Line (i * xStep3D, (j * yStep3D) - (PathMatrix(i, j) * HFactor))- _
((i + 1) * xStep3D, ((j + 1) * yStep3D) - (PathMatrix((i + 1), (j + _
1)) * HFactor)), RGB(0, 0, 0)
Next j
Next i
End Sub
Private Function FindHightestPoint(UnPoint As COORD)
Value = 0
For i = 1 To XSize - 1
For j = 1 To YSize - 1
If PathMatrix(i, j) > Value Then Value = PathMatrix(i, j): UnPoint.X = i: _
UnPoint.Y = j
Next j
Next i
MyWay(0, 0) = UnPoint.X: MyWay(0, 1) = UnPoint.Y
FindHightestPoint = Value
End Function
Private Sub Form_Resize()
Call InitControles
End Sub
Sub DrawPolyPath(i, j, Color)
If i = 1 Or j = 1 Then Exit Sub
Dim hBrush As Long, hRgn As Long
xStep3D = Me.Width / XSize
yStep3D = Me.Height / YSize
poly(1).X = (i * xStep3D) / 15
poly(1).Y = ((j * yStep3D) - (PathMatrix(i, j) * HFactor)) / 15
poly(2).X = ((i - 1) * xStep3D) / 15
poly(2).Y = (((j + 1) * yStep3D) - (PathMatrix(i - 1, j + 1) * HFactor)) / 15
poly(3).X = ((i - 2) * xStep3D) / 15
poly(3).Y = ((j * yStep3D) - (PathMatrix(i - 2, j) * HFactor)) / 15
poly(4).X = ((i - 1) * xStep3D) / 15
poly(4).Y = (((j - 1) * yStep3D) - (PathMatrix(i - 1, j - 1) * HFactor)) / 15
Polygon Picture1.hdc, poly(1), 4
hBrush = CreateSolidBrush(Color)
hRgn = CreatePolygonRgn(poly(1), 4, ALTERNATE)
If hRgn Then FillRgn Picture1.hdc, hRgn, hBrush
DeleteObject hBrush
DeleteObject hRgn
End Sub
Sub RasterPath()
Picture1.BackColor = RGB(0, 0, 0)
Ech = 255 / FindHightestPoint(UnPoint)
For i = 2 To XSize
For j = 2 To YSize - 1
Value = PathMatrix(i, j) + PathMatrix(i - 1, j + 1) + PathMatrix(i - 2, j - _
1) + PathMatrix(i - 1, j - 1)
Value = Value / 4 * Ech
If Value > 50 Then
Call DrawPolyPath(i, j, RGB(0, Value, 0))
Else
Call DrawPolyPath(i, j, RGB(0, 0, Value + 40))
End If
Next j
Next i
Picture1.Refresh
End Sub
Sub DrawAreas()
Call Draw3DPath
For i = 1 To XSize - 1
For j = 1 To YSize - 1
If Int(Rnd * 10) = 0 Then Call DrawPolyPath(i, j, RGB(128, 0, 0))
If Int(Rnd * 10) = 0 Then Call DrawPolyPath(i, j, RGB(0, 0, 128))
Next j
Next i
Picture1.Refresh
End Sub
Sub StartTrip()
xStep3D = Me.Width / XSize
yStep3D = Me.Height / YSize
Call FindHightestPoint(UnPoint)
CountTripLength = 0
done = False
Do
Picture1.Circle (UnPoint.X * xStep3D, (UnPoint.Y * yStep3D) - (PathMatrix( _
UnPoint.X, UnPoint.Y) * HFactor)), 100, RGB(255, 0, 0)
done = FindNextPoint(UnPoint)
Loop While done = True
Call DrawItineraire
End Sub
Private Function FindNextPoint(UnPoint As COORD)
Hauteur = PathMatrix(UnPoint.X, UnPoint.Y)
done = False: X = UnPoint.X: Y = UnPoint.Y
For i = X - 1 To X + 1
For j = Y - 1 To Y + 1
If i >= 0 And j >= 0 And i <= XSize And j <= YSize Then
If PathMatrix(i, j) <= Hauteur Then
Found = False
For z = 0 To CountTripLength
If MyWay(z, 0) = i And MyWay(z, 1) = j Then Found = True: Exit For
Next z
If Found = False Then
If done = False Then CountTripLength = CountTripLength + 1
Hauteur = PathMatrix(i, j)
UnPoint.X = i: UnPoint.Y = j: done = True
MyWay(CountTripLength, 0) = i: MyWay(CountTripLength, 1) = j
End If
End If
End If
Next j
Next i
FindNextPoint = done
End Function
Sub DrawItineraire()
xStep3D = Me.Width / XSize
yStep3D = Me.Height / YSize
For i = 0 To CountTripLength - 1
X = MyWay(i, 0) * xStep3D
Y = MyWay(i, 1) * yStep3D - (PathMatrix(MyWay(i, 0), MyWay(i, 1)) * HFactor)
X2 = MyWay(i + 1, 0) * xStep3D
Y2 = MyWay(i + 1, 1) * yStep3D - (PathMatrix(MyWay(i + 1, 0), MyWay(i + 1, 1 _
)) * HFactor)
Picture1.Line (X, Y)-(X2, Y2), RGB(255, 0, 0)
Next i
End Sub
Private Sub Picture1_Click()
Call SavePicture(Picture1.Image, "C:\temp.bmp")
Picture1.Picture = Picture2.Picture
Picture2.Picture = LoadPicture("C:\temp.bmp")
If Dir$("C:\temp.bmp") <> "" Then Kill "C:\temp.bmp"
End Sub
Conclusion :
<CENTER><IMG SRC='http://manipulator.free.fr/captures/terrain3d.jpg' WIDTH=620 HEIGHT=437></CENTER>
Dans la prochaine version on rajoute les bêtes ok?
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.