X000X-ActiveX.pas

Delphi source

Eine kleine Übersicht meiner bisherigen Delphi sourcen. Die alte Übersichtsseite ist noch online und steht hier:

delphi source

Gefallen Euch meine sourcen – freue ich mich über Eure Spende – Danke!





X000X-ActiveX.pas

Ich habe hier mal ein paar ältere Delphi sourcen eingearbeitet. Die Originale findet Ihr immer noch hier:

X000X-Btn.pas
X000X-SysUtils.pas
X000X-ActiveX.pas



unit X000XActiveX;

interface

uses Windows;

type
  OLE_HANDLE = LongWord;
  OLE_XPOS_HIMETRIC  = Longint;
  OLE_YPOS_HIMETRIC  = Longint;
  OLE_XSIZE_HIMETRIC = Longint;
  OLE_YSIZE_HIMETRIC = Longint;
  Largeint = Int64;
  POleStr = PWideChar;
  TIID = TGUID;
  TCLSID = TGUID;

  IStream = interface;

{ IStream interface }

  PStatStg = ^TStatStg;
  tagSTATSTG = record
    pwcsName: POleStr;
    dwType: Longint;
    cbSize: Largeint;
    mtime: TFileTime;
    ctime: TFileTime;
    atime: TFileTime;
    grfMode: Longint;
    grfLocksSupported: Longint;
    clsid: TCLSID;
    grfStateBits: Longint;
    reserved: Longint;
  end;
  TStatStg = tagSTATSTG;
  STATSTG = TStatStg;

  ISequentialStream = interface(IUnknown)
    ['{0c733a30-2a1c-11ce-ade5-00aa0044773d}']
    function Read(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult;
      stdcall;
    function Write(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult;
      stdcall;
  end;

  IStream = interface(ISequentialStream)
    ['{0000000C-0000-0000-C000-000000000046}']
    function Seek(dlibMove: Largeint; dwOrigin: Longint;
      out libNewPosition: Largeint): HResult; stdcall;
    function SetSize(libNewSize: Largeint): HResult; stdcall;
    function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
      out cbWritten: Largeint): HResult; stdcall;
    function Commit(grfCommitFlags: Longint): HResult; stdcall;
    function Revert: HResult; stdcall;
    function LockRegion(libOffset: Largeint; cb: Largeint;
      dwLockType: Longint): HResult; stdcall;
    function UnlockRegion(libOffset: Largeint; cb: Largeint;
      dwLockType: Longint): HResult; stdcall;
    function Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult;
      stdcall;
    function Clone(out stm: IStream): HResult; stdcall;
  end;

type
  IPicture = interface
    ['{7BF80980-BF32-101A-8BBB-00AA00300CAB}']
    function get_Handle(out handle: OLE_HANDLE): HResult;  stdcall;
    function get_hPal(out handle: OLE_HANDLE): HResult; stdcall;
    function get_Type(out typ: Smallint): HResult; stdcall;
    function get_Width(out width: OLE_XSIZE_HIMETRIC): HResult; stdcall;
    function get_Height(out height: OLE_YSIZE_HIMETRIC): HResult; stdcall;
    function Render(dc: HDC; x, y, cx, cy: Longint;
      xSrc: OLE_XPOS_HIMETRIC; ySrc: OLE_YPOS_HIMETRIC;
      cxSrc: OLE_XSIZE_HIMETRIC; cySrc: OLE_YSIZE_HIMETRIC;
      const rcWBounds: TRect): HResult; stdcall;
    function set_hPal(hpal: OLE_HANDLE): HResult; stdcall;
    function get_CurDC(out dcOut: HDC): HResult; stdcall;
    function SelectPicture(dcIn: HDC; out hdcOut: HDC;
      out bmpOut: OLE_HANDLE): HResult; stdcall;
    function get_KeepOriginalFormat(out fkeep: BOOL): HResult; stdcall;
    function put_KeepOriginalFormat(fkeep: BOOL): HResult; stdcall;
    function PictureChanged: HResult; stdcall;
    function SaveAsFile(const stream: IStream; fSaveMemCopy: BOOL;
      out cbSize: Longint): HResult; stdcall;
    function get_Attributes(out dwAttr: Longint): HResult; stdcall;
  end;

type
   TFNCreateStreamOnHGlobalX = function(hglob: HGlobal; fDeleteOnRelease: BOOL;
                                        out stm: IStream): HResult; stdcall;
   TFNOleLoadPictureX        = function(stream: IStream; lSize: Longint; fRunmode: BOOL;
                                        const iid: TIID; out vObject): HResult; stdcall;

{function CreateStreamOnHGlobal(hglob: HGlobal; fDeleteOnRelease: BOOL;
  out stm: IStream): HResult; stdcall;
function OleLoadPicture(stream: IStream; lSize: Longint; fRunmode: BOOL;
  const iid: TIID; out vObject): HResult; stdcall;}

var
   CreateStreamOnHGlobalX : TFNCreateStreamOnHGlobalX = nil;
   OleLoadPictureX        : TFNOleLoadPictureX = nil;

   function LoadPictureFromFile(AFile: String; var pPicture: IPicture) : Boolean;
   function LoadPictureFromRes(Instance: THandle; const szResName, szResType : String; var pPicture: IPicture) : Boolean;

implementation

const
   OLE32    = 'ole32.dll';
   OLEPRO32 = 'olepro32.dll';

var LibOle32,
    LibOlePro32 : HMODULE;

function LoadX000XActiveX: Boolean;
begin
   Result := False;
   LibOle32 := LoadLibrary(@OLE32[1]);
   if LibOle32 <> 0 then begin
      LibOlePro32 := LoadLibrary(@OLEPRO32[1]);
      if LibOlePro32 <> 0 then begin
         CreateStreamOnHGlobalX := GetProcAddress(LibOle32, PChar('CreateStreamOnHGlobal'));
         OleLoadPictureX        := GetProcAddress(LibOlePro32, PChar('OleLoadPicture'));
         if Assigned(CreateStreamOnHGlobalX) And
            Assigned(OleLoadPictureX) then begin
            Result := True;
            Exit;
         end else begin
            CreateStreamOnHGlobalX := nil;
            OleLoadPictureX := nil;
            FreeLibrary(LibOle32);
            FreeLibrary(LibOlePro32);
         end;
      end else
         FreeLibrary(LibOle32);
   end;
end;

procedure UnloadX000XActiveX;
begin
   CreateStreamOnHGlobalX := nil;
   OleLoadPictureX := nil;
   FreeLibrary(LibOle32);
   FreeLibrary(LibOlePro32);
end;

(* Funktion l�dt ein Bild von der HDD in eine Variable vom Typ IPicture (X000XActiveX.pas) *)
function LoadPictureFromFile(AFile: String; var pPicture: IPicture) : Boolean;
const IID_IPicture : TGUID = '{7BF80980-BF32-101A-8BBB-00AA00300CAB}';
var
   hFile, hMem : THandle;
   dwFileSize,
   dwBytesRead : DWord;
   pData       : Pointer;
   bRead       : Boolean;
   hRes        : HResult;
   pStream     : IStream;
Begin
   Result := False;
   if LoadX000XActiveX then begin
      hMem   := 0;
      (* Datei �ffnen *)
      hFile  := CreateFile(PChar(AFile), GENERIC_READ, 0, nil,  OPEN_EXISTING, 0, 0);
      if hFile = INVALID_HANDLE_VALUE then Exit;
      (* Sollte was schief laufen, steigen wir mit exit aus, aufger�umt wird im Finally Block *)
      try
         (* Dateigr��e holen *)
         dwFileSize := GetFileSize(hFile, nil);
         if dwFileSize = INVALID_FILE_SIZE then
            Exit;
         (* "Dateigr��e" an Bytes vom Heap anfordern *)
         hMem := GlobalAlloc(GHND or GMEM_NODISCARD, dwFileSize);
         if hMem = 0 then
            Exit;
         (* Einen Zeiger auf den soeben angeforderten Speicherblock holen *)
         pData := GlobalLock(hMem);
         if Not Assigned(pData) then
            Exit;
         (* Datei in den Speicher lesen *)
         (* Dateigr��e und gelesene Bytes sollten hiernach �bereinstimmen *)
         bRead := ReadFile(hFile, pData^ , dwFileSize, dwBytesRead, nil);
         GlobalUnlock(hMem);
         if not bRead then
            Exit;
         (* Ein StreamObject erstellen (wir geben den HeapSpeicher selber frei - 2. Parameter) *)
         pStream := nil;
         hRes := CreateStreamOnHGlobalX(hMem, False, pStream);
         if FAILED(hRes) or (pStream = nil) then
            Exit;
         (* Das Picture in die Variable pPicture (IPicture) laden und bei Erfolg True zur�ckgeben *)
         hRes := OleLoadPictureX(pStream, dwFileSize, False, IID_IPicture, pPicture);
         if (hRes = S_OK) and (pPicture <> nil) then
            Result := True;
         (* StreamObjekt zerst�ren *)
         pStream := nil;
      finally
         (* Wenn wir vorhin erfolgreich Speicher angefordert haben, ihn hier *)
         (* auf jedenfall wieder frei geben *)
         if hMem <> 0 then
            GlobalFree(hMem);
         (* und zu guterletzt die Datei wieder schlie�en *)
         CloseHandle(hFile);
         UnloadX000XActiveX;
      end;
   end;
End;

function LoadPictureFromRes(Instance: THandle; const szResName, szResType : String; var pPicture: IPicture) : Boolean;
const IID_IPicture : TGUID = '{7BF80980-BF32-101A-8BBB-00AA00300CAB}';
var
   hResInfo,
   hResGlobal,
   hMem : THandle;
   dwFileSize  : DWord;
   pData,
   pResData    : Pointer;
   hRes        : HResult;
   pStream     : IStream;
Begin
   Result := False;
   if LoadX000XActiveX then begin
      hMem   := 0;
      (* Resource suchen und wenn vorhanden... *)
      hResInfo := FindResource(Instance, Pointer(szResName), Pointer(szResType));
      if hResInfo = 0 then Exit;
      (* ... laden *)
      hResGlobal := LoadResource(Instance, hResInfo);
      if hResGlobal = 0 then Exit;
      (* Sollte was schief laufen, steigen wir mit exit aus, aufger�umt wird im Finally Block *)
      try
         (* Handle auf die Daten holen *)
         pResData := LockResource(hResGlobal);
         if Not Assigned(pResData) then Exit;
         (* Gr��e der Resource in Bytes holen *)
         dwFileSize := SizeofResource(Instance, hResInfo);
         if dwFileSize = 0 then Exit;
         (* "Dateigr��e" an Bytes vom Heap anfordern *)
         hMem := GlobalAlloc(GHND or GMEM_NODISCARD, dwFileSize);
         if hMem = 0 then
            Exit;
         (* Einen Zeiger auf den soeben angeforderten Speicherblock holen *)
         pData := GlobalLock(hMem);
         if Not Assigned(pData) then
            Exit;
         (* Daten in den Speicher lesen *)
         Move(pResData^, pData^, dwFileSize);
         GlobalUnlock(hMem);
         (* Ein StreamObject erstellen (wir geben den HeapSpeicher selber frei - 2. Parameter) *)
         pStream := nil;
         hRes := CreateStreamOnHGlobalX(hMem, False, pStream);
         if FAILED(hRes) or (pStream = nil) then
            Exit;
         (* Das Picture in die Variable pPicture (IPicture) laden und bei Erfolg True zur�ckgeben *)
         hRes := OleLoadPictureX(pStream, dwFileSize, False, IID_IPicture, pPicture);
         if (hRes = S_OK) and (pPicture <> nil) then
            Result := True;
         (* StreamObjekt zerst�ren *)
         pStream := nil;
      finally
         (* Wenn wir vorhin erfolgreich Speicher angefordert haben, ihn hier *)
         (* auf jedenfall wieder frei geben *)
         if hMem <> 0 then
            GlobalFree(hMem);
         (* und zu guterletzt die Resource freigeben *)
         if hResGlobal <> 0 then
            FreeResource(hResGlobal);
         UnloadX000XActiveX;
      end;
   end;
End;

end.

Gefallen Euch meine sourcen – freue ich mich über Eure Spende – Danke!


Comments are closed.