From d2edd55f868dba8ac271e664ef7709682f83d207 Mon Sep 17 00:00:00 2001
From: marco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2>
Date: Fri, 11 Jun 2010 07:11:19 +0000
Subject:  * mass unblock CHM utility for win32/win64

git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@15406 3ad0048d-3df7-0310-abae-a5850022a9f2
---
 packages/chm/Makefile.fpc      |  4 +++
 packages/chm/src/unblockchm.pp | 65 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 69 insertions(+)
 create mode 100644 packages/chm/src/unblockchm.pp

(limited to 'packages/chm')

diff --git a/packages/chm/Makefile.fpc b/packages/chm/Makefile.fpc
index a623e04f9c..e33ec7393d 100644
--- a/packages/chm/Makefile.fpc
+++ b/packages/chm/Makefile.fpc
@@ -11,6 +11,8 @@ units=fasthtmlparser htmlutil paslzx paslzxcomp paslznonslide chmbase chmtypes \
       chmspecialfiles chmsitemap chmwriter chmfilewriter chmreader htmlindexer \
       chmfiftimain lzxcompressthread
 programs=chmcmd chmls
+programs_win32=unblockchm
+programs_win64=unblockchm
 examples=
 
 [require]
@@ -32,3 +34,5 @@ sourcedir=src tests
 cdmcmd$(EXEEXT): chmcmd.lpr
 
 chmls$(EXEEXT): chmls.lpr
+
+unblockchm$(EXEEXT): unblockchm.pp
\ No newline at end of file
diff --git a/packages/chm/src/unblockchm.pp b/packages/chm/src/unblockchm.pp
new file mode 100644
index 0000000000..cbb3b4d2d8
--- /dev/null
+++ b/packages/chm/src/unblockchm.pp
@@ -0,0 +1,65 @@
+program unblockchm;
+
+// Marco van de Voort
+// BSD license 
+// Quick and dirty scritp to unblocks CHMs on xpsp2/vista/w7
+//
+// todo : populatefiles needs fix for when filespec contains a directory.
+//
+// based on http://stackoverflow.com/questions/1617509/unblock-a-file-with-powershell
+
+{$mode delphi}
+uses sysutils,classes;
+
+procedure usage;
+
+begin
+  writeln('unblockchm. Unblocks chms in XPsp2,vista,w7  (C) 2010 Marco van de Voort');
+  writeln;
+  Writeln('usage: unblockchm <filespec> <filespec2> ..');
+  writeln;
+  writeln('<filespec> may contain basic wildcards.');
+  writeln;
+end;
+
+procedure unblockchm(s:string);
+var f : file;
+begin
+ writeln('unblocking ',s);
+ assignfile(f,s+':Zone.Identifier');
+ rewrite(f,1);
+ truncate(f);
+ closefile(f);
+end;
+
+procedure populatefiles(files:TStringlist;filespec:string);
+var
+  searchResult : TSearchRec;
+begin
+ if FindFirst(filespec, faAnyFile, searchResult) = 0 then
+  begin
+    repeat
+      files.add(searchresult.name);
+    until FindNext(searchResult) <> 0;
+    // Must free up resources used by these successful finds
+    FindClose(searchResult);
+  end;
+end;
+
+var files : TStringList;
+    i : Integer;
+
+begin
+ if paramcount=0 then
+   begin
+     Usage;
+     halt;
+   end;
+ files :=TStringList.create;
+ for i:=1 to paramcount do
+  populatefiles(files,paramstr(i));
+ if files.count>0 then
+   for i:=0 to files.count-1 do
+     unblockchm(files[i]);
+end.
+
-- 
cgit v1.2.1