Free VCL - DWG para Delphi:
ScreenShot: http://www.cadsofttools.com/images/cadimportvcl.gif Download: http://www.cadsofttools.com/download/cadimportvcl.zip Espero ter ajudado... Andy escreveu: > > > Segue abaixo o código que estou usando. É um código que achei na web ( > http://www.delphi3000.com > <http://www.delphi3000.com><http://www.delphi3000.com/articles/article_3806.asp > > <http://www.delphi3000.com/articles/article_3806.asp>>), > porém o site de onde peguei está fora do ar. > Estou mandando a unit completa, pois se alguém mais quiser é só pegar. Ela > funcionou bem para todos os arquivos que testei, exceto para arquivos .dwg > E eu tenho AutoCAD instalado no meu computador. Além disso, o thumbnail do > windows mostra normalmente a miniatura dos arquivos .dwg > > A única função que é preciso chamar é a última do arquivo: * > GetBitmapFromFile(**const FileName: String): TGraphic;* > E esta função retorna um TGraphic que utilizo para fazer um Assign em um > TImage, como abaixo: > Para Usar: *Image1.Picture.Assign(**GetBitmapFromFile(OpenDialog1.** > FileName))* > > Nesta função eu coloquei um* if (not AnsiEndsStr('.dwg', FileName))* para > filtar os arquivos dwg, pois o problema está exatamente na função > *ExtractImageGetFileThumbnail. > *com este if, a função funciona e retorna um Ícone do dwg. > > Obrigado, > Anderson > > *Código:* > > unit ShellObjHelper; > > {$IFDEF VER100}{$DEFINE DELPHI3}{$ENDIF} > > interface > > uses > Windows, ShlObj, ActiveX, ShellAPI, Graphics, StrUtils; > > type > { from ShlObjIdl.h } > IExtractImage = interface > ['{BB2E617C-0920-11D1-9A0B-00C04FC2D6C1}'] > function GetLocation(Buffer: PWideChar; > BufferSize: DWORD; > var Priority: DWORD; > var Size: TSize; > ColorDepth: DWORD; > var Flags: DWORD): HResult; stdcall; > function Extract(var BitmapHandle: HBITMAP): HResult; stdcall; > end; > > IRunnableTask = interface > ['{85788D00-6807-11D0-B810-00C04FD706EC}'] > function Run: HResult; stdcall; > function Kill(fWait: BOOL): HResult; stdcall; > function Suspend: HResult; stdcall; > function Resume: HResult; stdcall; > function IsRunning: Longint; stdcall; > end; > > const > { from ShlObjIdl.h } > ITSAT_MAX_PRIORITY = 2; > ITSAT_MIN_PRIORITY = 1; > ITSAT_DEFAULT_PRIORITY = 0; > > IEI_PRIORITY_MAX = ITSAT_MAX_PRIORITY; > IEI_PRIORITY_MIN = ITSAT_MIN_PRIORITY; > IEIT_PRIORITY_NORMAL = ITSAT_DEFAULT_PRIORITY; > > IEIFLAG_ASYNC = $001; // ask the extractor if it supports ASYNC > extract > // (free threaded) > IEIFLAG_CACHE = $002; // returned from the extractor if it does NOT > cache > // the thumbnail > IEIFLAG_ASPECT = $004; // passed to the extractor to beg it to render > to > // the aspect ratio of the supplied rect > IEIFLAG_OFFLINE = $008; // if the extractor shouldn't hit the net to get > // any content needs for the rendering > IEIFLAG_GLEAM = $010; // does the image have a gleam? this will be > // returned if it does > IEIFLAG_SCREEN = $020; // render as if for the screen (this is > exlusive > // with IEIFLAG_ASPECT ) > IEIFLAG_ORIGSIZE = $040; // render to the approx size passed, but crop if > // neccessary > IEIFLAG_NOSTAMP = $080; // returned from the extractor if it does NOT > want > // an icon stamp on the thumbnail > IEIFLAG_NOBORDER = $100; // returned from the extractor if it does NOT > want > // an a border around the thumbnail > IEIFLAG_QUALITY = $200; // passed to the Extract method to indicate that > // a slower, higher quality image is desired, > // re-compute the thumbnail > > {$IFDEF DELPHI3} > // Delphi 3 SysUtils does not have this function > function ExcludeTrailingBackslash(const Src: string): string; > {$ENDIF} > > // IShellFolder methods helper > procedure ShellFolderBindToObject(const ShellFolder: IShellFolder; > PIDL: PItemIDList; const riid: TGUID; out pv); > function ShellFolderGetUIObjectOf(const ShellFolder: IShellFolder; > cidl: DWORD; var PIDL: PItemIDList; riid: TGUID; out pv): Boolean; > procedure ShellFolderParseDisplayName(const ShellFolder: IShellFolder; > const DisplayName: string; out PIDL: PItemIDList); > function ShellFolderGetExtractImage(const ShellFolder: IShellFolder; > const RelativeFileName: string; Malloc: IMalloc; > out XtractImage: IExtractImage): Boolean; > > function GetExtractImageItfPtr(const FileName: string; > out XtractImage: IExtractImage): Boolean; > function GetFileLargeIcon(const FileName: string; > out LargeIcon: TIcon): Boolean; > function ExtractImageGetFileThumbnail(const XtractImage: IExtractImage; > ImgWidth, ImgHeight, ImgColorDepth: Integer; var Flags: DWORD; Bmp: > TBitmap; > out RunnableTask: IRunnableTask): Boolean; > function GetSysImgListIndex(const FileName: string): Integer; > procedure GetShellFolderItfPtr(const FolderName: string; Malloc: IMalloc; > out TargetFolder: IShellFolder); > function GetBitmapFromFile(const FileName: String): TGraphic; > > implementation > > uses SysUtils, ComObj; > > {$IFDEF DELPHI3} > function ExcludeTrailingBackslash(const Src: string): string; > begin > Result := Src; > if AnsiLastChar(Result) = '\' then > SetLength(Result, Pred(Length(Result))); > end; > {$ENDIF DELPHI3} > > procedure ShellFolderBindToObject(const ShellFolder: IShellFolder; > PIDL: PItemIDList; const riid: TGUID; out pv); > begin > OleCheck(ShellFolder.BindToObject(PIDL, nil, riid, > {$IFDEF DELPHI3}Pointer(pv){$ELSE}pv{$ENDIF})); > end; > > function ShellFolderGetUIObjectOf(const ShellFolder: IShellFolder; > cidl: DWORD; var PIDL: PItemIDList; riid: TGUID; out pv): Boolean; > begin > Result := NOERROR = ShellFolder.GetUIObjectOf(0, cidl, PIDL, > riid, nil, {$IFDEF DELPHI3}Pointer(pv){$ELSE}pv{$ENDIF}); > end; > > procedure ShellFolderParseDisplayName(const ShellFolder: IShellFolder; > const DisplayName: string; out PIDL: PItemIDList); > var > Attributes, Eaten: DWORD; > begin > OleCheck(ShellFolder.ParseDisplayName(0, nil, > PWideChar(WideString(DisplayName)), Eaten, PIDL, Attributes)); > end; > > function ShellFolderGetExtractImage(const ShellFolder: IShellFolder; > const RelativeFileName: string; Malloc: IMalloc; > out XtractImage: IExtractImage): Boolean; > var > PIDL: PItemIDList; > begin > ShellFolderParseDisplayName(ShellFolder, RelativeFileName, PIDL); > Result := ShellFolderGetUIObjectOf(ShellFolder, 1, PIDL, > IExtractImage, XtractImage); > Malloc.Free(PIDL); > end; > > function GetExtractImageItfPtr(const FileName: string; > out XtractImage: IExtractImage): Boolean; > var > TargetFolder: IShellFolder; > FilePath: string; > ItemIDList: PItemIDList; > Malloc: IMalloc; > begin > FilePath := ExcludeTrailingBackslash(ExtractFilePath(FileName)); > OleCheck(SHGetMalloc(Malloc)); > GetShellFolderItfPtr(FilePath, Malloc, TargetFolder); > ShellFolderParseDisplayName(TargetFolder, ExtractFileName(FileName), > ItemIDList); > try > Result := ShellFolderGetUIObjectOf(TargetFolder, 1, ItemIDList, > IExtractImage, XtractImage); > finally > Malloc.Free(ItemIDList); > end; > end; > > function GetFileLargeIcon(const FileName: string; out LargeIcon: TIcon): > Boolean; > var > SFI: TSHFileInfo; > begin > if 0 <> SHGetFileInfo(PChar(FileName), FILE_ATTRIBUTE_ARCHIVE, SFI, > sizeof(SFI), SHGFI_ICON or SHGFI_LARGEICON) then > begin > LargeIcon := TIcon.Create; > LargeIcon.Handle := SFI.hIcon; > Result := True; > end else > Result := False; > end; > > function ExtractImageGetFileThumbnail(const XtractImage: IExtractImage; > ImgWidth, ImgHeight, ImgColorDepth: Integer; var Flags: DWORD; Bmp: > TBitmap; > out RunnableTask: IRunnableTask): Boolean; > var > Size: TSize; > Buf: array[0..MAX_PATH] of WideChar; > BmpHandle: HBITMAP; > Priority: DWORD; > GetLocationRes: HRESULT; > > procedure FreeAndNilBitmap; > begin > {$IFNDEF DELPHI3} > FreeAndNil(Bmp); > {$ELSE} > Bmp.Free; > Bmp := nil; > {$ENDIF} > end; > > begin > Result := False; > RunnableTask := nil; > Size.cx := ImgWidth; > Size.cy := ImgHeight; > Priority := IEIT_PRIORITY_NORMAL; > Flags := Flags or IEIFLAG_ASYNC; > GetLocationRes := XtractImage.GetLocation(Buf, sizeof(Buf), Priority, > Size, > ImgColorDepth, Flags); > > if (GetLocationRes = NOERROR) or (GetLocationRes = E_PENDING) then > begin > if GetLocationRes = E_PENDING then > begin > { if QI for IRunnableTask succeed, we can use RunnableTask > interface pointer later to kill running extraction process. > We could spawn a new thread here to extract image. } > if S_OK <> XtractImage.QueryInterface(IRunnableTask, RunnableTask) > then > RunnableTask := nil; > end; > > try > OleCheck(XtractImage.Extract(BmpHandle)); // This could consume a long > time. > // If RunnableTask is > available > // then calling Kill() > method > // will immediately abort > the process. > Bmp.Handle := BmpHandle; > Result := True; > except > on E: EOleSysError do > begin > // ------------- > OutputDebugString(PChar(string(E.ClassName) + ': ' + E.Message)); > // ------------- > FreeAndNilBitmap; > Result := False; > end > else > begin > FreeAndNilBitmap; > raise; > end; > end; { try/except } > end; > end; > > function GetSysImgListIndex(const FileName: string): Integer; > var > SFI: TSHFileInfo; > begin > SHGetFileInfo(PChar(FileName), 0, SFI, sizeof(TSHFileInfo), > SHGFI_SYSICONINDEX); > Result := SFI.iIcon; > end; > > procedure GetShellFolderItfPtr(const FolderName: string; Malloc: IMalloc; > out TargetFolder: IShellFolder); > var > DesktopFolder: IShellFolder; > ItemIDList: PItemIDList; > begin > OleCheck(SHGetDesktopFolder(DesktopFolder)); > ShellFolderParseDisplayName(DesktopFolder, FolderName, ItemIDList); > try > ShellFolderBindToObject(DesktopFolder, ItemIDList, IShellFolder, > TargetFolder); > finally > Malloc.Free(ItemIDList); > end; > end; > > //******************************************************* > > function GetBitmapFromFile(const FileName: String): TGraphic; > var > XtractImage: IExtractImage; > Bmp: TBitmap; > Icon: TIcon; > ColorDepth: Integer; > Flags: DWORD; > RT: IRunnableTask; > begin > Flags := DWORD(IEIFLAG_OFFLINE) or DWORD(IEIFLAG_SCREEN); > ColorDepth := 32; > > Result := nil; > Icon := nil; > Bmp := TBitmap.Create; > try > if GetFileLargeIcon(FileName, Icon) then > Result := Icon; > > if GetExtractImageItfPtr(FileName, XTractImage) and > // (not AnsiEndsStr('.dwg', FileName)) and > ExtractImageGetFileThumbnail(XtractImage, 100, 100, ColorDepth, > Flags, Bmp, RT) then > begin > Result := Bmp; > Icon.Free; > end > else > Bmp.Free; > except > end; > end; > > end. > > {---------------------------------------------------------- > Unit Name: ShellObjHelper > Author : hans gulo (HG) > Purpose : Shell Object helper routines > Purpose : Demo application's main unit for retrieving IExtractImage > interface > pointer from Windows Shell folder to crete thumbnail image. > This code is a complementary for Delphi3000.com article at > http://www.delphi3000.com/articles/article_3806.asp > <http://www.delphi3000.com/articles/article_3806.asp> > ----------------------------------------------------------} > > [As partes desta mensagem que não continham texto foram removidas] > > . > >
