dynamically texturing a TriMesh

["Joseph J. Strout" <joe at realsoftware dot com>]

OK, I've somewhat cleaned up the code I've been working with that 
uses Quesa declares to attach a texture to a TriMesh at runtime. 
It's still not very neatly encapsulated, but this may be the only 
time I get this weekend, so for the intrepid...
The current code works with a TriMesh object, as in the Quesa 
Declares project.  You'll need that to make sense of what follows. 
It could certainly be adjusted to work with an object loaded from a 
3DMF file too, but you'd need to also iterate through the contents of 
that object and find the TriMesh you want to apply the texture to.
First, here's the function that shows the big picture:

Sub ApplyTexture(tm As TriMesh)
   // Let's try to stick a texture onto this TriMesh.

   // make a texture image
   Dim p As Picture
   Dim i,j As Integer
   p = NewPicture(256,256,32)
   p.Graphics.ForeColor = RGB(200,200,200)
   p.Graphics.FillRect 0,0,256,256
   p.Graphics.ForeColor = RGB(150,150,150)
   for i = 0 to 255\8
      for j = 0 to 255\8
         if (i mod 2 = j mod 2) then
            p.Graphics.FillRect i*8,j*8,8,8
         end if
      next
   next

   // convert it to an Object3D
   Dim textureSrcObj As Object3D
   textureSrcObj = New Object3D
   textureSrcObj.AddShapePicture p, 1.0

   // find the texture shader within that
   Dim textureH As Integer
   textureH = FindFirstTexShader( textureSrcObj.GetShapeHandle(0) )
   if textureH = 0 then
      MsgBox "Couldn't get texture from texture object"
      return
   end if

   // apply it to the target object
   Dim attrSet As Integer
   attrSet = Q3AttributeSet_New
   Q3AttributeSet_Add(attrSet, kQ3AttributeTypeSurfaceShader, textureH)
   tm.SetAttributeSet attrSet

   // clean up
   Q3Object_Dispose(textureH)

End Sub

This should be fairly self-explanatory, I think, except for 
FindFirstTexShader, which is:
Function FindFirstTexShader(quesaObj As Integer) As Integer
   // Find the first texture shader contained within the given object.
   // The quesaObj reference is owned by the caller, and so is an
   // extra reference added to whatever we return.

   Dim s As String
   Dim m As MemoryBlock
   Dim position As Integer
   Dim subobj As Integer
   Dim submesh As Integer

   Declare Function Q3Object_GetLeafType Lib QuesaLib (obj As 
Integer) as Integer
   Declare Function Q3Object_IsType Lib QuesaLib (obj As Integer, 
type As OSType) as Integer
   Declare Function Q3Group_GetFirstPosition Lib QuesaLib (grp As 
Integer, ByRef outPos As Integer) as Integer
   Declare Function Q3Group_GetNextPosition Lib QuesaLib (grp As 
Integer, ByRef outPos As Integer) as Integer
   Declare Function Q3Group_GetPositionObject Lib QuesaLib (grp As 
Integer, position As Integer, ByRef outObj As Integer) as Integer
   if quesaObj = 0 then return 0

   m = NewMemoryBlock(4)
   m.Long(0) = Q3Object_GetLeafType(quesaObj)
   s = m.StringValue(0,4)

   if s = "txsu" then
      Q3Shared_GetReference quesaObj
      return quesaObj
   end if

   if Q3Object_IsType(quesaObj, "grup") = kQ3True then
      // It's a group, so iterate over its contents as well.
      if Q3Group_GetFirstPosition(quesaObj, position) = kQ3Success then
         do
            if Q3Group_GetPositionObject(quesaObj, position, subobj) 
= kQ3Success then
               m.Long(0) = Q3Object_GetLeafType(quesaObj)
               s = m.StringValue(0,4)
               submesh = FindFirstTexShader(subobj)
               Q3Object_Dispose(subobj)
               if submesh <> 0 then return submesh
            end if
         loop until Q3Group_GetNextPosition(quesaObj, position) <> kQ3Success
      end if
   end if

End Function


And the only other function you need which isn't in the Quesa 
Declares module on the CD (or downloadable from RBD) is this little 
one:
Sub Q3Shared_GetReference(obj As Integer)
   Declare Function sQ3Shared_GetReference Lib QuesaLib Alias 
"Q3Shared_GetReference" (obj as Integer) as Integer
   Dim result As Integer

   result = sQ3Shared_GetReference(obj)
End Sub

That should do it... it's working for me, at least!

Cheers,
- Joe

--
,------------------------------------------------------------------.
|    Joseph J. Strout           REAL Software, Inc.                |
|    joe at realsoftware dot com       http://www.realsoftware.com        |
`------------------------------------------------------------------'

---
A searchable archive of this list is available at:
<http://support.realsoftware.com/listarchives/search.php>

Unsubscribe or switch delivery mode:
<http://support.realsoftware.com/listmanager/>
.