Тема: показати зображення

Добрий вечір,  шановні експерти! Перейшов з делфі на лазарус. Все подобається. В лазарусі програмувати так само як і на делфі. Так от моє питання:
Мені треба заповнити smallim1 шістьма фігурками з тим  масштабом, як у мене. допоможіть, будь-ласка.
Ось код програми
фрагмент uMain

unit uMain;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, LResources, FileUtil, Forms, Controls, Graphics, Dialogs, Menus,
  ExtCtrls, ComCtrls, StdCtrls, computations;

type
  TRec = record
   ndet,ang:integer;
   Xa1,Ya1,Xa2,Ya2,Xq,Yq:real;
         end;

  { TfMain }

  TfMain = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    OpenDialog1: TOpenDialog;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    SmallIm1: TImage;
    MainIm1: TImage;
    MainMenu1: TMainMenu;
    MenuItem1: TMenuItem;
    MenuItem3: TMenuItem;
    MenuItem2: TMenuItem;
    MenuItem4: TMenuItem;
    MenuItem5: TMenuItem;
    MenuItem6: TMenuItem;
    MenuItem7: TMenuItem;
    PageControl1: TPageControl;
    ScrollBox1: TScrollBox;
    TabSheet1: TTabSheet;
    procedure FormCreate(Sender: TObject);
    procedure OpenFileClick(Sender: TObject);
    procedure readresho;
    procedure readreshp;
    procedure showresho;
    procedure showreshp;
    procedure openf_dgt;
  private
    { private declarations }
  public
    { public declarations }
    namedet:string[100];
    kilkpointdet_r,ndetP,ang:array[1..40] of integer;
    dets_r,det_P,uklO,uklP:array[1..40] of figure;
  end;

var
  fMain: TfMain;
  f:text;
  str,fname,fname_ukl0,fname_ukl1,fname_dgt:string[100];
  mgod,kilkdet,clickadd,clickdel,xp_e,yp_e,KilkuklO,KilkuklP,NumResh:integer;
  mashim2,mashim1,xe,ye,dlmat,shmat,xp,yp,mashim4O,dlUkl_max,shUkl_max,
  mashim4P,mashim3,dlright,dlleft,shup,shdown,pv,snet,smat:real;
  dldet,shdet,sdet,XcO,YcO,dlO,shO,XcP,YcP,dlP,shP:array[1..40] of real;
  admode,delmode,detmode,reshmode,fl:boolean;
  shmUklO,shmUklP: array[1..100] of TRec;

implementation


{$R *.lfm}

{ TfMain }
{=========================================================}
procedure TfMain.OpenFileClick(Sender: TObject);//відкрити файл і запам’ятати дані
//Стандартна процедура, де параметр Sender передається як об’єкт, який ініціалізує процедуру.
var I ,L:integer;
//Блок описання змінних.
//Змінна i має цілочислений тип і використовується як змінна циклу.
Begin //початок процедури
Pagecontrol1.ActivePage:=tabsheet1; //встановлюємо активну сторінку
SmallIm1.Picture:=nil;//очищаємо малюнок з мініатюрними зображенями2
SmallIm1.Height:=2000;//встановлюємо розмір малюнку з мініатюрними зображенями2
OpenDialog1.InitialDir:=ExtractFilePath(Application.Exename);
if OpenDialog1.Execute then begin //якщо діалог виконується
 fname:=opendialog1.FileName; //зберегти ім’я, вибране в діалозі у змінну
 str:=ExtractFileName(fname);
 l:=length(str);
 for i:=1 to l do begin
  if (str[i]='_') and (str[i+1]='0') then begin
   fname_ukl0:=ExtractFilePath(Application.Exename)+'ukl\'+str; readreshO;
   pagecontrol1.ActivePage.Caption:=fname_ukl0; // виводимо «ім’я моделі» в назву активної сторінки
                                          end;
  if (str[i]='_') and (str[i+1]='1') then begin
   fname_ukl1:=ExtractFilePath(Application.Exename)+'ukl\'+str; readreshP;
   pagecontrol1.ActivePage.Caption:=fname_ukl1; // виводимо «ім’я моделі» в назву активної сторінки
   reshmode:=true; showreshp;
                                          end;
  if str[i]='_' then begin
   delete(str,i,6); fname_dgt:=ExtractFilePath(Application.Exename)+'dgt\'+str+'.dgt';
                     end;
                  end;
                            end; //кінець якщо діалог виконується
PageControl1.Show;
openf_dgt;
fMain.Caption:=fname_dgt;
end;
{=========================================================}
procedure TfMain.openf_dgt;
var i,j:integer;
    maxX,maxY,minX,minY:array[1..40] of real;
begin
assignfile(f,fname_dgt); // зв’язуємо віртуальний файл з ім’ям у змінній
 reset(f); //відкриваємо файл для читання з переводом курсору на початок файлу
 readln(f); //читаємо з файлу першу стрinttostr(shmuklP[2].Xa1)ічку в змінну «ім’я моделі»
 readln(f,kilkdet); //читаємо з файлу другу стрічку в змінну «кількість деталей»
 for i:=1 to kilkdet do readln(f,namedet[i]); //в циклі від 1 до кількості
 //деталей послідовно зчитувати з файлу стрічки у масив «імена деталей»
 for i:=1 to kilkdet do readln(f,kilkpointdet_r[i]);//в циклі від 1 до кількості
 //деталей послідовно зчитувати з файлу стрічки у масив «кількість точок деталей»
 for i:=1 to kilkdet do //в циклі від 1 до кількості деталей
  for j:=0 to kilkpointdet_r[i]-1 do begin//в циклі від 0 до кількості точок
  //деталей – 1 послідовно зчитувати з файлу стрічки у масив «координати деталей»
   readln(f,dets_r[i][j].x,dets_r[i][j].y);
   det_P[i,j].x:=-dets_r[i,j].x;
      det_P[i,j].y:=-dets_r[i,j].y;
                                     end;
 closefile(f); //закриваємо файл
 for i:=1 to kilkdet do begin
maxY[i]:=min_maxY(dets_r[i],kilkpointdet_r[i],1);//в циклі від 1 до кількості деталей
//розраховуємо мінімальне і максимальне значення по х і у відповідно
maxX[i]:=min_maxX(dets_r[i],kilkpointdet_r[i],1);
minX[i]:=min_maxX(dets_r[i],kilkpointdet_r[i],-1);
minY[i]:=min_maxY(dets_r[i],kilkpointdet_r[i],-1);
//розраховуємо довжину і ширину деталі
dldet[i]:=maxX[i]-minX[i];
shdet[i]:=maxY[i]-minY[i];
                         end; //кінець циклу по кількості деталей
end;
{=========================================================}
procedure TfMain.FormCreate(Sender: TObject);
begin
PageControl1.Hide;
reshmode:=false;
end;
{=========================================================}
procedure TfMain.readresho;
var i:integer;
begin
 assignfile(f,fname_ukl0); // зв’язуємо віртуальний файл з ім’ям у змінній
 Reset(f); //відкриваємо файл для читання з переводом курсору на початок файлу
 Readln(f,KilkuklO); //читаємо з файлу перше слово в змінну «кількість укладок»
for i:=1 to KilkuklO do
 with shmUklO[i] do begin
 Read(f,ndet); //читаємо з файлу перше слово в змінну «номер деталі»
 read(f,xa1,ya1,xa2,ya2);//читаємо з файлу решту слів стрічки в змінні «координати деталей»
 readln(f,ang);  //читаємо з файлу останнє слово в змінну «кут деталі»
                     end;
 CloseFile(f); //закриваємо файл
 ramka(1,KilkuklO);
end;
{=========================================================}
procedure TfMain.readreshp;
var i:integer;
begin
 assignfile(f,fname_ukl1); // зв’язуємо віртуальний файл з ім’ям у змінній
 Reset(f); //відкриваємо файл для читання з переводом курсору на початок файлу
 Readln(f,KilkuklP); //читаємо з файлу перше слово в змінну «кількість укладок»
for i:=1 to KilkuklP do
 with shmUklP[i] do begin
 Read(f,ndet); //читаємо з файлу перше слово в змінну «номер деталі»
 read(f,xa1,ya1,xa2,ya2,xq,yq);//читаємо з файлу решту слів стрічки в змінні «координати деталей»
 readln(f,ang);  //читаємо з файлу останнє слово в змінну «кут деталі»
                     end;
 CloseFile(f); //закриваємо файл
 ramka(1,KilkuklP);
end;
{=========================================================}
procedure TfMain.showresho;
var XminO,YminO,XmaxO,YmaxO:array[1..6] of real;
    alpha,beta,mashy:real;
    i,j:integer;
    det:figure;
begin

 for j:=1 to KilkuklO do begin
  with shmUklO[j] do begin
  for i:=1 to 4 do begin
   case i of
   1:begin alpha:=0; beta:=0; end;
   2:begin alpha:=xa1; beta:=ya1; end;
   3:begin alpha:=xa2; beta:=ya2; end;
   4:begin alpha:=xa1+xa2; beta:=ya1+ya2; end;
   end;
   XminO[i]:=-dldet[ndet]/2+alpha;
   XmaxO[i]:=dldet[ndet]/2+alpha;
   YminO[i]:=-shdet[ndet]/2+beta;
   YmaxO[i]:=shdet[ndet]/2+beta;
                 end;
  dlO[j]:=maxR(4, XmaxO)-minR(4, XminO);
  XcO[j]:=(maxR(4, XmaxO)+minR(4, XminO))/2;
  shO[j]:=maxR(4, YmaxO)-minR(4, YminO);
  YcO[j]:=(maxR(4, YmaxO)+minR(4, YminO))/2;
                     end;
                              end;        if dlO[3]<>0 then begin
 dlUkl_max:=maxR(KilkuklO, dlO);
 shUkl_max:=maxR(KilkuklO, shO);
                  end;
 edit1.Text:=FormatFloat('0.00',shUkl_max);
 edit2.Text:=FormatFloat('0.00',dlUkl_max);
 mashim4O:=60/dlUkl_max;
  mashy:=60/shUkl_max;
 if mashim4O> mashy then  mashim4O:=mashy;
 ramka(4,KilkuklO);
 for i:=1 to KilkuklO do
  with shmUklO[i] do begin
  graphimsmall(1,kilkpointdet_r[ndet],dets_r[ndet],mashim4O,XcO[i],YcO[i],37,75*(2*i-1)/2);
 for j:=0 to kilkpointdet_r[ndet]-1 do begin
  det[j].x:=dets_r[ndet,j].x+Xa1;
  det[j].y:=dets_r[ndet,j].y+Ya1;
                                       end;
 graphimsmall(1,kilkpointdet_r[ndet],det,mashim4O,XcO[i],YcO[i],37,75*(2*i-1)/2);
   for j:=0 to kilkpointdet_r[ndet]-1 do begin
  det[j].x:=dets_r[ndet,j].x+Xa2;
  det[j].y:=dets_r[ndet,j].y+Ya2;
                                         end;
  graphimsmall(1,kilkpointdet_r[ndet],det,mashim4O,XcO[i],YcO[i],37,75*(2*i-1)/2);
   for j:=0 to kilkpointdet_r[ndet]-1 do begin
  det[j].x:=dets_r[ndet,j].x+Xa1+Xa2;
  det[j].y:=dets_r[ndet,j].y+Ya1+Ya2;
                                         end;
  graphimsmall(1,kilkpointdet_r[ndet],det,mashim4O,XcO[i],YcO[i],37,75*(2*i-1)/2);
                   end;
end;
{======================================================}
procedure TfMain.showreshp;
var XminP,YminP,XmaxP,YmaxP:array[1..6] of real;
    alpha,beta,mashY:real;
    i,j:integer;
    det:figure;
begin
for j:=1 to KilkuklP do begin
 with shmUklP[j] do begin
  for i:=1 to 6 do begin
  if i=1 then begin alpha:=0; beta:=0; end;
  if i=2 then begin alpha:=xa1; beta:=ya1; end;
  if i=3 then begin alpha:=xq; beta:=yq; end;
  if i=4 then begin alpha:=xa1+xq; beta:=ya1+yq; end;
  if i=5 then begin alpha:=xa2; beta:=ya2; end;
  if i=6 then begin alpha:=xa1+xa2; beta:=ya1+ya2; end;
  XminP[i]:=-dldet[ndet]/2+alpha;
  XmaxP[i]:=dldet[ndet]/2+alpha;
  YminP[i]:=-shdet[ndet]/2+beta;
  YmaxP[i]:=shdet[ndet]/2+beta;
                  end;
 dlP[j]:=maxR(6, XmaxP)-minR(6, XminP);
 XcP[j]:=(maxR(6, XmaxP)+minR(6, XminP))/2;
 shP[j]:=maxR(6, YmaxP)-minR(6, YminP);
 YcP[j]:=(maxR(6, YmaxP)+minR(6, YminP))/2;
                    end;
                        end;
 dlUkl_max:=maxR(KilkuklP, dlP);
 shUkl_max:=maxR(KilkuklP, shP);
 for j:=1 to KilkuklP do
  edit1.Text:=edit1.Text+FormatFloat('0.00',XcP[j]);
 for j:=1 to KilkuklP do
  edit2.Text:=edit2.Text+FormatFloat('0.00',YcP[j]);
 mashim4P:=dlUkl_max/60;
 mashy:=shUkl_max/80;
 if mashim4P>mashy then mashim4P:=mashy ELSE MASHIM4P:=0.07;
 for i:=1 to KilkuklP do
  with shmUklP[i] do begin
  graphimsmall(1,kilkpointdet_r[ndet],dets_r[ndet],mashim4P,XcP[i],YcP[i],37,75*(2*i-1)/2);
 for j:=0 to kilkpointdet_r[ndet]-1 do begin
  det[j].x:=dets_r[ndet,j].x+Xa1;
  det[j].y:=dets_r[ndet,j].y+Ya1;
                                   end;
  graphimsmall(1,kilkpointdet_r[ndet],det,mashim4P,XcP[i],YcP[i],37,75*(2*i-1)/2);
  for j:=0 to kilkpointdet_r[ndet]-1 do begin
  det[j].x:=det_P[ndet,j].x+Xq;
  det[j].y:=det_P[ndet,j].y+Yq;
                                   end;
  graphimsmall(1,kilkpointdet_r[ndet],det,mashim4P,XcP[i],YcP[i],37,75*(2*i-1)/2);
   for j:=0 to kilkpointdet_r[ndet]-1 do begin
  det[j].x:=det_P[ndet,j].x+Xq+Xa1;
  det[j].y:=det_P[ndet,j].y+Yq+Ya1;
                                   end;
  graphimsmall(1,kilkpointdet_r[ndet],det,mashim4P,XcP[i],YcP[i],37,75*(2*i-1)/2);
   for j:=0 to kilkpointdet_r[ndet]-1 do begin
  det[j].x:=dets_r[ndet,j].x+Xa2;
  det[j].y:=dets_r[ndet,j].y+Ya2;
                                   end;
  graphimsmall(1,kilkpointdet_r[ndet],det,mashim4P,XcP[i],YcP[i],37,75*(2*i-1)/2);
   for j:=0 to kilkpointdet_r[ndet]-1 do begin
  det[j].x:=dets_r[ndet,j].x+Xa1+Xa2;
  det[j].y:=dets_r[ndet,j].y+Ya1+Ya2;
                                   end;
 graphimsmall(1,kilkpointdet_r[ndet],det,mashim4P,XcP[i],YcP[i],37,75*(2*i-1)/2);
                  end;
end;
{======================================================}
end.

фрагмент

unit computations;

interface

uses SysUtils, Forms, Classes, Buttons, Graphics, StdCtrls, ExtCtrls;

type
   point = record
     x : real;
     y : real;
     end;
  figure = array[0..100] of point;
function minR(n:integer;a :array of real):real;
function maxR(n:integer;a :array of real):real;
function elminx(n:integer;a :figure;var p:integer):real;
function elminy(n:integer;a :figure;var p:integer):real;
function elmaxx(n:integer;a :figure;var p:integer):real;
function elmaxy(n:integer;a :figure;var p:integer):real;
function min_maxX(a :figure; n,p:integer):real;
function min_maxY(a :figure; n,p:integer):real;
procedure sort(n:integer;a :figure; km:integer; var b :figure);
procedure ramka(im,kilk:integer);
procedure graphimsmall(im,n:integer;d:array of point;mxy,xcf,ycf,xce,yce:real);
procedure graphim1(n:integer;d:array of point;mxy,xce,yce,xp,yp:real;p,q:integer);
procedure obhod(n:integer;a :figure;var b :figure);
procedure godog(nn,nr:integer;fn,fr:figure;var m:integer;var gxy:figure);
procedure obolonka(n:integer;a :figure; var m:integer;var b:figure);
procedure prg_info(flg:byte);
implementation

uses  uMain;

{============================================================}
function minR(n:integer;a :array of real):real;
var i:integer; //знаходимо мінімальний елемент
    zam:real;
begin
zam:=a[1];
for i:=2 to n do
 if a[i]<zam then zam:=a[i];
minR:=zam;
end;
{=========================================================}
function maxR(n:integer;a :array of real):real;
var i:integer; //знаходимо мінімальний елемент
    zam:real;
begin
zam:=a[1];
for i:=2 to n do
 if a[i]>zam then zam:=a[i];
maxR:=zam;
end;
{============================================================}
procedure obolonka(n:integer;a :figure;var m:integer;var b:figure);
var i,p,nr:integer;
    ax,ay,bx,by,d:real;
    flag:boolean;
begin
nr:=n;//зберігаємо кількість точок
 repeat
  flag:=true;                   //всі точки включаємо
  i:=0; p:=0;
  b[p].x:=a[i].x;  b[p].y:=a[i].y;     //початкова точка апроксимованої фігури
   repeat
    ax:=a[i+1].x-a[i].x;  ay:=a[i+1].y-a[i].y;     //координати вектора а
    bx:=a[i+2].x-a[i].x;  by:=a[i+2].y-a[i].y;     //координати вектора b
    d:=ax*by-ay*bx;                                //знак обходу
    if d>0 then begin
     inc(p);
      b[p].x:=a[i+1].x;  b[p].y:=a[i+1].y;
     inc(p);
      b[p].x:=a[i+2].x;  b[p].y:=a[i+2].y;
                end
  else  begin
      flag:=false;             //цю точку не включаємо
      inc(p);
      b[p].x:=a[i+2].x;  b[p].y:=a[i+2].y;
         end;
   i:=i+2;                  //пересуваємося на кінець вектора b
   if i+2>nr-2 then  begin
   inc(p);
   b[p].x:=a[i+1].x;  b[p].y:=a[i+1].y;
   break;
                      end;
  until false;
  nr:=p+1;
  for i:=0 to nr-1 do begin
    a[i].x:=b[i].x;   a[i].y:=b[i].y;
                    end;
 until flag;
 m:=nr;
  b[m-1].x:=b[0].x;   b[m-1].y:=b[0].y;
end;
{=========================================================}
function elminx(n:integer;a :figure;var p:integer):real; //знаходимо точку з
var i:integer; //мінімальною х координатою та повертаємо її порядковий номер
     zam:real;
begin
zam:=a[0].x; p:=0;
for i:=1 to n-1 do
 if a[i].x<zam then begin
  zam:=a[i].x; p:=i;
                    end;
elminx:=zam;
end;
{=========================================================}
function elminy(n:integer;a :figure;var p:integer):real; //знаходимо точку з
var i:integer; //мінімальною у координатою та повертаємо її порядковий номер
   zam:real;
begin
zam:=a[0].y; p:=0;
for i:=1 to n-1 do
 if a[i].y<zam then begin
  zam:=a[i].y; p:=i;
                    end;
elminy:=zam;
end;
{=========================================================}
function elmaxx(n:integer;a :figure;var p:integer):real; //знаходимо точку з
var i:integer; //максимальною х координатою та фіксуємо її порядковий номер
   zam:real;
begin
zam:=a[0].x; p:=0;
for i:=1 to n-1 do
 if a[i].x>zam then begin
  zam:=a[i].x; p:=i;
                    end;
elmaxx:=zam;
end;
{=========================================================}
function elmaxy(n:integer;a :figure;var p:integer):real; //знаходимо точку з
var i:integer; //максимальною у координатою та фіксуємо її порядковий номер
   zam:real;
begin
zam:=a[0].y; p:=0;
for i:=1 to n-1 do
 if a[i].y>zam then begin
  zam:=a[i].y; p:=i;
                    end;
elmaxy:=zam;
end;
{=========================================================}
function min_maxX(a :figure; n,p:integer):real; //функція повертає точку з
var zam:real; //максимальною або мінімальною х координатою в
    i:integer; //залежності від параметра р: 1 – максимальне; -1 – мінімальне.
begin
zam:=a[1].x;
for i:=2 to n do
 if a[i].x*p>zam*p then
  zam:=a[i].x;
min_maxX:=zam;
end;
{=========================================================}
function min_maxY(a :figure; n,p:integer):real; //функція повертає точку з
var zam:real; //максимальною або мінімальною х координатою в
    i:integer; //залежності від параметра р: 1 – максимальне; -1 – мінімальне.
begin
zam:=a[1].y;
for i:=2 to n do
 if a[i].y*p>zam*p then
  zam:=a[i].y;
min_maxY:=zam;
end;
{=========================================================}
procedure sort(n:integer;a :figure; km:integer; var b :figure); //сортирує точки
var i:integer; //деталі за номером точки з максимальною або
begin   //мінімальною х чи у координатою
 if km=0 then begin
    b:=a;
    exit;
              end;
for i:=0 to n-1 do begin
   if km+i>n then break;
  b[i].x:=a[km+i].x;
  b[i].y:=a[km+i].y;
                   end;
for i:=1 to km do begin
  b[i+n-km-1].x:=a[i].x;
  b[i+n-km-1].y:=a[i].y;
                  end;
end;
{=========================================================}
procedure ramka(im,kilk:integer); // малює рамку зображення деталі на малюнку зліва
var i:integer;
    image:TComponent;
begin
image := fMain.FindComponent('SmallIm' + IntToStr(im));
with TImage(image).Canvas do begin
 Brush.Color:=clwhite;
 Rectangle(0,0,fMain.width,fMain.height);
 pen.Color:=clblack;
 for i:=1 to kilk do begin
  moveto(5,5+(i-1)*95);
  lineto(90,5+(i-1)*95);
  lineto(90,i*95);
  lineto(5,i*95);
  lineto(5,5+(i-1)*95);
  TImage(image).Height:=95*kilk+10;
                        end;
                                                           end;
end;
{=========================================================}
procedure graphimsmall(im,n:integer;d:array of point;mxy,xcf,ycf,xce,yce:real); // малює саме
var i:integer; //зображення деталі на малюнку зліва
    xr,yr:array[0..100]of integer;
image:TComponent;
begin
image := fMain.FindComponent('SmallIm' + IntToStr(im));
for i:=0 to n-1 do begin
 xr[i]:=round((d[i].x-xcf)*mxy+xce);
 yr[i]:=round((-d[i].y+ycf)*mxy+yce);
                   end;
 with TImage(image).Canvas do begin
   pen.Color:=clblack;
   for i:=0 to n-1 do
    if i=0 then moveto(xr[i],yr[i])
    else lineto(xr[i],yr[i]);
                             end;
end;
{=========================================================}
procedure graphim1(n:integer;d:array of point;mxy,xce,yce,xp,yp:real;p,q:integer);
var i:integer;                      //малює вибране зображення в іншому масштабі
    xr,yr:array[0..100]of integer;
begin
for i:=0 to n-1 do begin
 xr[i]:=round((d[i].x+xp)*mxy+xce);
 yr[i]:=round((-d[i].y-yp)*mxy+yce);
                   end;
 with fmain.MainIm1.Canvas do begin
   pen.Width:=p;
   if q=1 then pen.Color:=clblack
  else if q=2 then pen.Color:=clblue;
   for i:=0 to n-1 do
    if i=0 then moveto(xr[i],yr[i])
    else lineto(xr[i],yr[i]);
                             end;
end;
{=========================================================}
procedure obhod(n:integer;a :figure;var b :figure);   //перенумерація вершин
var i,NmaxY,NminY,NmaxX:integer;
begin
elmaxy(n,a,NmaxY);
if  NmaxY=0 then NmaxY:=n-1;
elminy(n,a,NminY);
elmaxx(n,a,NmaxX);
if (NminY<=NmaxX) and (NmaxX<=NmaxY) then begin
b:=a;
exit;
                                          end else for i:=0 to n-1 do begin
                                                b[i].x:=a[n-i-1].x;
                                                b[i].y:=a[n-i-1].y;
                                                                      end;
end;
{=========================================================}
procedure godog(nn,nr:integer;fn,fr:figure;var m:integer;var gxy:figure);
var i,j:integer; //будує годограф навколо фігури fn і повертає у вигляді фігури
    dc:real; //gxy з m точок
begin
m:=0; i:=0; j:=0;        //скидаємо показники точок
fn[nn]:=fn[1];           //кінцева точка фігури співпадає з першою
fr[nr]:=fr[1];           //кінцева точка фігури співпадає з першою
gxy[m].x:=fn[i].x-fr[j].x;//координата х годографа
gxy[m].y:=fn[i].y-fr[j].y;//координата у годографа
repeat                                        //повторювати
dc:=(fn[i+1].x-fn[i].x)*(fr[j+1].y-fr[j].y)-
            (fr[j+1].x-fr[j].x)*(fn[i+1].y-fn[i].y);//перевірка знаку обходу
inc(m);
if dc>0 then j:=j+1        //якщо "+", то збільшуємо показник точок рухомої фігури
else if dc<0 then i:=i+1   //якщо "-", то збільшуємо показник точок нерухомої фігури
       else begin  //якщо "0", то збільшуємо показники точок і рухомої і нерухомої фігури
             j:=j+1;
             i:=i+1;
            end;
gxy[m].x:=fn[i].x-fr[j].x;
gxy[m].y:=fn[i].y-fr[j].y;
until (gxy[m].x=gxy[0].x)and(gxy[m].y=gxy[0].y);//поки кінцева точка годографа не співпадатиме з першою
 inc(m);
end;
{=========================================================}
procedure prg_info(flg:byte);
var fHlp:TForm;
    mfield:TMemo;
    bClose:TBitBtn;
begin
fHlp:=TForm.Create(fMain);
with fHlp do begin
Caption:='Довідка програми - ';
Position:=poMainFormCenter;
Width:=520;
Height:=350;
Show;
             end;
mfield:=TMemo.Create(fHlp);
with mfield do begin
top:=2;
left:=2;
Width:=fHlp.ClientWidth-5;
Height:=fHlp.ClientHeight-35;
parent:=fHlp;
               end;
bClose:=TBitBtn.Create(fHlp);
with bClose do begin
top:=fHlp.ClientHeight-30;
left:=(mfield.Width-75) div 2;
parent:=fHlp;
kind:=bkClose;
               end;
if flg=0 then begin
mfield.Clear;
fHlp.Caption:=fHlp.Caption + fMain.MenuItem6.Caption;
mfield.Lines.LoadFromFile(ExtractFileDir(ParamStr(0))+'\help\prg.txt');
              end;
if flg=1 then begin
mfield.Clear;
fHlp.Caption:=fHlp.Caption + fMain.MenuItem7.Caption;
mfield.Lines.LoadFromFile(ExtractFileDir(ParamStr(0))+'\help\help.txt');
              end;
end;
{=========================================================}
end.
 

фрагмент

unit computations_ukl;

interface

uses Graphics, SysUtils, computations;

function minR(n:integer;a :array of real):real;
function maxR(n:integer;a :array of real):real;
Procedure Uk1;
Procedure Uk_God4;
Procedure Uk24(k:integer);
Procedure TocPer4(k:integer; Var Xn,Yn,Xv,Yv:real);
Procedure grafdet4(xa1,ya1,xa2,ya2:real);
procedure sortresh4(var xa1,ya1,xa2,ya2:real);
Procedure Uk_God6;
Procedure Uk26(k:integer);
Procedure TocPer6(k:integer; Var Xn,Yn,Xv,Yv:real);
Procedure grafdet6(xa1,ya1,xa2,ya2,xq,yq:real);
Procedure sortresh6(var xa1,ya1,xa2,ya2,qx,qy:real);
procedure shminit(xp,yp:real);
Procedure PDet(n1,n2:integer; Var d1,d2:figure; Var b:boolean);
procedure paral(x1,y1,x2,y2,x3,y3,x4,y4,xcf,ycf,xce,yce,mxy:real);
function pospointdet(n:integer;d:figure; x0,y0:real): boolean;

implementation

uses  uMain;

{============================================================}
function minR(n:integer;a :array of real):real;
var i:integer; //знаходимо мінімальний елемент
    zam:real;
begin
zam:=a[0];
for i:=1 to n-1 do
 if a[i]<zam then zam:=a[i];
minR:=zam;
end;
{=========================================================}
function maxR(n:integer;a :array of real):real;
var i:integer; //знаходимо мінімальний елемент
    zam:real;
begin
zam:=a[0];
for i:=1 to n-1 do
 if a[i]>zam then zam:=a[i];
maxR:=zam;
end;
{=========================================================}
Procedure Uk1;
var i:integer;
    phi:real;
begin
phi:=ang*pi/180;
 if (fMain.rbhundredeightydegree.Checked) then
  for i:=0 to fMain.kilkpointdet_r[nd_a]-1 do begin
   fMain.fn[i].x:=fMain.dets_r[nd_a][i].x*cos(phi)-fMain.dets_r[nd_a][i].y*sin(phi);
   fMain.fn[i].y:=fMain.dets_r[nd_a][i].y*sin(phi)+fMain.dets_r[nd_a][i].y*cos(phi);
   fMain.fr[i].x:=-fMain.fn[i].x;
   fMain.fr[i].y:=-fMain.fn[i].y;
                                            end else begin
   fMain.fn:=fMain.dets_r[nd_a];
   fMain.fr:=fMain.fn;
                                                     end;

end;
{=========================================================}
Procedure Uk_God6;               //
var NmaxX,NminX:integer;
begin
 elmaxX(fMain.kilkpointdet_r[nd_a],fMain.fn,NmaxX);
 sort(fMain.kilkpointdet_r[nd_a],fMain.fn,NmaxX,fMain.fn);
 elminx(fMain.kilkpointdet_r[nd_a],fMain.fr,NminX);
 sort(fMain.kilkpointdet_r[nd_a],fMain.fr,NminX,fMain.fr);
 godog(fMain.kilkpointdet_r[nd_a],fMain.kilkpointdet_r[nd_a],fMain.fn,fMain.fr,mgod1,god1);
end;
{=======================================================}
Procedure Uk_God4;                //
 var NmaxX,NminX:integer;
     fq:figure;
begin
 elmaxX(fMain.kilkpointdet_r[nd_a],fMain.fn,NmaxX);
 sort(fMain.kilkpointdet_r[nd_a],fMain.fn,NmaxX,fMain.fn);
 elminx(fMain.kilkpointdet_r[nd_a],fMain.fn,NminX);
 sort(fMain.kilkpointdet_r[nd_a],fMain.fn,NminX,fq);
 godog(fMain.kilkpointdet_r[nd_a],fMain.kilkpointdet_r[nd_a],fMain.fn,fq,mgod,god);
end;
{=========================================================}
Procedure Uk24(k:integer);
var i:integer;
begin
   for i:=0 to mgod-1 do begin
    god_r[i].x:= god[i].x+god[k].x;
    god_r[i].y:= god[i].y+god[k].y;
                         end;
end;
{=========================================================}
Procedure Uk26(k:integer);
var i:integer;
begin
   for i:=0 to mgod-1 do begin
    god_r[i].x:= god[i].x+god1[k].x;
    god_r[i].y:= god[i].y+god1[k].y;
                         end;
end;
{=========================================================}
Procedure TocPer4(k:integer; Var Xn,Yn,Xv,Yv:real);
var i,j,p,prizline,q:integer;
    x0a,y0a,x0b,y0b,delta:real;
    xverch,yverch,xnizh,ynizh:array [1..10] of real;
begin
p:=0;q:=0;
for i:=0 to mgod-2 do
  for j:=0 to mgod-2 do begin
     perline(god[i].x, god[i].y,god[i+1].x, god[i+1].y,god_r[j].x, god_r[j].y,
     god_r[j+1].x, god_r[j+1].y, prizline, x0a,y0a,x0b,y0b);
         if (prizline=1) or  (prizline=2) or  (prizline=3) then begin
     delta:=god[k].y*x0a-god[k].x*y0a;
     if delta>0  then begin
        p:=p+1;
      xverch[p]:=x0a;
      yverch[p]:=y0a;
                      end else begin
        q:=q+1;
      xnizh[q]:=x0a;
      ynizh[q]:=y0a;
                               end;
                                                                end;
                        end;
         Xn:=xnizh[q];
         Yn:=ynizh[q];
         Xv:=xverch[p];
         Yv:=yverch[p];
end;
{=========================================================}
Procedure TocPer6(k:integer; Var Xn,Yn,Xv,Yv:real);
var i,j,p,prizline,q:integer;
    x0a,y0a,x0b,y0b,delta:real;
    xverch,yverch,xnizh,ynizh:array [1..10] of real;
begin
p:=0;q:=0;
for i:=0 to mgod1-2 do
  for j:=0 to mgod-2 do begin
     perline(god1[i].x, god1[i].y,god1[i+1].x, god1[i+1].y,god_r[j].x, god_r[j].y,
     god_r[j+1].x, god_r[j+1].y, prizline, x0a,y0a,x0b,y0b);
         if (prizline=1) or  (prizline=2) or (prizline=3) then begin
     delta:=god1[k].y*x0a-god1[k].x*y0a;
     if delta>0  then begin
        p:=p+1;
      xverch[p]:=x0a;
      yverch[p]:=y0a;
                      end else begin
        q:=q+1;
      xnizh[q]:=x0a;
      ynizh[q]:=y0a;
                               end;
                                                                end;
                        end;
         Xn:=xnizh[q];
         Yn:=ynizh[q];
         Xv:=xverch[p];
         Yv:=yverch[p];
end;
{=========================================================}
Procedure grafdet4(xa1,ya1,xa2,ya2:real);
{=========================================================}
 procedure grafpar(mxy,xce,yce,xp,yp:real);
var i:integer;
    xr1,yr1:array[0..5]of integer;
    xr,yr:array[0..5]of real;
begin
 xr[0]:=0;   yr[0]:=0;
 xr[1]:=xa2;   yr[1]:=ya2;
 xr[2]:=xa1+xa2;   yr[2]:=ya1+ya2;
 xr[3]:=xa1;   yr[3]:=ya1;
 xr[4]:=0;   yr[4]:=0;
for i:=0 to 4 do begin
 xr1[i]:=round((xr[i]+xp)*mxy+xce);
 yr1[i]:=round((-yr[i]-yp)*mxy+yce);
                 end;
 with fmain.imgMain1.Canvas do begin
  pen.Color:=clblue;
   for i:=0 to 4 do
    if i=0 then moveto(xr1[i],yr1[i])
    else lineto(xr1[i],yr1[i]);
                             end;
end;
{=========================================================}
begin
fMain.imgMain1.Picture:=nil;
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/4,xe,ye,0,0,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/4,xe,ye,xa1,ya1,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/4,xe,ye,xa2,ya2,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/4,xe,ye,xa1+xa2,ya1+ya2,ang);
grafpar(mashim1/4,0,0,xe,ye);
end;
{=========================================================}
Procedure grafdet6(xa1,ya1,xa2,ya2,xq,yq:real);
{=========================================================}
 procedure grafpar(mxy,xce,yce:real);
var i:integer;
    xr1,yr1:array[0..5]of integer;
    xr,yr:array[0..5]of real;
begin
 xr[0]:=0;   yr[0]:=0;
 xr[1]:=xa1;   yr[1]:=ya1;
 xr[2]:=xa1+xa2;    yr[2]:=ya1+ya2;
 xr[3]:=xa2;   yr[3]:=ya2;
 xr[4]:=xr[0];   yr[4]:=yr[0];
for i:=0 to 4 do begin
 xr1[i]:=round((xr[i])*mxy+xce);
 yr1[i]:=round((-yr[i])*mxy+yce);
                 end;
 with fmain.imgMain1.Canvas do begin
  pen.Color:=clblue;
   for i:=0 to 4 do
    if i=0 then moveto(xr1[i],yr1[i])
    else lineto(xr1[i],yr1[i]);
                               end;
end;
{=========================================================}
begin
fMain.imgMain1.Picture:=nil;
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/5,xe,ye,0,0,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/5,xe,ye,xa1,ya1,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/5,xe,ye,xa2,ya2,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/5,xe,ye,xa1+xa2,ya1+ya2,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fr,mashim1/5,xe,ye,xq+xa1,yq+ya1,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fr,mashim1/5,xe,ye,xq,yq,ang);
grafpar(mashim1/5,xe,ye);
end;
{=========================================================}
procedure sortresh4(var xa1,ya1, xa2,ya2:real);
var i:integer;
    maxd,d:real;
begin
    i:=0;
   xa1:=a1x[i];
   ya1:=a1y[i];
   xa2:=a2x[i];
   ya2:=a2y[i];
   maxd:=abs(a1x[i]*a2y[i]-a1y[i]*a2x[i]);
 for i:=1 to mgod-1 do begin
    d:=abs(a1x[i]*a2y[i]-a1y[i]*a2x[i]);
  if maxd>d then begin
   xa1:=a1x[i];
   ya1:=a1y[i];
   xa2:=a2x[i];
   ya2:=a2y[i];
    maxd:=d;
                 end;
                       end;
end;
{=========================================================}
procedure sortresh6(var xa1,ya1, xa2,ya2,qx,qy:real);
var i:integer;
    maxd,d:real;
begin
    i:=0;
   xa1:=a1x[i];
   ya1:=a1y[i];
   xa2:=a2x[i];
   ya2:=a2y[i];
   qx:=gx[i];
   qy:=gy[i];
   maxd:=abs(a1x[i]*a2y[i]-a1y[i]*a2x[i]);
 for i:=1 to mgod1-1 do begin
    d:=a1x[i]*a2y[i]-a1y[i]*a2x[i];
  if maxd>d then begin
   xa1:=a1x[i];
   ya1:=a1y[i];
   xa2:=a2x[i];
   ya2:=a2y[i];
   qx:=gx[i];
   qy:=gy[i];
    maxd:=d;
                 end;
                       end;
end;
{=========================================================}
procedure shminit(xp,yp:real);
begin
inc(kdet);
with shm[kdet] do begin
 numdet:=nd_m;
 x_p:=xp;
 y_p:=yp;
 phi:=angle;
 pr:=1;
                  end;
end;
{=========================================================}
Procedure PDet(n1,n2:integer; Var d1,d2:figure; Var b:boolean);
Var i:integer;
    Bp:boolean;
Begin
B:=False;
for i:=0 to n2-1 do begin
 bp:=pospointdet(n1,d1,d2[i].x,d2[i].y);
 if bp then begin
  b:=Bp;
  exit
            end;
                    end;
for i:=0 to n1-1 do begin
 bp:=pospointdet(n2,d2,d1[i].x,d1[i].y);
 if bp then begin
  b:=Bp;
  exit
            end;
                    end;
End;
{============================================================}
procedure paral(x1,y1,x2,y2,x3,y3,x4,y4,xcf,ycf,xce,yce,mxy:real);
var
    i:integer;                      //малює вибране зображення в іншому масштабі
    xr,yr:array[0..4]of integer;
     xr1,yr1:array[0..4]of real;
begin
 xr1[0]:=x1;  yr1[0]:=y1;
 xr1[1]:=x2;  yr1[1]:=y2;
 xr1[2]:=x3;  yr1[2]:=y3;
 xr1[3]:=x4;  yr1[3]:=y4;
 xr1[4]:=x1;  yr1[4]:=y1;
for i:=0 to 4 do begin
 xr[i]:=round((xr1[i]+xcf)*mxy+xce);
 yr[i]:=round((yr1[i]+ycf)*mxy+yce);
                   end;
 with fMain.imgMain2.Canvas do begin
   pen.Width:=1;
   pen.Mode:=pmcopy;
   pen.Color:=clgreen;
   for i:=0 to 4 do
    if i=0 then moveto(xr[i],yr[i])
    else lineto(xr[i],yr[i]);
                             end;
end;
{============================================================}
function pospointdet(n:integer;d:figure; x0,y0:real): boolean;
var i,k:integer;
    t1,t2,t:real;
begin
pospointdet:=false;  k:=0;
for i:=0 to n-2 do begin
 if d[i].y=d[i+1].y then continue;
 if (d[i].y>y0) and (d[i+1].y>y0) then continue;
 if (d[i].y<y0) and (d[i+1].y<y0) then continue;
 if d[i].y>d[i+1].y then begin
  t1:= d[i+1].y; t2:= d[i].y;
                         end else begin
                                  t1:= d[i].y; t2:= d[i+1].y;
                                  end;
 if t1=y0 then continue
 else if t2=y0 then k:=k+1
      else begin
       t:=(y0-d[i].y)/(d[i+1].y-d[i].y);
       if (t>0) and (t<1) and (d[i].x+t*(d[i+1].x-d[i].x)>=x0) then k:=k+1;
           end;
                     end;
if   odd(k) then  pospointdet:=true;
end;
{============================================================}

end.

2

Re: показати зображення

Прихований текст
Видалив дубльовану тему.
x

3

Re: показати зображення

заповнити smallim1 шістьма фігурками

так роби copyrect() або BitBlt(), там й промасштабувати можливо.

Білоруський журнал «Радиолюбитель»
Lead Radar systems engineer & Software developer of industrial automation
Мої розробки та відеоблог

4

Re: показати зображення

tarasgavrilov
Використовуйте Canvas.StretchDraw. Наприклад:

Image2.Canvas.StretchDraw(Rect(0,0, 255, 255), Image1.Picture.Graphic);

raxp
BitBlt тільки для вінди.

Подякували: shabaranskij1

5 Востаннє редагувалося raxp (27.07.2016 06:38:34)

Re: показати зображення

Torbins, TC-у треба не тiльки промасштабувати, але й заповнити 6-зображеннями на одному канвасi.

Що до вiнди, то використання Lazarus не обов'язково обумовлене необхiднiстю кроскомпiлювання, наприклад треба лише нашару IDE. Та й для повного фаршу краще форк - Typhon.

Білоруський журнал «Радиолюбитель»
Lead Radar systems engineer & Software developer of industrial automation
Мої розробки та відеоблог

6

Re: показати зображення

raxp
Якщо автору щось іще не зрозуміло, то нехай запитує. Я ж не проти.

7

Re: показати зображення

Все пояснено дуже професійно  і дохідчиво.
красно дякую

8

Re: показати зображення

у мене інше питання: як правильно зробити заставку перед програмою?
яку властивість fLogo.Visibility чи fLogo.Enabled треба змінювати або щось інше?

9

Re: показати зображення

Який тип має fLogo? Це звичайна форма?

10

Re: показати зображення

так

11

Re: показати зображення

Показ лого можна організувати на базі тієї ж форми, що є основною (не виплоджуючи зайві вiкна). Маніпулювати досить видимістю інших візуальних компонентів на ній і Show/Hide форми.

Білоруський журнал «Радиолюбитель»
Lead Radar systems engineer & Software developer of industrial automation
Мої розробки та відеоблог

12

Re: показати зображення

tarasgavrilov
Клацніть менюшку Проект > Дивитись код проекту.
Туди впишіть щось типу такого:

program Project1;

{$mode objfpc}{$H+}

uses
  //Якісь модулі

{$R *.res}

begin
  RequireDerivedFormResource:=True;
  Application.Initialize;
  fLogo:=TfLogo.create(Application); //Створюємо форму так, щоб вона не стала головною
  fLogo.show; //Віддаємо наказ (message) показати її
  fLogo.Update; //Віддаємо наказ відмалювати увесь вміст
  Application.ProcessMessages; //Виконання наказів
  Application.CreateForm(TfMain, fMain); //Перша форма створена таким чином стане головною
  //Сюди вставте створення усіх інших потрібних вам форм окрім fLogo
  fLogo.close; //Наказ приховати форму
  fLogo.Release; //Наказ знищити непотрібну форму
  Application.Run; //Безкінечне виконання усіх наказів до закриття головної форми
end.

Для fLogo можна ще поставити FormStyle = fsSplash.

13

Re: показати зображення

дякую всім за допомогу торбінсу дві подяки

14 Востаннє редагувалося Romanvolja (11.10.2016 10:41:19)

Re: показати зображення

Доброго дня
Підскажіть бутьласка як видалити(очистити) зображя з Image

Пробував так:

Image1.Clear;
Image1.Picures.Clear;

Але нічого  виходить, компілятор вибиває помилку у цьому рядку.

15

Re: показати зображення

Доброго дня
треба так

image1.picture:=nil;
Подякували: Romanvolja1

16

Re: показати зображення

Я вирішив зберігати зображення поза межами бази даних.

Для завантаження на форму при клацанні по гріді написав так


procedure TOrchardProgr_Fr.Orchard_GrCellClick(Column: TColumn);
begin
  if NS_Or_Pc_ADOTb.FieldByName('Name file').Text<>'' then
    begin
      Pictures_OPDlg.FileName:=ExtractFilePath(Application.ExeName)+'\Database\PickGrd\'
                              +NS_Or_Pc_ADOTb.FieldByName('Name file').AsVariant;
      Pictures_Im.Picture.LoadFromFile(Pictures_OPDlg.FileName);
    end;
end;

Для збереження в папку зображень і запису в базу я написав такий код

procedure TOrchardProgr_Fr.InsertPct_SBtClick(Sender: TObject);
var
   Nm:Integer;
begin
  if(Pictures_OPDlg.Execute) then
    begin
      Pictures_Im.Picture.LoadFromFile(Pictures_OPDlg.FileName);
    end;
  with NS_Or_ON_ADOTb do
    begin
      IndexFieldNames:='ID';
      First;
    end;
  with AddInfo_Fr.Pictures_ADOTb do
    begin
      IndexFieldNames:='ID';
      Last;
    end;
  Nm:=AddInfo_Fr.Pictures_ADOTb.FieldByName('ID').AsInteger+1;
  OnePic_Pn.Caption:=NS_Or_ON_ADOTb.FieldByName('Name sort').AsString+' -'+IntToStr(Nm)+'.jpg';
  with AddInfo_Fr.Pictures_ADOTb do
    begin
          Insert;
          FieldByName('Orchard_ID').AsInteger:=StrToInt(ID_Ed.Text);
          FieldByName('Name file').AsString:=OnePic_Pn.Caption;
          Post;
    end;
  Pictures_SPDlg.FileName:=ExtractFilePath(Application.ExeName)+'\Database\PickGrd\'
                           +AddInfo_Fr.Pictures_ADOTb.FieldByName('Name file').AsVariant;
  Pictures_Im.Picture.SaveToFile(Pictures_SPDlg.FileName);
  OnePic_Pn.Caption:='';//тут не знав як правильно очистити каптіот панелі тому написив так.
end; 

Працює все нормально зображення додаютьсяв потрібну папку їх назви записуються в базу даних.

Та після оновлення таблиці "NS_Or_Pc_ADOTb" не відкивається OpenPictureDlg, а зображення в папку додається те, яке знаходиться в Image; при тому назва в базу записується правильно.



Вирішив очищати Image, дякую що підказали як:

Pictures_Im.picture:=nil;

Вставив це тут(5-й рядок):

procedure TOrchardProgr_Fr.InsertPct_SBtClick(Sender: TObject);
var
   Nm:Integer;
begin
  Pictures_Im.picture:=nil;
  if(Pictures_OPDlg.Execute) then
    begin
      Pictures_Im.Picture.LoadFromFile(Pictures_OPDlg.FileName);
    end;
.....

Тоді на відміну від першого випадку після оновлення таблиці "NS_Or_Pc_ADOTb" не відкивається OpenPictureDlg, і зображення в папку не додається; при тому назва в базу записується правильно.

Підкажіть будь ласка де є  баг в коді. Буду дуже вдячний.

17

Re: показати зображення

Замало коду, і що у вас в базі також невідомо. Але такі помилки дуже легко виправити, якщо вміти користуватися налагоджувачем: http://www.delphikingdom.com/asp/viewit … ader_2_1_1 (російською).
І будь ласка, наступного разу створюйте нову тему для нової проблеми.

18

Re: показати зображення

на перший погляд ви ж в

    procedure TOrchardProgr_Fr.InsertPct_SBtClick(Sender: TObject);
    var
       Nm:Integer;
    begin
      Pictures_Im.picture:=nil;
      if(Pictures_OPDlg.Execute) then
        begin
          Pictures_Im.Picture.LoadFromFile(Pictures_OPDlg.FileName);
        end;
    .....

спочатку очищуете малюнок ви спробуйте в іншому місці очищувати
і справді в новій темі дайте більше коду

19

Re: показати зображення

Рішення знайшов, можливо не саме краще, але зате працює як потрібно.

Для перегляду зображень при клацані по гріду я написав так:

procedure TOrchardProgr_Fr.Orchard_GrCellClick(Column: TColumn);
begin
  if NS_Or_Pc_ADOTb.FieldByName('Name file').Text<>'' then
    begin
      Pictures_OPDlg.FileName:=ExtractFilePath(Application.ExeName)+'\Database\PickGrd\'
                              +NS_Or_Pc_ADOTb.FieldByName('Name file').AsVariant;
      Pictures_Im.Picture.LoadFromFile(Pictures_OPDlg.FileName);
    end
  else
    begin
      Pictures_Im.picture:=nil;
    end;
end;

Проблема була в тому що при клацанні по гріду у властивість FileName(OpenPictureDialog) додавалась інформація.

Тому при додаванні зображень я її просто очистив


 

Pictures_OPDlg.FileName:='';
procedure TOrchardProgr_Fr.InsertPct_SBtClick(Sender: TObject);
var
   Nm:Integer;
begin
  Pictures_OPDlg.FileName:='';
  if(Pictures_OPDlg.Execute) then
    begin
      Pictures_Im.picture:=nil;
      Pictures_Im.Picture.LoadFromFile(Pictures_OPDlg.FileName);
    end;
  with NS_Or_ON_ADOTb do
    begin
      IndexFieldNames:='ID';
      First;
    end;
  with AddInfo_Fr.Pictures_ADOTb do
    begin
      IndexFieldNames:='ID';
      Last;
    end;
  Nm:=AddInfo_Fr.Pictures_ADOTb.FieldByName('ID').AsInteger+1;
  OnePic_Pn.Caption:=NS_Or_ON_ADOTb.FieldByName('Name sort').AsString+' -'+IntToStr(Nm)+'.jpg';
  with AddInfo_Fr.Pictures_ADOTb do
    begin
          Insert;
          FieldByName('Orchard_ID').AsInteger:=StrToInt(ID_Ed.Text);
          FieldByName('Name file').AsString:=OnePic_Pn.Caption;
          Post;
    end;
  Pictures_SPDlg.FileName:=ExtractFilePath(Application.ExeName)+'\Database\PickGrd\'
                           +AddInfo_Fr.Pictures_ADOTb.FieldByName('Name file').AsVariant;
  Pictures_Im.Picture.SaveToFile(Pictures_SPDlg.FileName);
  OnePic_Pn.Caption:='';
end;

20

Re: показати зображення

поздоровляю
я ж казав, що треба десь ще очищати

Подякували: Romanvolja1