Преобразование кода VB в Delphi (он извлечет изображение из файла EMF) - PullRequest
Новая
       16

Преобразование кода VB в Delphi (он извлечет изображение из файла EMF)

2 голосов
/ 17 июня 2010

При поиске в сети я получил несколько строк кода в VB для извлечения изображения из файла EMF.

Я пытался преобразовать это в Delphi, но не работает.

Помогите мне впреобразование этого кода в Delphi. 

Public Function CallBack_ENumMetafile(ByVal hdc As Long, _
                                      ByVal lpHtable As Long, _
                                      ByVal lpMFR As Long, _
                                      ByVal nObj As Long, _
                                      ByVal lpClientData As Long) As Long
  Dim PEnhEMR As EMR
  Dim PEnhStrecthDiBits As EMRSTRETCHDIBITS
  Dim tmpDc As Long
  Dim hBitmap  As Long
  Dim lRet As Long
  Dim BITMAPINFO As BITMAPINFO
  Dim pBitsMem As Long
  Dim pBitmapInfo As Long
  Static RecordCount As Long

  lRet = PlayEnhMetaFileRecord(hdc, ByVal lpHtable, ByVal lpMFR, ByVal nObj)


  RecordCount = RecordCount + 1
  CopyMemory PEnhEMR, ByVal lpMFR, Len(PEnhEMR)
  Select Case PEnhEMR.iType
  Case 1  'header
    RecordCount = 1
  Case EMR_STRETCHDIBITS
    CopyMemory PEnhStrecthDiBits, ByVal lpMFR, Len(PEnhStrecthDiBits)
    pBitmapInfo = lpMFR + PEnhStrecthDiBits.offBmiSrc
    CopyMemory BITMAPINFO, ByVal pBitmapInfo, Len(BITMAPINFO)
    pBitsMem = lpMFR + PEnhStrecthDiBits.offBitsSrc

    tmpDc = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
    hBitmap = CreateDIBitmap(tmpDc, _
                            BITMAPINFO.bmiHeader, _
                            CBM_INIT, _
                            ByVal pBitsMem, _
                            BITMAPINFO, _
                            DIB_RGB_COLORS)
    lRet = DeleteDC(tmpDc)

  End Select
  CallBack_ENumMetafile = True

End Function

1 Ответ

4 голосов
/ 17 июня 2010

То, что вы опубликовали, является экземпляром функции обратного вызова EnumMetaFileProc, поэтому мы начнем с подписи: 

function Callback_EnumMetafile(
  hdc: HDC;
  lpHTable: PHandleTable;
  lpMFR: PMetaRecord;
  nObj: Integer;
  lpClientData: LParam
): Integer; stdcall;

Он начинается с объявления группы переменных, но я пока пропущу это, поскольку не знаю, какие из них нам действительно понадобятся, а VB имеет более ограниченную систему типов, чем Delphi. Я собираюсь объявить их, как они нам нужны; Вы можете сами переместить их в начало функции.

Далее следует вызов PlayEnhMetaFileRecord с использованием большинства тех же параметров, которые были переданы в функцию обратного вызова. Функция возвращает Bool, но затем код игнорирует ее, поэтому давайте не будем беспокоиться о lRet. 

PlayEnhMetaFileRecord(hdc, lpHtable, lpMFR, nObj);

Далее мы инициализируем RecordCount. Он объявлен как статический, что означает, что он сохраняет свое значение от одного вызова к другому. Это выглядит немного сомнительно; вероятно, его следует передать как указатель в параметре lpClientData, но давайте пока не будем слишком далеко отклоняться от исходного кода. Delphi создает статические переменные с типизированными константами , и они должны быть модифицируемыми, поэтому мы будем использовать директиву $ J: 

{$J+}
const
  RecordCount: Integer = 0;
{$J}

Inc(RecordCount);

Затем мы скопируем часть мета-записи в другую переменную: 

var
  PEnhEMR: TEMR;

CopyMemory(@PEnhEMR, lpMFR, SizeOf(PEnhEMR));

Кажется немного странным копировать структуру TMetaRecord в структуру TEMR, поскольку они не очень похожи, но опять же, я не хочу слишком сильно отклоняться от исходного кода.

Далее следует инструкция case в поле iType. Первый случай, когда это 1: 

case PEnhEMR.iType of
  1: RecordCount := 1;

Следующий случай - это emr_StretchDIBits. Он копирует больше мета-записи, а затем назначает некоторые другие указатели для ссылки на подразделы основной структуры данных. 

var
  PEnhStretchDIBits: TEMRStretchDIBits;
  BitmapInfo: TBitmapInfo;
  pBitmapInfo: Pointer;
  pBitsMem: Pointer;

  emr_StretchDIBits: begin
    CopyMemory(@PEnhStrecthDIBits, lpMFR, SizeOf(PEnhStrecthDIBits));
    pBitmapInfo := Pointer(Cardinal(lpMFR) + PEnhStrecthDiBits.offBmiSrc);
    CopyMemory(@BitmapInfo, pBitmapInfo, SizeOf(BitmapInfo));
    pBitsMem := Pointer(Cardinal(lpMFR) + PEnhStrecthDiBits.offBitsSrc);

Затем следует то, что кажется истинным смыслом функции, где мы создаем контекст отображения и растровое изображение для его использования, используя DIB-биты, извлеченные с использованием предыдущего кода. 

var
  tmpDc: HDC;
  hBitmap: HBitmap;

    tmpDc := CreateDC('DISPLAY', nil, nil, nil);
    hBitmap := CreateDIBitmap(tmpDc, @BitmapInfo.bmiHeader, cbm_Init,
      pBitsMem, @BitmapInfo, dib_RGB_Colors);
    DeleteDC(tmpDc);
  end; // emr_StretchDIBits
end; // case

Наконец, мы присваиваем возвращаемое значение функции обратного вызова: 

Result := 1;

Итак, вот ваш перевод. Оберните его в блок begin - end, удалите мой комментарий и переместите все объявления переменных в верхнюю часть, и вы должны иметь код Delphi, который эквивалентен вашему VB-коду. Однако в конечном итоге весь этот код генерирует утечки памяти. Переменная hBitmap является локальной для функции, поэтому дескриптор растрового изображения, который она содержит, пропускается, как только эта функция возвращается. Я предполагаю, что код VB работает для вас, поэтому, я думаю, у вас есть другие планы относительно того, что с ним делать.

Если вы работаете с метафайлами, рассматривали ли вы вопрос об использовании класса TMetafile в модуле Graphics ? Это может сделать вашу жизнь проще.

...