excel hücreye resim aktarımı

[greenegitim]

Merhaba stok tablomda stokkodu,stokadı,barkodkodu, v.s alanlar mevcut stok resmini stokkodu.jpg gibi image klasöründe tutuyorum fastreportla resimli rapor falan verebiliyorum bunda sorun yok yalnız benden istenilen şey

resimdeki gibi excele dökmek componentle tablodaki bilgileri excele aktarabiliyordum bu sefer hücrelere sırasıyla ilgili resmi de atmam gerekiyor.

[SimaWB]

Excel'e resim eklemek için önce hücre seçimi yapılmalı ardından resim Insert edilmeli:
BURAYA bakabilirsin.

[mustafasoy]

muharrem beyin örneği üzerinde de viewtopic.php?f=2&t=2736&p=13627&hilit= ... sim#p13627
deneme yaptım ancak konuyu açan arkadaşın istediğini yapamadım tam olarak istediğim örnekteki resim

procedure TForm1.Button1Click(Sender: TObject);
Var
xExcel : Variant;
Resim : String;
picture:OleVariant;
genislik,yukseklik:integer;
Begin
genislik:=100;
yukseklik:=100;
xExcel := CreateOleObject('Excel.Application');
xExcel.Workbooks.Open( 'D:\Deneme.XLS' );
xExcel.Visible := True;
Resim := 'D:\resim\1000.jpg';
Picture := xExcel.ActiveSheet.Pictures.Insert(resim);
Picture.Width := genislik
Picture.Height := yukseklik;
Picture.ShapeRange.Left := 0; //pictureleft
Picture.ShapeRange.Top := 0;//PictureTop;

xexcel.ActiveSheet.Cells[2, 2].Select;
end;

2.kolonun 2.satırından başlıyor ama istediğim tam içeriğine yerleştirmek bu konuyu nasıl çözebilirim?

[greenegitim]

Merhaba bu sorunu DevExpress v14.1.2 sürümü ile halletim burada önemli olan gride nasıl görüyorsan aynen öyle aktarıyor o yüzden row height i manuel yada cxGrid1DBTableView1.OptionsView.DataRowHeight:=StrToIntDef(Edit1.Text,100); gibi bir değerle kullanıcıya girdirtebilirsin width değerini mous ile kullanıcı değiştirebilir görüntü aynen resimde ki gibi çok fazla resim olmadığı için ben blob bir field açıp oraya yükledim.

https://www.devexpress.com/Support/Cent ... ails/A2322 buradaki gibi de yapılabilir.

Kod: Tümünü seç

var path: string;
begin
   SaveDialog1.Filter := 'Excel|*.xlsx';
   SaveDialog1.DefaultExt := 'xlsx';
   if SaveDialog1.Execute then
   begin
      path := SaveDialog1.FileName;
      ExportGridToXLSX (path,cxGrid1,True,True,False,'xlsx');
      showMessage ('Aktarım Tamamlandı');

[mrmarman]

Ben de bir örnek vereyim, üçüncü parti bileşen kurup lisans ile uğraşmak istemeyenler için. ( DevExpress $599.99 başlangıç fiyatı çekmiş. )

içinde veritabanı da var.
proje ve veritabanı içeren paket linki buradan indirebilirsiniz.

EK : Dosya download edilirken Chrome kötü niyetli olarak bir algı yaratıyor.
RAR paketi içinde EXE dosyasını silmeyi unutmuşum ondandır. Bilginize...

Kaynak Kod :

Kod: Tümünü seç

USES JPEG, ComObj;
Var
  xKontrolBende : Boolean;

Procedure ExcelListesi_RESIMLI( AdoQuery:TAdoQuery; ResimEkle:Boolean; Progress:TProgressbar );
Const // Excel97 unitinden devşirdik...
  xlWBATWorksheet    = $FFFFEFB9;
  xlLandscape        = $00000002;
  xlPortrait         = $00000001;
  xlAutomatic        = $FFFFEFF7;
  xlCenter           = $FFFFEFF4;
  xlEdgeLeft         = $00000007;
  xlEdgeRight        = $0000000A;
  xlInsideHorizontal = $0000000C;
  xlInsideVertical   = $0000000B;
  xlContinuous       = $00000001;
  xlEdgeTop          = $00000008;
  xlEdgeBottom       = $00000009;
  xlMove             = $00000002;
  msoTrue            = $FFFFFFFF;
  msoFalse           = $00000000;
  procedure InsertPicture( ActiveSheet: OleVariant;  aImageFilePath: string; aRow, aCol: Integer );
  var
    Picture: OleVariant;
  begin
    Picture           := ActiveSheet.Pictures.Insert(aImageFilePath);
    Picture.ShapeRange.LockAspectRatio := msoFalse;// msoTrue; olursa resmin orjinal oranı korunur. 
    Picture.Left      := ActiveSheet.Cells[aRow, aCol].Left + 2;
    Picture.Top       := ActiveSheet.Cells[aRow, aCol].Top  + 2;
    Picture.Height    := ActiveSheet.Cells[aRow+1, aCol  ].Top  - ActiveSheet.Cells[aRow, aCol].Top  - 4;
    Picture.Width     := ActiveSheet.Cells[aRow,   aCol+1].Left - ActiveSheet.Cells[aRow, aCol].Left - 4 - 40;
    Picture.Placement := xlMove;
  end;
Var
  xExcel,
  xRange     : OleVariant;
  Sayac,
  Sa         : Integer;
  Harfler    : TStringList;
  ResimDosya : String;
  TopSutun   : Integer;
begin
  Harfler := TStringList.Create; // Bu şekilde harfleri de sütun numarası gibi değerlendiriyoruz...
  For Sayac := 65 to 90 do Harfler.Add(     Chr( Sayac ) );
  For Sayac := 65 to 90 do Harfler.Add( 'A'+Chr( Sayac ) );
  For Sayac := 65 to 90 do Harfler.Add( 'B'+Chr( Sayac ) );
  Sa := 1;
  With AdoQuery do begin
    if RecordCount > 0 then
    begin
      if Progress <> Nil then
      begin
        Progress.Min      := 0;
        Progress.Max      := RecordCount;
        Progress.Position := RecNo;
        Progress.Visible  := True;
      end;

      AdoQuery.DisableControls;
      First;
      Try
        xExcel := CreateOleObject('Excel.Application'); // ComObj
        xExcel.Workbooks.Add(xlWBatWorkSheet);
        xExcel.Workbooks[1].WorkSheets[1].Name := Format('(%s)',[DateToStr(Now)]);
      Except
        Active := False;
        MessageDlg('İşlem Başarısız...', mtError, [mbOk], 0);
        Exit;
      End;

      // -------------------------------------------------------------------
      // Başlıklar...
      // -------------------------------------------------------------------
      TopSutun := 03;

      xExcel.Range[ Harfler[00]+IntToStr(Sa) ].Value := 'Sıra / Afiş';
      xExcel.Range[ Harfler[00]+IntToStr(Sa) ].Columns.ColumnWidth := 5;

      xExcel.Range[ Harfler[01]+IntToStr(Sa) ].Value := 'Film Adı';
      xExcel.Range[ Harfler[01]+IntToStr(Sa) ].Columns.ColumnWidth := 7;

      xExcel.Range[ Harfler[02]+IntToStr(Sa) ].Value := 'Yapım Yılı';
      xExcel.Range[ Harfler[02]+IntToStr(Sa) ].Columns.ColumnWidth := 7;

      xRange := xExcel.Range[ Harfler[00]+IntToStr(Sa), Harfler[TopSutun-1]+IntToStr(Sa) ];
        xRange.Columns.RowHeight                          := 15;
        xRange.Cells.Interior.Color                       := clYellow;
        xRange.Borders.Item[xlEdgeLeft].LineStyle         := xlContinuous;
        xRange.Borders.Item[xlEdgeRight].LineStyle        := xlContinuous;
        xRange.Borders.Item[xlInsideHorizontal].LineStyle := xlContinuous;
        xRange.Borders.Item[xlInsideVertical].LineStyle   := xlContinuous;
        xRange.Borders.Item[xlEdgeTop].LineStyle          := xlContinuous;
        xRange.Borders.Item[xlEdgeBottom].LineStyle       := xlContinuous;
      // -------------------------------------------------------------------
      inc(sa);
      // -------------------------------------------------------------------
      // Veri / İçerik
      // -------------------------------------------------------------------
      while NOT EOF do
      begin
        if Progress <> Nil then
        begin
          Progress.Position := RecNo;
        end;
        xExcel.Range[ Harfler[00]+IntToStr(Sa) ].Value := RecNo;
        xExcel.Range[ Harfler[01]+IntToStr(Sa) ].Value := FieldByName('M_Name').AsString;
        xExcel.Range[ Harfler[02]+IntToStr(Sa) ].Value := FieldByName('M_Year').AsString;
        if ResimEkle then
        begin // Akreditasyon için resim ekleme fonksiyonu...
          xExcel.Range[ Harfler[00]+IntToStr(Sa) ].Columns.RowHeight    := 96;
          xExcel.Range[ Harfler[00]+IntToStr(Sa) ].ColumnWidth          := 22;
          ResimDosya := ExtractFilePath(Application.Exename) + '\RESIM\'+ FieldByName('ID').AsString + '.JPG';
          if FileExists( ResimDosya )
            then InsertPicture( xExcel.WorkBooks[1].ActiveSheet, ResimDosya, Sa, 1 );
        end;
        inc(Sa);
        Next;
      end;
      // -------------------------------------------------------------------
      // İçerik Formatı...
      // -------------------------------------------------------------------
      xRange := xExcel.Range[ Harfler[00]+IntToStr(1), Harfler[02]+IntToStr(Sa+1) ];
      xRange.VerticalAlignment    := xlCenter;

      xRange := xExcel.Range[ Harfler[01]+IntToStr(1), Harfler[02]+IntToStr(Sa+1) ];
      xRange.Columns.AutoFit;

      xRange := xExcel.Range[ Harfler[02]+IntToStr(1), Harfler[02]+IntToStr(Sa+1) ];
      xRange.HorizontalAlignment  := xlCenter;

      // -------------------------------------------------------------------
      // Sayfa Formatı
      // -------------------------------------------------------------------
      xExcel.Workbooks[1].WorkSheets[1].PageSetup.PrintTitleRows     := '$1:$2';
      xExcel.Workbooks[1].WorkSheets[1].PageSetup.PrintTitleColumns  := '$A:$B';
      xExcel.Workbooks[1].WorkSheets[1].PageSetup.LeftMargin         := 10;
      xExcel.Workbooks[1].WorkSheets[1].PageSetup.RightMargin        := 10;
      xExcel.Workbooks[1].WorkSheets[1].PageSetup.TopMargin          := 30;
      xExcel.Workbooks[1].WorkSheets[1].PageSetup.BottomMargin       := 35;
      xExcel.Workbooks[1].WorkSheets[1].PageSetup.FooterMargin       := 8;
      xExcel.Workbooks[1].WorkSheets[1].PageSetup.Orientation        := xlPortrait;
      xExcel.Workbooks[1].WorkSheets[1].PageSetup.CenterHorizontally := True;
      xExcel.Workbooks[1].WorkSheets[1].PageSetup.CenterVertically   := False;
      xExcel.Workbooks[1].WorkSheets[1].PageSetup.CenterFooter       := '&"Arial Narrow,Normal"&8Sayfa &P / &N';
      xExcel.Workbooks[1].WorkSheets[1].PageSetup.FirstPageNumber    := xlAutomatic;
      // xExcel.Workbooks[1].WorkSheets[1].PageSetup.RightFooter     := xExcelReklam;
      xExcel.Visible := True;
      AdoQuery.EnableControls;
    end; // if
  end;
  Harfler.Free;
  if Progress <> Nil then
  begin
    Progress.Visible  := False;
  end;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
  xKontrolBende := True;
  ExcelListesi_RESIMLI( ADOQuery1, True, ProgressBar1 );
  xKontrolBende := False;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  AdoConnection1.LoginPrompt := False;
  AdoConnection1.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;'
  + 'Data Source='+ ExtractFilePath(Application.Exename) + 'film_veritabani.mdb';
  AdoQuery1.Connection := ADOConnection1;
  AdoQuery1.SQL.Text   := 'SELECT M_Name, M_Year, ID FROM FILM';
  AdoQuery1.Active     := True;
  DataSource1.DataSet  := ADOQuery1;
  DBGrid1.DataSource   := DataSource1;
  DBGrid1.Options      := DBGrid1.Options - [dgEditing];
end;

procedure TForm1.ADOQuery1AfterScroll(DataSet: TDataSet);
Var
  strResimLink : String;
begin
  if xKontrolBende then exit;
  strResimLink := ExtractFilePath(Application.Exename) + '\RESIM\'+ DataSet.FieldByName('ID').AsString + '.JPG';
  if FileExists(strResimLink)
    then Image1.Picture.LoadFromFile( strResimLink )
    else Image1.Picture.Graphic := Nil;
end;

[greenegitim]

Elinize sağlık hocam gayet güzel çalışıyor link kırılmasın diye yandex e yükledim.
https://yadi.sk/d/bKKxcGsmfXTrR

[mehmetantalya]

Merhabalar,
Benim resimlerim database icerisine gömülü. Dosyadan degilde database icerisindeki resimleri nasil ekleyebiliriz acaba?
Suanda dosyayi tektek dbden cektikten sonra diske kaydediyorum ve oradan excel'e ekliyorum.

Olusturulan excel dosyasi fiziksel dosyayi ariyor. Bunun içinde excel dosyasi ile resimleride klasoruyle beraber vermek gerekiyor. Baska turlu nasil yapilabilir acaba?
Teşekkürler

[mrmarman]

Merhaba.

İki türlü yapabilirsin. (sen yinede en etkili olan 1 nolu verdiğim olanı tercih et derim)
(1) İşlemleriniz sırasında resimleri zaten fiziksel bir dosyaya dönüştürme durumunuz varsa o zaman kodda fazladan büyük bir değişiklik yapmadan

Kod: Tümünü seç

ResimDosya := ExtractFilePath(Application.Exename) + '\RESIM\'+ FieldByName('ID').AsString + '.JPG';

satırındaki resmin yolunu döngü içindeki her bir kayıt için fiziksel hale getirdiğiniz veritabanı resminizin fiziksel yolunu vermeniz kafidir.

Biliyorsun EXEL başka bir programdır. Bir dosyayı kendi projendeki bir yapı gibi hooop diye atamazsın. Bazı engelleri aşman lazım gelir. Aşağıdaki alternatif durum da bununla ilgilidir.

(2) Bunu fiziksel bir dosyaya atmayım dersen bu biraz işçilik ister ayrıca Clipboard operasyonu olduğundan raporlama sırasında başka bir copy/paste işleminden etkilenebilir. Ne yapılır, MemorySteram'e atılan veritabanı resmini bir TPicture nesnesine alır, bunu Clipborad'a copy edilip Excel'de paste ettirilir. Sonra da bu select halinde olduğu için yer boyut ayarlaması yapılır.

* Oyum 1 nolu tekniğe yöneliktir. Hem hızlı hem de verimlidir.

[mehmetantalya]

Teşekkür ederim Muharrem Bey.
Birinci yontemde excel dosyasini baska bir pc ye tasimak gerektiginde (mesala baska bir birime veya musteriye gondermek gerektiginde ) resimleride tasimak gerektiginden sıkıntılı bir durum teskil edecektir.
İkinci yontem sonradan benimde aklima geldi ama bir turlu excele clipboard daki veriyi yapistiramadim. Sistem kilitlenip durdu her denememde.

[mrmarman]

Kaygını anlıyorum.
Şöyle bir değişiklik yapman kafidir.
Detayları comment olarak satır sonlarına ekledim. Böylece resim dosyaları EXCEL'e gömülmüş oldu.

Kod: Tümünü seç

  procedure InsertPicture( ActiveSheet: OleVariant;  aImageFilePath: string; aRow, aCol: Integer );
  var
    Picture: OleVariant;
  begin
    //Picture           := ActiveSheet.Pictures.Insert(aImageFilePath);
    //Picture.ShapeRange.LockAspectRatio := msoFalse;// msoTrue; olursa resmin orjinal oranı korunur.

    Picture := ActiveSheet.Shapes.AddPicture(aImageFilePath,
      False, // LinkToFile parametresi (dosya bağını kopardık...)
      True , // SaveWithDocument parametresi (içerik excel dosyası ile kaydedilecek)
      0  , // Left ( varsayılan sol  offset )
      0  , // Top  ( varsayılan tepe offset )
      10 , // Width  ( varsayılan genişlik  )
      10); // Height (varsayılan yükseklik  )
    Picture.Left      := ActiveSheet.Cells[aRow, aCol].Left + 2;
    Picture.Top       := ActiveSheet.Cells[aRow, aCol].Top  + 2;
    Picture.Height    := ActiveSheet.Cells[aRow+1, aCol  ].Top  - ActiveSheet.Cells[aRow, aCol].Top  - 4;
    Picture.Width     := ActiveSheet.Cells[aRow,   aCol+1].Left - ActiveSheet.Cells[aRow, aCol].Left - 4 - 40;
    Picture.Placement := xlMove;
  end;

[mehmetantalya]

Çok Teşekkür Ederim Muharrem Bey. Deneyeceğim.

[mrmarman]

Şimdi bir şey fark ettim, varsayılan olarak 10, 10 verince excel otomatik olarak boyutlandırıyormuş. Bunun için ihtiyacınız olan tam büyüklüğe göre varsayalına ataması yapacak şekilde modifiye ettim.

Bu şekilde denerseniz hem diskte kapyalacağı alanı tama ihtiyacınız kadar olan ile sınırlamış da olacaksınız. Aksi halde gereğinden büyük varsayalına vermeniz sonra yeniden boyutlandırmanız gerekecekti.

Verimli kod aşağıdaki gibi.

Kod: Tümünü seç

  procedure InsertPicture( ActiveSheet: OleVariant;  aImageFilePath: string; aRow, aCol: Integer );
  var
    Picture: OleVariant;
    aLeft, aTop, aWidth, aHeight : Integer;
  begin
    aLeft   := ActiveSheet.Cells[aRow, aCol].Left + 2;
    aTop    := ActiveSheet.Cells[aRow, aCol].Top  + 2;
    aWidth  := ActiveSheet.Cells[aRow,   aCol+1].Left - ActiveSheet.Cells[aRow, aCol].Left - 4 - 40;
    aHeight := ActiveSheet.Cells[aRow+1, aCol  ].Top  - ActiveSheet.Cells[aRow, aCol].Top  - 4;
    Picture := ActiveSheet.Shapes.AddPicture(aImageFilePath,
      False ,   // LinkToFile parametresi (dosya bağını kopardık...)
      True  ,   // SaveWithDocument parametresi (içerik excel dosyası ile kaydedilecek)
      aLeft ,   // Left ( varsayılan sol  offset )
      aTop  ,   // Top  ( varsayılan tepe offset )
      aWidth,   // Width  ( varsayılan genişlik  )
      aHeight); // Height (varsayılan yükseklik  )
    Picture.Placement := xlMove;
  end;

[mehmetantalya]

Çok Teşekkür ederim Muharrem bey. Denedim güzel çalışıyor.