CUBE 3D DESSINER AVEC SOURIS (3DSMAX) SANS DIRECTX NI OPENGL

'code tres simple mais éfficace :p
'davidauche@icqmail.com


Private Type COORD
    X As Long
    Y As Long
End Type
    Dim poly(1 To 4) As COORD
    Dim poly1(1 To 4) As COORD
    Dim poly2(1 To 4) As COORD
    Dim poly3(1 To 4) As COORD
    Dim poly4(1 To 4) As COORD
    Dim Xdepart1, Ydepart1 As Integer
    Dim NumCoords As Long
    Dim value As Integer
    Dim hBrush As Long, hRgn As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As Any, ByVal nCount 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 FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Const ALTERNATE = 1
Const WINDING = 2
Const BLACKBRUSH = 3

Private Sub CubeBase(ByVal Xdepart As Integer, ByVal Ydepart As Integer, ByVal Xfinal As Integer, ByVal Yfinal As Integer, ByVal AngleRot As Integer, Couleur As OLE_COLOR)
On Error Resume Next

pi = 4 * Atn(1)
NumCoords = 4

z = Sqr((Xfinal - Xdepart) ^ 2 + (Yfinal - Ydepart) ^ 2)

If Xfinal >= Xdepart Then
        cosA = (Yfinal - Ydepart) / z
        angle = Atn(Sqr(1 - cosA ^ 2) / cosA) * 180 / pi
    
    If Yfinal = Ydepart Then AngleA = AngleRot Else AngleA = 90 - AngleRot - angle
        longeur = z * Cos(AngleA * pi / 180)
        longeur2 = z * Sin(AngleA * pi / 180)
   
        Me.Cls
        X1 = longeur * Cos(AngleRot * pi / 180)
        Y1 = longeur * Sin(AngleRot * pi / 180)
        X2 = longeur2 * Sin(AngleRot * pi / 180)
        Y2 = longeur2 * Cos(AngleRot * pi / 180)
    
    If Yfinal > Ydepart Then
        poly(1).X = Xdepart: poly(1).Y = Ydepart
        poly(4).X = Xdepart + X1: poly(4).Y = Ydepart + Y1
        poly(3).X = Xfinal: poly(3).Y = Yfinal
        poly(2).X = Xdepart - X2: poly(2).Y = Ydepart + Y2
        
        Me.ForeColor = Couleur
        Polygon Me.hdc, poly(1), NumCoords
    Else
        If Yfinal < Ydepart Then
            poly(1).X = Xdepart: poly(1).Y = Ydepart
            poly(4).X = Xdepart - X1: poly(4).Y = Ydepart - Y1
            poly(3).X = Xfinal: poly(3).Y = Yfinal
            poly(2).X = Xdepart + X2: poly(2).Y = Ydepart - Y2
        
            Me.ForeColor = Couleur
            Polygon Me.hdc, poly(1), NumCoords
        Else
            poly(1).X = Xdepart: poly(1).Y = Ydepart
            poly(4).X = Xdepart + X1: poly(4).Y = Ydepart + Y1
            poly(3).X = Xfinal: poly(3).Y = Yfinal
            poly(2).X = Xdepart + X2: poly(2).Y = Ydepart - Y2
        
            Me.ForeColor = Couleur
            Polygon Me.hdc, poly(1), NumCoords
        End If
    End If
    
Else
    cosA = Abs(Xfinal - Xdepart) / z
    angle = Atn(Sqr(1 - cosA ^ 2) / cosA) * 180 / pi
    
    If Yfinal > Ydepart Then AngleA = AngleRot + angle Else AngleA = angle - AngleRot
        longeur = z * Cos(AngleA * pi / 180)
        longeur2 = z * Sin(AngleA * pi / 180)
        X1 = longeur * Cos(AngleRot * pi / 180)
        Y1 = longeur * Sin(AngleRot * pi / 180)
        X2 = longeur2 * Cos((90 - AngleRot) * pi / 180)
        Y2 = longeur2 * Sin((90 - AngleRot) * pi / 180)
        Me.Cls
    
    If Yfinal > Ydepart Then
        poly(1).X = Xdepart: poly(1).Y = Ydepart
        poly(4).X = Xdepart - X1: poly(4).Y = Ydepart - Y1
        poly(3).X = Xfinal: poly(3).Y = Yfinal
        poly(2).X = Xdepart - X2: poly(2).Y = Ydepart + Y2
        
        Me.ForeColor = Couleur
        Polygon Me.hdc, poly(1), NumCoords
    Else
        poly(1).X = Xdepart: poly(1).Y = Ydepart
        poly(4).X = Xdepart - X1: poly(4).Y = Ydepart - Y1
        poly(3).X = Xfinal: poly(3).Y = Yfinal
        poly(2).X = Xdepart + X2: poly(2).Y = Ydepart - Y2
        
        Me.ForeColor = Couleur
        Polygon Me.hdc, poly(1), NumCoords
    End If
End If
End Sub

Private Sub Command1_Click()
    value = 0
    Command1.Enabled = False: Command2.Enabled = True
End Sub

Private Sub Command2_Click()
    value = 0
    Command2.Enabled = False: Command1.Enabled = True
End Sub

Private Sub Form_Load()
CubeBase 240, 0, 440, 528, 30, &HC0C0C0
Me.AutoRedraw = True
    Polygon Me.hdc, poly(1), NumCoords
Me.AutoRedraw = False
Command1.Enabled = False
Me.Caption = "Plan avec 30°"
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If value = 2 Then
    Me.AutoRedraw = True
        Polygon Me.hdc, poly1(1), 4
        Polygon Me.hdc, poly2(1), 4
        Polygon Me.hdc, poly3(1), 4
    Me.AutoRedraw = False
    
   If Command2.Enabled = False Then value = 0 Else value = 3
End If

If Button = 1 And value = 0 Then
    value = 1
    Xdepart1 = X: Ydepart1 = Y
End If

If Button = 2 Then value = 3: Command2.Enabled = True: Command1.Enabled = True

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If value = 3 Then Exit Sub

If Button = 1 And value = 1 Then
    CubeBase Xdepart1, Ydepart1, X, Y, 30, vbRed
End If

If value = 2 Then
    CubeFin Y, vbRed
End If

End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

If value = 3 Then Exit Sub

Me.AutoRedraw = True
    Polygon Me.hdc, poly(1), NumCoords
    value = 2
Me.AutoRedraw = False

Command1.Enabled = True
End Sub
Private Sub CubeFin(ByVal Yfinal As Integer, Couleur As OLE_COLOR)
Dim hauteur As Integer

hauteur = poly(3).Y - Yfinal

poly1(1).X = poly(1).X
poly1(1).Y = poly(1).Y - hauteur
poly1(2).X = poly(2).X
poly1(2).Y = poly(2).Y - hauteur
poly1(3).X = poly(3).X
poly1(3).Y = poly(3).Y - hauteur
poly1(4).X = poly(4).X
poly1(4).Y = poly(4).Y - hauteur

poly2(1) = poly(1)
poly2(2) = poly(2)
poly2(3) = poly1(2)
poly2(4) = poly1(1)

poly3(1) = poly(4)
poly3(2) = poly(3)
poly3(3) = poly1(3)
poly3(4) = poly1(4)

poly4(1) = poly(2)
poly4(2) = poly(3)
poly4(3) = poly1(3)
poly4(4) = poly1(2)

Me.Cls
    
    
        hBrush = GetStockObject(BLACKBRUSH)
    hRgn = CreatePolygonRgn(poly3(1), NumCoords, ALTERNATE)
    If hRgn Then FillRgn Me.hdc, hRgn, hBrush
    DeleteObject hRgn
    
        hRgn = CreatePolygonRgn(poly1(1), NumCoords, ALTERNATE)
    If hRgn Then FillRgn Me.hdc, hRgn, hBrush
    DeleteObject hRgn
    
        hRgn = CreatePolygonRgn(poly4(1), NumCoords, ALTERNATE)
    If hRgn Then FillRgn Me.hdc, hRgn, hBrush
    DeleteObject hRgn
    
    Polygon Me.hdc, poly1(1), 4
    Polygon Me.hdc, poly4(1), 4
    Polygon Me.hdc, poly3(1), 4

End Sub