📄 unit_geturl.pas
字号:
unit Unit_GetUrl;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ActnList, ExtCtrls,wininet,StrUtils, ComCtrls,Unit_UrlShowEdit
,SHDocVw,Comobj, Menus, Buttons, ImgList;
type
TForm_GetUrl = class(TForm)
GetFistUrl: TEdit;
GetLastUrl: TEdit;
Explore: TButton;
UrlList: TListBox;
Panel1: TPanel;
Label1: TLabel;
Label2: TLabel;
SBGuessStart: TSpeedButton;
Label4: TLabel;
Panel2: TPanel;
ReMove0: TCheckBox;
DelGUrl: TButton;
GroupBox1: TGroupBox;
ExploreTheOne: TButton;
StatusBar1: TStatusBar;
RdGp_MaxGsUrl: TRadioGroup;
GroupBox2: TGroupBox;
FormulaShow: TMemo;
Label3: TLabel;
ShowUrlWin: TButton;
Panel3: TPanel;
Panel4: TPanel;
Button1: TButton;
GuessBalance: TRadioButton;
GuessAlone: TRadioButton;
MainMenu1: TMainMenu;
N1: TMenuItem;
MP31: TMenuItem;
MTV1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
N7: TMenuItem;
N8: TMenuItem;
N9: TMenuItem;
N1001: TMenuItem;
N5001: TMenuItem;
N10001: TMenuItem;
N20001: TMenuItem;
N50001: TMenuItem;
N10: TMenuItem;
N11: TMenuItem;
N12: TMenuItem;
N13: TMenuItem;
N14: TMenuItem;
N15: TMenuItem;
N16: TMenuItem;
URLKING1: TMenuItem;
N17: TMenuItem;
N21: TMenuItem;
N18: TMenuItem;
N22: TMenuItem;
N19: TMenuItem;
procedure ExploreClick(Sender: TObject);
procedure GetLastUrlExit(Sender: TObject);
procedure GetFistUrlExit(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure SBGuessStartClick(Sender: TObject);
procedure DelGUrlClick(Sender: TObject);
procedure ExploreTheOneClick(Sender: TObject);
procedure GetFistUrlClick(Sender: TObject);
procedure GetLastUrlClick(Sender: TObject);
procedure ShowUrlWinClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure GuessAloneClick(Sender: TObject);
procedure GuessBalanceClick(Sender: TObject);
procedure ExploreTheOneMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
procedure GroupBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ShowUrlWinMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Button1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ExploreMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure DelGUrlMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure UrlListMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Panel2MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure RdGp_MaxGsUrlClick(Sender: TObject);
procedure GuessAloneMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure GuessBalanceMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure GroupBox2MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ReMove0MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormulaShowMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure SBGuessStartMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure N6Click(Sender: TObject);
procedure N7Click(Sender: TObject);
procedure N8Click(Sender: TObject);
procedure N1001Click(Sender: TObject);
procedure N5001Click(Sender: TObject);
procedure N10001Click(Sender: TObject);
procedure N20001Click(Sender: TObject);
procedure N50001Click(Sender: TObject);
procedure N10Click(Sender: TObject);
procedure N11Click(Sender: TObject);
procedure N12Click(Sender: TObject);
procedure N13Click(Sender: TObject);
procedure N15Click(Sender: TObject);
procedure N16Click(Sender: TObject);
procedure URLKING1Click(Sender: TObject);
procedure N3Click(Sender: TObject);
procedure MTV1Click(Sender: TObject);
procedure MP31Click(Sender: TObject);
procedure N21Click(Sender: TObject);
procedure N18Click(Sender: TObject);
procedure N22Click(Sender: TObject);
procedure N19Click(Sender: TObject);
procedure ReMove0Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
Type
UrlTextList=Record
RealUrl:string;
BtfName:string;
UrlNum:integer;
end;
Type
PointInt=^integer;
PointStr=^string;
var
Form_GetUrl: TForm_GetUrl;
UrlTexList:array[1..100] of UrlTextList;
IEApp: Variant;
UrlType:string;
AntoDelFinished:boolean;
implementation
{$R *.dfm}
//判断地址有效性开始
function IsURL(s: string): Boolean;
var
i: integer;
begin
Result := False;
if Length(s) < 5 then exit;
if (s[Length(s)] = '.') or (Pos('..', s) > 0) then exit;
for i := 1 to Length(s) do
//if (Ord(s[i]) < 33) or (Ord(s[i]) > 126) then exit;
if (Pos('www.',LowerCase(s)) = 1) or (Pos('news:', LowerCase(s)) = 1) and
(Length(s) > 6) then
begin
Result := True;
Exit;
end;
//判断Email地址
//if (Length(s) > 12) or (Pos('mailto:', LowerCase(s)) = 1) and
// (Pos('@', s) > 1) and (Pos('.', s) > 4) and (Pos('.', s) > (Pos('@', s) +1)) then
//begin
//Result := True;
//Exit;
//end;
if (Pos('http://', LowerCase(s)) > 0) or (Pos('ftp://', LowerCase(s)) > 0) or
(pos('rtsp://',LowerCase(s)) > 0) or (Pos('mms://',LowerCase(s)) > 0) and
(Length(s) > 10) and (Pos('.', s) > 7) then
begin
Result := True;
Exit;
end;
end;
//判断地址有效性结束
//探测地址函数开始
Function CheckUrl(url:string):boolean;
var
hSession, hfile, hRequest: hInternet;
dwindex,dwcodelen :dword;
dwcode:array[1..20] of char;
res : pchar;
begin
if (pos('http://',lowercase(url))=0) and (Pos('ftp://', LowerCase(url)) = 0) and
(pos('rtsp://',LowerCase(url))= 0) and (Pos('mms://',LowerCase(url)) = 0) then
url := 'http://'+url;
Result := false;//这句并不是针对上面的if
hSession := InternetOpen('InetURL:/1.0',INTERNET_OPEN_TYPE_PRECONFIG,nil, nil, 0);
if assigned(hsession) then
begin
hfile := InternetOpenUrl(hsession,pchar(url),nil,0,INTERNET_FLAG_RELOAD,0);
dwIndex := 0;
dwCodeLen := 10;
HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE,@dwcode, dwcodeLen, dwIndex);
res := pchar(@dwcode);
result:= (res ='200') or (res ='302');
if assigned(hfile) then
InternetCloseHandle(hfile);
InternetCloseHandle(hsession);
end;
end;
//探测地址函数结束
//返回字符串是否是正确的整数表达
function IsInteger(mStr: string): Boolean;
var
I: Integer;
E: Integer;
begin
Val(mStr, I, E);
Result := E = 0;
E := Trunc(I);
end; {IsInteger }
///////返回字符串是否是正确的整数表达结束
{得到最末字符数块}
function GetBackStrNums(StartN:integer;Str:String;BeginN:PointInt):String;
Var i_for:integer;
Begin
BeginN^:=0;
Result:='';
for i_for:=StartN downto 1 do
Begin
//showmessage('长度 '+inttostr(length(str)));
//if ByteType(Str,i_for)=mbSingleByte then showmessage('单字节');
//if ByteType(Str,i_for)=mbLeadByte then showmessage('双字节第一位');
//if ByteType(Str,i_for)=mbTrailByte then showmessage('双字节第二位');
if IsInteger(Str[i_for]) then
Begin
Result:=Str[i_for]+Result;
if length(Result)>9 then
Result:=leftstr(Result,9);
if not IsInteger(Str[i_for-1]) then//结束条件
Begin
if Result='' then Result:='#';
//结束处理
BeginN^:=i_for;
exit;
end;
end;
end;
end;{得到最末字符数块}
{判断输入地址是否合法}
function JerqueUrl():boolean;
begin
Result:=True;
if( //判断地址一有效性
(trim(Form_GetUrl.GetFistUrl.Text)='')
or (Form_GetUrl.GetFistUrl.Text='请在这里输入参考地址一(完整的)'))
or (IsURL(Form_GetUrl.GetFistUrl.Text)<>true) then
begin
showmessage('抱歉,参考地址一无效');
Result:=False;
exit;
end;
if Form_GetUrl.GetLastUrl.Enabled=True then//是否有必要判断
begin
if ( //判断地址二有效性
(trim(Form_GetUrl.GetLastUrl.Text)='')
or (Form_GetUrl.GetLastUrl.Text='请在这里输入参考地址二(完整的)')
or (isUrl(Form_GetUrl.GetLastUrl.Text)<>true)) then
begin
showmessage('抱歉,参考地址二无效');
Result:=False;
exit;
end;
end;
if Result=True then
Form_GetUrl.Explore.Enabled:=True;
end;{判断输入地址是否合法结束}
{得到Url1与Url2不同的最末整数
Url1:地址1
Url2:地址2
BackN1:地址1最后的不同整数
BN1:BackNum1在Url1中第一个字符的位置
BackN2:地址2最后的不同整数
BN2:BackNum2在Url2中第一个字符的位置
WildcardLen:要改变数串的长度,通配符长度
LUrl,RUrl:数串左、右地址
}
function GetBackNumInfo_Two(Url1,Url2:string;BackN1,BackN2,WildcardLen:PointInt;LUrl,RUrl:PointStr):boolean;
var SN1,SN2:integer;//从末尾开始查找的位置
var BackStrNums1,BackStrNums2:string;
var GoOnGet:boolean;
var BN1,BN2:integer;//不等数串在地址中第一个字符出现的位置
var BasisUrl:string;//得Info的地址(二址之一）
Var BasisBN:integer;//得到R\LUrl的条件之一
begin
SN1:=LastDelimiter('.', Url1);
SN2:=LastDelimiter('.', Url2);
Result:=True;
repeat//得到不同的最末整数BackNum1,BackNum2
GoOnGet:=False;
BackStrNums1:=GetBackStrNums(SN1,Url1,@BN1);
BackStrNums2:=GetBackStrNums(SN2,Url2,@BN2);
//Showmessage(inttostr(BN1));exit;
if(BackStrNums1=BackStrNums2)then
begin
GoOnGet:=True;
if ((BN1)<=1) or ((BN2)<=1) then
Begin
Showmessage('没有找到可供猜测的数据!');
Result:=False;
exit;
end;
SN1:=BN1-1;
SN2:=BN2-1;
end
else
begin//转换为整数
if Length(BackStrNums1)>=length(BackStrNums2) then//得到通配符长
begin
WildcardLen^:=length(BackStrNums1);
BasisUrl:=Url1;//为后面的LUrl、RUrl提供依据
BasisBN:=BN1;
end
else
begin
WildcardLen^:=length(BackStrNums2);
BasisUrl:=Url2;
BasisBN:=BN2;
end;
{
||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
MidStr主要用于 取出 双字节的字符串,下标以 1 开始,双字节算一个字节
copy()功能与其类似 ,双字节算一个字节
copy()无论下标以 0 开始,还是以 1 开始,都是指第一个字符,实际以 1 开始
||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
LUrl^:=copy(BasisUrl,1,BasisBN-1);
RUrl^:=copy(BasisUrl,BasisBN+WildcardLen^,(length(BasisUrl)-BasisBN-WildcardLen^+1));//数块右边的地址
{//检测以上转换结果
showmessage('BasisUrl='+BasisUrl+#13+#10
+'BasisBN+WildcardLen^='+inttostr(BasisBN+WildcardLen^)+#13+#10
+'length(BasisUrl)='+inttostr(length(BasisUrl))+#13+#10
+'WildcardLen^='+inttostr(WildcardLen^)+#13+#10
+'Copy(BasisUrl,(BasisBN+WildcardLen^),3)='+Copy(BasisUrl,(BasisBN+WildcardLen^),3)+#13+#10
);}
BackN1^:=strtoint(BackStrNums1);
BackN2^:=strtoint(BackStrNums2);
GoOnGet:=False;
end;
until GoOnGet=False;//得到不同的最末整数结束
end;{得到Url1与Url2不同的最末整数结束}
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -