//////////////////////////////////////////////////////////////////////////////// /// /// Модуль чтения файлов Digitals (*.dmf) /// /// (c) 2012 Александр Калабухов e-mail: kavlad@mail.ru /// //////////////////////////////////////////////////////////////////////////////// unit uDMFFile; interface uses SysUtils, Classes, Contnrs, Graphics, Windows, StrUtils, Math, DIB, OleCtnrs, Forms; type TdmfFile = class; TdmfFrame3D = packed record X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3, X4, Y4, Z4: Extended; end; TdmfMapHeader = packed record Scale: Extended; Count: integer; Units: integer; Status: integer; Frame: TdmfFrame3D; Name: ShortString; LeftFile: ShortString; RightFile: ShortString; end; TdmfLayersHeader = packed record Size: integer; Status: integer; Count: integer; MinService: integer; Reserved: Byte; Empty:integer; end; TdmfHorizAlign = (haLeft, haCenter, haRight); TdmfVertAlign = (vaTop, vaCenter, vaBottom); TdmfEntityType = ( etPoly, // Полигон/полилиния-1, etSoftPoly, // Полигон/полилиния(гладкая)-2, etPiquet, // Пикет-3, etSymbol, // Символ-4, etFrame, // Рамка и легенда-5, edTable, // Таблица-6, etCMR, // ЦМР-7, etPages, // Разметка листов-8, etRastr, // растровые изображения etTriangNet, // триангуляционная сеть etOLE, // OLE объект etText, // подпись etTrajectory, // траектория et3DModel, // 3D модель etLayerGroup // Группа слоев-0 ); // невидимый-3, видимый-2, помечаемый-1, редактируемый-0 TdmfState = (lsEditable, lsMarkable, lsVisible, lsInvisible); TdmfPolyType = (ptPolyline, ptPolygon); // Байт-1, Слово-2, Целое-3, Вещественное-4, Строка-5, Логическое-6, Файл (ссылка)-7, Список-8, Таблица-9 TdmfParamType = (prByte, prWord, prInt, prReal, prStr, prBool, prFileLink, prList, prTable); TdmfObject = class public function GetText: String; virtual; abstract; end; TdmfLayer = class(TdmfObject) private FAvailableParams: TList; FEntityType: TdmfEntityType; FState: TdmfState; FParams: array of Byte; FPolyType: TdmfPolyType; FName: String; FBrushColor: integer; FPenStyle: Byte; FFontSize: integer; FMinScale: integer; FFontStyle: Byte; FSymbolId: integer; FBrushStyle: Byte; FId: integer; FFontName: String; FFormat: String; FPenWidth: integer; FPenColor: integer; FFontSize10: integer; FFontColor: integer; FReference: integer; FMaxScale: integer; FPenWidth100: integer; procedure PrepareParams; procedure SetBrushColor(const Value: integer); procedure SetBrushStyle(const Value: Byte); procedure SetFontColor(const Value: integer); procedure SetFontName(const Value: String); procedure SetFontSize(const Value: integer); procedure SetFontSize10(const Value: integer); procedure SetFontStyle(const Value: Byte); procedure SetFormat(const Value: String); procedure SetId(const Value: integer); procedure SetMaxScale(const Value: integer); procedure SetMinScale(const Value: integer); procedure SetName(const Value: String); procedure SetPenColor(const Value: integer); procedure SetPenStyle(const Value: Byte); procedure SetPenWidth(const Value: integer); procedure SetPenWidth100(const Value: integer); procedure SetReference(const Value: integer); procedure SetSymbolId(const Value: integer); function GetParamCount: Integer; function GetParams(Index: Integer): Integer; procedure SynchParams(aFile: TdmfFile); public constructor Create; destructor Destroy; override; // function GetText: String; override; // property EntityType: TdmfEntityType read FEntityType write FEntityType; property PolyType: TdmfPolyType read FPolyType write FPolyType; property State: TdmfState read FState write FState; // property Id: integer read FId write SetId; property MinScale: integer read FMinScale write SetMinScale; property MaxScale: integer read FMaxScale write SetMaxScale; property PenColor: integer read FPenColor write SetPenColor; property PenWidth: integer read FPenWidth write SetPenWidth; property BrushColor: integer read FBrushColor write SetBrushColor; property FontColor: integer read FFontColor write SetFontColor; property FontSize: integer read FFontSize write SetFontSize; property PenStyle: Byte read FPenStyle write SetPenStyle; property BrushStyle: Byte read FBrushStyle write SetBrushStyle; property FontStyle: Byte read FFontStyle write SetFontStyle; property Name: String read FName write SetName; property FontName: String read FFontName write SetFontName; property SymbolId: integer read FSymbolId write SetSymbolId; property Format: String read FFormat write SetFormat; property Reference: integer read FReference write SetReference; property PenWidth100: integer read FPenWidth100 write SetPenWidth100; property FontSize10: integer read FFontSize10 write SetFontSize10; // property ParamCount: Integer read GetParamCount; property Params[Index: Integer]: Integer read GetParams; end; TdmfParam = class(TdmfObject) protected FSymbol: integer; FName: String; FBrushColor: integer; FParams: array of Byte; FPenStyle: Byte; FFontSize: integer; FMinScale: integer; FFontStyle: Byte; FParamLength: integer; FBrushStyle: Byte; FId: integer; FFontName: String; FBrushBMPSize: integer; FFormat: String; FPenWidth: integer; FPenColor: integer; FSize: integer; FFontSize10: integer; FFontColor: integer; FReference: integer; FMaxScale: integer; FPenWidth100: integer; FKind: TdmfParamType; FState: TdmfState; procedure SetBrushBMPSize(const Value: integer); procedure SetBrushColor(const Value: integer); procedure SetBrushStyle(const Value: Byte); procedure SetFontColor(const Value: integer); procedure SetFontName(const Value: String); procedure SetFontSize(const Value: integer); procedure SetFontSize10(const Value: integer); procedure SetFontStyle(const Value: Byte); procedure SetFormat(const Value: String); procedure SetId(const Value: integer); procedure SetMaxScale(const Value: integer); procedure SetMinScale(const Value: integer); procedure SetName(const Value: String); procedure SetParamLength(const Value: integer); procedure SetPenColor(const Value: integer); procedure SetPenStyle(const Value: Byte); procedure SetPenWidth(const Value: integer); procedure SetPenWidth100(const Value: integer); procedure SetReference(const Value: integer); procedure SetSize(const Value: integer); procedure SetSymbol(const Value: integer); public function GetText: String; override; procedure SetStatus(Value: integer); // property Size: integer read FSize write SetSize; property Id: integer read FId write SetId; property MinScale: integer read FMinScale write SetMinScale; property MaxScale: integer read FMaxScale write SetMaxScale; property PenColor: integer read FPenColor write SetPenColor; property PenWidth: integer read FPenWidth write SetPenWidth; property BrushColor: integer read FBrushColor write SetBrushColor; property FontColor: integer read FFontColor write SetFontColor; property FontSize: integer read FFontSize write SetFontSize; property PenStyle: Byte read FPenStyle write SetPenStyle; property BrushStyle: Byte read FBrushStyle write SetBrushStyle; property FontStyle: Byte read FFontStyle write SetFontStyle; property Name: String read FName write SetName; property FontName: String read FFontName write SetFontName; property BrushBMPSize: integer read FBrushBMPSize write SetBrushBMPSize; property ParamLength: integer read FParamLength write SetParamLength; property SymbolId: integer read FSymbol write SetSymbol; property Format: String read FFormat write SetFormat; property Reference: integer read FReference write SetReference; property PenWidth100: integer read FPenWidth100 write SetPenWidth100; property FontSize10: integer read FFontSize10 write SetFontSize10; end; TfdmLabelInfo = record ShiftX: Double; ShiftY: Double; ShiftZ: Double; Rotate: Double; Hidden: Boolean; VAlign: TdmfVertAlign; HAlign: TdmfHorizAlign; end; TdmfLabel = class(TdmfParam) private FInfos: array of TfdmLabelInfo; FFollowContour: Boolean; FDisplayed: Boolean; FText: String; procedure SetText(const Value: String); function GetRotate: Double; function GetShiftX: Double; function GetShiftY: Double; public constructor Create(aParam: TdmfParam); /// property Text: String read FText write SetText; property ShiftX: Double read GetShiftX; property ShiftY: Double read GetShiftY; property Rotate: Double read GetRotate; end; TdmfPrimitive = class(TdmfObject) private FBrushColor: integer; FPenStyle: Byte; FX2: integer; FY2: integer; FX1: integer; FY1: integer; FBrushStyle: Byte; FKind: String; FPenWidth: integer; FPenColor: integer; FGroup: Byte; procedure SetBrushColor(const Value: integer); procedure SetBrushStyle(const Value: Byte); procedure SetGroup(const Value: Byte); procedure SetKind(const Value: String); procedure SetPenColor(const Value: integer); procedure SetPenStyle(const Value: Byte); procedure SetPenWidth(const Value: integer); procedure SetX1(const Value: integer); procedure SetX2(const Value: integer); procedure SetY1(const Value: integer); procedure SetY2(const Value: integer); public function GetText: String; override; /// property Kind:String read FKind write SetKind; property Group:Byte read FGroup write SetGroup; property PenStyle:Byte read FPenStyle write SetPenStyle; property BrushStyle:Byte read FBrushStyle write SetBrushStyle; property PenColor:integer read FPenColor write SetPenColor; property PenWidth:integer read FPenWidth write SetPenWidth; property BrushColor:integer read FBrushColor write SetBrushColor; property X1:integer read FX1 write SetX1; property Y1:integer read FY1 write SetY1; property X2:integer read FX2 write SetX2; property Y2:integer read FY2 write SetY2; end; TdmfSymbol = class(TdmfObject) private FLength: integer; FHeaderSize: integer; FCount: integer; FID: integer; FKind: integer; FHeight: integer; procedure SetCount(const Value: integer); procedure SetHeaderSize(const Value: integer); procedure SetHeight(const Value: integer); procedure SetID(const Value: integer); procedure SetKind(const Value: integer); procedure SetLength(const Value: integer); public procedure AddPrimitive(aPrimitive: TdmfPrimitive); function GetKindText: String; function GetText: String; override; // property HeaderSize:integer read FHeaderSize write SetHeaderSize; property ID:integer read FID write SetID; property Count:integer read FCount write SetCount; property Length:integer read FLength write SetLength; property Kind:integer read FKind write SetKind; property Height:integer read FHeight write SetHeight; end; TEntityObjectKind = (eokObject, eokTable); TdmfTableColInfo = record Auto: Boolean; Align: TdmfHorizAlign; Width: Integer; end; TdmfPoint = class private FZ: Extended; FX: Extended; FY: Extended; FStatus: Integer; procedure SetStatus(const Value: Integer); procedure SetX(const Value: Extended); procedure SetY(const Value: Extended); procedure SetZ(const Value: Extended); public constructor Create(const Status: Integer; const X, Y, Z: Extended); /// function IsEqual(aPt: TdmfPoint): Boolean; /// property Status: Integer read FStatus write SetStatus; property X: Extended read FX write SetX; property Y: Extended read FY write SetY; property Z: Extended read FZ write SetZ; end; TdmfPointList = class(TObjectList) private function GetItems(Index: Integer): TdmfPoint; procedure SetItems(Index: Integer; const Value: TdmfPoint); public procedure AddPoint(const Status: Integer; const X, Y, Z: Extended); /// property Items[Index: Integer]: TdmfPoint read GetItems write SetItems; default; end; TdmfPartList = class(TObjectList) private function GetItems(Index: Integer): TdmfPointList; procedure SetItems(Index: Integer; const Value: TdmfPointList); public property Items[Index: Integer]: TdmfPointList read GetItems write SetItems; default; end; TdmfEntity = class(TdmfObject) private FDMFFile: TdmfFile; FLabels: TObjectList; // FParams: TObjectList; FPoints: TObjectList; FSymbolRotation: Integer; FKind: TEntityObjectKind; FScale: Single; FLayer: TdmfLayer; FId: Integer; /// для таблицы FCols: array of TdmfTableColInfo; FCells: array of array of String; FFormat: String; FHeader: Boolean; FColCount: Integer; FRowCount: Integer; FRowHeight: Integer; FDeleted: Boolean; FImage: TDIB; FOLE: TOLEContainer; procedure SetKind(const Value: TEntityObjectKind); procedure SetScale(const Value: Single); procedure SetSymbolRotation(const Value: Integer); procedure SetId(const Value: Integer); procedure SetLayer(const Value: TdmfLayer); procedure SetDeleted(const Value: Boolean); function GetPoints(Index: Integer): TdmfPoint; private function GetArea: String; function GetLength: String; function GetZ: String; function GetX: String; function GetY: String; function GetLayerName: String; function GetId: String; function GetLayerId: String; function GetPointCount: String; function GetPointNumbers: String; function GetLineLengths: String; function GetLabels(Index: Integer): TdmfLabel; function GetLabelCount: Integer; protected function AddLabel(aParam: TdmfParam): TdmfLabel; procedure LoadObjectParams(ParamsText: TStringList); procedure LoadTableHeader(HeaderText: String); procedure LoadTableParams(ParamsText: String); public constructor Create; destructor Destroy; override; // procedure AddPoint(const Status: Integer; const X, Y, Z: Extended); function GetCenter: TdmfPoint; function GetParamValue(const ParamName: String): String; function GetText: String; override; function HasInvisibleLines: Boolean; function IsClosed: Boolean; procedure LoadParams(ParamText: String); function PointCount: Integer; function VisibleParts: TdmfPartList; // property Deleted: Boolean read FDeleted write SetDeleted; property Id: Integer read FId write SetId; property Kind: TEntityObjectKind read FKind write SetKind; property LabelCount: Integer read GetLabelCount; property Labels[Index: Integer]: TdmfLabel read GetLabels; property Layer: TdmfLayer read FLayer write SetLayer; property Points[Index: Integer]: TdmfPoint read GetPoints; default; property Scale: Single read FScale write SetScale; property SymbolRotation: Integer read FSymbolRotation write SetSymbolRotation; end; TdmfFile = class private FError: Boolean; FFileStream: TStream; FStream: TStream; FV1, FV2: Integer; FMapHeader: TdmfMapHeader; FLayersHeader: TdmfLayersHeader; FLayers: TObjectList; FParams: TObjectList; FSymbols: TObjectList; FEntities: TObjectList; FMinParamNum: Integer; function ReadByte: Byte; function ReadCardinal: Cardinal; function ReadChars(Count: integer): String; function ReadInt: integer; function ReadReal: Extended; function ReadSingle: Single; function ReadStr: String; function ReadWord: Word; function GetLayerCount: Integer; function GetLayers(Index: Integer): TdmfLayer; function GetParamCount: Integer; function GetParams(Index: Integer): TdmfParam; function GetSymbolCount: Integer; function GetSymbols(Index: Integer): TdmfSymbol; function GetEntities(Index: Integer): TdmfEntity; function GetEntityCount: Integer; protected procedure DoOnError; function GetLayerIndex(LayerNumber: Integer): Integer; function GetParamById(ParamId: Integer): TdmfParam; function GetParamByNumber(ParamNumber: Integer): TdmfParam; procedure ReadHeader; procedure ReadEntity(Ent: TdmfEntity); procedure ReadLayer(aLayer: TdmfLayer); procedure ReadLayers; procedure ReadObjects; procedure ReadParam(aParam: TdmfParam); procedure ReadParams; procedure ReadPrimitive(aPrimitive: TdmfPrimitive); procedure ReadSymbol(aSymbol: TdmfSymbol); procedure ReadSymbols; public constructor Create; destructor Destroy; override; // function GetLayerById(LayerId: Integer): TdmfLayer; function GetLayerByName(const LayerName: String): TdmfLayer; procedure Load(const aFileName: String); // property EntityCount: Integer read GetEntityCount; property Entities[Index: Integer]: TdmfEntity read GetEntities; property LayerCount: Integer read GetLayerCount; property Layers[Index: Integer]: TdmfLayer read GetLayers; property ParamCount: Integer read GetParamCount; property Params[Index: Integer]: TdmfParam read GetParams; property SymbolCount: Integer read GetSymbolCount; property Symbols[Index: Integer]: TdmfSymbol read GetSymbols; end; implementation uses ZLib; const DMFFileSignature = 'GeoSystem DMF, Version '; //выравнивание подписей CDMFLblLeft=0; CDMFLblMiddle=1; CDMFLblRight=2; CDMFLblTop=0; CDMFLblCenter=1; CDMFLblBottom=2; CDMFLblNone=129; //эти подписи не отображаются //статус слоя и параметра CDMFStEdit=0; CDMFStSelect=1; CDMFStVisible=2; CDMFStHide=3; //коды строки параметров CDMFParStart = #1; CDMFParEnd = #2; CDMFParSep = #3; CDMFParInfo = #5; CDMFParMultiSep = '|'; CDMFTblHdrEnd = #7; CDMFTblColEnd = #9; CDMFTblRowEnd = #10; CDMFTblInfSep = ' '; CDMFTblLineSep = '||'; CDMFTblCols = 'COLS'; CDMFTblRows = 'ROWS'; CDMFTblLAlign = 'L'; CDMFTblCAlign = 'C'; CDMFTblRAlign = 'R'; CDMFTblRowHeight = 'ROWHEIGHT'; CDMFTblFormat = 'FORMAT'; CDMFTblNoHeader = 'NOHEADER'; CDMFPrimDefs: array[0..4] of Char = ('P','C','R','M',#0); CDMFAlignDefs: array[TdmfHorizAlign] of Char = ('L','C','R'); CDMFHAlignCnts: array[0..2] of integer = (CDMFLblLeft,CDMFLblMiddle,CDMFLblRight); CDMFVAlignCnts: array[0..2] of integer = (CDMFLblTop,CDMFLblCenter,CDMFLblBottom); CTblHdrDef: array[0..4] of string = (CDMFTblCols,CDMFTblRowHeight,CDMFTblFormat, CDMFTblRows,CDMFTblNoHeader); EPSILON = 0.01; type TChars = set of Char; function FindDelimiters(Delimiters: TChars; aText: String; var Position: Integer): Boolean; var I: Integer; begin Result := False; for I := 1 to Length(aText) do if aText[I] in Delimiters then begin Position := I; Result := True; Exit; end; end; function GetEntityType(Code: Byte): TdmfEntityType; begin case Code of 0: Result := etLayerGroup; 1: Result := etPoly; 2: Result := etSoftPoly; 3: Result := etPiquet; 4: Result := etSymbol; 5: Result := etFrame; 6: Result := edTable; 7: Result := etCMR; 8: Result := etPages; 9: Result := etRastr; 10: Result := etTriangNet; 11: Result := etOLE; 12: Result := etText; 13: Result := etTrajectory; 14: Result := et3DModel; else Result := etLayerGroup; //raise Exception.Create('Неверный код типа объектов слоя!'); end; end; function GetState(Code: Byte): TdmfState; begin case Code of 0: Result := lsEditable; 1: Result := lsMarkable; 2: Result := lsVisible; 3: Result := lsInvisible; else raise Exception.Create('Неверный код состояния слоя!'); end; end; function GetParamType(Code: Byte): TdmfParamType; begin case Code of 1: Result := prByte; 2: Result := prWord; 3: Result := prInt; 4: Result := prReal; 5: Result := prStr; 6: Result := prBool; 7: Result := prFileLink; 8: Result := prList; 9: Result := prTable; else raise Exception.Create('Неверный код типа параметра!'); end; end; { TDMFFile } constructor TdmfFile.Create; begin FLayers := TObjectList.Create; FParams := TObjectList.Create; FSymbols := TObjectList.Create; FEntities := TObjectList.Create; end; destructor TdmfFile.Destroy; begin FreeAndNil(FEntities); FreeAndNil(FSymbols); FreeAndNil(FParams); FreeAndNil(FLayers); inherited; end; procedure TdmfFile.DoOnError; begin FError := True; end; function TdmfFile.GetEntities(Index: Integer): TdmfEntity; begin Result := TdmfEntity(FEntities[Index]); end; function TdmfFile.GetEntityCount: Integer; begin Result := FEntities.Count; end; function TdmfFile.GetLayerById(LayerId: Integer): TdmfLayer; var I: Integer; begin Result := nil; for I := 0 to FLayers.Count - 1 do if TdmfLayer(Flayers[I]).FId = LayerId then begin Result := TdmfLayer(Flayers[I]); Exit; end; end; function TdmfFile.GetLayerByName(const LayerName: String): TdmfLayer; var I: Integer; begin Result := nil; for I := 0 to FLayers.Count - 1 do if Layers[I].Name = LayerName then begin Result := Layers[I]; Exit; end; end; function TdmfFile.GetLayerCount: Integer; begin Result := FLayers.Count; end; function TdmfFile.GetLayerIndex(LayerNumber: Integer): Integer; var I, N: Integer; Service: Boolean; begin Service := False; N := 0; for I := 0 to LayerCount - 1 do begin if Layers[I].Id < 0 then Service := True else if Layers[I].Id = 0 then begin if Service then Service := False else Inc(N); end else if Layers[I].Id > 0 then Inc(N); /// if N = FLayersHeader.MinService then begin Result := LayerNumber + I - 1; Exit; end; end; Result := -1; end; function TdmfFile.GetLayers(Index: Integer): TdmfLayer; begin Result := FLayers[Index] as TdmfLayer; end; function TdmfFile.GetParamById(ParamId: Integer): TdmfParam; var I: Integer; begin for I := 0 to ParamCount - 1 do if Params[I].Id = ParamId then begin Result := Params[I]; Exit; end; Result := nil; end; function TdmfFile.GetParamByNumber(ParamNumber: Integer): TdmfParam; var I, J, N: Integer; Service: Boolean; begin Service := False; N := 0; for I := 0 to ParamCount - 1 do begin if Params[I].Id < 0 then begin Service := True; if Params[I].Id = ParamNumber then begin Result := Params[I]; Exit; end; end else if Params[I].Id = 0 then begin if Service then Service := False else Inc(N); end else if Params[I].Id > 0 then Inc(N); /// if N = FMinParamNum then begin J := ParamNumber + I - 2; if J < ParamCount then Result := Params[J] else Result := nil; Exit; end; end; Result := nil; end; function TdmfFile.GetParamCount: Integer; begin Result := FParams.Count; end; function TdmfFile.GetParams(Index: Integer): TdmfParam; begin Result := FParams[Index] as TdmfParam; end; function TdmfFile.GetSymbolCount: Integer; begin Result := FSymbols.Count; end; function TdmfFile.GetSymbols(Index: Integer): TdmfSymbol; begin Result := FSymbols[Index] as TdmfSymbol; end; procedure TdmfFile.Load(const aFileName: String); begin FFileStream := TFileStream.Create(aFileName, fmOpenRead); try ReadHeader; ReadLayers; ReadParams; ReadSymbols; ReadObjects; finally FreeAndNil(FFileStream); end; end; constructor TdmfLayer.Create; begin FAvailableParams := TList.Create; end; destructor TdmfLayer.Destroy; begin FreeAndNil(FAvailableParams); inherited; end; function TdmfLayer.GetParamCount: Integer; begin Result := FAvailableParams.Count; end; function TdmfLayer.GetParams(Index: Integer): Integer; begin Result := Integer(FAvailableParams[Index]); end; function TdmfLayer.GetText: String; begin Result := SysUtils.Format('%-.11d', [Id]) + ': ' + Self.Name; end; procedure TdmfLayer.PrepareParams; var ByteInd, ParInd, Mask, BitInd: integer; begin ParInd := 0; for ByteInd := 0 to High(FParams) do begin Mask := 1; for BitInd := 1 to 8 do begin // внутри каждого байта -по битам if (Mask and FParams[ByteInd]) <> 0 then FAvailableParams.Add(Pointer(ParInd)); Inc(ParInd); Mask := Mask shl 1; end; end; end; procedure TdmfLayer.SetBrushColor(const Value: integer); begin FBrushColor := Value; end; procedure TdmfLayer.SetBrushStyle(const Value: Byte); begin FBrushStyle := Value; end; procedure TdmfLayer.SetFontColor(const Value: integer); begin FFontColor := Value; end; procedure TdmfLayer.SetFontName(const Value: String); begin FFontName := Value; end; procedure TdmfLayer.SetFontSize(const Value: integer); begin FFontSize := Value; end; procedure TdmfLayer.SetFontSize10(const Value: integer); begin FFontSize10 := Value; end; procedure TdmfLayer.SetFontStyle(const Value: Byte); begin FFontStyle := Value; end; procedure TdmfLayer.SetFormat(const Value: String); begin FFormat := Value; end; procedure TdmfLayer.SetId(const Value: integer); begin FId := Value; end; procedure TdmfLayer.SetMaxScale(const Value: integer); begin FMaxScale := Value; end; procedure TdmfLayer.SetMinScale(const Value: integer); begin FMinScale := Value; end; procedure TdmfLayer.SetName(const Value: String); begin FName := Value; end; procedure TdmfLayer.SetPenColor(const Value: integer); begin FPenColor := Value; end; procedure TdmfLayer.SetPenStyle(const Value: Byte); begin FPenStyle := Value; end; procedure TdmfLayer.SetPenWidth(const Value: integer); begin FPenWidth := Value; end; procedure TdmfLayer.SetPenWidth100(const Value: integer); begin FPenWidth100 := Value; end; procedure TdmfLayer.SetReference(const Value: integer); begin FReference := Value; end; procedure TdmfLayer.SetSymbolId(const Value: integer); begin FSymbolId := Value; end; procedure TdmfLayer.SynchParams(aFile: TdmfFile); var I: Integer; begin for I := FAvailableParams.Count - 1 downto 0 do if Integer(FAvailableParams[I]) >= aFile.ParamCount then FAvailableParams.Delete(I); end; function TdmfFile.ReadByte: Byte; begin Result := 0; if FStream.Read(Result, SizeOf(Result)) <> SizeOf(Result) then DoOnError(); end; function TdmfFile.ReadCardinal: Cardinal; begin Result := 0; if FStream.Read(Result, SizeOf(Result)) <> SizeOf(Result) then DoOnError(); end; function TdmfFile.ReadChars(Count: integer): String; var C: Char; I: integer; begin Result := ''; for I := 0 to Pred(Count) do if FStream.Read(C, SizeOf(C)) = SizeOf(C) then Result := Result + C else DoOnError; end; procedure TdmfFile.ReadEntity(Ent: TdmfEntity); var I, Sz, PtCount, Status, StartPos, EndPos: Integer; LayerNum, LayerId: Integer; Params: String; L1, L2: TdmfLayer; AttachmentType: Integer; X, Y, Z: Extended; begin StartPos := FStream.Position + SizeOf(Sz); Sz := ReadInt; EndPos := StartPos + Sz; ReadWord; {HeaderSz := }ReadInt; PtCount := ReadInt; LayerId := ReadInt; {Tag := }ReadInt; LayerNum := ReadInt; Ent.Id := ReadInt; Status := ReadInt; if (Status and 2) <> 0 then Ent.Deleted := True; {TS := }ReadCardinal; Ent.Scale := ReadSingle; {Group := }ReadInt; {Parent := }ReadInt; Ent.SymbolRotation := ReadInt; if Ent.Scale < 1 then Ent.Scale := 1; I := GetLayerIndex(LayerNum); // I := LayerNum - FLayersHeader.MinService; L1 := nil; if I < FLayers.Count then L1 := Layers[I]; L2 := GetLayerById(LayerId); if L1 = L2 then Ent.Layer := L1 else Ent.Layer := L1; // Sz := ReadInt; Params := ReadChars(Sz); if Copy(Params, 1, 4) = 'COLS' then Ent.Kind := eokTable else Ent.Kind := eokObject; /// if (PtCount < 0) or (PtCount > High(Word)) then Exit; I := 0; while I < PtCount do begin Status := ReadInt; X := ReadReal; Y := ReadReal; Z := ReadReal; Ent.AddPoint(Status, X, Y, Z); Inc(I); end; if Ent.FKind = eokObject then if Ent.Layer.EntityType = etPoly then if Ent.Layer.PolyType = ptPolygon then if Ent.PointCount > 1 then if not Ent.Points[0].IsEqual(Ent.Points[Ent.PointCount - 1]) then with Ent.Points[0] do Ent.AddPoint(Status, X, Y, Z); /// if FStream.Position < EndPos - 8 then begin //тип данных, 0 - bitmap, 1 - OLE AttachmentType := ReadInt; //размер данных Sz := ReadInt; if Sz > 0 then case AttachmentType of 0: begin Ent.FImage := TDIB.Create; Ent.FImage.LoadFromStream(FStream); end; 1: begin Ent.FOLE := TOLEContainer.Create(nil); Ent.FOLE.Parent := Application.MainForm; Ent.FOLE.Visible := False; Ent.FOLE.Enabled := False; Ent.FOLE.BorderStyle := bsNone; Ent.FOLE.SizeMode := smClip; Ent.FOLE.LoadFromStream(FStream); end; end; end; /// Ent.LoadParams(Params); end; procedure TdmfFile.ReadHeader; var S: String; HeaderSize, aPos: integer; begin if not Assigned(FFileStream) then begin DoOnError; Exit; end; FStream := FFileStream; S := ReadChars(Length(DMFFileSignature)); if (DMFFileSignature <> S) and (Copy(S, 1, 3) <> 'DMF') then DoOnError; S := ReadChars(1); if not TryStrToInt(S, FV1) then DoOnError; S := ReadChars(1); if S <> '.' then DoOnError; S := ReadChars(2); if not TryStrToInt(S, FV2) then DoOnError; S := ReadChars(5); if S[2] = 'C' then FStream := TDecompressionStream.Create(FFileStream) else begin FStream := TMemoryStream.Create; aPos := FFileStream.Position; FFileStream.Position := 0; FStream.CopyFrom(FFileStream, FFileStream.Size); FStream.Position := aPos; end; HeaderSize := ReadInt(); aPos := FStream.Position + HeaderSize; FMapHeader.Scale := ReadReal; FMapHeader.Count := ReadInt; FMapHeader.Units := ReadInt; FMapHeader.Status := ReadInt; FMapHeader.Frame.X1 := ReadReal; FMapHeader.Frame.Y1 := ReadReal; FMapHeader.Frame.Z1 := ReadReal; FMapHeader.Frame.X2 := ReadReal; FMapHeader.Frame.Y2 := ReadReal; FMapHeader.Frame.Z2 := ReadReal; FMapHeader.Frame.X3 := ReadReal; FMapHeader.Frame.Y3 := ReadReal; FMapHeader.Frame.Z3 := ReadReal; FMapHeader.Frame.X4 := ReadReal; FMapHeader.Frame.Y4 := ReadReal; FMapHeader.Frame.Z4 := ReadReal; ReadByte; FMapHeader.Name := Trim(ReadChars(255)); ReadByte; FMapHeader.LeftFile := Trim(ReadChars(255)); ReadByte; FMapHeader.RightFile := Trim(ReadChars(255)); // if FStream.Read(FMapHeader, HeaderSize) <> HeaderSize then // DoOnError; if FStream.Position <> aPos then FStream.Seek(aPos, soFromBeginning); end; function TdmfFile.ReadInt: integer; begin Result := 0; if FStream.Read(Result, SizeOf(Result)) <> SizeOf(Result) then DoOnError(); end; procedure TdmfFile.ReadLayer(aLayer: TdmfLayer); const ByteOne: Byte = 1; var B: Byte; Sz, StartPos, EndPos, aStatus: Integer; begin Sz := ReadInt; StartPos := FStream.Position; EndPos := StartPos + Sz; aStatus := ReadInt; aLayer.EntityType := GetEntityType(Hi(HiWord(aStatus))); aLayer.State := TdmfState(Lo(HiWord(aStatus))); B := Lo(LoWord(aStatus)); if (B and 1) <> 1 then aLayer.PolyType := ptPolyline else aLayer.PolyType := ptPolygon; aLayer.Id := ReadInt; aLayer.MinScale := ReadInt; aLayer.MaxScale := ReadInt; aLayer.PenColor := ReadInt; aLayer.PenWidth := ReadInt; aLayer.BrushColor := ReadInt; aLayer.FontColor := ReadInt; aLayer.FontSize := ReadInt; aLayer.PenStyle := ReadByte; aLayer.BrushStyle := ReadByte; aLayer.FontStyle := ReadByte; aLayer.Name := ReadStr; aLayer.FontName := ReadStr; Sz := ReadInt; if Sz > 0 then begin // aLayer.FBrushPattern := TDIB.Create; // aLayer.FBrushPattern.LoadFromStream(S); FStream.Seek(Sz, soFromCurrent); end; Sz := ReadInt; SetLength(aLayer.FParams, Sz); if Sz > 0 then FStream.Read(aLayer.FParams[0], Sz); aLayer.PrepareParams; aLayer.SymbolId := ReadInt; aLayer.Format := ReadStr; if EndPos > FStream.Position then begin aLayer.Reference := ReadInt; aLayer.PenWidth100 := ReadInt; aLayer.FontSize10 := ReadInt; end else begin aLayer.Reference := 0; aLayer.PenWidth100 := 0; aLayer.FontSize10 := 0; end; if EndPos > FStream.Position // считали меньше данных, чем требуется // устанавливаем позицию -начало след. параметра then FStream.Seek(EndPos, soFromBeginning) // если считали больше данных, чем требуется -ошибка else if EndPos < FStream.Position then DoOnError(); end; procedure TdmfFile.ReadLayers; var LayerCount, I: Integer; Layer: TdmfLayer; begin FLayersHeader.Size := ReadInt; FStream.Position; FLayersHeader.Status := ReadInt; FLayersHeader.Count := ReadInt; FLayersHeader.MinService := ReadInt; FLayersHeader.Reserved := ReadByte; FLayersHeader.Empty := ReadInt; // if FStream.Read(FLayersHeader, SizeOf(FLayersHeader)) <> SizeOf(FLayersHeader) // then // DoOnError; // проверяем или не слишком много слоев в списке и // не выходит ли размер списка слоев за размер файла if (FLayersHeader.Count > High(Word)) or (FLayersHeader.Count < 0) or (FLayersHeader.Size < 0) then DoOnError; LayerCount := FLayersHeader.Count - Abs(FLayersHeader.MinService); I := 0; while I < LayerCount do begin Layer := TdmfLayer.Create; FLayers.Add(Layer); ReadLayer(Layer); if Layer.Id > 0 then Inc(I); end; end; procedure TdmfFile.ReadObjects; var I: Integer; Ent: TdmfEntity; begin I := 0; while I < FMapHeader.Count do begin Ent := TdmfEntity.Create; try Ent.FDMFFile := Self; ReadEntity(Ent); except FreeAndNil(Ent); end; if Assigned(Ent) then FEntities.Add(Ent); Inc(I); end; end; procedure TdmfFile.ReadParam(aParam: TdmfParam); var StartPos, EndPos, Sz, Count: Integer; begin Sz := ReadInt; StartPos := FStream.Position; EndPos := StartPos + Sz; aParam.SetStatus(ReadInt); aParam.Id := ReadInt; aParam.MinScale := ReadInt; aParam.MaxScale := ReadInt; aParam.PenColor := ReadInt; aParam.PenWidth := ReadInt; aParam.BrushColor := ReadInt; aParam.FontColor := ReadInt; aParam.FontSize := ReadInt; aParam.PenStyle := ReadByte; aParam.BrushStyle := ReadByte; aParam.FontStyle := ReadByte; aParam.Name := ReadStr; aParam.FontName := ReadStr; Sz := ReadInt; if Sz > 0 then FStream.Seek(Sz, soFromCurrent); Count := ReadInt; SetLength(aParam.FParams, Count); if Count > 0 then FStream.Read(aParam.FParams[0], Count); aParam.SymbolId := ReadInt; aParam.Format := ReadStr; if EndPos < FStream.Position then begin aParam.Reference := ReadInt; aParam.PenWidth100 := ReadInt; aParam.FontSize10 := ReadInt; end else begin aParam.Reference := 0; aParam.PenWidth100 := 0; aParam.FontSize10 := 0; end; if EndPos > FStream.Position // считали меньше данных, чем требуется // устанавливаем позицию -начало след. параметра then FStream.Seek(EndPos, soFromBeginning) // если считали больше данных, чем требуется -ошибка else if EndPos < FStream.Position then DoOnError(); end; procedure TdmfFile.ReadParams; var Count: integer; I: integer; aParam: TdmfParam; begin ReadInt; ReadInt; Count := ReadInt; FMinParamNum := ReadInt; ReadByte; ReadInt; I := 0; while I < Count do begin aParam := TdmfParam.Create; FParams.Add(aParam); ReadParam(aParam); if aParam.Id > 0 then Inc(I); end; /// for I := 0 to LayerCount - 1 do Layers[I].SynchParams(Self); end; procedure TdmfFile.ReadPrimitive(aPrimitive: TdmfPrimitive); begin aPrimitive.Kind:=ReadChars(1); aPrimitive.Group:=ReadByte; aPrimitive.PenStyle:=ReadByte; aPrimitive.BrushStyle:=ReadByte; aPrimitive.PenColor:=ReadInt; aPrimitive.PenWidth:=ReadInt; aPrimitive.BrushColor:=ReadInt; aPrimitive.X1:=ReadInt; aPrimitive.Y1:=ReadInt; aPrimitive.X2:=ReadInt; aPrimitive.Y2:=ReadInt; end; function TdmfFile.ReadReal: Extended; begin Result := 0; if FStream.Read(Result, SizeOf(Result)) <> SizeOf(Result) then DoOnError(); end; function TdmfFile.ReadSingle: Single; begin Result := 0; if FStream.Read(Result, SizeOf(Result)) <> SizeOf(Result) then DoOnError(); end; function TdmfFile.ReadStr: String; var Sz: integer; begin Sz := ReadByte; if Sz = 255 then Sz := ReadInt; if Sz > 0 then Result := ReadChars(Sz); end; procedure TdmfFile.ReadSymbol(aSymbol: TdmfSymbol); var Sz, I, EndPos: Integer; aPrimitive: TdmfPrimitive; begin Sz := ReadInt; EndPos := FStream.Position + Sz; aSymbol.HeaderSize := ReadInt; aSymbol.ID := ReadInt; aSymbol.Count := ReadInt; aSymbol.Length := ReadInt; aSymbol.Kind := ReadInt; aSymbol.Height := ReadInt; for I := 0 to aSymbol.Count - 1 do begin aPrimitive := TdmfPrimitive.Create; aSymbol.AddPrimitive(aPrimitive); ReadPrimitive(aPrimitive); end; if EndPos > FStream.Position // считали меньше данных, чем требуется // устанавливаем позицию -начало след. параметра then FStream.Seek(EndPos, soFromBeginning) // если считали больше данных, чем требуется -ошибка else if EndPos < FStream.Position then DoOnError(); end; procedure TdmfFile.ReadSymbols; var Count, I: Integer; S: TdmfSymbol; begin ReadInt;// Count := ReadInt; for I := 1 to Count do begin S := TdmfSymbol.Create; FSymbols.Add(S); ReadSymbol(S); end; end; function TdmfFile.ReadWord: Word; begin Result := 0; if FStream.Read(Result, SizeOf(Result)) <> SizeOf(Result) then DoOnError(); end; { TdmfParam } function TdmfParam.GetText: String; begin Result := Name; end; procedure TdmfParam.SetBrushBMPSize(const Value: integer); begin FBrushBMPSize := Value; end; procedure TdmfParam.SetBrushColor(const Value: integer); begin FBrushColor := Value; end; procedure TdmfParam.SetBrushStyle(const Value: Byte); begin FBrushStyle := Value; end; procedure TdmfParam.SetFontColor(const Value: integer); begin FFontColor := Value; end; procedure TdmfParam.SetFontName(const Value: String); begin FFontName := Value; end; procedure TdmfParam.SetFontSize(const Value: integer); begin FFontSize := Value; end; procedure TdmfParam.SetFontSize10(const Value: integer); begin FFontSize10 := Value; end; procedure TdmfParam.SetFontStyle(const Value: Byte); begin FFontStyle := Value; end; procedure TdmfParam.SetFormat(const Value: String); begin FFormat := Value; end; procedure TdmfParam.SetId(const Value: integer); begin FId := Value; end; procedure TdmfParam.SetMaxScale(const Value: integer); begin FMaxScale := Value; end; procedure TdmfParam.SetMinScale(const Value: integer); begin FMinScale := Value; end; procedure TdmfParam.SetName(const Value: String); begin FName := Value; end; procedure TdmfParam.SetParamLength(const Value: integer); begin FParamLength := Value; end; procedure TdmfParam.SetPenColor(const Value: integer); begin FPenColor := Value; end; procedure TdmfParam.SetPenStyle(const Value: Byte); begin FPenStyle := Value; end; procedure TdmfParam.SetPenWidth(const Value: integer); begin FPenWidth := Value; end; procedure TdmfParam.SetPenWidth100(const Value: integer); begin FPenWidth100 := Value; end; procedure TdmfParam.SetReference(const Value: integer); begin FReference := Value; end; procedure TdmfParam.SetSize(const Value: integer); begin FSize := Value; end; procedure TdmfParam.SetStatus(Value: integer); begin FState := GetState(Lo(HiWord(Value))); FKind := GetParamType(Hi(HiWord(Value))); end; procedure TdmfParam.SetSymbol(const Value: integer); begin FSymbol := Value; end; { TdmfSymbol } procedure TdmfSymbol.AddPrimitive(aPrimitive: TdmfPrimitive); begin end; function TdmfSymbol.GetKindText: String; begin case FKind of 0 : Result := 'одиночный'; 1 : Result := 'линейный'; 2 : Result := 'площадной'; 3 : Result := 'линейно-ориентированый'; 4 : Result := 'линейно-масштабируемый'; 5 : Result := 'двулинейный'; end; end; function TdmfSymbol.GetText: String; begin Result := ClassName; end; procedure TdmfSymbol.SetCount(const Value: integer); begin FCount := Value; end; procedure TdmfSymbol.SetHeaderSize(const Value: integer); begin FHeaderSize := Value; end; procedure TdmfSymbol.SetHeight(const Value: integer); begin FHeight := Value; end; procedure TdmfSymbol.SetID(const Value: integer); begin FID := Value; end; procedure TdmfSymbol.SetKind(const Value: integer); begin FKind := Value; end; procedure TdmfSymbol.SetLength(const Value: integer); begin FLength := Value; end; { TdmfPrimitive } function TdmfPrimitive.GetText: String; begin Result := ClassName; end; procedure TdmfPrimitive.SetBrushColor(const Value: integer); begin FBrushColor := Value; end; procedure TdmfPrimitive.SetBrushStyle(const Value: Byte); begin FBrushStyle := Value; end; procedure TdmfPrimitive.SetGroup(const Value: Byte); begin FGroup := Value; end; procedure TdmfPrimitive.SetKind(const Value: String); begin FKind := Value; end; procedure TdmfPrimitive.SetPenColor(const Value: integer); begin FPenColor := Value; end; procedure TdmfPrimitive.SetPenStyle(const Value: Byte); begin FPenStyle := Value; end; procedure TdmfPrimitive.SetPenWidth(const Value: integer); begin FPenWidth := Value; end; procedure TdmfPrimitive.SetX1(const Value: integer); begin FX1 := Value; end; procedure TdmfPrimitive.SetX2(const Value: integer); begin FX2 := Value; end; procedure TdmfPrimitive.SetY1(const Value: integer); begin FY1 := Value; end; procedure TdmfPrimitive.SetY2(const Value: integer); begin FY2 := Value; end; { TdmfEntity } function TdmfEntity.AddLabel(aParam: TdmfParam): TdmfLabel; begin Result := TdmfLabel.Create(aParam); FLabels.Add(Result); end; procedure TdmfEntity.AddPoint(const Status: Integer; const X, Y, Z: Extended); begin FPoints.Add(TdmfPoint.Create(Status, X, Y, Z)); end; constructor TdmfEntity.Create; begin FLabels := TObjectList.Create; FPoints := TObjectList.Create; end; destructor TdmfEntity.Destroy; begin FreeAndNil(FPoints); FreeAndNil(FLabels); inherited; end; function TdmfEntity.GetArea: String; begin Result := ''; end; function TdmfEntity.GetCenter: TdmfPoint; var I, C: Integer; Xmax, Xmin, Ymax, Ymin: Extended; begin C := PointCount; if C = 0 then Result := nil else begin Xmin := Points[0].X; Xmax := Xmin; Ymin := Points[0].Y; Ymax := Ymin; for I := 1 to C - 1 do begin Xmin := Min(Xmin, Points[I].X); Xmax := Max(Xmax, Points[I].X); Ymin := Min(Ymin, Points[I].Y); Ymax := Max(Ymax, Points[I].Y); end; Result := TdmfPoint.Create(0, Xmin + (Xmax - Xmin) / 2, Ymin + (Ymax - Ymin) / 2, 0); end; end; function TdmfEntity.GetId: String; begin Result := IntToStr(Id); end; function TdmfEntity.GetLabelCount: Integer; begin Result := FLabels.Count; end; function TdmfEntity.GetLabels(Index: Integer): TdmfLabel; begin Result := FLabels[Index] as TdmfLabel; end; function TdmfEntity.GetLayerId: String; begin Result := ''; if Assigned(Layer) then Result := IntToStr(Layer.Id); end; function TdmfEntity.GetLayerName: String; begin Result := ''; if Assigned(Layer) then Result := Layer.Name; end; function TdmfEntity.GetLength: String; begin Result := ''; end; function TdmfEntity.GetLineLengths: String; begin Result := ''; end; function TdmfEntity.GetParamValue(const ParamName: String): String; var L: TdmfLabel; I: Integer; begin Result := ''; for I := 0 to Pred(FLabels.Count) do begin L := TdmfLabel(FLabels[I]); if L.Name = ParamName then begin Result := L.Text; Exit; end; end; end; function TdmfEntity.GetPointCount: String; begin Result := IntToStr(PointCount); end; function TdmfEntity.GetPointNumbers: String; begin Result := ''; end; function TdmfEntity.GetPoints(Index: Integer): TdmfPoint; begin Result := TdmfPoint(FPoints[Index]); end; function TdmfEntity.GetText: String; begin Result := 'TdmfEntity'; end; function TdmfEntity.GetX: String; begin Result := ''; if Assigned(Layer) then if Layer.FEntityType = etPiquet then if PointCount > 0 then Result := FloatToStr(Points[0].X); end; function TdmfEntity.GetY: String; begin Result := ''; if Assigned(Layer) then if Layer.FEntityType = etPiquet then if PointCount > 0 then Result := FloatToStr(Points[0].Y); end; function TdmfEntity.GetZ: String; begin Result := ''; if Assigned(Layer) then if Layer.FEntityType = etPiquet then if PointCount > 0 then Result := FloatToStr(Points[0].Z); end; function TdmfEntity.HasInvisibleLines: Boolean; var I: Integer; begin for I := 0 to PointCount - 1 do if Points[I].Status <> 0 then begin Result := True; Exit; end; Result := False; end; function TdmfEntity.IsClosed: Boolean; begin Result := not HasInvisibleLines; if Result then Result := PointCount > 2; if Result then Result := Points[0].IsEqual(Points[PointCount - 1]); end; procedure TdmfEntity.LoadObjectParams(ParamsText: TStringList); var EndPos, I, J, InfoCount, InfoIdx, N: Integer; ParamText, NumText, LabelText, InfoText, S1: String; InfoType: Char; L: TdmfLabel; D: Double; Param: TdmfParam; begin //aMinNumber := 0; //разбираем строку параметров объекта //выполняем цикл пока находим признак завершения параметра for J := 0 to Pred(ParamsText.Count) do begin ParamText := ParamsText[J]; //получаем индекс параметра в списке if not FindDelimiters([CDMFParSep], ParamText, EndPos) then Continue; NumText := Copy(ParamText, 1, EndPos - 1); Delete(ParamText, 1, EndPos); //индекс параметра за пределами списка или не числовое значение if not TryStrToInt(NumText, I) then Continue; Param := FDMFFile.GetParamByNumber(I); if not Assigned(Param) then Continue; //создаем новую подпись //ищем значение подписи if I <= 0 then begin case I of 0 : LabelText := GetArea; -1 : LabelText := GetLength; -2 : LabelText := GetZ; -3 : LabelText := GetY; -4 : LabelText := GetX; -5 : LabelText := GetLayerName; -6 : LabelText := GetId; -7 : LabelText := GetLayerId; -8 : LabelText := GetPointCount; -9 : LabelText := GetPointNumbers; -10 : LabelText := GetLineLengths; end; end else if FindDelimiters([CDMFParInfo], ParamText, EndPos) then begin LabelText := Copy(ParamText, 1, EndPos - 1); Delete(ParamText, 1, EndPos); end else LabelText := ParamText; //L := AddLabel(FDMFFile.Params[I - aMinNumber]); L := AddLabel(Param); L.Text := LabelText; // InfoCount := 0; //если подпись отображается -разбираем параметры отображения while FindDelimiters([CDMFParInfo], ParamText, EndPos) do begin //признак типа инфо InfoText := Copy(ParamText, 1, EndPos - 1); Delete(ParamText, 1, EndPos); if InfoText <> '' then InfoType := UpCase(InfoText[1]) else InfoType := ' '; InfoIdx := 0; if not FindDelimiters([CDMFParMultiSep], InfoText, EndPos) then begin Delete(InfoText, 1, 1); //заменяем разделитель на точку InfoText := StringReplace(InfoText, ',', DecimalSeparator, []); InfoText := StringReplace(InfoText, '.', DecimalSeparator, []); if not TryStrToFloat(InfoText, D) then Continue; I := Trunc(D); /// N := Length(L.FInfos); if InfoIdx >= N then SetLength(L.FInfos, N + 10); case InfoType of 'X': begin L.FInfos[InfoIdx].ShiftX := D; Inc(InfoCount); end; 'Y': L.FInfos[InfoIdx].ShiftY := D; 'Z': L.FInfos[InfoIdx].ShiftZ := D; 'O': L.FInfos[InfoIdx].Rotate := I; 'L': //подписи с таким выравниванием не отображаются if (CDMFLblNone and I) = CDMFLblNone then L.FInfos[InfoIdx].Hidden := True else begin L.FInfos[InfoIdx].Hidden := False; L.FInfos[InfoIdx].HAlign := haLeft; L.FInfos[InfoIdx].VAlign := vaTop; //младший байт -выравн. по гориз. case Lo(I) of CDMFLblMiddle: L.FInfos[InfoIdx].HAlign := haCenter; CDMFLblRight: L.FInfos[InfoIdx].HAlign := haRight; end; //старший байт -выравн. по верт. case Hi(I) of CDMFLblCenter: L.FInfos[InfoIdx].VAlign := vaCenter; CDMFLblBottom: L.FInfos[InfoIdx].VAlign := vaBottom; end; end; 'S': L.FFontSize := I; 'P': L.FFollowContour := True; end; Inc(InfoIdx); end; /// while FindDelimiters([CDMFParMultiSep], InfoText, EndPos) do begin //само инфо S1 := Copy(InfoText, 1, EndPos - 1); Delete(InfoText, 1, EndPos); //заменяем разделитель на точку S1 := StringReplace(S1, ',', '.', []); if not TryStrToFloat(S1, D) then Break; I := Trunc(D); /// N := Length(L.FInfos); if InfoIdx >= N then SetLength(L.FInfos, N + 10); case InfoType of 'X': begin L.FInfos[InfoIdx].ShiftX := D; Inc(InfoCount); end; 'Y': L.FInfos[InfoIdx].ShiftY := D; 'Z': L.FInfos[InfoIdx].ShiftZ := D; 'O': L.FInfos[InfoIdx].Rotate := I; 'L': //подписи с таким выравниванием не отображаются if (CDMFLblNone and I) = CDMFLblNone then L.FInfos[InfoIdx].Hidden := True else begin L.FInfos[InfoIdx].Hidden := False; L.FInfos[InfoIdx].HAlign := haLeft; L.FInfos[InfoIdx].VAlign := vaTop; //младший байт -выравн. по гориз. case Lo(I) of CDMFLblMiddle: L.FInfos[InfoIdx].HAlign := haCenter; CDMFLblRight: L.FInfos[InfoIdx].HAlign := haRight; end; //старший байт -выравн. по верт. case Hi(I) of CDMFLblCenter: L.FInfos[InfoIdx].VAlign := vaCenter; CDMFLblBottom: L.FInfos[InfoIdx].VAlign := vaBottom; end; end; 'S': L.FFontSize := I; 'P': L.FFollowContour := True; end; Inc(InfoIdx); end; end; //длина всех цепочек значений должна быть одинаковая //устанавливаем длину по кол-ву значений для параметра X SetLength(L.FInfos, Min(Length(L.FInfos), InfoCount)); //записываем нулевые координаты в ограничивающий подпись рект L.FDisplayed := Length(L.FInfos) > 0; end; end; procedure TdmfEntity.LoadParams(ParamText: String); var ParamStrings: TStringList; I1, I2: Integer; begin ParamStrings := TStringList.Create; try I1 := Pos(#1, ParamText); while I1 > 0 do begin I2 := Pos(#2, ParamText); if I2 > I1 then begin ParamStrings.Add(Copy(ParamText, I1 + 1, I2 - I1 - 1)); Delete(ParamText, 1, I2); end else Break; I1 := Pos(#1, ParamText); end; /// if ParamStrings.Count > 0 then if Kind = eokTable then begin LoadTableParams(ParamStrings[0]); ParamStrings.Delete(0); end; LoadObjectParams(ParamStrings); finally FreeAndNil(ParamStrings); end; end; procedure TdmfEntity.LoadTableHeader(HeaderText: String); var I, HdrIdx, EndPos, ColCnt: Integer; S: String; Al: TdmfHorizAlign; begin for HdrIdx := Low(CTblHdrDef) to High(CTblHdrDef) do begin if StartsStr(CTblHdrDef[HdrIdx], HeaderText) then begin Delete(HeaderText, 1, Length(CTblHdrDef[HdrIdx])); if FindDelimiters([CDMFTblRowEnd, CDMFTblHdrEnd], HeaderText, EndPos) then begin case HdrIdx of 0 : //COLS begin FColCount := 0; ColCnt := 0; while FindDelimiters([CDMFTblInfSep,CDMFTblRowEnd,CDMFTblHdrEnd], HeaderText, EndPos) do begin S := Copy(HeaderText, 1, EndPos - 1); Delete(HeaderText, 1, EndPos); if S = '' then Continue; if FColCount = 0 then begin //количество колонок if not TryStrToInt(Trim(S), I) then Continue; SetLength(FCols, I); FColCount := I; end else begin if ColCnt > Length(FCols) then Continue; //выравнивание в колонке FCols[ColCnt - 1].Align := haLeft; for Al := Low(TdmfHorizAlign) to High(TdmfHorizAlign) do if CDMFAlignDefs[Al] = S[1] then FCols[ColCnt-1].Align := Al; Delete(S, 1, 1); FCols[ColCnt - 1].Auto := True; if S = '' then Continue; if S[1] = '+' then begin //ширина колонки фиксирована FCols[ColCnt-1].Auto := False; Delete(S, 1, 1); end; if not TryStrToInt(S, I) then Continue; FCols[ColCnt - 1].Width := I; end; Inc(ColCnt); end; end; 1: //ROWHEIGHT begin S := Copy(HeaderText, 1, EndPos - 1); Delete(HeaderText, 1, EndPos); if not TryStrToInt(S, I) then Continue; FRowHeight := I; end; 2: //FORMAT begin FFormat := Copy(HeaderText, 1, EndPos - 1); Delete(HeaderText, 1, EndPos); end; 3: //ROWS begin S := Copy(HeaderText, 1, EndPos - 1); Delete(HeaderText, 1, EndPos); if not TryStrToInt(S, I) then Continue; FRowCount := I; end; 4: //NOHEADER FHeader := False; end; end; end; end; end; procedure TdmfEntity.LoadTableParams(ParamsText: String); var EndPos, ColCnt, RowCnt: Integer; S, S1, HeaderText, RowText: String; begin if FindDelimiters([CDMFTblHdrEnd], ParamsText, EndPos) then begin HeaderText := Copy(ParamsText, 1, EndPos - 1); Delete(ParamsText, 1, EndPos); LoadTableHeader(HeaderText); //преобразовываем строку параметров объекта //в список подписей или таблицу //считываем заголовок таблицы //считываем строки SetLength(FCells, FColCount, FRowCount); ColCnt := 0; RowCnt := 0; //цикл по строкам while FindDelimiters([CDMFTblRowEnd], S, EndPos) do begin RowText := Copy(S, 1, EndPos - 1); Delete(S, 1, EndPos); //цикл по столбцам while FindDelimiters([CDMFTblColEnd], RowText, EndPos) do begin //текст ячейки S1 := Copy(RowText, 1, EndPos - 1); Delete(RowText, 1, EndPos); //заменяем символ переноса строки на #13#10 S1 := StringReplace(S1, CDMFTblLineSep, #13#10, [rfReplaceAll]); if ColCnt >= FColCount then Continue; FCells[ColCnt, RowCnt] := S1; Inc(ColCnt); if RowText[EndPos] = CDMFTblRowEnd then begin Inc(RowCnt); if RowCnt >= FRowCount then Continue; ColCnt := 0; end; end; end; end; end; function TdmfEntity.VisibleParts: TdmfPartList; var I, K1, K2: Integer; LineVisible: Boolean; aPart: TdmfPointList; begin if HasInvisibleLines then begin Result := TdmfPartList.Create; aPart := nil; for K1 := 0 to PointCount - 2 do begin K2 := K1 + 1; LineVisible := Points[K2].Status = 0; if LineVisible then begin if not Assigned(aPart) then aPart := TdmfPointList.Create; if aPart.Count = 0 then with Points[K1] do aPart.AddPoint(Status, X, Y, Z); with Points[K2] do aPart.AddPoint(Status, X, Y, Z); end else begin if Assigned(aPart) then if aPart.Count > 0 then begin Result.Add(aPart); aPart := nil; end; end; end; if Assigned(aPart) then if aPart.Count > 0 then Result.Add(aPart); end else begin Result := TdmfPartList.Create; aPart := TdmfPointList.Create; Result.Add(aPart); for I := 0 to PointCount - 1 do with Points[I] do aPart.AddPoint(Status, X, Y, Z); end; end; function TdmfEntity.PointCount: Integer; begin Result := FPoints.Count; end; procedure TdmfEntity.SetDeleted(const Value: Boolean); begin FDeleted := Value; end; procedure TdmfEntity.SetId(const Value: Integer); begin FId := Value; end; procedure TdmfEntity.SetKind(const Value: TEntityObjectKind); begin FKind := Value; end; procedure TdmfEntity.SetLayer(const Value: TdmfLayer); begin FLayer := Value; end; procedure TdmfEntity.SetScale(const Value: Single); begin FScale := Value; end; procedure TdmfEntity.SetSymbolRotation(const Value: Integer); begin FSymbolRotation := Value; end; { TdmfLabel } constructor TdmfLabel.Create(aParam: TdmfParam); begin FSymbol := aParam.FSymbol; FName := aParam.FName; FBrushColor := aParam.FBrushColor; FParams := aParam.FParams; FPenStyle := aParam.FPenStyle; FFontSize := aParam.FFontSize; FMinScale := aParam.FMinScale; FFontStyle := aParam.FFontStyle; FParamLength := aParam.FParamLength; FBrushStyle := aParam.FBrushStyle; FId := aParam.FId; FFontName := aParam.FFontName; FBrushBMPSize := aParam.FBrushBMPSize; FFormat := aParam.FFormat; FPenWidth := aParam.FPenWidth; FPenColor := aParam.FPenColor; FSize := aParam.FSize; FFontSize10 := aParam.FFontSize10; FFontColor := aParam.FFontColor; FReference := aParam.FReference; FMaxScale := aParam.FMaxScale; FPenWidth100 := aParam.FPenWidth100; FKind := aParam.FKind; FState := aParam.FState; end; function TdmfLabel.GetRotate: Double; var I: Integer; begin Result := 0; for I := 0 to Length(FInfos) - 1 do if not FInfos[I].Hidden then if FInfos[I].Rotate <> 0 then Result := FInfos[I].Rotate; end; function TdmfLabel.GetShiftX: Double; var I: Integer; begin Result := 0; for I := 0 to Length(FInfos) - 1 do if not FInfos[I].Hidden then if FInfos[I].ShiftX <> 0 then Result := FInfos[I].ShiftX; end; function TdmfLabel.GetShiftY: Double; var I: Integer; begin Result := 0; for I := 0 to Length(FInfos) - 1 do if not FInfos[I].Hidden then if FInfos[I].ShiftY <> 0 then Result := FInfos[I].ShiftY; end; procedure TdmfLabel.SetText(const Value: String); begin FText := Value; end; { Tdmfpoint } constructor Tdmfpoint.Create(const Status: Integer; const X, Y, Z: Extended); begin FStatus := Status; FX := X; FY := Y; FZ := Z; end; function TdmfPoint.IsEqual(aPt: TdmfPoint): Boolean; begin Result := Assigned(aPt); if Result then Result := ((aPt.X - X) < EPSILON) and ((aPt.Y - Y) < EPSILON) and ((aPt.Z - Z) < EPSILON); end; procedure Tdmfpoint.SetStatus(const Value: Integer); begin FStatus := Value; end; procedure Tdmfpoint.SetX(const Value: Extended); begin FX := Value; end; procedure Tdmfpoint.SetY(const Value: Extended); begin FY := Value; end; procedure Tdmfpoint.SetZ(const Value: Extended); begin FZ := Value; end; { TdmfPointList } procedure TdmfPointList.AddPoint(const Status: Integer; const X, Y, Z: Extended); begin Add(TdmfPoint.Create(Status, X, Y, Z)); end; function TdmfPointList.GetItems(Index: Integer): TdmfPoint; begin Result := inherited Items[Index] as TdmfPoint; end; procedure TdmfPointList.SetItems(Index: Integer; const Value: TdmfPoint); begin inherited Items[Index] := Value; end; { TdmfPartList } function TdmfPartList.GetItems(Index: Integer): TdmfPointList; begin Result := inherited Items[Index] as TdmfPointList; end; procedure TdmfPartList.SetItems(Index: Integer; const Value: TdmfPointList); begin inherited Items[Index] := Value; end; end.