//Original Author: Akira1364
//Last Modified: 09/10/16
unit unit_OBJSceneWriter;
{$mode Delphi}{$H+}
interface
uses
Classes, Dialogs, Forms, SysUtils, FileUtil, LazFileUtils, unit_Scene,
unit_Functions, unit_Primitives, unit_PrimitiveList;
type
TOBJSceneWriter = class(TObject)
OBJData: TStringList;
MaterialData: TStringList;
TextureList: TStringList;
ExportList: TPrimitiveList;
private
FScene: TScene;
FDecimalPrecision: string;
FSmoothingLevel: integer;
public
constructor Create(AScene: TScene; ADecimalPrecision: string; ASmoothingLevel: integer);
destructor Destroy; override;
procedure WriteToFile(OBJFileName: string);
property DecimalPrecision: string read FDecimalPrecision;
property SmoothingLevel: integer read FSmoothingLevel;
end;
implementation
constructor TOBJSceneWriter.Create(AScene: TScene; ADecimalPrecision: string; ASmoothingLevel: integer);
begin
inherited Create;
FScene := AScene;
FDecimalPrecision := ADecimalPrecision;
FSmoothingLevel := ASmoothingLevel;
OBJData := TStringList.Create;
MaterialData := TStringList.Create;
TextureList := TStringList.Create;
ExportList := FScene.Primitives.Copy;
end;
destructor TOBJSceneWriter.Destroy;
begin
OBJData.Free;
MaterialData.Free;
TextureList.Free;
ExportList.Free;
inherited Destroy;
end;
procedure TOBJSceneWriter.WriteToFile(OBJFileName: string);
var
LastTextureUsed, PolyIndexString, PolyString, MaterialFileName, TextureSaveDirectory,
RelativeTextureFileName: string;
I, J, K, L: integer;
begin
L := 0;
try
TextureSaveDirectory := ExtractFilePath(OBJFileName) + 'Textures';
CreateDirUTF8(TextureSaveDirectory);
MaterialFileName := ExtractFilePath(OBJFileName) + ExtractFileNameOnly(OBJFileName) + '.mtl';
OBJData.Append('# Created by DeleD 2.45 Lazarus Edition #');
OBJData.Append('mtllib ' + ExtractFileNameOnly(MaterialFileName) + '.mtl');
for I := 0 to ExportList.NumPrimitives - 1 do
begin
if ExportList[I].IsLightOrPathOrSkeletonPart = True then
Continue;
with ExportList[I] do
begin
InitializeNormals(SmoothingLevel);
OBJData.Append('');
OBJData.Append('o ' + Name);
OBJData.Append('# Vertices #');
for J := 0 to NumPolygons - 1 do
begin
for K := 0 to Polygons[J].NumVertices - 1 do
begin
with Polygons[J].VerticeList[K] do
begin
OBJData.Append('v ' + FormatFloat(DecimalPrecision, x) + ' ' +
FormatFloat(DecimalPrecision, y) + ' ' + FormatFloat(DecimalPrecision, z));
end;
end;
end;
OBJData.Append('');
OBJData.Append('# Texture Coordinates #');
for J := 0 to NumPolygons - 1 do
begin
for K := 0 to Polygons[J].UVCoordinates[0].Count - 1 do
begin
with Polygons[J].UVCoordinates[0][K] do
begin
OBJData.Append('vt ' + FormatFloat(DecimalPrecision, u) + ' ' +
FormatFloat(DecimalPrecision, -v));
end;
end;
end;
OBJData.Append('');
OBJData.Append('# Normals #');
for J := 0 to NumPolygons - 1 do
begin
for K := 0 to Polygons[J].NumVertexNormals - 1 do
begin
with Polygons[J].VertexNormals[K] do
begin
OBJData.Append('vn ' + FormatFloat(DecimalPrecision, x) + ' ' +
FormatFloat(DecimalPrecision, y) + ' ' + FormatFloat(DecimalPrecision, z));
end;
end;
end;
OBJData.Append('');
OBJData.Append('# Polygons #');
for J := 0 to NumPolygons - 1 do
begin
with Polygons[J] do
begin
with Material.TextureLayers[0].Texture do
begin
if IsColorTexture = True then
begin
if LastTextureUsed <> Material.Name then
OBJData.Append('usemtl ' + Material.Name);
LastTextureUsed := Material.Name;
end
else
begin
RelativeTextureFileName :=
'Textures' + DirectorySeparator + ExtractFileName(FileName);
if LastTextureUsed <> RelativeTextureFileName then
OBJData.Append('usemtl ' + RelativeTextureFileName);
LastTextureUsed := RelativeTextureFileName;
end;
end;
PolyString := 'f';
for K := 0 to NumVertices - 1 do
begin
Inc(L);
PolyIndexString := IntToStr(L);
PolyString := PolyString + ' ' + PolyIndexString + '/' +
PolyIndexString + '/' + PolyIndexString;
end;
OBJData.Append(PolyString);
end;
end;
for J := 0 to NumPolygons - 1 do
begin
with Polygons[J].Material.TextureLayers[0].Texture do
begin
if (FileName <> '') and (TextureList.IndexOf(FileName) = -1) and
(TextureList.IndexOf(Polygons[J].Material.Name) = -1) then
begin
if IsColorTexture = True then
begin
MaterialData.Append('newmtl ' + Polygons[J].Material.Name);
with ColorToRGB(Color) do
MaterialData.Append('Kd ' + FormatFloat(DecimalPrecision, r) +
' ' + FormatFloat(DecimalPrecision, g) + ' ' +
FormatFloat(DecimalPrecision, b));
TextureList.Append(Polygons[J].Material.Name);
end
else
begin
RelativeTextureFileName :=
'Textures' + DirectorySeparator + ExtractFileName(FileName);
MaterialData.Append('newmtl ' + RelativeTextureFileName);
MaterialData.Append('map_Kd ' + RelativeTextureFileName);
CopyFile(FileName, TextureSaveDirectory + DirectorySeparator +
ExtractFileName(FileName), True);
TextureList.Append(FileName);
end;
end;
end;
end;
end;
end;
OBJData.SaveToFile(OBJFileName);
MaterialData.SaveToFile(MaterialFileName);
except
ShowMessage('Export error.');
end;
end;
end.
Recent
