Author: Jonas Bilinkevicius
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:
1
2 procedure CreateShortcut(const FileName: string; Location: ShortcutType);
3 {Procedure to create a shortcut on the desktop or startmenu}
4 var
5 MyObject: IUnknown;
6 MySLink: IShellLink;
7 MyPFile: IPersistFile;
8 Directory: string;
9 LinkName: string;
10 IconName: string;
11 DirName: string;
12 pifName: WideString;
13 WFileName: WideString;
14 QuickLaunchReg: TRegIniFile;
15 aPidl: PItemIDList;
16 Res: HResult;
17 Buf: PByteArray;
18 PPif: pif_record_ref_type absolute Buf;
19 Flag: boolean;
20 i, j: integer;
21 n: longint;
22 PHeading: section_heading_record_ref_type;
23 PVMMSection: windows_vmm_section_ref_type;
24 PW386Section: ^windows_386_section_type;
25 f: file;
26 begin
27 MyObject := CreateComObject(CLSID_ShellLink);
28 MySLink := MyObject as IShellLink;
29 MyPFile := MyObject as IPersistFile;
30 MySLink.SetPath(PChar(FileName));
31 LinkName := ChangeFileExt(FileName, '.lnk');
32 LinkName := ExtractFileName(LinkName);
33 case Location of
34 _DESKTOP:
35 Res := SHGetSpecialFolderLocation(Application.Handle, CSIDL_DESKTOPDIRECTORY,
36 aPidl);
37 _STARTMENU:
38 Res := SHGetSpecialFolderLocation(Application.Handle, CSIDL_STARTMENU, aPidl);
39 _SENDTO:
40 Res := SHGetSpecialFolderLocation(Application.Handle, CSIDL_SENDTO, aPidl);
41 _QUICKLAUNCH:
42 Res := 0;
43 end;
44 if Res <> NOERROR then
45 begin
46 case Location of
47 _DESKTOP:
48 Directory := 'ShellFolders->Desktop';
49 _STARTMENU:
50 Directory := 'ShellFolders->Start Menu';
51 _SENDTO:
52 Directory := 'ShellFolders->SendTo';
53 _QUICKLAUNCH:
54 Directory := 'MapGroups->Quick Launch';
55 end;
56 ShowMessage(Directory + ': Failed');
57 end
58 else
59 begin
60 {Get the actual path from the PItemIDList}
61 SetLength(Directory, MAX_PATH);
62 SHGetPathFromIDList(aPidl, PChar(Directory));
63 SetLength(Directory, StrLen(PChar(Directory)));
64 WFileName := Directory + '\' + LinkName;
65 if (Location = _DESKTOP) and (LinkName = 'PAULITA.lnk') then
66 begin
67 pifName := ExtractFilePath(FileName);
68 Res := MyPFile.Load(PWChar(pifName + 'SYS\PauLita.pif'), 0);
69 if Res = E_OUTOFMEMORY then
70 ShowMessage('.PIF LOAD: Out of Memory')
71 else if Res = E_FAIL then
72 ShowMessage('.PIF LOAD: Failed');
73 IconName := pifName + 'SYS\PAULITA.ICO';
74 Res := MySLink.SetIconLocation(PChar(IconName), 0);
75 if Res <> NOERROR then
76 ShowMessage('SetIconLocation: Failed');
77 end;
78 MySLink.SetPath(PChar(FileName));
79 DirName := ExtractFilePath(FileName);
80 DirName := Copy(DirName, 1, Length(DirName) - 1);
81 MySLink.SetWorkingDirectory(PChar(DirName));
82 Res := MyPFile.Save(PWChar(WFileName), FALSE);
83 if Res <> S_OK then
84 ShowMessage('Save ' + WFileName + ' Failed');
85 if (Location = _DESKTOP) and (LinkName = 'PAULITA.lnk') then
86 begin
87 Buf := nil;
88 Assign(f, Directory + '\PAULITA.PIF');
89 try
90 Reset(f, 1);
91 n := FileSize(f);
92 GetMem(Buf, n);
93 BlockRead(f, Buf^, n);
94 PW386Section := nil;
95 Flag := FALSE;
96 i := $187;
97 while i + SizeOf(section_heading_record_type) <= n do
98 begin
99 PHeading := @Buf^[i];
100 {ShowMessage(PHeading^.Name); }
101 {Look for WINDOWS 386 3.0 group}
102 if StrPas(@PHeading^.Name) = 'WINDOWS 386 3.0' then
103 begin
104 PW386Section := @Buf^[i + SizeOf(section_heading_record_type)];
105 end;
106 {Look for WINDOWS VMM 4.0 group}
107 if StrPas(@PHeading^.Name) = 'WINDOWS VMM 4.0' then
108 begin
109 Flag := TRUE;
110 Break;
111 end;
112 i := i + SizeOf(section_heading_record_type) + PHeading^.Len;
113 end;
114 if not Flag then
115 begin
116 ShowMessage('WINDOWS VMM 4.0 not Found in' + Directory + '\PAULITA.PIF');
117 end
118 else
119 begin
120 Flag := FALSE;
121 if (PPif^.Flags1 and CLOSE_ON_EXIT) = $0000 then
122 begin
123 PPif^.Flags1 := PPif^.Flags1 or CLOSE_ON_EXIT;
124 Flag := TRUE;
125 end;
126 j := Pos('PAULITA.EXE', PPif^.FileName);
127 if j > 0 then
128 begin
129 StrPCopy(PPif^.FileName, Copy(StrPas(@PPif^.FileName), 1, j - 1) +
130 'LITA.BAT'#0);
131 Flag := TRUE;
132 end;
133 if PW386Section <> nil then
134 begin
135 if (PW386Section^.Flags1 and $00000008) = $0000 then
136 begin
137 {Used}
138 PW386Section^.Flags1 := PW386Section^.Flags1or $00000008;
139 {Full screen mode}
140 Flag := TRUE;
141 end;
142 if (PW386Section^.MaxEMS <> $FFFF) or (PW386Section^.ReqEMS <> $0000) or
143 (PW386Section^.MaxXMS <> $FFFF) or (PW386Section^.ReqXMS <> $0000)
144 then
145 begin
146 PW386Section^.MaxEMS := $FFFF;
147 PW386Section^.ReqEMS := $0000;
148 PW386Section^.MaxXMS := $FFFF;
149 PW386Section^.ReqXMS := $0000;
150 Flag := TRUE;
151 end;
152 end;
153 PVMMSection := @Buf^[i + SizeOf(section_heading_record_type)];
154 if (PVMMSection^.Flags2 and FULL_SCREEN_MODE) = $0000 then
155 begin
156 {Not used}
157 PVMMSection^.Flags2 := PVMMSection^.Flags2 or FULL_SCREEN_MODE;
158 Flag := TRUE;
159 end;
160 if Flag then
161 begin
162 Seek(f, 0);
163 BlockWrite(f, Buf^, n);
164 end;
165 end;
166 finally
167 Close(f);
168 if Buf <> nil then
169 FreeMem(Buf, n);
170 end;
171 end;
172 end;
173 end;
|
