HOTMAP

Top  Previous  Next

 

{ THotMap : Delphi1.0 komponens

         A kép részleteit zárt poligonokkal (szegmensek) ID és SegmentName

         azonosítókkal láthatunk el.

         Egérrel információt kaphatunk a kurzor alatti szegmensről.

}

 

unit HotMap;

 

interface

 

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,

Dialogs, stdctrls, ExtCtrls, DGrafik;

 

type

   TDrawMode = (tamNone,tamSearch,tamDraw,tamDrag,tamInsert,tamDelete);

   TPoligonMode = (pomNone,pomNew,pomOpen,pomClosed);

 

   THotMapHeader = record             {*.HX}

        PictureFile        : string[120];        {Képfile neve teljes Path-al}

        SegmentCount        : word;                {Szegmensek száma}

   end;

 

   THotMapSegment = record

         ID                : Longint;        {Segmens azonosító: -1=törölt szegmens}

        SegmentName        : String[30];   {Segmens fantázia neve}

         PointCount        : word;                {Pontok száma a poligon kerületén}

        Box                : Trect;        {Segmens befoglaló négyszöge}

        Address        : Longint;        {Segmens kezdőcíme: rekordsorszám}

         Rgn           : HRgn;         {Region handle}

   end;

 

   THotMapPoint = record              {*.HM}

         ID                : Longint;        {Segmens azonosító: -1=törölt pont}

         No                : word;                {Pont sorszám a poligon kerületén}

         Koord                : TPoint;        {Descartes koordináták}

   end;

 

   TActiveSegmentEvent = procedure(Sender: TObject;SegCount,ID:longint; SegmentName:String) of Object;

   TActivePointEvent = procedure(Sender: TObject; DrawMode: TDrawMode;

                     No,Count:longint; p:TPoint) of Object;

 

TCustomHotMap = class(TImage)

private

   FPictureFile : TFileName;               {Alapkép file}

   FHotMapFile : TFileName;                {Hotmap szegmens/poligonok állománya}

   FSegmentVisible : boolean;

   FInvertSegment : boolean;

   FSegmentCount : word;

   FEdit : boolean;

   FActiveSegmentName : string;

   FActiveSegmentID : longint;

   FDrawMode : TDrawMode;

   FOriginHeight : integer;

   FOriginWidth : integer;

   FArrCount : integer;

   FArrNo : integer;

   FOnPoint : TActivePointEvent;

   FOnSegment : TActiveSegmentEvent;

   function GetSegmentCount: word;

   function GetActiveSegmentName: string;

   function GetActivSegmentID: longint;

   procedure SetPictureFile(Value:TFileName);

   procedure SetHotmapFile(Value:TFileName);

   procedure SetSegmentVisible(Value:boolean);

   procedure SetInvertSegment(Value:boolean);

   procedure SetArrCount(Value:integer);

   procedure SetArrNo(Value:integer);

   procedure SetDrawMode(Value:TDrawMode);

protected

   BaseColorImage: TImage;      {alapkép betöltéséhez szines alapbitmap}

   hmHeader : THotMapHeader;

   hmSeg    : THotMapSegment;

   hmPoint  : THotMapPoint;

   Arr      : Array[1..1000] of TPoint;  {tömb az aktuális poligonnak}

   Origin,MovePt,oldOrigin,oldMovePt: TPoint;

   von1     : boolean;

   procedure Ujrarajzol;

   procedure Rajzol( T,B: TPoint; AMode: TPenMode; ujrajz: Boolean);virtual;

   procedure MouseDown(Button: TMouseButton; Shift: TShiftState;

     X, Y: Integer); override;

   procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;

   procedure MouseUp(Button: TMouseButton; Shift: TShiftState;

     X, Y: Integer); override;

public

   tm     : TMemoryStream;      {Hotmap poligonok stream-je}

   tmSeg  : TMemoryStream;      {Hotmap segmensek stream-je}

   PoligonMode : TPoligonMode;  {Poligon rajzolás állapota}

   constructor Create(AOwner:TComponent);override;

   destructor Destroy;override;

   Procedure LoadFromFile(FileName: string);

   Procedure SaveToFile(FileName: string);

   Procedure GetSegmentNames(List : TStrings);

   function SrcSegmentID(ID:longint):longint;

   Function GetAddrFromId(ID:Longint) : longint;

   Function GetAddFromName(Seg_Name:string) : longint;

   Property ArrCount : integer read FArrCount write SetArrCount;  {tömb elemek száma}

   Property ArrNo : integer read FArrNo write SetArrNo;  {tömb aktuális eleme}

   procedure InitArr;                       {tömb inicializálás felhasználás előtt}

   procedure AddArr(p:TPoint);              {tömb n. eleme után fűz egy uj elemet}

   procedure DelArr(No:integer;p:TPoint);   {tömb n. elemeét törli}

   procedure InsArr(No:integer;p:TPoint);   {tömb n. eleme helyére beszűr egy uj elemet}

   function SrcArrPoint(p:TPoint):longint; {Keres a tömbben egy megfelelő pontot}

   procedure LoadSegment(ID:longint);

   procedure SaveSegment(hm_Seg:THotMapSegment);

   function NewSegmentID:longint;          {Keresés uj szegmens azonosítóra}

   Property SegmentCount : word read GetSegmentCount write FSegmentCount default 0;

   Property ActiveSegmentID : longint read GetActivSegmentID write FActiveSegmentID ;

   Property ActiveSegmentName : string read GetActiveSegmentName write FActiveSegmentName ;

   Property OriginHeight : integer read FOriginHeight default 0;

   Property OriginWidth : integer read FOriginWidth default 0;

   Property PictureFile : TFileName read FPictureFile write SetPictureFile;

   Property HotMapFile : TFileName read FHotMapFile write SetHotMapFile;

   Property SegmentVisible : boolean read FSegmentVisible write SetSegmentVisible ;

   Property InvertSegment : boolean read FInvertSegment write SetInvertSegment ;

   Property Edit : boolean read FEdit write FEdit ;

   Property DrawMode : TDrawMode read FDrawMode write SetDrawMode;

   Property OnPoint : TActivePointEvent read FOnPoint write FOnPoint ;

   Property OnSegment : TActiveSegmentEvent read FOnSegment write FOnSegment ;

end;

 

THotMap = class(TCustomHotMap)

published

   Property ActiveSegmentName;

   Property HotMapFile;

   Property PictureFile;

   Property SegmentCount;

   Property SegmentVisible;

   Property InvertSegment;

   Property Edit;

   Property OnPoint;

   Property OnSegment;

end;

 

implementation

 

constructor TCustomHotMap.Create(AOwner:TComponent);

begin

    inherited Create(AOwner);

    tm := TmemoryStream.Create;

    tmSeg := TmemoryStream.Create;

    BaseColorImage:= TImage.Create(Self);

    With hmHeader do begin

        PictureFile        := '';

        SegmentCount        := 0;

    end;

    FSegmentCount := 0;

    FOriginHeight := 0;

    FOriginWidth  := 0;

    AutoSize      := True;

end;

 

destructor TCustomHotMap.Destroy;

begin

    tm.Free;

    tmSeg.Free;

    BaseColorImage.Free;

    inherited Destroy;

end;

 

 

procedure TCustomHotMap.SetPictureFile(Value:TFileName);

begin

If (Value<>'') and FileExists(Value) then begin

    FPictureFile:=Value;

    Picture.LoadFromFile(Value);

    BaseColorImage.Picture.LoadFromFile(Value);

end;

end;

 

procedure TCustomHotMap.SetHotmapFile(Value:TFileName);

begin

If (Value<>'') and FileExists(Value) then begin

    FHotmapFile:=Value;

    LoadFromFile(Value);

end else FHotmapFile:='';

end;

 

procedure TCustomHotMap.SetDrawMode(Value:TDrawMode);

begin

    FDrawMode:=Value;

    Case Value of

    tamDraw :

       begin

         InitArr;

       end;

    end;

    If Assigned(FOnPoint) then FOnPoint(Self,DrawMode,ArrNo,ArrCount,Origin);

end;

 

procedure TCustomHotMap.SetSegmentVisible(Value:boolean);

begin

FSegmentVisible := Value;

Ujrarajzol;

end;

 

procedure TCustomHotMap.SetInvertSegment(Value:boolean);

begin

 

end;

 

function TCustomHotMap.GetSegmentCount: word;

begin

Result := tmSeg.Size div SizeOf(hmSeg);

end;

 

 

function TCustomHotMap.GetActiveSegmentName: string;

begin

 

end;

 

 

function TCustomHotMap.GetActivSegmentID: longint;

begin

 

end;

 

Procedure TCustomHotMap.LoadFromFile(FileName: string);

var fn,fnSeg : string;

begin

    fn    := ChangeFileExt(FileName,'.HM');

    fnSeg := ChangeFileExt(FileName,'.HX');

    If FileExists(fn) then tm.LoadFromFile(fn);

    If FileExists(fnSeg) then tmSeg.LoadFromFile(fnSeg);

       tmSeg.Seek(0,0);

       tmSeg.Read(hmSeg,SizeOf(hmSeg));

    IF Assigned(FOnSegment) then FOnSegment(Self,SegmentCount,hmSeg.ID,hmSeg.SegmentName);

end;

 

Procedure TCustomHotMap.SaveToFile(FileName: string);

var mentFile,mentFileSeg : TFileStream;

   i,j,meret,meretSeg : longint;

   poz, pontszam, newAddress : longint;

   fn,fnSeg : string;

begin

fn    := ChangeFileExt(FileName,'.HM');

fnSeg := ChangeFileExt(FileName,'.HX');

mentFile    := TFileStream.Create(fn,fmCreate);

mentFileSeg := TFileStream.Create(fnSeg,fmCreate);

meretSeg := tmSeg.Size div SizeOf(hmSeg);

tmSeg.Seek(0,0);

 

For i:=1 to meretSeg do begin

     tmSeg.Read(hmSeg,SizeOf(hmSeg));

     if hmSeg.ID > -1 then begin

        poz := mentFile.Position;

        tm.Seek(hmSeg.Address,0);

        pontszam := 0;

        If hmSeg.PointCount>0 then begin

           For j:=1 to hmSeg.PointCount do begin

               tm.Read(hmPoint,SizeOf(hmPoint));

               If hmPoint.ID > -1 then begin

                  Inc(pontszam);

                  hmPoint.No := pontszam;

                  mentFile.Write(hmPoint,SizeOf(hmPoint));

               end;

           end;

           hmSeg.PointCount := pontszam;

           hmSeg.Address    := poz;

           mentFileSeg.Write(hmSeg,SizeOf(hmSeg));

        end;

     end;

end;

 

mentFile.Free;

mentFileSeg.Free;

tm.LoadFromFile(fn);

tmSeg.LoadFromFile(fnSeg);

IF Assigned(FOnSegment) then FOnSegment(Self,SegmentCount,hmSeg.ID,hmSeg.SegmentName);

end;

 

Procedure TCustomHotMap.GetSegmentNames(List : TStrings);

var i,meret: integer;

begin

List.Clear;

meret := tmSeg.Size div SizeOf(hmSeg);

tmSeg.Seek(0,0);

For i:=1 to meret do begin

     tmSeg.Read(hmSeg,SizeOf(hmSeg));

     List.Add(hmSeg.SegmentName);

end;

end;

 

{A tmSeg streamen ID azonosítójú szegmens rekordot keres:

  ha talál : akkor a címével tér vissza és a tmSeg rekordra áll;

  ha nem   : akkor -1 -el}

function TCustomHotMap.SrcSegmentID(ID:longint):longint;

var i,meret: integer;

begin

Result := -1;

meret := tmSeg.Size div SizeOf(hmSeg);

tmSeg.Seek(0,0);

For i:=1 to meret do begin

     tmSeg.Read(hmSeg,SizeOf(hmSeg));

     If hmSeg.Id = ID then begin

        Result := tmSeg.Position - SizeOf(hmSeg);

        Break;

     end;

end;

end;

 

Function TCustomHotMap.GetAddrFromId(ID:Longint) : longint;

var i,meret: integer;

   pos    : longint;

begin

Try

pos   := tmSeg.Position;

meret := tmSeg.Size div SizeOf(hmSeg);

tmSeg.Seek(0,0);

For i:=1 to meret do begin

     tmSeg.Read(hmSeg,SizeOf(hmSeg));

     If hmSeg.Id = ID then begin

        Result := hmSeg.Address;

        Break;

     end;

end;

finally

tmSeg.Position := pos;

end;

end;

 

Function TCustomHotMap.GetAddFromName(Seg_Name:string) : longint;

begin

 

end;

 

procedure TCustomHotMap.Ujrarajzol;

begin

If FSegmentVisible then begin

end;

end;

 

procedure TCustomHotMap.MouseDown(Button: TMouseButton; Shift: TShiftState;

     X, Y: Integer);

begin

oldOrigin := Origin;

oldMovePt := MovePt;

Origin := Point(X, Y);

MovePt := Origin;

Case DrawMode of

 

tamDraw:

   begin

     If Button=mbLeft then begin

        If von1 and (SrcArrPoint(Origin)=1) then begin

{         (Abs(Arr[1].x-x)<4) and (Abs(Arr[1].y-y)<4) then begin}

             von1 := False;

             invalidate;

        end else begin

           Von1 := True;

           ArrNo:=ArrNo+1;

           ArrCount:=ArrCount+1;

           Arr[ArrNo]:=Origin;

        end;

     end;

     If (Button=mbRight) and von1 then begin

             von1 := False;

             Rajzol(oldOrigin,oldMovePt,pmNotXor,False);

             invalidate;

     end;

     If Assigned(FOnPoint) then FOnPoint(Self,DrawMode,ArrNo,ArrCount,Origin);

   end;

 

end;

inherited MouseDown(Button, Shift, X, Y);

end;

 

procedure TCustomHotMap.MouseMove(Shift: TShiftState; X, Y: Integer);

begin

oldMovePt := MovePt;

MovePt := Point(x,y);

 

If SrcArrPoint(MovePt)=-1 then Cursor:=crDefault

    else Cursor:=crDrag;

 

Case DrawMode of

tamDraw:

   If von1 then begin

          Rajzol(Origin,oldMovePt,pmNotXor,False);

          Rajzol(Origin,MovePt,pmNotXor,False);

   end;

end;

inherited MouseMove(Shift, X, Y);

end;

 

procedure TCustomHotMap.MouseUp(Button: TMouseButton; Shift: TShiftState;

     X, Y: Integer);

begin

{  MovePt := Point(x,y);

Case DrawMode of

tamDraw:

   If (Button=mbRight) and von1 then begin

      Rajzol(Origin,MovePt,pmNotXor,False);

      von1 := False;

   end;

end;}

inherited MouseUp(Button, Shift, X, Y);

end;

 

{......Munka tömb eljárások .....}

 

   procedure TCustomHotMap.SetArrCount(Value:integer);

   begin

     FArrCount:=Value;

     If Assigned(FOnPoint) then FOnPoint(Self,DrawMode,ArrNo,ArrCount,Origin);

   end;

 

   procedure TCustomHotMap.SetArrNo(Value:integer);

   begin

     FArrNo:=Value;

     If Assigned(FOnPoint) then FOnPoint(Self,DrawMode,ArrNo,ArrCount,Origin);

   end;

 

procedure TCustomHotMap.InitArr;           {tömb inicializálás felhasználás előtt}

var i: integer;

begin

ArrNo := 0;

ArrCount := 0;

For i:=1 to High(Arr) do Arr[i]:=Point(0,0);

PoligonMode := pomNew;

end;

 

procedure TCustomHotMap.AddArr(p:TPoint);  {tömb n. eleme után fűz egy uj elemet}

begin

ArrCount:=ArrCount+1;

Arr[ArrCount]:=p;

end;

 

procedure TCustomHotMap.DelArr(No:integer;p:TPoint);{tömb n. elemeét törli}

var i:integer;

begin

If ArrCount>0 then begin

For i:=No+1 to ArrCount do

     Arr[i-1]:=Arr[i];

ArrCount:=ArrCount-1;

end;

end;

 

procedure TCustomHotMap.InsArr(No:integer;p:TPoint);{tömb n. eleme helyére beszűr egy uj elemet}

var i:integer;

begin

If ArrCount<High(Arr) then begin

ArrCount:=ArrCount+1;

For i:=ArrCount downto No+1 do

     Arr[i]:=Arr[i-1];

Arr[No]:=p;

end;

end;

 

{Keres a tömbben egy megfelelő pontot: p +- 4 sugarú körében:

      Ha talál, akkor a tömindexxel tér vissza;

      ha nem akkor -1 -el.}

function TCustomHotMap.SrcArrPoint(p:TPoint):longint;

var i:integer;

begin

Result := -1;

For i:=1 to ArrCount do

     If (Abs(Arr[i].x-p.x)<4) and (Abs(Arr[i].y-p.y)<4) then

     begin

        Result := i;

        exit;

     end;

end;

 

{Keresés uj szegmens azonosítóra, általában új zárt poligon metéséhez}

function TCustomHotMap.NewSegmentID:longint;

var i,meret: integer;

begin

meret := tmSeg.Size div SizeOf(hmSeg);

tmSeg.Seek(0,0);

Result := 0;

For i:=1 to meret do begin

     tmSeg.Read(hmSeg,SizeOf(hmSeg));

     if hmSeg.ID>=Result then Result := hmSeg.ID+1;

end;

end;

 

procedure TCustomHotMap.LoadSegment(ID:longint);

begin

end;

 

{Ar Arr tömb poligonját menti a tm, tmSeg streamekre;

ha már volt ilyen Segmens, akkor a szegmens rekordot, az előzőre uj Address-el,

a pontokat pedig minden esetben a tm stream végére fűzi.}

procedure TCustomHotMap.SaveSegment(hm_Seg:THotMapSegment);

var i  : longint;

   hmp  : THotMapPoint;

begin

tm.Seek(0,2);

With hm_Seg do begin

      If SrcSegmentID(hm_Seg.ID)=-1 then ID := NewSegmentID;

      SegmentName  := SegmentName;

      PointCount   := ArrCount;

      Box            := Rect(0,0,0,0);

      Address            := tm.Position;

      Rgn          := CreatePolygonRgn(Arr,ArrCount,ALTERNATE);

end;

For i:=1 to ArrNo do begin

     hmp.ID := hm_Seg.ID;

     hmp.No := i;

     hmp.Koord := Arr[i];

     tm.Write(hmp,SizeOf(hmp));

end;

tmSeg.Write(hm_Seg,SizeOf(hm_Seg));

IF Assigned(FOnSegment) then FOnSegment(Self,SegmentCount,hm_Seg.ID,hm_Seg.SegmentName);

end;

 

procedure TCustomHotMap.Rajzol( T,B: TPoint; AMode: TPenMode; ujrajz: Boolean);

var DC:HDC;

begin

DC := GetDC(Canvas.Handle);

With Canvas do

begin

   If Amode=pmNotXor then

      SetPen(canvas,clRed,2,psSolid,AMode)

   else

      SetPen(canvas,clRed,2,psSolid,AMode);

   Brush.Color:=clWhite;

   Brush.style:=bsClear;

   If (T.X<>B.x) OR (T.Y<>B.Y) then

   begin

{        If ujrajz then

           case RajzMod of

           rmPont :      Pen.Color := cw.pontszin;

           rmFelirat :   Pen.Color := rrec.szovegszin;

           rmTermanual,rmTavmeres,rmPoligonkijelol:

              begin Pen.Color := clRed; Pen.Width:=2; end;

           end;}

       case DrawMode of

       tamDraw:

           begin

               MoveTo(T.X, T.Y); LineTo(B.X, B.Y);

           end;

{        rmPontVonallal:

           begin

               MoveTo(T.X, T.Y); LineTo(B.X, B.Y);

               Pen.Color := cw.pontszin;

               Rectangle(T.X-pontmeret,T.Y-pontmeret,T.X+pontmeret,T.Y+pontmeret);

               Rectangle(B.X-pontmeret,B.Y-pontmeret,B.X+pontmeret,B.Y+pontmeret);

           end;}

       end;

   end;

end;

RestoreDC(Canvas.Handle,DC);

end;

 

end.