1 PROGRAM LinkLib; 2 3 uses exec, triton, tritonmacros, linklist, 4 amigautils,strings, easyasl, utility; 5 6 { 7 A demo in FPC Pascal using triton.library 8 9 Updated for fpc 1.0.7 10 09 Jan 2003. 11 12 nils.sjoholm@mailbox.swipnet.se 13 } 14 15 16 17 VAR 18 Project : pTR_Project; 19 mylist : pList; 20 llist : pList; 21 pdummy : ARRAY [0..108] OF Char; 22 path : PChar; 23 Triton_App : pTR_App; 24 25 const 26 27 LibListGadID = 1; 28 AddGadID = 2; 29 RemoveGadID = 3; 30 RemAllGadID = 4; 31 UpGadID = 5; 32 DownGadID = 6; 33 OkButton = 7; 34 CancelButton = 8; 35 36 37 PROCEDURE CleanExit(errstring : STRING; rc : Longint); 38 BEGIN 39 IF assigned(Project) THEN TR_CloseProject(Project); 40 IF Assigned(mylist) THEN DestroyList(mylist); 41 IF Assigned(llist) THEN DestroyList(llist); 42 IF errstring <> '' THEN WriteLn(errstring); 43 Halt(rc) 44 END; 45 46 PROCEDURE disablegads; 47 VAR 48 dummy : Longint; 49 BEGIN 50 IF NodesInList(mylist) > 0 THEN dummy := 0 51 ELSE dummy := 1; 52 53 TR_SetAttribute(Project,RemoveGadID,TRAT_Disabled,dummy); 54 TR_SetAttribute(Project,RemAllGadID,TRAT_Disabled,dummy); 55 TR_SetAttribute(Project,UpGadID,TRAT_Disabled,dummy); 56 TR_SetAttribute(Project,DownGadID,TRAT_Disabled,dummy); 57 END; 58 59 PROCEDURE readinlist; 60 VAR 61 dummy : BOOLEAN; 62 temp : pFPCNode; 63 BEGIN 64 dummy := FileToList('ram:fpclistoffiles',mylist); 65 IF dummy THEN BEGIN 66 temp := GetFirstNode(mylist); 67 IF temp <> NIL THEN StrCopy(path,PathOf(GetNodeData(temp))); 68 temp := GetLastNode(mylist); 69 IF StrLen(GetNodeData(temp)) = 0 THEN RemoveLastNode(mylist); 70 END; 71 END; 72 73 PROCEDURE addfiles; 74 75 VAR 76 dummy : BOOLEAN; 77 mynode,tempnode : pFPCNode; 78 temp : Longint; 79 80 BEGIN 81 dummy := GetMultiAsl('Pick a file or two :)',path,llist,NIL,NIL); 82 IF dummy THEN BEGIN 83 mynode := GetFirstNode(llist); 84 FOR temp := 1 TO NodesInList(llist) DO BEGIN 85 tempnode := AddNewNode(mylist,(PathAndFile(path,GetNodeData(mynode)))); 86 mynode := GetNextNode(mynode); 87 END; 88 TR_UpdateListView(Project,LibListGadID,mylist); 89 TR_SetValue(Project,LibListGadID,0); 90 disablegads; 91 ClearList(llist); 92 END; 93 END; 94 95 PROCEDURE removelib; 96 VAR 97 num : Longint; 98 mynode : pFPCNode; 99 strbuf : ARRAY [0..255] OF Char; 100 buffer : PChar; 101 dummy : Longint; 102 BEGIN 103 buffer := @strbuf; 104 num := TR_GetValue(Project,LibListGadID); 105 mynode := GetNodeNumber(mylist,num); 106 107 dummy := TR_EasyRequestTags(Triton_App,'Sure you want to delete'+#10+ 108 strpas(GetNodeData(mynode)),'_Remove|_Cancel',[ 109 TREZ_LockProject, AsTag(Project), 110 TREZ_Title, AsTag('Delete this file?'), 111 TREZ_Activate,1, 112 TAG_END]); 113 IF dummy = 1 THEN BEGIN 114 DeleteNode(mynode); 115 TR_UpdateListView(Project,LibListGadID,mylist); 116 TR_SetValue(Project,LibListGadID,0); 117 disablegads; 118 END; 119 END; 120 121 PROCEDURE removeall; 122 VAR 123 dummy : Longint; 124 BEGIN 125 dummy := TR_EasyRequestTags(Triton_App,'Sure you want to remove all files?', 126 '_Remove|_Cancel',[ 127 TREZ_LockProject, AsTag(Project), 128 TREZ_Title, AsTag('Delete all?'), 129 TREZ_Activate,1, 130 TAG_END]); 131 IF dummy = 1 THEN BEGIN 132 ClearList(mylist); 133 TR_UpdateListView(Project,LibListGadID,mylist); 134 disablegads; 135 END; 136 END; 137 138 PROCEDURE savethelist; 139 VAR 140 dummy : BOOLEAN; 141 BEGIN 142 dummy := ListToFile('Ram:fpclistoffiles',mylist); 143 END; 144 145 PROCEDURE movedown; 146 VAR 147 num : INTEGER; 148 mynode : pFPCNode; 149 BEGIN 150 num := TR_GetValue(project,LibListGadID); 151 IF num < (NodesInList(mylist)-1) THEN BEGIN 152 mynode := GetNodeNumber(mylist,num); 153 IF mynode <> NIL THEN BEGIN 154 MoveNodeDown(mylist,mynode); 155 TR_UpdateListView(Project,LibListGadID,mylist); 156 TR_SetValue(Project,LibListGadID,num + 1); 157 END; 158 END; 159 END; 160 161 PROCEDURE moveup; 162 VAR 163 num : Longint; 164 mynode : pFPCNode; 165 BEGIN 166 num := TR_GetValue(project,LibListGadID); 167 IF num > 0 THEN BEGIN 168 mynode := GetNodeNumber(mylist,num); 169 IF mynode <> NIL THEN BEGIN 170 MoveNodeUp(mylist,mynode); 171 TR_UpdateListView(Project,LibListGadID,mylist); 172 TR_SetValue(Project,LibListGadID,num-1); 173 END; 174 END; 175 END; 176 177 PROCEDURE do_demo; 178 VAR 179 close_me : BOOLEAN; 180 trmsg : pTR_Message; 181 dummy : Longint; 182 183 BEGIN 184 ProjectStart; 185 WindowID(1); 186 WindowPosition(TRWP_CENTERDISPLAY); 187 WindowTitle('TritonListViewDemo in FPC Pascal'); 188 HorizGroupAC; 189 Space; 190 VertGroupAC; 191 Space; 192 NamedSeparator('List of files'); 193 Space; 194 ListSSM(mylist,LibListGadID,0,0,25); 195 Space; 196 EndGroup; 197 Space; 198 VertSeparator; 199 Space; 200 SetTRTag(TRGR_Vert, TRGR_ALIGN OR TRGR_FIXHORIZ); 201 Space; 202 Button('_Add...',AddGadID); 203 SpaceS; 204 Button('_Remove...',RemoveGadID); 205 SpaceS; 206 Button('Re_move All...',RemAllGadID); 207 SpaceS; 208 Button('_Up',UpGadID); 209 SpaceS; 210 Button('_Down',DownGadID); 211 VertGroupS;Space;EndGroup; 212 Button('_Ok',OkButton); 213 SpaceS; 214 Button('_Cancel',CancelButton); 215 Space; 216 EndGroup; 217 Space; 218 EndGroup; 219 EndProject; 220 221 Project := TR_OpenProject(Triton_App,@tritontags); 222 IF Project <> NIL THEN BEGIN 223 disablegads; 224 close_me := FALSE; 225 WHILE NOT close_me DO BEGIN 226 dummy := TR_Wait(Triton_App,0); 227 REPEAT 228 trmsg := TR_GetMsg(Triton_App); 229 IF trmsg <> NIL THEN BEGIN 230 IF (trmsg^.trm_Project = Project) THEN BEGIN 231 CASE trmsg^.trm_Class OF 232 TRMS_CLOSEWINDOW : close_me := True; 233 TRMS_ERROR: WriteLN(TR_GetErrorString(trmsg^.trm_Data)); 234 TRMS_ACTION : 235 BEGIN 236 CASE trmsg^.trm_ID OF 237 AddGadID : addfiles; 238 UpGadID : moveup; 239 DownGadID : movedown; 240 RemoveGadID : removelib; 241 RemAllGadID : removeall; 242 OkButton : BEGIN savethelist; close_me := True; END; 243 CancelButton : close_me := True; 244 END; 245 END; 246 ELSE 247 END; 248 END; 249 TR_ReplyMsg(trmsg); 250 END 251 UNTIL close_me OR (trmsg = NIL); 252 END; 253 END ELSE WriteLN(TR_GetErrorString(TR_GetLastError(Triton_App))); 254 END; 255 256 257 BEGIN { Main } 258 if not Assigned(TritonBase) then 259 begin 260 writeln('cannot open ' + TRITONNAME); 261 Halt(5); 262 end; 263 Triton_App := TR_CreateAppTags([ 264 TRCA_Name, AsTag('Triton ListView Demo'), 265 TRCA_LongName, AsTag('Demo of ListView in Triton, made in FPC Pascal'), 266 TRCA_Version, AsTag('0.01'), 267 TRCA_Info, AsTag('Uses tritonsupport'), 268 TRCA_Release, AsTag('11'), 269 TRCA_Date, AsTag('03-02-1998'), 270 TAG_END]); 271 if Triton_App <> nil then begin 272 path := @pdummy; 273 StrpCopy(path,'sys:'); 274 CreateList(mylist); 275 CreateList(llist); 276 readinlist; 277 do_demo; 278 CleanExit('',0); 279 END 280 ELSE CleanExit('Can''t create application',20); 281 END. 282