Edit *.pif files programmatically

Problem/Question/Abstract:

Does anybody know how to create and/ or modify a *.pif programmatically? Windows creates *.pif files for all DOS programs but does not provide any method to edit it except manually. Is that right?

Answer:

procedure CreateShortcut(const FileName: string; Location: ShortcutType);
{Procedure to create a shortcut on the desktop or startmenu}
var
  MyObject: IUnknown;
  MySLink: IShellLink;
  MyPFile: IPersistFile;
  Directory: string;
  LinkName: string;
  IconName: string;
  DirName: string;
  pifName: WideString;
  WFileName: WideString;
  QuickLaunchReg: TRegIniFile;
  aPidl: PItemIDList;
  Res: HResult;
  Buf: PByteArray;
  PPif: pif_record_ref_type absolute Buf;
  Flag: boolean;
  i, j: integer;
  n: longint;
  PHeading: section_heading_record_ref_type;
  PVMMSection: windows_vmm_section_ref_type;
  PW386Section: ^windows_386_section_type;
  f: file;
begin
  MyObject := CreateComObject(CLSID_ShellLink);
  MySLink := MyObject as IShellLink;
  MyPFile := MyObject as IPersistFile;
  MySLink.SetPath(PChar(FileName));
  LinkName := ChangeFileExt(FileName, '.lnk');
  LinkName := ExtractFileName(LinkName);
  case Location of
    _DESKTOP:
      Res := SHGetSpecialFolderLocation(Application.Handle, CSIDL_DESKTOPDIRECTORY,
        aPidl);
    _STARTMENU:
      Res := SHGetSpecialFolderLocation(Application.Handle, CSIDL_STARTMENU, aPidl);
    _SENDTO:
      Res := SHGetSpecialFolderLocation(Application.Handle, CSIDL_SENDTO, aPidl);
    _QUICKLAUNCH:
      Res := 0;
  end;
  if Res <> NOERROR then
  begin
    case Location of
      _DESKTOP:
        Directory := 'ShellFolders->Desktop';
      _STARTMENU:
        Directory := 'ShellFolders->Start Menu';
      _SENDTO:
        Directory := 'ShellFolders->SendTo';
      _QUICKLAUNCH:
        Directory := 'MapGroups->Quick Launch';
    end;
    ShowMessage(Directory + ': Failed');
  end
  else
  begin
    {Get the actual path from the PItemIDList}
    SetLength(Directory, MAX_PATH);
    SHGetPathFromIDList(aPidl, PChar(Directory));
    SetLength(Directory, StrLen(PChar(Directory)));
    WFileName := Directory + '\' + LinkName;
    if (Location = _DESKTOP) and (LinkName = 'PAULITA.lnk') then
    begin
      pifName := ExtractFilePath(FileName);
      Res := MyPFile.Load(PWChar(pifName + 'SYS\PauLita.pif'), 0);
      if Res = E_OUTOFMEMORY then
        ShowMessage('.PIF LOAD: Out of Memory')
      else if Res = E_FAIL then
        ShowMessage('.PIF LOAD: Failed');
      IconName := pifName + 'SYS\PAULITA.ICO';
      Res := MySLink.SetIconLocation(PChar(IconName), 0);
      if Res <> NOERROR then
        ShowMessage('SetIconLocation: Failed');
    end;
    MySLink.SetPath(PChar(FileName));
    DirName := ExtractFilePath(FileName);
    DirName := Copy(DirName, 1, Length(DirName) - 1);
    MySLink.SetWorkingDirectory(PChar(DirName));
    Res := MyPFile.Save(PWChar(WFileName), FALSE);
    if Res <> S_OK then
      ShowMessage('Save ' + WFileName + ' Failed');
    if (Location = _DESKTOP) and (LinkName = 'PAULITA.lnk') then
    begin
      Buf := nil;
      Assign(f, Directory + '\PAULITA.PIF');
      try
        Reset(f, 1);
        n := FileSize(f);
        GetMem(Buf, n);
        BlockRead(f, Buf^, n);
        PW386Section := nil;
        Flag := FALSE;
        i := $187;
        while i + SizeOf(section_heading_record_type) <= n do
        begin
          PHeading := @Buf^[i];
          {ShowMessage(PHeading^.Name); }
          {Look for WINDOWS 386 3.0 group}
          if StrPas(@PHeading^.Name) = 'WINDOWS 386 3.0' then
          begin
            PW386Section := @Buf^[i + SizeOf(section_heading_record_type)];
          end;
          {Look for WINDOWS VMM 4.0 group}
          if StrPas(@PHeading^.Name) = 'WINDOWS VMM 4.0' then
          begin
            Flag := TRUE;
            Break;
          end;
          i := i + SizeOf(section_heading_record_type) + PHeading^.Len;
        end;
        if not Flag then
        begin
          ShowMessage('WINDOWS VMM 4.0 not Found in' + Directory + '\PAULITA.PIF');
        end
        else
        begin
          Flag := FALSE;
          if (PPif^.Flags1 and CLOSE_ON_EXIT) = $0000 then
          begin
            PPif^.Flags1 := PPif^.Flags1 or CLOSE_ON_EXIT;
            Flag := TRUE;
          end;
          j := Pos('PAULITA.EXE', PPif^.FileName);
          if j > 0 then
          begin
            StrPCopy(PPif^.FileName, Copy(StrPas(@PPif^.FileName), 1, j - 1) +
              'LITA.BAT'#0);
            Flag := TRUE;
          end;
          if PW386Section <> nil then
          begin
            if (PW386Section^.Flags1 and $00000008) = $0000 then
            begin
              {Used}
              PW386Section^.Flags1 := PW386Section^.Flags1or $00000008;
                {Full screen mode}
              Flag := TRUE;
            end;
            if (PW386Section^.MaxEMS <> $FFFF) or (PW386Section^.ReqEMS <> $0000) or
              (PW386Section^.MaxXMS <> $FFFF) or (PW386Section^.ReqXMS <> $0000) then
            begin
              PW386Section^.MaxEMS := $FFFF;
              PW386Section^.ReqEMS := $0000;
              PW386Section^.MaxXMS := $FFFF;
              PW386Section^.ReqXMS := $0000;
              Flag := TRUE;
            end;
          end;
          PVMMSection := @Buf^[i + SizeOf(section_heading_record_type)];
          if (PVMMSection^.Flags2 and FULL_SCREEN_MODE) = $0000 then
          begin
            {Not used}
            PVMMSection^.Flags2 := PVMMSection^.Flags2 or FULL_SCREEN_MODE;
            Flag := TRUE;
          end;
          if Flag then
          begin
            Seek(f, 0);
            BlockWrite(f, Buf^, n);
          end;
        end;
      finally
        Close(f);
        if Buf <> nil then
          FreeMem(Buf, n);
      end;
    end;
  end;
end;