fmain.pas

这是三Ｄ开发的一些源码

procedure TMain.ACOpenExecute(Sender: TObject);
begin
   if OpenDialog.Execute then
      DoOpen(OpenDialog.FileName);
end;

procedure TMain.GLSceneViewerMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   mx:=x; my:=y;
   md:=True;
end;

procedure TMain.GLSceneViewerMouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
var
   d : Single;
begin
   if md and (Shift<>[]) then begin
      if ssLeft in Shift then
         if ssShift in Shift then
            GLCamera.MoveAroundTarget((my-y)*0.1, (mx-x)*0.1)
         else GLCamera.MoveAroundTarget(my-y, mx-x)
      else if ssRight in Shift then begin
         d:=GLCamera.DistanceToTarget*0.01*(x-mx+y-my);
         if IsKeyDown('x') then
            FreeForm.Translate(d, 0, 0)
         else if IsKeyDown('y') then
            FreeForm.Translate(0, d, 0)
         else if IsKeyDown('z') then
            FreeForm.Translate(0, 0, d)
         else begin
            if ssShift in Shift then
               GLCamera.RotateObject(FreeForm, (my-y)*0.1, (mx-x)*0.1)
            else GLCamera.RotateObject(FreeForm, my-y, mx-x);
         end;
      end;
      mx:=x; my:=y;
   end;
end;

procedure TMain.GLSceneViewerMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
   md:=False;
end;

procedure TMain.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
   if FreeForm.MeshObjects.Count>0 then begin
      GLCamera.AdjustDistanceToTarget(Power(1.05, WheelDelta/120));
      GLCamera.DepthOfView:=2*GLCamera.DistanceToTarget+2*FreeForm.BoundingSphereRadius;
   end;
   Handled:=True;
end;

procedure TMain.ACZoomInExecute(Sender: TObject);
var
   h : Boolean;
begin
   FormMouseWheel(Self, [], -120*4, Point(0, 0), h);
end;

procedure TMain.ACZoomOutExecute(Sender: TObject);
var
   h : Boolean;
begin
   FormMouseWheel(Self, [], 120*4, Point(0, 0), h);
end;

procedure TMain.ACExitExecute(Sender: TObject);
begin
   Close;
end;

procedure TMain.ACShadeSmoothExecute(Sender: TObject);
begin
   ApplyShadeMode;
end;

procedure TMain.MIAADefaultClick(Sender: TObject);
begin
   (Sender as TMenuItem).Checked:=True;
   ApplyFSAA;
end;

procedure TMain.ACResetViewExecute(Sender: TObject);
begin
   DoResetCamera;
end;

procedure TMain.ACCullFaceExecute(Sender: TObject);
begin
   ACCullFace.Checked:=not ACCullFace.Checked;
   ApplyFaceCull;
end;

procedure TMain.MIBgColorClick(Sender: TObject);
begin
   if ColorDialog.Execute then
      ApplyBgColor;
end;

procedure TMain.GLMaterialLibraryTextureNeeded(Sender: TObject;
  var textureFileName: String);
begin
   if not ACTexturing.Enabled then
      textureFileName:='';
end;

procedure TMain.ACTexturingExecute(Sender: TObject);
begin
   ACTexturing.Checked:=not ACTexturing.Checked;
   if ACTexturing.Checked then
      if lastLoadWithTextures then
         ApplyTexturing
      else begin
         DoOpen(lastFileName);
      end
   else ApplyTexturing;
end;

procedure TMain.MIFileClick(Sender: TObject);
begin
   MIPickTexture.Enabled:=(GLMaterialLibrary.Materials.Count>0);
end;

procedure TMain.MIPickTextureClick(Sender: TObject);
begin
   if OpenPictureDialog.Execute then begin
      with GLMaterialLibrary.Materials do begin
         with Items[Count-1] do begin
            Tag:=1;
            Material.Texture.Image.LoadFromFile(OpenPictureDialog.FileName);
            Material.Texture.Enabled:=True;
         end;
      end;
      ApplyTexturing;
   end;
end;

procedure TMain.MIOpenTexLibClick(Sender: TObject);
var
   i : Integer;
begin
   if ODTextures.Execute then with GLMaterialLibrary do begin
      LoadFromFile(ODTextures.FileName);
      for i:=0 to Materials.Count-1 do
         with Materials[i].Material do BackProperties.Assign(FrontProperties);
      ApplyShadeMode;
      ApplyTexturing;
   end;
end;

procedure TMain.ACInvertNormalsExecute(Sender: TObject);
var
   i : Integer;
begin
   with FreeForm.MeshObjects do
      for i:=0 to Count-1 do
         Items[i].Normals.Scale(-1);
   FreeForm.StructureChanged;
end;

procedure TMain.ACReverseRenderingOrderExecute(Sender: TObject);
var
   i, j, n : Integer;
   fg : TFaceGroup;
begin
   with FreeForm.MeshObjects do begin
      // invert meshobjects order
      for i:=0 to (Count div 2) do
         Exchange(i, Count-1-i);
      // for each mesh object
      for i:=0 to Count-1 do with Items[i] do begin
         // invert facegroups order
         n:=FaceGroups.Count;
         for j:=0 to (n div 2) do
            Exchange(j, n-1-j);
         // for each facegroup
         for j:=0 to n-1 do begin
            fg:=FaceGroups[j];
            fg.Reverse;
         end;
      end;
   end;
   FreeForm.StructureChanged;
end;

procedure TMain.ACSaveAsExecute(Sender: TObject);
var
   ext : String;
begin
   if SaveDialog.Execute then begin
      ext:=ExtractFileExt(SaveDialog.FileName);
      if ext='' then
         SaveDialog.FileName:=ChangeFileExt(SaveDialog.FileName,
            '.'+GetVectorFileFormats.FindExtByIndex(SaveDialog.FilterIndex, False, True));
      //if GetVectorFileFormats.FindFromFileName(SaveDialog.FileName)=nil then
      //   ShowMessage('Unsupported or unspecified file extension.')
      {else }
      ext:= ExtractFileExt(SaveDialog.FileName);
      if UpperCase(ext) = '.3DS' then begin
        {oxInit3DSExport( @FreeForm );
        oxSave3DS( SaveDialog.FileName );
        oxHalt3DSExport;}
        ToolSave3DS.SaveTo3DS(SaveDialog.FileName);
      end else begin
        FreeForm.SaveToFile(SaveDialog.FileName);
      end;
   end;
end;

procedure TMain.ACSaveAsUpdate(Sender: TObject);
begin
   ACSaveAs.Enabled:=(FreeForm.MeshObjects.Count>0);
end;

procedure TMain.ACConvertToIndexedTrianglesExecute(Sender: TObject);
var
   v : TAffineVectorList;
   i : TIntegerList;
   m : TMeshObject;
   fg : TFGVertexIndexList;
begin
   v:=FreeForm.MeshObjects.ExtractTriangles;
   try
      i:=BuildVectorCountOptimizedIndices(v);
      try
         RemapAndCleanupReferences(v, i);
         IncreaseCoherency(i, 12);
         i.Capacity:=i.Count;
         FreeForm.MeshObjects.Clean;
         m:=TMeshObject.CreateOwned(FreeForm.MeshObjects);
         m.Vertices:=v;
         m.BuildNormals(i, momTriangles);
         m.Mode:=momFaceGroups;
         fg:=TFGVertexIndexList.CreateOwned(m.FaceGroups);
         fg.VertexIndices:=i;
         fg.Mode:=fgmmTriangles;
         FreeForm.StructureChanged;
      finally
         i.Free;
      end;
   finally
      v.Free;
   end;
   GLMaterialLibrary.Materials.Clear;
   SetupFreeFormShading;
end;

procedure TMain.ACStripifyExecute(Sender: TObject);
{var
   i : Integer;
   mo : TMeshObject;
   fg : TFGVertexIndexList;
   strips : TPersistentObjectList;  }
begin
 {  ACConvertToIndexedTriangles.Execute;
   mo:=FreeForm.MeshObjects[0];
   fg:=(mo.FaceGroups[0] as TFGVertexIndexList);
   strips:=StripifyMesh(fg.VertexIndices, mo.Vertices.Count, True);
   try
      //mo.FaceGroups[0].Free;
      fg.Free;
      for i:= 0 to strips.Count -1 do begin
      fg:=TFGVertexIndexList.CreateOwned(mo.FaceGroups);
      fg.VertexIndices:= ( strips[i] as TIntegerList );
      if i = 0 then
      fg.Mode:= fgmmTriangles
      else
      fg.Mode:=fgmmTriangleStrip;
      end;
   finally
      strips.Free;
   end;}
   //SmoothMesh(FreeForm);
end;

procedure TMain.ACOptimizeExecute(Sender: TObject);
begin
   OptimizeMesh(FreeForm.MeshObjects, [mooVertexCache, mooSortByMaterials]);
   FreeForm.StructureChanged;
   SetupFreeFormShading;
end;

procedure TMain.GLCadencerProgress(Sender: TObject; const deltaTime,
  newTime: Double);
begin
   if Self.Focused then
      GLSceneViewer.Refresh;
end;

procedure TMain.ACFPSExecute(Sender: TObject);
begin
   ACFPS.Checked:=not ACFPS.Checked;
   ApplyFPS;
end;

procedure TMain.ACLightingExecute(Sender: TObject);
begin
   ACLighting.Checked:=not ACLighting.Checked;
//   TBLighting
   ApplyShadeMode;
end;

procedure TMain.TimerTimer(Sender: TObject);
begin
   StatusBar.Panels[1].Text:=Format('%.1f FPS', [GLSceneViewer.FramesPerSecond]);
   GLSceneViewer.ResetPerformanceMonitor;
end;

procedure TMain.ACSaveTexturesExecute(Sender: TObject);
begin
   if SDTextures.Execute then
      GLMaterialLibrary.SaveToFile(SDTextures.FileName);
end;

procedure TMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ToolSave3DS.Free;
  GLSceneViewer.Buffer.DestroyRC;
end;

procedure TMain.FormDestroy(Sender: TObject);
begin
  GLSceneViewer.Buffer.DestroyRC;
end;

procedure TMain.ListBox2Click(Sender: TObject);
var i: integer;
    tBmp: TBitmap;
begin
  for i:= 0 to ListBox2.Count -1 do begin
    if ListBox2.Selected[i] then begin
      tBmp:= TFaceGroup( ListBox2.Items.Objects[i] ).MaterialCache.Material.Texture.Image.AsBitmap;
      Label3.Caption:= 'Texture Name: '+TFaceGroup( ListBox2.Items.Objects[i] ).MaterialCache.Material.Texture.Image.TextureFileName;
      Image1.Picture.Bitmap:= tBmp;
      tBmp.Free;
    end;
  end;
end;

end.