freepascal.ru

Всех с новым годом.
Excel при копировании ячеек в буфер обмена создает там набор различных представлений этой информации. Одним из них он пишет "METAFILE PICTURE".
В статьях в интернетевезде написано, что для передачи метафайла через буфер обмена надо использовать структуру METAFILEPICT, которая указывает на область памяти где размещен метафайл. Если делаю код, то файл сам физически у меня создается правильно.
Но когда пишется эта структура в буфер обмена, то это крошечный набор байт. В случае же с Excel там 66 строк данных при просмотре содержимого буфера. Получается, что Excel пишет не пакет, а сам метафайл в буфер?
Если так, то не могу понять как то что создается WinAPI загнать в память для записи.

Конечная задача записать в буфер обмена таблицу аналогично тому, как это делает Excel чтобы ее смог прочитать AutoCAD. Последний без записи метафайла и OBJECTDESCRIPTOR не хочет видеть данные в нужном мне виде.

Код: Выделить всё

procedure SetAsMetafile(TextData: String);
var
  Stream: TStream;
  hMeta:HGLOBAL;
  hdcMeta:HDC;
  hMF:HMETAFILE;
  lpMETA:LPMETAFILEPICT;
  hwnd1:hwnd;
  hMetaGreenPen:HPEN;
  hMetaVioletBrush:HBRUSH;
  PointMeta:LPPoint;
begin
  if CF_MetaFilePict = 0 then
    exit;
   try


      hdcMeta := CreateMetaFile(nil); //'test.met'
      SetWindowOrgEx(hdcMeta, 0, 0, nil);
      SetWindowExtEx(hdcMeta, 100, 100, nil);

      hMetaGreenPen := CreatePen(0, 0, $0000FF00);
      SelectObject(hDCMeta, hMetaGreenPen);

      hMetaVioletBrush := CreateSolidBrush($00FF00FF);
      SelectObject(hDCMeta, hMetaVioletBrush);

      GetCurrentPositionEx(hdcMeta, PointMeta);
      MoveToEx(hdcMeta, 0, 0, PointMeta);
      TextOut(hdcMeta, 10, 10, 'Hello People', 12);
      LineTo(hdcMeta, 10, 10);

      hMF := CloseMetaFile(hdcMeta);
   //Вариант пакета для буфера обмена, согласно статьи
   {
      hMeta := GlobalAlloc(GHND, sizeof(METAFILEPICT));

      lpMeta       :=GlobalLock(hMeta);
      lpmeta^.mm   :=MM_ANISOTROPIC;
      lpmeta^.hMF  :=hMF;
      lpmeta^.xExt :=0;
      lpmeta^.yExt :=0;

      GlobalUnlock(hMeta);
      }

      //if(hMeta<>0)then
      //begin
    // Вариант записи пакета в память буфера обмена, но тогда теряется другая записанная ранее информация
         //OpenClipboard(Application.MainForm.Handle);
         //EmptyClipboard;
         //SetClipboardData(CF_METAFILEPICT, hMeta);
         //CloseClipboard;
        Stream.Size := 0;
        Stream.Position := 0;
        Stream.WriteBuffer(lpMeta, SizeOf(lpMeta)); //Also write terminating zero
        Stream.Position := 0;
      //end;

      ClipBoard.AddFormat(CF_METAFILEPICTURE, Stream);

  finally
    Stream.Free;
  end;
end; 


надо писатьт SetClipboardData(CF_METAFILEPICT, hMeta), а не поток пихать в клипбоард
дай рабочий пример того что не получается

zub писал(а):надо писатьт SetClipboardData(CF_METAFILEPICT, hMeta), а не поток пихать в клипбоард
дай рабочий пример того что не получается

Исходники во вложение. Да там уже ничего не получается. Сейчас пытался просто скопировать содержимое буфера обмена и своей программой залить его же. Результат отрицательный.
Через приложение CLCL смотрю что в буфере после записи Excel в него. Удалил все лишние блоки данных, т.е. минимизировал объем данных в буфере до объема при котором AutoCAD распознает содержимое как таблицу и создает на ее основе свою. Все в том же CLCL. Сделал экспорт этого минимального объема данных в файлы, и программой загружаю обратно в буфер обмена. Т.е. имитирую запись как бы Excel-ем. И фиг, AutoCAD игнорит.
Т.е. когда CLCL через свои "образцы" закидывает обрезанную информацию AutoCAD как то начинает распознавать, а если я через свою программу ту же информацию - облом.

**у AutoCAD есть команда PasteSpec, она же "Вставка - Специальная вставка". Если все правильно, то в диалоге появляется выбор создать "Объект AutoCAD". И на основе сведений буфера обмена получаем адекватную таблицу автокада в чертеже. Работает только с Excel, с LibreOffice облом. Если бы получилось разобраться как это все работает, то хороший способ загрузки таблиц спецификаций в LT версию получился бы.

вот валидная запись в метафайла в буфер

Код: Выделить всё

procedure TForm1.Button1Click(Sender: TObject);
var
  hdcMeta:HDC;
  hMF:HMETAFILE;
  lpMETA:LPMETAFILEPICT;
  hMetaGreenPen:HPEN;
  hMetaVioletBrush:HBRUSH;
  PointMeta:LPPoint;
  hMem:HANDLE;
begin
  hdcMeta := CreateMetaFile(nil); //'test.met'
  SetWindowOrgEx(hdcMeta, 0, 0, nil);
  SetWindowExtEx(hdcMeta, 100, 100, nil);

  hMetaGreenPen := CreatePen(0, 0, $0000FF00);
  SelectObject(hDCMeta, hMetaGreenPen);

  hMetaVioletBrush := CreateSolidBrush($00FF00FF);
  SelectObject(hDCMeta, hMetaVioletBrush);

  GetCurrentPositionEx(hdcMeta, PointMeta);
  MoveToEx(hdcMeta, 0, 0, PointMeta);
  TextOut(hdcMeta, 10, 10, 'Hello People', 12);
  LineTo(hdcMeta, 100, 100);
  hMF := CloseMetaFile(hdcMeta);

  PlayMetaFile(Self.Canvas.Handle,hMF);

  hMem:=GlobalAlloc(GHND, sizeof(METAFILEPICT));
  lpMETA:=GlobalLock(hMem);

  lpMETA^.hMF:=hMF;
  lpMETA^.xExt:=100;
  lpMETA^.yExt:=100;
  lpMETA^.mm:=MM_ANISOTROPIC;

  GlobalUnlock(hMem);

  OpenClipboard(Application.MainForm.Handle);
  EmptyClipboard;
  SetClipboardData(CF_METAFILEPICT,hMem);
  CloseClipboard;
  GlobalFree(hMem);
end;

Но. этого мало. ексель пишет в клипбоард не сам файл, а множество различных представлений таблицы в разных форматах. я например там вижу

Код: Выделить всё

DataObject
image/x-emf
image/x-wmf
image/bmp
application/x-ms-shortcut
5
XML Spreadsheet
HTML Format
text/plain
text/plain
CSV
Rich Text Format
Embed Source
Native
OwnerLink
Object Descriptor
Link Source
Link Source Descriptor
Link
129
ObjectLink
Ole Private Data
application/x-ms-locale
application/x-ms-oemtext
image/bmp

что из этого автокад воспримет как таблицу - надо разбираться. твой(мой) же пример пишет только

Код: Выделить всё

image/lcl.metafilepict

автокад это игнорит

zub писал(а):автокад это игнорит

Я же тебе писал, и в исходниках что выложил посмотри картинку. Там скриншот минимального набора записей: Metafile pictur; Object Decriptor; XML; HTML; TEXT.
Твой вариант создания метафайла, из-за способа записи в буфер сотрет все остальные варианты. Ты через WinAPI пишешь, а не функциями FPC, надо одним типом функций писать.
Но у меня этот минимальный набор представлений почему то прокатывает только когда через CLCL делаю. А если я делаю в чистую, то нет. И еще если я сам подгружаю metafile, то он так и остается. А когда загружаю средствами CLCL, то автоматически создается Enhanced metafile. Подозреваю что ACAD с ним работает, а не древним вариантом.

Про автокад. Примерно так у меня получалось:
Если есть TEXT, то он закидывается в МТЕКСТ как есть.
Если есть METAFILE PICTURE и HTML, то создается таблица автокада, и содержимое оказыавется в таблице.
Если есть все выше описанное и XML, то каждая ячейка форматируется по шрифту как в буфере обмена, игнорируя стили автокада(на работе от этого плевались)
Если есть только METAFILE, то рисуются линии и текст, просто как элементы без создания таблицы.
*Во всех случаях еще должно быть сопровождение записью Object Decriptor, кроме просто TEXT

Чушь какая то, по большому счету. Одного HTML достаточно было, чтобы создать таблицу. А они заморочились.

т.к. lcl метафайлы не умеет - придется писать winapi, оно позволяет записать варианты

zub писал(а):.к. lcl метафайлы не умеет - придется писать winapi, оно позволяет записать варианты

Точнее почти не умеет...

Код: Выделить всё

unit mymetafile;

{$mode objfpc}{$H+}

interface


uses
  Windows,  Classes, SysUtils, Graphics;

type
  TMetafile = class;

  { TMetafileCanvas }

  TMetafileCanvas = class(TCanvas)
  private
    FMetafile: TMetafile;
  public
    constructor Create(AMetafile: TMetafile; ReferenceDevice: HDC);
    constructor CreateWithComment(AMetafile: TMetafile; ReferenceDevice: HDC;
      const CreatedBy, Description: String);
    destructor Destroy; override;
  end;

  { TMetafile }

  TMetafile = class(TGraphic)
  private
    FImageHandle: HENHMETAFILE;
    FImageMMWidth: Integer;      // are in 0.01 mm logical pixels
    FImageMMHeight: Integer;     // are in 0.01 mm logical pixels
    FImagePxWidth: Integer;  // in device pixels
    FImagePxHeight: Integer; // in device pixels


    procedure DeleteImage;
    function GetAuthor: String;
    function GetDescription: String;
    function GetHandle: HENHMETAFILE;
    function GetMMHeight: Integer;
    function GetMMWidth: Integer;
    procedure SetHandle(Value: HENHMETAFILE);
    procedure SetMMHeight(Value: Integer);
    procedure SetMMWidth(Value: Integer);
  protected
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    procedure SetHeight(Value: Integer); override;
    procedure SetWidth(Value: Integer); override;
  public
    constructor Create; override;
    destructor Destroy; override;

    procedure Assign(Source: TPersistent); override;

    procedure Clear;
    procedure LoadFromFile(const Filename: String);
    procedure SaveToFile(const Filename: String); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;

    function ReleaseHandle: HENHMETAFILE;
    property Handle: HENHMETAFILE read GetHandle write SetHandle;

    property CreatedBy: String read GetAuthor;
    property Description: String read GetDescription;
    property Empty: boolean read GetEmpty;

    property MMWidth: Integer read GetMMWidth write SetMMWidth;
    property MMHeight: Integer read GetMMHeight write SetMMHeight;
  end;

implementation



{ TMetafile }

procedure TMetafile.DeleteImage;
begin
    DeleteEnhMetafile(FImageHandle);
    FImageHandle := 0;
end;

function TMetafile.GetAuthor: String;
var
  NC: Integer;
begin
  Result := '';
  if FImageHandle = 0 then Exit;

  NC := GetEnhMetafileDescription(FImageHandle, 0, nil);
  if NC <= 0 then Exit
  else begin
     SetLength(Result, NC);
     GetEnhMetafileDescription(FImageHandle, NC, PChar(Result));
     SetLength(Result, StrLen(PChar(Result)) );
  end;
end;

function TMetafile.GetDescription: String;
var
  NC: Integer;
begin
  Result := '';
  if FImageHandle = 0 then Exit;

  NC := GetEnhMetafileDescription(FImageHandle, 0, nil);
  if NC <= 0 then Exit
  else begin
     SetLength(Result, NC);
     GetEnhMetafileDescription(FImageHandle, NC, PChar(Result));
     Delete(Result, 1, StrLen(PChar(Result))+1);
     SetLength(Result, StrLen(PChar(Result)));
  end;
end;

function TMetafile.GetHandle: HENHMETAFILE;
begin
    Result := FImageHandle;
end;

function TMetafile.GetMMHeight: Integer;
begin
  Result := FImageMMHeight;
end;

function TMetafile.GetMMWidth: Integer;
begin
  Result := FImageMMWidth;
end;

procedure TMetafile.SetHandle(Value: HENHMETAFILE);
var
  EnhHeader: TEnhMetaHeader;
begin
  if (Value <= 0) or (GetEnhMetafileHeader(Value, sizeof(EnhHeader), @EnhHeader) = 0) then
     raise EInvalidImage.Create('Invalid Metafile');;

  DeleteImage;

  FImageHandle := Value;
  FImagePxWidth := 0;
  FImagePxHeight := 0;
  FImageMMWidth := EnhHeader.rclFrame.Right - EnhHeader.rclFrame.Left;
  FImageMMHeight := EnhHeader.rclFrame.Bottom - EnhHeader.rclFrame.Top;
end;

procedure TMetafile.SetMMHeight(Value: Integer);
begin
  FImagePxHeight := 0;
  if FImageMMHeight <> Value then FImageMMHeight := Value;
end;

procedure TMetafile.SetMMWidth(Value: Integer);
begin
  FImagePxWidth := 0;
  if FImageMMWidth <> Value then FImageMMWidth := Value;
end;

function TMetafile.GetEmpty: Boolean;
begin
   Result := (FImageHandle = 0);
end;

function TMetafile.GetHeight: Integer;
var
  EMFHeader: TEnhMetaHeader;
begin
  if FImageHandle = 0 then
     Result := FImagePxHeight
  else begin               // convert 0.01mm units to device pixels
       GetEnhMetaFileHeader(FImageHandle, Sizeof(EMFHeader), @EMFHeader);
       Result := MulDiv(FImageMMHeight,               // metafile height in 0.01mm
         EMFHeader.szlDevice.cy,                      // device height in pixels
         EMFHeader.szlMillimeters.cy*100);            // device height in mm
     end
end;

function TMetafile.GetWidth: Integer;
var
  EMFHeader: TEnhMetaHeader;
begin
  if FImageHandle = 0 then
     Result := FImagePxWidth
  else begin     // convert 0.01mm units to device pixels
        GetEnhMetaFileHeader(FImageHandle, Sizeof(EMFHeader), @EMFHeader);
        Result := MulDiv(FImageMMWidth,                // metafile width in 0.01mm
          EMFHeader.szlDevice.cx,                      // device width in pixels
          EMFHeader.szlMillimeters.cx*100);            // device width in 0.01mm
      end

end;

procedure TMetafile.Draw(ACanvas: TCanvas; const Rect: TRect);
var
  RT: TRect;
begin
  if FImageHandle = 0 then Exit;
  RT := Rect;
  PlayEnhMetaFile(ACanvas.Handle, FImageHandle, RT);
end;

procedure TMetafile.SetHeight(Value: Integer);
var
  EMFHeader: TEnhMetaHeader;
begin
    if FImageHandle = 0 then
       FImagePxHeight := Value
    else begin                 // convert device pixels to 0.01mm units
       GetEnhMetaFileHeader(FImageHandle, Sizeof(EMFHeader), @EMFHeader);
       MMHeight := MulDiv(Value,                      // metafile height in pixels
          EMFHeader.szlMillimeters.cy*100,             // device height in 0.01mm
          EMFHeader.szlDevice.cy);                     // device height in pixels
    end
end;

procedure TMetafile.SetWidth(Value: Integer);
var
  EMFHeader: TEnhMetaHeader;
begin
  if FImageHandle = 0 then
     FImagePxWidth := Value
  else begin                 // convert device pixels to 0.01mm units
        GetEnhMetaFileHeader(FImageHandle, Sizeof(EMFHeader), @EMFHeader);
        MMWidth := MulDiv(Value,                      // metafile width in pixels
          EMFHeader.szlMillimeters.cx*100,            // device width in mm
          EMFHeader.szlDevice.cx);                    // device width in pixels
  end
end;

constructor TMetafile.Create;
begin
  inherited Create;
  FImageHandle := 0;
end;

destructor TMetafile.Destroy;
begin
  ReleaseHandle;
  inherited Destroy;
end;

procedure TMetafile.Assign(Source: TPersistent);
begin
if (Source is TMetafile) then begin
      FImageHandle := TMetafile(Source).Handle;
      FImageMMWidth := TMetafile(Source).MMWidth;
      FImageMMHeight := TMetafile(Source).MMHeight;
      FImagePxWidth := TMetafile(Source).Width;
      FImagePxHeight := TMetafile(Source).Height;
end;
inherited Assign(Source);
end;

procedure TMetafile.Clear;
begin
  DeleteImage;
end;

procedure TMetafile.LoadFromFile(const Filename: String);
begin
      raise EComponentError.Create('Not Implemented');
end;

procedure TMetafile.SaveToFile(const Filename: String);
var
  outFile: HENHMETAFILE;
begin
   if FImageHandle = 0 then exit;
  outFile := CopyEnhMetaFile(FImageHandle, PChar(FileName));
  if outFile = 0 then
    RaiseLastWin32Error;
    DeleteEnhMetaFile(outFile);

//      raise EComponentError.Create('Not Implemented');
end;

procedure TMetafile.LoadFromStream(Stream: TStream);
begin
      raise EComponentError.Create('Not Implemented');
end;

procedure TMetafile.SaveToStream(Stream: TStream);
begin
      raise EComponentError.Create('Not Implemented');
end;

function TMetafile.ReleaseHandle: HENHMETAFILE;
begin
  Result := FImageHandle;
  DeleteImage;
end;

{ TMetafileCanvas }

constructor TMetafileCanvas.Create(AMetafile: TMetafile; ReferenceDevice: HDC);
begin
  CreateWithComment(AMetafile, ReferenceDevice, AMetafile.CreatedBy,
    AMetafile.Description);
end;

constructor TMetafileCanvas.CreateWithComment(AMetafile: TMetafile;
  ReferenceDevice: HDC; const CreatedBy, Description: String);
var
  RefDC: HDC;
  R: TRect;
  Temp: HDC;
  P: PChar;
begin
  inherited Create;
  FMetafile := AMetafile;

  if ReferenceDevice = 0 then RefDC := GetDC(0)
  else RefDC := ReferenceDevice;

  try
    if FMetafile.MMWidth = 0 then begin
      if FMetafile.Width = 0 then //if no width get RefDC height
        FMetafile.MMWidth := GetDeviceCaps(RefDC, HORZSIZE)*100
      else FMetafile.MMWidth := MulDiv(FMetafile.Width, //else convert
              GetDeviceCaps(RefDC, HORZSIZE)*100, GetDeviceCaps(RefDC, HORZRES));
    end;

    if FMetafile.MMHeight = 0 then begin
      if FMetafile.Height = 0 then //if no height get RefDC height
        FMetafile.MMHeight := GetDeviceCaps(RefDC, VERTSIZE)*100
      else FMetafile.MMHeight := MulDiv(FMetafile.Height, //else convert
              GetDeviceCaps(RefDC, VERTSIZE)*100, GetDeviceCaps(RefDC, VERTRES));
    end;

    R := Rect(0,0,FMetafile.MMWidth,FMetafile.MMHeight);
    //lpDescription stores both author and description
    if (Length(CreatedBy) > 0) or (Length(Description) > 0) then
      P := PChar(CreatedBy+#0+Description+#0#0)
    else
      P := nil;
    Temp := CreateEnhMetafile(RefDC, nil, @R, P);
    if Temp = 0 then raise EOutOfResources.Create('Out of Resources');;
    Handle := Temp;
  finally
    if ReferenceDevice = 0 then ReleaseDC(0, RefDC);
  end;

end;

destructor TMetafileCanvas.Destroy;
begin
  FMetafile.Handle := CloseEnhMetafile(Handle);
  Handle := 0;
  inherited Destroy;
end;

end.


https://wiki.freepascal.org/TMetafile_/_TMetafileCanvas