home *** CD-ROM | disk | FTP | other *** search
/ The Houseplan Collection / HRCD2005.ISO / data1.cab / Zusatz / 3DS / DATA2.Z / WuerfelDialog.frm < prev    next >
Text File  |  1999-10-08  |  9KB  |  232 lines
  1. VERSION 5.00
  2. Begin VB.Form WuerfelDialog 
  3.    Caption         =   "Form1"
  4.    ClientHeight    =   3195
  5.    ClientLeft      =   60
  6.    ClientTop       =   345
  7.    ClientWidth     =   4680
  8.    LinkTopic       =   "Form1"
  9.    ScaleHeight     =   3195
  10.    ScaleWidth      =   4680
  11.    StartUpPosition =   3  'Windows Default
  12.    Visible         =   0   'False
  13. End
  14. Attribute VB_Name = "WuerfelDialog"
  15. Attribute VB_GlobalNameSpace = False
  16. Attribute VB_Creatable = False
  17. Attribute VB_PredeclaredId = True
  18. Attribute VB_Exposed = False
  19. Option Explicit
  20.  
  21. Private Declare Function SetForegroundWindow Lib "user32" _
  22.         (ByVal hwnd As Long) As Long
  23.  
  24. Const PI As Double = 3.1415926
  25.  
  26. Const defaultPath As String = "\ArCon-SPU\Demos\Visual Basic\WuerfelGruppe\Res\"
  27. Const NameOfTex1 As String = "wuerfel_1.bmp"
  28. Const NameOfTex2 As String = "wuerfel_2.bmp"
  29. Const NameOfTex3 As String = "wuerfel_3.bmp"
  30. Const NameOfTex4 As String = "wuerfel_4.bmp"
  31. Const NameOfTex5 As String = "wuerfel_5.bmp"
  32. Const NameOfTex6 As String = "wuerfel_6.bmp"
  33.  
  34. Dim WithEvents prg As ArCon.ArCon
  35. Attribute prg.VB_VarHelpID = -1
  36. Dim TexDir As String
  37.     
  38.     
  39. Dim constr(2) As ArCon.ObjectConstructor
  40. Dim wuerfel(2) As ArCon.Object3D, gruppe As ArCon.Object3D
  41. Dim mat(2) As ArCon.Material
  42.  
  43. Private Sub Form_Load()
  44.     Set prg = New ArCon.ArCon
  45.     prg.StartMe hwnd, ""
  46.     
  47.     On Error GoTo failed
  48.     TexDir = App.Path & "\"
  49. test:
  50.     If FileLen(TexDir & NameOfTex1) Then GoTo found
  51.     GoTo found
  52. failed:
  53.     TexDir = defaultPath
  54.     On Error GoTo none
  55.     GoTo test
  56. none:
  57.     SetForegroundWindow hwnd
  58.     MsgBox "Texturen nicht gefunden, starten Sie das Makro als EXE Datei" & Chr(13) & _
  59.            "oder Σndern Sie die Konstante 'defaultPath' im Quelltext!"
  60.     Unload Me
  61.     Exit Sub
  62.  
  63. found:
  64.     If prg.Mode = AC_NoMode Then
  65.         prg.CreateProject prg.NewProject
  66.     End If
  67.     prg.Mode = AC_ModeDesign
  68.     CreateCubes
  69. End Sub
  70.  
  71. Private Sub CreateMat(ByRef mat As ArCon.Material, ByVal color As Long)
  72.     With mat
  73.         .AmbientCoefficient = 0.2
  74.         .DiffuseCoefficient = 0.4
  75.         .SpecularCoefficient = 0.4
  76.         .DiffuseColor = color
  77.         .SpecularColor = color
  78.         .Transparent = False
  79.         .Flags = ACMATFL_ISTEXTURED Or ACMATFL_MIXTEXCOL
  80.     End With
  81. End Sub
  82.  
  83. Private Sub CreateGeometry(ByRef constr As ArCon.ObjectConstructor, ByRef mat As ArCon.Material)
  84.     With constr
  85.         .SetPoint 0, -0.5, 0.5, -0.5, 0, 1
  86.         .SetPoint 1, 0.5, 0.5, -0.5, 1, 1
  87.         .SetPoint 2, 0.5, -0.5, -0.5, 1, 0
  88.         .SetPoint 3, -0.5, -0.5, -0.5, 0, 0
  89.         .SetContext 1
  90.         .AddQuadriliteral 15, mat, TexDir & NameOfTex1
  91.             
  92.         .SetPoint 0, -0.5, -0.5, 0.5, 0, 0
  93.         .SetPoint 1, 0.5, -0.5, 0.5, 1, 0
  94.         .SetPoint 2, 0.5, 0.5, 0.5, 1, 1
  95.         .SetPoint 3, -0.5, 0.5, 0.5, 0, 1
  96.         .SetContext 6
  97.         .AddQuadriliteral 15, mat, TexDir & NameOfTex6
  98.         
  99.         .SetPoint 0, -0.5, 0.5, 0.5, 0, 1
  100.         .SetPoint 1, -0.5, 0.5, -0.5, 1, 1
  101.         .SetPoint 2, -0.5, -0.5, -0.5, 1, 0
  102.         .SetPoint 3, -0.5, -0.5, 0.5, 0, 0
  103.         .SetContext 4
  104.         .AddQuadriliteral 15, mat, TexDir & NameOfTex4
  105.             
  106.         .SetPoint 0, 0.5, -0.5, 0.5, 0, 0
  107.         .SetPoint 1, 0.5, -0.5, -0.5, 1, 0
  108.         .SetPoint 2, 0.5, 0.5, -0.5, 1, 1
  109.         .SetPoint 3, 0.5, 0.5, 0.5, 0, 1
  110.         .SetContext 3
  111.         .AddQuadriliteral 15, mat, TexDir & NameOfTex3
  112.             
  113.         .SetPoint 0, -0.5, 0.5, 0.5, 0, 0
  114.         .SetPoint 1, 0.5, 0.5, 0.5, 1, 0
  115.         .SetPoint 2, 0.5, 0.5, -0.5, 1, 1
  116.         .SetPoint 3, -0.5, 0.5, -0.5, 0, 1
  117.         .SetContext 5
  118.         .AddQuadriliteral 15, mat, TexDir & NameOfTex5
  119.             
  120.         .SetPoint 0, -0.5, -0.5, -0.5, 0, 1
  121.         .SetPoint 1, 0.5, -0.5, -0.5, 1, 1
  122.         .SetPoint 2, 0.5, -0.5, 0.5, 1, 0
  123.         .SetPoint 3, -0.5, -0.5, 0.5, 0, 0
  124.         .SetContext 2
  125.         .AddQuadriliteral 15, mat, TexDir & NameOfTex2
  126.     End With
  127. End Sub
  128.  
  129. Private Sub SetMatrix(ByRef m, ByVal xPos As Single, ByVal yPos As Single, ByVal zPos As Single)
  130.     m(0, 0) = 1: m(0, 1) = 0: m(0, 2) = 0: m(0, 3) = xPos
  131.     m(1, 0) = 0: m(1, 1) = 1: m(1, 2) = 0: m(1, 3) = yPos
  132.     m(2, 0) = 0: m(2, 1) = 0: m(2, 2) = 1: m(2, 3) = zPos
  133.     m(3, 0) = 0: m(3, 1) = 0: m(3, 2) = 0: m(3, 3) = 1
  134. End Sub
  135.  
  136. Private Sub CreateCubes()
  137.     Set mat(0) = prg.NewMaterial
  138.     CreateMat mat(0), RGB(255, 0, 0)
  139.     Set mat(1) = prg.NewMaterial
  140.     CreateMat mat(1), RGB(0, 255, 0)
  141.     Set mat(2) = prg.NewMaterial
  142.     CreateMat mat(2), RGB(0, 0, 255)
  143.     
  144.     Set constr(0) = prg.NewObjectConstructor(0, PI / 180 * 105)
  145.     CreateGeometry constr(0), mat(0)
  146.     constr(0).Finish "Linker Wⁿrfel", False, ACO_DURATION_ONLYWITHINSTANCES
  147.     Set constr(1) = prg.NewObjectConstructor(0, PI / 180 * 105)
  148.     CreateGeometry constr(1), mat(1)
  149.     constr(1).Finish "Mittlerer Wⁿrfel", False, ACO_DURATION_ONLYWITHINSTANCES
  150.     Set constr(2) = prg.NewObjectConstructor(0, PI / 180 * 105)
  151.     CreateGeometry constr(2), mat(2)
  152.     constr(2).Finish "Rechter Wⁿrfel", False, ACO_DURATION_ONLYWITHINSTANCES
  153.     
  154.     Dim mc_wc(3, 3) As Single
  155.     Set wuerfel(0) = constr(0).Create(Nothing, False)
  156.     SetMatrix mc_wc, -1.25, 0, 0
  157.     wuerfel(0).SetModelToWorldTransformation mc_wc
  158.     prg.SetObject3DEventMask wuerfel(0), ACO3D_EVENT_TEXTURE_DROPPED Or ACO3D_EVENT_DBLCLK
  159.     
  160.     Set wuerfel(1) = constr(1).Create(Nothing, False)
  161.     prg.SetObject3DEventMask wuerfel(1), ACO3D_EVENT_TEXTURE_DROPPED Or ACO3D_EVENT_DBLCLK
  162.     
  163.     Set wuerfel(2) = constr(2).Create(Nothing, False)
  164.     SetMatrix mc_wc, 1.25, 0, 0
  165.     wuerfel(2).SetModelToWorldTransformation mc_wc
  166.     prg.SetObject3DEventMask wuerfel(2), ACO3D_EVENT_TEXTURE_DROPPED Or ACO3D_EVENT_DBLCLK
  167.     
  168.     Set gruppe = prg.GroupDesignObjects("Wⁿrfelgruppe", 3, wuerfel)
  169.     gruppe.InsertIntoWorld False
  170.     prg.SetObject3DEventMask gruppe, ACO3D_EVENT_DBLCLK
  171. End Sub
  172.  
  173. Private Sub Form_Unload(Cancel As Integer)
  174.     If Not prg Is Nothing Then
  175.         prg.EndMe
  176.         Set prg = Nothing
  177.     End If
  178. End Sub
  179.  
  180. Private Sub prg_ProgramExit()
  181.     If Not prg Is Nothing Then
  182.         prg.EndMe
  183.         Set prg = Nothing
  184.     End If
  185.     Unload Me
  186. End Sub
  187.  
  188. Private Sub prg_ProjectClosed()
  189.     prg_ProgramExit
  190. End Sub
  191.  
  192. Private Sub prg_WorldObject3DDoubleClicked(ByVal selObj As ArCon.IObject3D, ByVal clickedObj As ArCon.IObject3D, ByVal objectPartID As Long, Modified As Boolean)
  193.     SetForegroundWindow hwnd
  194.     Dim s As String
  195.     If objectPartID Then
  196.         s = "Sie haben die Seite " & objectPartID & " des Objektes " & clickedObj.Name & " angeklickt!"
  197.     Else
  198.         s = "Sie haben das Objekt " & selObj.Name & " angeklickt!"
  199.     End If
  200.     s = s & Chr(13) & "M÷chten Sie diesen Wⁿrfel durch einen wei▀en ersetzen?"
  201.     If MsgBox(s, vbYesNo) = vbYes Then
  202.         Dim i As Integer
  203.         If clickedObj.id = wuerfel(0).id Then
  204.             i = 0
  205.         ElseIf clickedObj.id = wuerfel(1).id Then
  206.             i = 1
  207.         ElseIf clickedObj.id = wuerfel(2).id Then
  208.             i = 2
  209.         End If
  210.         Dim mc_wc(3, 3) As Single
  211.         Set constr(i) = prg.NewObjectConstructor(0, PI / 180 * 105)
  212.         CreateMat mat(i), RGB(255, 255, 255)
  213.         CreateGeometry constr(i), mat(i)
  214.         constr(i).Finish clickedObj.Name, False, ACO_DURATION_ONLYWITHINSTANCES
  215.         Set wuerfel(i) = constr(i).Create(Nothing, False)
  216.         SetMatrix mc_wc, (i - 1) * 1.25, 0, 0
  217.         wuerfel(i).SetModelToWorldTransformation mc_wc
  218.         prg.SetObject3DEventMask wuerfel(i), ACO3D_EVENT_TEXTURE_DROPPED Or ACO3D_EVENT_DBLCLK
  219.         gruppe.GroupReplaceObject clickedObj, wuerfel(i), True
  220.         Modified = True
  221.     End If
  222.     SetForegroundWindow prg.ArConWindowHandle
  223. End Sub
  224.  
  225. Private Sub prg_WorldObject3DTextureDropped(ByVal obj As ArCon.IObject3D, ByVal evnt As Long, ByVal hitX As Single, ByVal hitY As Single, ByVal hitZ As Single, ByVal pickedMat As ArCon.IMaterial, ByVal objectPartID As Long, ByVal oldTexName As String, ByVal newTexName As String, mayDrop As Boolean)
  226.     If (evnt And AC_DRAG_N_DROP_DROP) = 0 Then Exit Sub
  227.     SetForegroundWindow hwnd
  228.     mayDrop = MsgBox("Objekt " & obj.Name & ", Seite " & objectPartID & "," & Chr(13) & "Textur wird durch " & newTexName & Chr(13) & " ersetzt." & Chr(13) & "Sind Sie sicher, da▀ Sie diese Textur als " & objectPartID & " erkennen k÷nnen?", vbYesNo) = vbYes
  229.     SetForegroundWindow prg.ArConWindowHandle
  230. End Sub
  231.  
  232.