Un ch'tit terrain pour vos nurmites

Soyez le premier à donner votre avis sur cette source.

Snippet vu 2 702 fois - Téléchargée 62 fois

Commenter

Contenu du snippet

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?

A voir également

Ajouter un commentaire

Commentaires

Signaler
yiab
Messages postés
27
Date d'inscription
jeudi 10 juillet 2008
Statut
Membre
Dernière intervention
31 mai 2015
 -
excellent ce code !
Signaler
-
Ben oui c'est de moi, pour l'exe je te ferrais ça mais tu peux le faire toi même, il n'y a aucne dépendances, tout le code est là.
Signaler
-
Heuuuuuuu
Je pourrait avoir l'exe stp ??
(PS: t sur ke ce code est de toi ??)
Signaler
-
C INCROYABLE !!!
Comment arrive tu a faire des trucs pareils ?
Signaler
-
Je tiens a te felicité pour tes superbe programme. Encore un grand bravo..
Afficher les 8 commentaires
S'inscrire maintenant

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.

Du même auteur (cs_Mémère)