Bu unit program internet işleminde kullanılır.
Kod: Tümünü seç
Unit Ads_IntNet;
{Copyright(c)2000 Advanced Delphi Systems
Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
maley@advdelphisys.com
The code herein can be used or modified by anyone. Please retain references
to Richard Maley at Advanced Delphi Systems. If you make improvements to the
code please send your improvements to maley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
}
Interface
Uses
SysUtils, ExtCtrls, Classes, NMHttp, Buttons, Forms, StdCtrls, Ads_Strg,
WinProcs, WinTypes, Wininet, Dialogs, Ads_Date, Ads_File, FileCtrl,
Ads_Misc;
{!~ Copies an internet URL to a file. Returns True
if successful, False otherwise. The source URL can
be a remote http address or it can be a local file.}
Function InternetCopyURLToFile(
SourceURL : String;
DestFile : String;
ShowMessages : Boolean;
StatusPanel : TPanel
): Boolean;
{!~ Returns the Base URL of a URL address. The source
URL can be a remote http address or it can be a local
file.}
Function InternetGetBaseURL(URL : String): String;
{!~ Tests for the existence of a URL. True is returned
if the URL exists and False otherwise. The source URL
can be a remote http address or it can be a local file.}
Function InternetIsUrl(URL : String): Boolean;
{!~
INTERNET_GETURLSFROMCACHEPAGES
The purpose of this procedure is to extract URL information from
web pages stored in the Temporary Internet Files Directory.
The URL's gathered by this procedure are stored in a new HTML page given
by the OutputFile argument.
This procedure needs a working directory designated
by the WorkingDirectoryName argument. This working directory should
be for the exclusive use of this procedure because all files in the
directory are deleted at the beginning of the process.
The location of the Temporary Internet Files Directory is provided by
the TemporaryInternetDirectory argument.
A number of boolean options are provided in this procedure:
SortByLabels : Sort the Results by the <a Tag Labels.
EliminateDuplicates : Eliminate duplicates.
DiscardRelativePaths : Discard URL's with relative paths.
EmptyCacheWhenDone : Empty the Internet Cache when the process
is completed.
Some URL's can be discarded from the results by identifying a
string that would trigger the disposal of the URL. There is no limit
how many of these string triggers can be used. To pass these triggers
to the procedure use a TStringList with one trigger per line. The
TStringList should be passed to the EliminateURLsContaining argument.
Example:
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
Internet_GetURLsFromCachePages(
Edit1.Text, //TemporaryInternetDirectory : String;
GlobalExecutablePath+Edit2.Text, //WorkingDirectoryName : String;
Edit3.Text, //OutputFile : String;
CheckBox1.Checked, //SortByLabels : Boolean;
CheckBox2.Checked, //EliminateDuplicates : Boolean;
CheckBox3.Checked, //DiscardRelativePaths : Boolean;
CheckBox4.Checked, //EmptyCacheWhenDone : Boolean;
Memo1.Lines); //EliminateURLsContaining : TStrings);
end;
}
procedure Internet_GetURLsFromCachePages(
TemporaryInternetDirectory : String;
WorkingDirectoryName : String;
OutputFile : String;
SortByLabels : Boolean;
EliminateDuplicates : Boolean;
DiscardRelativePaths : Boolean;
EmptyCacheWhenDone : Boolean;
EliminateURLsContaining : TStrings);
{!~
NMHTTP_GETURLTOFILE
This utility assumes you have the NetMasters FastNet
internet components. The FastNet components can be purchased
from NetMasters at http://www.netmastersllc.com.
This utility copies a URL to file.
}
Function NMHttp_GetURLToFile(
NMHttp : TNMHttp;
SourceURL : String;
DestFile : String;
Button_Stop : TSpeedButton
): Boolean;
{!~
NMHTTP_ISURL
This utility assumes you have the NetMasters FastNet
internet components. The FastNet components can be purchased
from NetMasters at http://www.netmastersllc.com.
This utility tests the existance of a URL. If the URL exists
True is returned, otherwise False.
}
Function NMHttp_IsUrl(NMHttp: TNMHttp; URLString: String): Boolean;
{!~
NMHttp_PostURLToFile
This utility assumes you have the NetMasters FastNet
internet components. The FastNet components can be purchased
from NetMasters at http://www.netmastersllc.com.
This utility copies a URL to file using http post.
}
Function NMHttp_PostURLToFile(
NMHttp : TNMHttp;
SourceURL : String;
Parameters : String;
DestFile : String;
Button_Stop : TSpeedButton
): Boolean;
{!~ Purges files from the internet cache}
Procedure PurgeInternetCache(
MainForm : TForm;
WinDir : String;
IntTempDir : String);
Implementation
Type
TPanel_Cmp_Sec_ads = class(TPanel)
Public
procedure ResizeShadowLabel(Sender: TObject);
End;
procedure TPanel_Cmp_Sec_ads.ResizeShadowLabel(
Sender : TObject);
Var
PH, PW : Integer;
LH, LW : Integer;
begin
PH := TPanel(Sender).Height;
PW := TPanel(Sender).Width;
LH := TLabel(Controls[0]).Height;
LW := TLabel(Controls[0]).Width;
TLabel(Controls[0]).Top := ((PH-LH) div 2)-3;
TLabel(Controls[0]).Left := ((Pw-Lw) div 2)-3;
end;
Type
TEditKeyFilter = Class(TEdit)
Published
{!~ Throws away all keys except 0-9,-,+,.}
Procedure OnlyNumbers(Sender: TObject; var Key: Char);
{!~ Throws away all keys except 0-9}
Procedure OnlyNumbersAbsolute(Sender: TObject; var Key: Char);
{!~ Throws away all keys except a-z and A-Z}
Procedure OnlyAToZ(Sender: TObject; var Key: Char);
End;
{!~ Throws away all keys except 0-9,-,+,.}
Procedure TEditKeyFilter.OnlyNumbers(Sender: TObject; var Key: Char);
Begin
KeyPressOnlyNumbers(Key);
End;
{!~ Throws away all keys except 0-9}
Procedure TEditKeyFilter.OnlyNumbersAbsolute(Sender: TObject; var Key: Char);
Begin
KeyPressOnlyNumbersAbsolute(Key);
End;
{!~ Throws away all keys except a-z and A-Z}
Procedure TEditKeyFilter.OnlyAToZ(Sender: TObject; var Key: Char);
Begin
KeyPressOnlyAToZ(Key);
End;
Function NMHttp_URLToFileDetail(
NMHttp : TNMHttp;
SourceURL : String;
Parameters : String;
DestFile : String;
Button_Stop : TSpeedButton
): Boolean;
Var
BodyFile_SL : TStringList;
BodyFile : String;
begin
Try
Button_Stop.Enabled := True;
BodyFile := DestFile;
NMHttp.InputFileMode := False;
NMHttp.OutputFileMode := False;
NMHttp.Header := 'Header.Txt';
NMHttp.Body := BodyFile;
NMHttp.ReportLevel := 2;
With NMHttp.HeaderInfo do
Begin
Cookie := '';
LocalMailAddress := '';
LocalProgram := '';
Referer := '';
UserID := '';
Password := '';
End;
If (Parameters = '') Then
Begin
NMHttp.Get(SourceURL);
End
Else
Begin
NMHttp.Post(SourceURL,Parameters);
End;
BodyFile_SL := TStringList.Create();
Try
BodyFile_SL.Clear;
BodyFile_SL.Add(NMHttp.Body);
BodyFile_SL.SaveToFile(BodyFile);
Finally
BodyFile_SL.Free;
End;
Result := True;
Except
Result := False;
End;
Button_Stop.Enabled := False;
end;
{!~ Copies an internet URL to a file. Returns True
if successful, False otherwise. The source URL can
be a remote http address or it can be a local file.}
Function InternetCopyURLToFile(
SourceURL : String;
DestFile : String;
ShowMessages : Boolean;
StatusPanel : TPanel
): Boolean;
const MAX_PATH = 600;
var
hStdOut : THandle;
OutDir : String;
OutFile : String;
{ Msg : String;}{zzz}
// Start Embedded Functions in CopyURL
Function InternetLoadRate(
StartTime : TDateTime;
iBytes : integer
): integer;
Var
iStartSecond : integer;
iSeconds : integer;
Hour : word;
Min : word;
Sec : word;
MSec : word;
Begin
DecodeTime( StartTime, Hour, Min, Sec, MSec );
iStartSecond := Sec + Min * 60 + Hour * 360;
DecodeTime( Now, Hour, Min, Sec, MSec );
iSeconds := ( Sec + Min * 60 + Hour * 360 ) - iStartSecond;
If ( Trunc( Now - StartTime ) > 0 ) Then
Begin
iSeconds := iSeconds + Trunc( Now - StartTime ) * 24 * 60 * 60;
End;
If ( iSeconds > 0 ) Then
Begin
Result := iBytes div iSeconds;
End
Else
Begin
Result := 0;
End;
end;
Function InternetGetFile(
Source_Handle : HINTERNET;
DestFile_Handle : THandle;
ShowMessages : Boolean;
StatusPanel : TPanel
): Boolean;
const FILE_SMALL_BUFFER = 4096;
const RETRY_READ = 10;
Var
iRetry : integer;
bOk : bool;
StartTime : TDateTime;
EndTime : TDateTime;
iWriteFileTotal : integer;
iWriteFileCount : integer;
iReadFileCount : integer;
SmallBuffer : array [ 1..FILE_SMALL_BUFFER ] of char;
Msg : String;
Begin
Result := False;
Try
iWriteFileTotal := 0;
StartTime := Now;
Repeat
Begin
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption :=
IntToStr(iWriteFileTotal)+
' bytes transferred ... (' +
IntToStr(InternetLoadRate( StartTime, iWriteFileTotal ))+
' bytes/sec)';
StatusPanel.Refresh;
End;
iRetry := 0;
Repeat
Begin
iReadFileCount := 0;
bOk :=
InternetReadFile(
Source_Handle,
@SmallBuffer,
FILE_SMALL_BUFFER,
Cardinal(iReadFileCount));
Inc( iRetry );
End;
Until ((iReadFileCount <> 0) or (bOk) or (iRetry = RETRY_READ));
If (iReadFileCount > 0) Then
Begin
iWriteFileCount := 0;
bOk :=
WriteFile(
DestFile_Handle,
SmallBuffer,
iReadFileCount,
Cardinal(iWriteFileCount),
nil);
bOk := (bOk) and (iReadFileCount = iWriteFileCount);
If (bOk) Then
Begin
iWriteFileTotal := iWriteFileTotal + iWriteFileCount;
End
Else
Begin
iReadFileCount := 0;
Msg := 'Error writing to the output file.';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
If ShowMessages Then
Begin
ShowMessage(Msg);
End;
Exit;
End;
End
Else
Begin
If (not bOk) Then
Begin
Msg := 'Error reading the data.';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
If ShowMessages Then ShowMessage(Msg);
Exit;
End;
End;
End;
Until (iReadFileCount = 0);
EndTime := now();
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption :=
'('+
FormatFloat(
'###,###,##0',
TimeDeltaInSeconds(
StartTime,
EndTime))+
' seconds)';
StatusPanel.Refresh;
End;
Result := True;
Except
Result := False;
End;
end;
Function InternetFetchFile(
hSession : HINTERNET;
SourceURL : string;
DestFile : string;
hStdOut : THandle;
ShowMessages : Boolean;
RevealDest : Boolean;
StatusPanel : TPanel
): Boolean;
Var
Source_Handle : HINTERNET;
DestFile_Handle : THandle;
Msg : String;
Begin
Result := False;
Try
Msg := 'Opening "'+SourceURL+'"';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
Source_Handle :=
InternetOpenUrl(
hSession,
PChar(SourceURL),
nil,
Cardinal(-1),
INTERNET_FLAG_DONT_CACHE or
INTERNET_FLAG_RAW_DATA,
0);
If (Source_Handle <> nil) Then
Begin
If (DestFile = '') Then
Begin
DestFile_Handle := hStdOut;
If RevealDest Then
Begin
Msg := 'Output directed to default';
End
Else
Begin
Msg := 'Output initiated';
End;
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
End
Else
Begin
If RevealDest Then
Begin
Msg := 'Creating "'+DestFile+'"';
End
Else
Begin
Msg := 'Output initiated';
End;
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
DestFile_Handle :=
CreateFile(
PChar(DestFile),
GENERIC_WRITE,
FILE_SHARE_READ,
nil,
CREATE_NEW,
FILE_FLAG_WRITE_THROUGH or
FILE_FLAG_SEQUENTIAL_SCAN,
0 );
End;
If (DestFile_Handle <> INVALID_HANDLE_VALUE ) Then
Begin
Msg := 'Starting Download';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
InternetGetFile(
Source_Handle,
DestFile_Handle,
ShowMessages,
StatusPanel);
If (DestFile_Handle <> hStdOut ) Then
Begin
CloseHandle(DestFile_Handle);
End;
End
Else
Begin
Msg := 'Output Failed!!! Closing "'+SourceURL+'"';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
If ShowMessages Then
Begin
ShowMessage(Msg);
End;
InternetCloseHandle(Source_Handle);
Exit;
End;
End
Else
Begin
Msg := 'URL could not be opened';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
If ShowMessages Then
Begin
ShowMessage(Msg);
End;
Exit;
End;
Result := True;
Except
Result := False;
End;
End;
Function InternetCreateSession(
SourceUrl : string;
DestFile : string;
sCaller : string;
hStdOut : THandle;
ShowMessages : Boolean;
StatusPanel : TPanel
): Boolean;
Var
hSession : HINTERNET;
Msg : String;
Begin
Result := False;
Try
Msg := 'Opening Internet Session "'+ sCaller+'"';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
hSession :=
InternetOpen(
PChar(sCaller),
LOCAL_INTERNET_ACCESS,
nil,
PChar(INTERNET_INVALID_PORT_NUMBER),
INTERNET_FLAG_DONT_CACHE );
If (hSession <> nil) Then
Begin
Msg := 'Done "'+ sCaller+'" ';
If InternetFetchFile(
hSession,
SourceURL,
DestFile,
hStdOut,
ShowMessages,
False,
StatusPanel) Then
Begin
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg + StatusPanel.Caption;
StatusPanel.Refresh;
End;
InternetCloseHandle( hSession );
End
Else
Begin
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg + StatusPanel.Caption;
StatusPanel.Refresh;
End;
InternetCloseHandle( hSession );
Exit;
End;
End
Else
Begin
Msg := 'Internet session not opened. Process Aborted!';
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := Msg;
StatusPanel.Refresh;
End;
If ShowMessages Then
Begin
ShowMessage(Msg);
End;
Exit;
End;
Result := True;
Except
Result := False;
End;
End;
// End Embedded Functions in CopyURL
Begin
Result := False;
Try
{Check the input parameters}
If SourceUrl = '' Then
Begin
If ShowMessages Then
Begin
ShowMessage('No Source URL was provided. Process Aborted!');
End;
Exit;
End;
If DestFile = '' Then
Begin
If ShowMessages Then
Begin
ShowMessage('No Destination File was provided. Process Aborted!');
End;
Exit;
End;
If (Length(SourceUrl) > INTERNET_MAX_URL_LENGTH ) Then
Begin
If ShowMessages Then
Begin
ShowMessage(
'URL is longer than '+
IntToStr(INTERNET_MAX_URL_LENGTH)+
'. Process Aborted!');
End;
Exit;
End;
If FileExists(OutFile) Then SysUtils.DeleteFile(OutFile);
OutDir := FilePath(DestFile);
OutFile:= ExtractFileName(DestFile);
If Not DirectoryExists(OutDir) Then
Begin
If ShowMessages Then
Begin
ShowMessage('Output Path = '+OutDir);
ShowMessage('The Output directory does not exist. Process Aborted!');
End;
Exit;
End;
If Length(DestFile) > 255 Then
Begin
If ShowMessages Then
Begin
ShowMessage('The Output File and Path are too long. Process Aborted!');
End;
Exit;
End;
hStdOut := GetStdHandle( STD_OUTPUT_HANDLE );
Result := InternetCreateSession(
SourceURL,
DestFile,
SourceURL,
hStdOut,
ShowMessages,
StatusPanel);
If Not Result Then
Begin
If (StatusPanel <> nil) Then
Begin
StatusPanel.Caption := '';
StatusPanel.Refresh;
End;
End;
Except
Result := False;
End;
End;
{!~ Returns the Base URL of a URL address. The source
URL can be a remote http address or it can be a local
file.}
Function InternetGetBaseURL(URL : String): String;
Var
URLString : ShortString;
{StringToPeriod : ShortString;}{zzz}
i{,L}{zzz} : Integer;
PeriodPos : Integer;
C : Char;
ShouldBreak : Boolean;
ParseMin : Integer;
Begin
Result := '';
If Not InternetIsUrl(URL) Then Exit;
If FileExists(URL) Then
Begin
Result := FilePath(URL);
Exit;
End;
If Length(URL) > 255 Then
Begin
Result := URL;
Exit;
End;
If SubStr(URL,Length(URL),1) = '/' Then
Begin
Result := URL;
Exit
End;
URLString := ShortString(URL);
PeriodPos := Pos('.',SubStr(URLString,Length(URLString)-6,7));
{L := Length(URLString);}{zzz}
ParseMin := 8;
If UpperCase(SubStr(URL,1,7)) = 'HTTP://' Then ParseMin := 8;
If UpperCase(SubStr(URL,1,6)) = 'FTP://' Then ParseMin := 7;
If PeriodPos > 0 Then
Begin
For i := (Length(URLString)-6 + PeriodPos - 2) DownTo ParseMin Do
Begin
ShouldBreak := False;
C := URLString[i];
Case C of
'.' : ShouldBreak := True;
'/' : ShouldBreak := True;
'~' : ShouldBreak := True;
'-' : ShouldBreak := True;
End;
If ShouldBreak Then
Begin
Result := SubStr(URLString,1,i);
Exit;
End;
End;
End;
Result := URL+'/';
End;
{!~ Tests for the existence of a URL. True is returned
if the URL exists and False otherwise. The source URL
can be a remote http address or it can be a local file.}
Function InternetIsUrl(URL : String): Boolean;
Var
hSession : HINTERNET;
Source_Handle : HINTERNET;
Avail : Integer;
Begin
Try
If FileExists(URL) Then
Begin
Result := True;
Exit;
End;
Except
End;
hSession := nil;
Source_Handle := nil;
Try
Try
hSession :=
InternetOpen(
PChar('nil'),
LOCAL_INTERNET_ACCESS,
nil,
PChar(INTERNET_INVALID_PORT_NUMBER),
INTERNET_FLAG_DONT_CACHE );
If (hSession <> nil) Then
Begin
Source_Handle :=
InternetOpenUrl(
hSession,
PChar(URL),
nil,
Cardinal(-1),
INTERNET_FLAG_DONT_CACHE or
INTERNET_FLAG_RAW_DATA,
0);
If (Source_Handle <> nil) Then
Begin
Try
Avail := -1;
InternetQueryDataAvailable(
Source_Handle,
Cardinal(Avail),
0,
0);
If Avail > 42 Then
Begin
Result := True;
End
Else
Begin
Result := False;
End;
Except
Result := False;
End;
End
Else
Begin
Result := False;
End;
End
Else
Begin
Result := False;
End;
Except
Result := False;
End;
Finally
InternetCloseHandle( hSession );
InternetCloseHandle(Source_Handle);
End;
End;
{!~
INTERNET_GETURLSFROMCACHEPAGES
The purpose of this procedure is to extract URL information from
web pages stored in the Temporary Internet Files Directory.
The URL's gathered by this procedure are stored in a new HTML page given
by the OutputFile argument.
This procedure needs a working directory designated
by the WorkingDirectoryName argument. This working directory should
be for the exclusive use of this procedure because all files in the
directory are deleted at the beginning of the process.
The location of the Temporary Internet Files Directory is provided by
the TemporaryInternetDirectory argument.
A number of boolean options are provided in this procedure:
SortByLabels : Sort the Results by the <a Tag Labels.
EliminateDuplicates : Eliminate duplicates.
DiscardRelativePaths : Discard URL's with relative paths.
EmptyCacheWhenDone : Empty the Internet Cache when the process
is completed.
Some URL's can be discarded from the results by identifying a
string that would trigger the disposal of the URL. There is no limit
how many of these string triggers can be used. To pass these triggers
to the procedure use a TStringList with one trigger per line. The
TStringList should be passed to the EliminateURLsContaining argument.
Example:
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
Internet_GetURLsFromCachePages(
Edit1.Text, //TemporaryInternetDirectory : String;
GlobalExecutablePath+Edit2.Text, //WorkingDirectoryName : String;
Edit3.Text, //OutputFile : String;
CheckBox1.Checked, //SortByLabels : Boolean;
CheckBox2.Checked, //EliminateDuplicates : Boolean;
CheckBox3.Checked, //DiscardRelativePaths : Boolean;
CheckBox4.Checked, //EmptyCacheWhenDone : Boolean;
Memo1.Lines); //EliminateURLsContaining : TStrings);
end;
}
procedure Internet_GetURLsFromCachePages(
TemporaryInternetDirectory : String;
WorkingDirectoryName : String;
OutputFile : String;
SortByLabels : Boolean;
EliminateDuplicates : Boolean;
DiscardRelativePaths : Boolean;
EmptyCacheWhenDone : Boolean;
EliminateURLsContaining : TStrings);
Var
T : TStringList;
U : TStringList;
D : TStringList;
i,j,c,p : Integer;
ToFile : String;
FromFile : String;
BeginTag : String;
EndTag : String;
Containing : String;
S : String;
begin
T := TStringList.Create();
U := TStringList.Create();
D := TStringList.Create();
Try
If TemporaryInternetDirectory = '' Then
Begin
Msg('The Web Cache Directory needs to be provided!');
Exit;
End;
If Not DirectoryExists(TemporaryInternetDirectory) Then
Begin
Msg('The Web Cache Directory is invalid!');
Exit;
End;
If OutputFile = '' Then
Begin
Msg('The Output File need to be provided!');
Exit;
End;
If Not DirectoryExists(ExtractFileDir(OutputFile)) Then
Begin
Msg('The Output File Directory is invalid!');
Exit;
End;
If Copy(TemporaryInternetDirectory,Length(TemporaryInternetDirectory),1) <> '\' Then
Begin
TemporaryInternetDirectory := TemporaryInternetDirectory + '\';
End;
//Get SubDirectories Under The Temporary Internet Directory
FilesInDirDetail(
D, //FileList : TStrings;
TemporaryInternetDirectory, //Directory : String;
'*.*', //Mask : String;
True, //Intersection: Boolean;
False, //IsReadOnly : Boolean;
True, //IsHidden : Boolean;
False, //IsSystem : Boolean;
False, //IsVolumeID : Boolean;
True, //IsDirectory : Boolean;
False, //IsArchive : Boolean;
False, //IsNormal : Boolean;
False); //InclDotFiles: Boolean): Boolean;
T.Clear;
If Copy(WorkingDirectoryName,Length(WorkingDirectoryName),1) <> '\' Then
Begin
WorkingDirectoryName := WorkingDirectoryName + '\';
End;
If Not DirectoryExists(WorkingDirectoryName) Then
ForceDirectories(WorkingDirectoryName);
//Empty the Working Directory
T.Clear;
FilesInDirDetail(
T, //FileList : TStrings;
WorkingDirectoryName, //Directory : String;
'*.*', //Mask : String;
False, //Intersection: Boolean;
False, //IsReadOnly : Boolean;
False, //IsHidden : Boolean;
False, //IsSystem : Boolean;
False, //IsVolumeID : Boolean;
False, //IsDirectory : Boolean;
False, //IsArchive : Boolean;
True, //IsNormal : Boolean;
False); //InclDotFiles: Boolean): Boolean;
For i := 0 To T.Count - 1 Do
Begin
SysUtils.DeleteFile(WorkingDirectoryName+T[i]);
End;
//Get Files From SubDirectories Under The Temporary Internet Directory
For c:= 0 To D.Count - 1 Do
Begin
T.Clear;
{!~ Populates a TStrings FileList with the files meeting selected
file attribute criteria in a directory. The mask argument is a
standard DOS file argument like '*.*. The InclDotFiles argument
allows the user to exclude the system files "." and ".." by
setting the value to False. If the Intersection argument is set
to true then the result will reflect only those files that satisfy
all attribute criteria. If Intersection is set to false then the
result will be a union of files that meet any of the criteria.}
S := TemporaryInternetDirectory+D[c]+'\';
FilesInDirDetail(
T, //FileList : TStrings;
S, //Directory : String;
'*.htm*', //Mask : String;
False, //Intersection: Boolean;
False, //IsReadOnly : Boolean;
False, //IsHidden : Boolean;
False, //IsSystem : Boolean;
False, //IsVolumeID : Boolean;
False, //IsDirectory : Boolean;
False, //IsArchive : Boolean;
True, //IsNormal : Boolean;
False); //InclDotFiles: Boolean): Boolean;
For i := 0 To T.Count - 1 Do
Begin
FromFile := TemporaryInternetDirectory+D[c]+'\'+T[i];
ToFile :=
WorkingDirectoryName+
FileNextNumberName(WorkingDirectoryName,'*.*')+
'.htm';
CopyFile(FromFile, ToFile);
End;
End;
T.Clear;
{!~ Populates a TStrings FileList with the files meeting selected
file attribute criteria in a directory. The mask argument is a
standard DOS file argument like '*.*. The InclDotFiles argument
allows the user to exclude the system files "." and ".." by
setting the value to False. If the Intersection argument is set
to true then the result will reflect only those files that satisfy
all attribute criteria. If Intersection is set to false then the
result will be a union of files that meet any of the criteria.}
FilesInDirDetail(
T, //FileList : TStrings;
WorkingDirectoryName, //Directory : String;
'*.*', //Mask : String;
False, //Intersection: Boolean;
False, //IsReadOnly : Boolean;
False, //IsHidden : Boolean;
False, //IsSystem : Boolean;
False, //IsVolumeID : Boolean;
False, //IsDirectory : Boolean;
False, //IsArchive : Boolean;
True, //IsNormal : Boolean;
False); //InclDotFiles: Boolean): Boolean;
For i := 0 To T.Count - 1 Do
Begin
U.Clear;
U.LoadFromFile(WorkingDirectoryName+T[i]);
S := U.Text;
S := String_LineFeed_Format(S);
S :=
String_Replace(
#13+#10, //OldSubString : String;
'', //NewSubString : String;
S); //SourceString : String): String;
U.SetText(PChar(S));
T.Append(U.Text);
End;
//Capture Raw URL Information
U.Clear;
BeginTag := '<a href=';
EndTag := '</a>';
Containing := '';
{!~ All matches are added to the Stringlist.}
String_GrepAllToStringList(
T.Text, //Source : String; //The input string
BeginTag, //StartTag : String; //The start tag
EndTag, //EndTag : String; //The end tag
Containing, //Containing : String; //A match must contain this string
U, //Var StringList : TStringList; //A List of Matches
False, //CaseSensitiveTags : Boolean; //True if tags are casesensitive
True); //CaseSensitiveContaining : Boolean //True if Containing string is casesensitive
//): Boolean; //True if a match was found
U.Sorted := True;
U.Sorted := False;
//Eliminate Partial Paths If Required
T.Clear;
If DiscardRelativePaths Then
Begin
For I := 0 To U.Count - 1 Do
Begin
If Pos('HTTP://',UpperCase(U[i])) > 0 Then T.Add('<li>'+BeginTag+U[i]+EndTag+'</li>');
End;
End;
U.Clear;
U.Assign(T);
//Eliminate Duplicates If Required
T.Clear;
If EliminateDuplicates Then
Begin
T.Duplicates := dupIgnore;
For I := 0 To U.Count - 1 Do
Begin
T.Add(U[i]);
End;
T.Duplicates := dupAccept;
End;
U.Clear;
U.Assign(T);
//Eliminate everything but URL's
T.Clear;
For i := 0 To U.Count - 1 Do
Begin
Trim(U[i]);
If UpperCase(Copy(U[i],1,4)) = '<LI>' Then T.Add(U[i]);
End;
U.Clear;
U.Assign(T);
For j := 0 To EliminateURLsContaining.Count - 1 Do
Begin
T.Clear;
For i := 0 To U.Count - 1 Do
Begin
Trim(U[i]);
If Pos(UpperCase(EliminateURLsContaining[j]),UpperCase(U[i])) < 1 Then T.Add(U[i]);
End;
U.Clear;
U.Assign(T);
End;
If SortByLabels Then
Begin
T.Clear;
T.Sorted := True;
If EliminateDuplicates Then
Begin
T.Duplicates := dupIgnore;
End
Else
Begin
T.Duplicates := dupAccept;
End;
For i := 0 To U.Count - 1 Do
Begin
S := String_Reverse(U[i]);
p := Pos(UpperCase('>il/<>a/<'),S);
S := Copy(S,P+10,Length(S)-10);
p := Pos('>',S);
S := Copy(S,1,p-1);
S := Trim(s);
S := String_Reverse(S);
S := StringPad(S,' ',150,True);
S := S + U[i];
Try
T.Add(S);
Except
End;
End;
U.Clear;
U.Assign(T);
T.Sorted := False;
T.Duplicates := dupAccept;
For i := 0 To U.Count - 1 Do
Begin
U[i] := Copy(U[i],151,Length(U[i])-150);
End;
End;
T.Clear;
T.Add('<html>');
T.Add('<body>');
T.Add('<ul>');
T.Append(U.Text);
T.Add('</ul>');
T.Add('</body>');
T.Add('</html>');
T.SaveToFile(OutputFile);
If EmptyCacheWhenDone Then
Begin
Internet_EmptyCacheDirectories(TemporaryInternetDirectory);
End;
Finally
T.Free;
U.Free;
D.Free;
End;
end;
{
Example:
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
Internet_GetURLsFromCachePages(
Edit1.Text, //TemporaryInternetDirectory : String;
GlobalExecutablePath+Edit2.Text, //WorkingDirectoryName : String;
Edit3.Text, //OutputFile : String;
CheckBox1.Checked, //SortByLabels : Boolean;
CheckBox2.Checked, //EliminateDuplicates : Boolean;
CheckBox3.Checked, //DiscardRelativePaths : Boolean;
CheckBox4.Checked, //EmptyCacheWhenDone : Boolean;
Memo1.Lines); //EliminateURLsContaining : TStrings);
end;
}
{!~
NMHTTP_GETURLTOFILE
This utility assumes you have the NetMasters FastNet
internet components. The FastNet components can be purchased
from NetMasters at http://www.netmastersllc.com.
This utility copies a URL to file.
}
Function NMHttp_GetURLToFile(
NMHttp : TNMHttp;
SourceURL : String;
DestFile : String;
Button_Stop : TSpeedButton
): Boolean;
begin
Result :=
NMHttp_URLToFileDetail(
NMHttp,
SourceURL,
'',
DestFile,
Button_Stop
);
end;
{!~
NMHTTP_ISURL
This utility assumes you have the NetMasters FastNet
internet components. The FastNet components can be purchased
from NetMasters at http://www.netmastersllc.com.
This utility tests the existance of a URL. If the URL exists
True is returned, otherwise False.
}
Function NMHttp_IsUrl(NMHttp: TNMHttp; URLString: String): Boolean;
Begin
Try
If FileExists(URLString) Then
Begin
Result := True;
Exit;
End;
Except
End;
Try
NMHttp.Head(URLString);
Result := True;
Except
Result := False;
End;
End;
{!~
NMHttp_PostURLToFile
This utility assumes you have the NetMasters FastNet
internet components. The FastNet components can be purchased
from NetMasters at http://www.netmastersllc.com.
This utility copies a URL to file using http post.
}
Function NMHttp_PostURLToFile(
NMHttp : TNMHttp;
SourceURL : String;
Parameters : String;
DestFile : String;
Button_Stop : TSpeedButton
): Boolean;
begin
Result :=
NMHttp_URLToFileDetail(
NMHttp,
SourceURL,
Parameters,
DestFile,
Button_Stop
);
end;
{!~ Purges files from the internet cache}
Procedure PurgeInternetCache(
MainForm : TForm;
WinDir : String;
IntTempDir : String);
Var
CacheNum : Integer;
c,i : Integer;
CurCache : String;
FileString : String;
FileList : TFileListBox;
StringList : TStringList;
CacheDir : String;
Begin
FileList := TFileListBox.Create(nil);
FileList.Height := 1;
FileList.Width := 1;
FileList.Parent := MainForm;
StringList := TStringList.Create();
Try
CacheNum := 4;
For c := 1 To CacheNum Do
Begin
CurCache := 'Cache'+ IntToStr(c);
CacheDir := WinDir+'\'+IntTempDir+'\'+CurCache;
FileList.Directory := CacheDir;
FileList.Mask := '*.*';
StringList.Clear;
StringList.Assign(FileList.Items);
For i := 0 To StringList.Count - 1 Do
Begin
FileString := CacheDir+'\'+StringList[i];
SetFileAttributes(
PChar(FileString),
FILE_ATTRIBUTE_NORMAL);
DeleteFile(PChar(FileString));
End;
End;
Finally
FileList.Free;
StringList.Free;
End;
End;
End.