delphi 使用SHGetFileInfo函数获取任何文件大图标(修复长时间运行报错问题)

uses

    ShellAPI, CommCtrl;

function GetFileICO(AFile: string; AWidth, AHeight: Integer): TBitmap;

   function GetFileIconEX(AFile: string; ASHIL_FLAG: Cardinal): HICON;

      function _X: Boolean; {判断是否符合系统版本}

      begin

         Result := False;

         if Win32MajorVersion < 5 then

            Exit;

         if (Win32MajorVersion = 5) and (Win32MinorVersion < 1) then

            Exit;

         Result := True;

      end;

   type

      _SHGetImageList = function(iImageList: Integer; const riid: TGUID; var ppvObj: Pointer): HResult; stdcall;

   var

      nHandle: THandle;

      nImageList: HIMAGELIST;

      nSHGetImageList: _SHGetImageList;

      nFileInfo: TSHFileInfo;

   const

      IID_IImageList: TGUID = '{46EB5926-582E-4017-9FDF-E8998DAA0950}';

   begin

      Result := 0;

      nHandle := LoadLibrary('Shell32.dll');

      nImageList := 0;

      if nHandle <> S_OK then

      try

         nSHGetImageList := GetProcAddress(nHandle, PChar(727));

         if Assigned(nSHGetImageList) and _X then

            nSHGetImageList(ASHIL_FLAG, IID_IImageList, Pointer(nImageList));

         if nImageList > 0 then

         begin

            SHGetFileInfo(PChar(AFile), FILE_ATTRIBUTE_NORMAL, nFileInfo, SizeOf(TSHFileInfo), SHGFI_SYSICONINDEX);

            Result := ImageList_GetIcon(nImageList, nFileInfo.iIcon, ILD_NORMAL); //?????

         end;

      finally

         FreeLibrary(nHandle);

      end;

   end;

   function IcoToBmp(Icon: TIcon; ASHIL_FLAG: Cardinal): TBitmap;

   begin

      Result := TBitmap.Create;

      with Result do

      begin

         case ASHIL_FLAG of

            0:

               Width := 32;

            1:

               Width := 16;

            2:

               Width := 48;

            3:

               Width := 16;

            4:

               Width := 256;

         end;

         case ASHIL_FLAG of

            0:

               Height := 32;

            1:

               Height := 16;

            2:

               Height := 48;

            3:

               Height := 16;

            4:

               Height := 256;

         end;

         Canvas.Lock;

         Canvas.StretchDraw(Rect(0, 0, Width, Height), Icon);

         Canvas.Unlock;

      end;

   end;

   function BMPCenter(bmpSrc: TBitmap): TBitmap;

   begin

      Result := TBitMap.Create;

      Result.Width := AWidth;

      Result.Height := AHeight;

      Result.Canvas.Lock;

      Result.Canvas.Draw((AWidth - bmpSrc.Width) div 2, (AHeight - bmpSrc.Height) div 2, bmpSrc);

      Result.Canvas.Unlock;      

   end;

const

   SHIL_LARGE = 0; {32x32}

   SHIL_SMALL = 1; {16x16} //小图标

   SHIL_EXTRALARGE = 2; {48x48} //中图标

   SHIL_SYSSMALL = 3; {16x16}

   SHIL_JUMBO = 4; {256x256}

var

   ico: HIcon;

   ico2: TIcon;

   IconInfo: _ICONINFO;

   b: Boolean;

   i: Integer;

   bmp: TBitmap;

begin

   Result := nil;

   if (AWidth <= 16) or (AHeight <= 16) then

      i := SHIL_SMALL

   else if (AWidth <= 32) or (AHeight <= 32) then

      i := SHIL_LARGE

   else if (AWidth <= 48) or (AHeight <= 48) then

      i := SHIL_EXTRALARGE

   else if (AWidth < 256) or (AHeight < 256) then

      i := SHIL_EXTRALARGE

   else

      i := SHIL_EXTRALARGE; //SHIL_JUMBO; 256大图有些图标获取不到,暂时使用SHIL_EXTRALARGE吧

   try

      ico := GetFileIconEX(AFile, i);

      if ico = 0 then

         Exit;

      try

         b := GetIconInfo(ico, IconInfo);

         if b then

         begin

            ico2 := TIcon.Create;

            try

               ico2.Handle := CreateIconIndirect(IconInfo);

               bmp := IcoToBmp(ico2, i); 

               try

                  Result := BMPCenter(bmp);

               finally

                  FreeAndNil(bmp);

               end;

            finally

               FreeAndNil(ico2);

            end;

         end;

         DeleteObject(IconInfo.hbmMask); //网上的其它文章这里没有释放

         DeleteObject(IconInfo.hbmColor); //网上的其它文章这里没有释放

      finally

         DestroyIcon(ico); //网上的其它文章这里没有释放

      end;

   except

      on e: Exception do

      begin

      end;

   end;

end;

————————————————

原文链接：https://blog.csdn.net/lqena/article/details/105895509