Edit *.pif files programmatically (Views: 28)
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; |