Soyez le premier à donner votre avis sur cette source.
Vue 6 149 fois - Téléchargée 542 fois
Global NmbAseObjet As Integer Global NmbAseMaterial As Integer Global F As String Private Type CoordV VChar As Variant X As Integer Y As Integer Z As Integer End Type Private Type FaceV FChar As Variant Mat As Integer A As Integer B As Integer C As Integer AB As Boolean BC As Boolean CA As Boolean End Type Private Type ASEObjetV Ochar As Variant NmbVertex As Integer NmbFace As Integer Vertex() As CoordV Face() As FaceV ScaleX As Single ScaleY As Single ScaleZ As Single Nom As String CenterX As Single CenterY As Single CenterZ As Single R As Single G As Single B As Single End Type Private Type MaterialV MChar As Variant Nom As String Amb(3) As GLfloat Dif(3) As GLfloat Spec(3) As GLfloat Trans As GLfloat Shine As GLfloat End Type Global ASEObjet() As ASEObjetV Global ASEMaterial() As MaterialV Private Sub GetColor(M As Integer, Fin As Variant) S = "*WIREFRAME_COLOR" With ASEObjet(M) I = InStr(.Ochar, F, S, vbBinaryCompare) L = I + Len(S) + 1 J = InStr(L, F, "}", vbBinaryCompare) V = Split(Mid(F, L, J - L), vbTab) .R = Val(V(0)): .G = Val(V(1)): .B = Mid(Val(V(2)), 1, Len(V(2)) - 2) End With End Sub Private Sub GetFace(M As Integer, Fin As Variant) With ASEObjet(M) Debut = .Ochar V = Split(Mid(F, Debut, CVar(Fin - Debut)), "*MESH_FACE ") For I = 1 To UBound(V) Suite4: If I > UBound(V) Then Exit Sub W = W + 1: ReDim Preserve .Face(W - 1): .NmbFace = (W - 1) U = Split(V(I), " ") With .Face(W - 1) For J = 1 To UBound(U) If U(J) = "A:" Or U(J) = "B:" Or U(J) = "C:" Or U(J) = "AB:" Or U(J) = "BC:" Or U(J) = "CA:" Then For K = CInt(J + 1) To UBound(U) If U(K) <> "" Then Exit For Next Select Case U(J) Case "A:": .A = U(K) Case "B:": .B = U(K) Case "C:": .C = U(K) Case "AB:": .AB = U(K) Case "BC:": .BC = U(K) Case "CA:": .CA = U(K) GoTo Suite3 End Select J = K End If Next Suite3: U = Split(V(I), "*MESH_MTLID ") .Mat = Val(Mid(U(1), 1, Len(U(1)) - 5)) + 2 End With Next End With End Sub Private Sub GetMat() StrCmp = "*MATERIAL_AMBIENT" For I = 1 To NmbAseMaterial With ASEMaterial(I) If NmbAseMaterial <= 1 Or I = NmbAseMaterial Then Fin = Len(F) Else Fin = ASEMaterial(I + 1).MChar End If S = Mid(F, .MChar, Fin) Boucle: U = Split(S, StrCmp) V = Split(U(1), vbTab) For J = 0 To 2 Select Case StrCmp Case "*MATERIAL_AMBIENT": .Amb(J) = Val(V(J)) If J = 2 Then StrCmp = "*MATERIAL_DIFFUSE": GoTo Boucle Case "*MATERIAL_DIFFUSE": .Dif(J) = Val(V(J)) If J = 2 Then StrCmp = "*MATERIAL_SPECULAR": GoTo Boucle Case "*MATERIAL_SPECULAR": .Spec(J) = Val(V(J)) If J = 2 Then StrCmp = "*MATERIAL_AMBIENT" End Select Next U = Split(S, "*MATERIAL_SHINE") V = Split(U(1), " ") .Shine = Val(V(1)) U = Split(S, "*MATERIAL_TRANSPARENCY") V = Split(U(1), " ") .Trans = Val(V(1)) .Amb(3) = 1 .Dif(3) = 1 .Spec(3) = 1 End With Next End Sub Private Sub GetStr(StrCmp As String, Debut As Variant, Fin As Variant, Element As Variant, Nmb As Integer) L = Len(StrCmp) I = InStr(Debut, F, StrCmp, vbTextCompare) J = InStr(I + L, F, "*", vbTextCompare) S = Mid(F, I + L, J - I - L) U = CVar(Split(S, vbTab)) T = 4 With ASEObjet(Nmb) Select Case Element Case 0: .ScaleX = (1 / Val(U(0))) * T .ScaleY = (1 / Val(U(1))) * T .ScaleZ = (1 / Val(Left(U(2), Len(U(2)) - 2))) * T Case 1: .Nom = CVar(Mid(U(0), 3, Len(U(0)) - 5)) Case 2: .CenterX = Val(U(0)) * T .CenterY = Val(U(1)) * T .CenterZ = Val(Left(U(2), Len(U(2)) - 2)) * T End Select End With End Sub Private Sub GetVertex(M As Integer, Fin As Variant) With ASEObjet(M) Debut = .Ochar V = Split(Mid(F, Debut, CVar(Fin - Debut)), vbTab & vbTab & vbTab) For I = 1 To UBound(V) U = Split(V(I), vbTab) If Left(U(0), 12) <> "*MESH_VERTEX" Then Exit Sub ReDim Preserve .Vertex(I - 1) .Vertex(I - 1).X = Val(U(1)) * .ScaleX .Vertex(I - 1).Y = Val(U(2)) * .ScaleY .Vertex(I - 1).Z = -Val(Mid(U(3), 1, Len(U(3)) - 2)) * .ScaleZ ' Afin d'eviter le vbtab & vbtab final! Negation a cause du format qui l'impose Next End With End Sub Sub LoadASE(Fichier As String) 'Loading "CHARGEMENT DE " & Fichier Open Fichier For Input As 1 F = CStr(Input$(LOF(1), #1)) Close 'Loading "OBJET GEOMETRIQUE" NmbAseObjet = 0: NmbAseMaterial = 0 StrSrch "*GEOMOBJECT", 1, Len(F), 0 'Loading "MATERIAUX" StrSrch "MATERIAL ", 1, Len(F), 1 GetMat For I = 1 To NmbAseObjet With ASEObjet(I) If NmbAseObjet <= 1 Or I = NmbAseObjet Then Fin = Len(F) Else Fin = ASEObjet(I + 1).Ochar End If ' Loading "OBJET " & I & " : NOM" GetStr "*NODE_NAME", .Ochar, Fin, 1, CInt(I) ' Loading "OBJET " & I & " : ECHELLES" GetStr "*TM_SCALE", .Ochar, Fin, 0, CInt(I) ' Loading "OBJET " & I & " : POSITION" GetStr "*TM_POS", .Ochar, Fin, 2, CInt(I) ' Loading "OBJET " & I & " : EMPLACEMENT DES VERTICES" StrSrch "*MESH_NUMVERTEX", .Ochar, Fin, 2, CInt(I) ' Loading "OBJET " & I & " : EMPLACEMENT DES FACES" StrSrch "*MESH_NUMFACES", .Ochar, Fin, 3, CInt(I) ' Loading "OBJET " & I & " : STOCKAGE DES VERTICES" GetVertex CInt(I), Fin ' Loading "OBJET " & I & " : STOCKAGE DES FACES" GetFace CInt(I), Fin ' Loading "OBJET " & I & " : COULEURS" GetColor CInt(I), Fin End With Next 'Loading "FIN", False 'PUTAIN CA MARCHE!!!!!!!!!!!!!!!!!!!!! End Sub Private Sub StrSrch(StrCmp As String, Debut As Variant, Fin As Variant, Element As Variant, Optional Nmb As Integer) S = Mid(F, Debut, Fin - Debut) U = Split(S, StrCmp) n = UBound(U) For I = 1 To n J = InStr(1, F, U(I), vbBinaryCompare) Select Case Element Case 0: NmbAseObjet = n ReDim Preserve ASEObjet(NmbAseObjet) ASEObjet(I).Ochar = J Case 1: NmbAseMaterial = n ReDim Preserve ASEMaterial(NmbAseMaterial) ASEMaterial(I).MChar = J Case 2: ReDim Preserve ASEObjet(Nmb).Vertex(n) ASEObjet(Nmb).Vertex(I).VChar = J Case 3: ReDim Preserve ASEObjet(Nmb).Face(n) ASEObjet(Nmb).Face(I).FChar = J End Select Next End Sub
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.