unifunc.pas

查询邮政区号、身份证号、手机号的归属地

  sLinks:IHTMLElementCollection;
  sItem:OleVariant;
  iLen,iLoop:Integer;
begin
  Result:='';
  try
    sDoc:=WebBrowser.Document as IHTMLDocument2;
    sLinks:=sDoc.Links;
    iLen:=sLinks.Length;
    for iLoop:=0 to iLen-1 do
    begin
      sItem:=sLinks.item(iLoop,varEmpty);
      Link.Add(Trim(sItem.Href));          //链接地址
      LinkName.add(Trim(sItem.InnerText)); //链接标题
    end;
    Result:=Link.Strings[0];
  except
  end;
end;

function GetMediaFile(const URL:String;var FileName:String;var bBoBoMedia:Boolean):Boolean;
function GetBoBoFile(const URL:String;var FileName:String):Boolean;
var
  tmpStr:String;
  Index:Integer;
begin
  Index:=Pos('?-',URL); //文件名在"?"前面
  if not (Index>0) then Index:=Pos('?+',URL); //文件名在"?"前面
  if not (Index>0) then Index:=Pos('?',URL); //文件名在"?"前面
  if Index>0 then
  begin
    FileName:=Trim(Copy(URL,1,Index-1)); //取文件名
    //删除尾部非法字符
    tmpStr:=RightStr(FileName,1);
    while (tmpStr='/') or
          (tmpStr='\') or
          (tmpStr='<') or
          (tmpStr='>') or
          (tmpStr='"') or
          (tmpStr='|') or
          (tmpStr='*') or
          (tmpStr='?') do
    begin
      FileName:=Copy(FileName,1,Length(FileName)-1);
      tmpStr:=RightStr(FileName,1);
    end;
    //取文件名
    for Index:=Length(FileName) downto 1 do
    begin
      try
        tmpStr:=FileName[Index];
        if (tmpStr='/') or
           (tmpStr='\') or
           (tmpStr='<') or
           (tmpStr='>') or
           (tmpStr='"') or
           (tmpStr='|') or
           (tmpStr='*') or
           (tmpStr='?') then
        begin
          Delete(FileName,1,Index);
          Break;
        end;
      except
        Break;
      end;
    end;
    Result:=True; //设置BoBo媒体标志
  end
  else //找不到文件分隔标志"?"
  begin
    FileName:='';
    Result:=False; //不是BoBo媒体
  end;
end;
function GetHttpFile(const URL:String):String;
var
  iIndex:Integer;
  sURL:String;
begin
  sURL:=Trim(URL);
  iIndex:=PosR('/',sURL);
  if iIndex>0 then
  begin
    Delete(sURL,1,iIndex);
    if Pos('.',sURL)>0 then
      Result:=sURL
    else
      Result:='';
  end
  else Result:='';
end;
var
  MediaURL:String;
begin
  MediaURL:=Trim(URL);
  bBoBoMedia:=False;
  if Copy(MediaURL,2,2)=':\' then //判断是否本地媒体文件
  begin
    FileName:='';
    if FileExists(MediaURL) then
      FileName:=ExtractFileName(MediaURL) //取文件名用于判断媒体格式
    else
      FileName:='';
  end
  else if MediaURL<>'' then //网络媒体
  begin
    FileName:=LowerCase(Copy(MediaURL,1,5));
    if      (FileName='rtsp:') then FileName:='rtsp.rm' //RealAudio 格式
    else if (FileName='mms:/') then FileName:='mms.wmv' //MMS 流媒体格式
    else if (FileName='kplay') then //已经关联的链接类型
    begin
      bBoBoMedia:=GetBoBoFile(MediaURL,FileName);
    end
    else if (FileName='http:') then //检查 http 类型的链接
    begin
      FileName:=LowerCase(Copy(MediaURL,1,17));
      if (FileName='http://localhost:') or (FileName='http://127.0.0.1:') then
        bBoBoMedia:=GetBoBoFile(MediaURL,FileName)
      else
        FileName:=GetHttpFile(MediaURL); //从HTTP链接中取文件名
    end
    else bBoBoMedia:=GetBoBoFile(MediaURL,FileName);
  end
  else FileName:=''; //文件名或网络链接为空
  Result:=(GetType(FileName)<>isError);
end;

function SetKPlay(RegKey,FileName:String):Boolean;
begin
  try
    WriteRegString(HKEY_LOCAL_MACHINE,'SOFTWARE\Classes\'+RegKey,'','URL: kplay Protocol');
    WriteRegString(HKEY_LOCAL_MACHINE,'SOFTWARE\Classes\'+RegKey,'URL Protocol','');
    WriteRegString(HKEY_LOCAL_MACHINE,'SOFTWARE\Classes\'+RegKey+'\DefaultIcon','',FileName);
    WriteRegString(HKEY_LOCAL_MACHINE,'SOFTWARE\Classes\'+RegKey+'\Shell','','Open');
    WriteRegString(HKEY_LOCAL_MACHINE,'SOFTWARE\Classes\'+RegKey+'\shell\Open','','Open');
    WriteRegString(HKEY_LOCAL_MACHINE,'SOFTWARE\Classes\'+RegKey+'\Shell\Open\Command','',FileName+' "%1"');
    Result:=True;
  except
    Result:=False;
  end;
end;

//添加IE右键菜单
function SetIEMenu(MenuCaption,FileName:String;CreateMenu:Boolean=True):Boolean;
begin //CheckExist=True 表示创建写入　False：表示读取(测试是否已经存在)
  try
    with TRegistry.Create do
    try
      RootKey:=HKEY_CURRENT_USER;  { 注册表主键 }
      OpenKey(Pchar('Software\Microsoft\Internet Explorer\MenuExt\'+MenuCaption),CreateMenu); { 打开子键 }
      try
        if CreateMenu then
        begin
          WriteString('',FileName);
          WriteInteger('Contexts',$22);
          Result:=True;
        end
        else Result:=(ReadString('')<>'') and (ReadInteger('Contexts')=$22);
      finally
        CloseKey;
      end;
    finally
      Free;
    end;
  except
    Result:=False;
  end;
end;

function SetUnInstall(AppTitle,FileName,AppDescriptive:String):Boolean;
begin
  try
    WriteRegString(HKEY_LOCAL_MACHINE,'Software\Microsoft\Windows\CurrentVersion\Uninstall\'+AppTitle,'DisplayName',AppDescriptive);
    WriteRegString(HKEY_LOCAL_MACHINE,'Software\Microsoft\Windows\CurrentVersion\Uninstall\'+AppTitle,'UninstallString',FileName);
    Result:=True;
  except
    Result:=False;
  end;
end;

{使用ShellLink过程要保证路径文件名参数正确，如下：
ShellLink('C:\Pwin98\Desktop', '快捷方式名', 'C:\Command.com','', '简短描述');
ShellLink('C:\Pwin98\Desktop', 'Win32程序.Lnk', 'D:\Setup.exe', '', ''); }
procedure ShellLink(const DestPath,LinkName,LinkAppPath,LinkArgs,Description:String;IconIndex:Integer=0);
var //创建快捷方式
  aObj:IUnknown;
  WFileName:WideString;
begin
  try
    aObj:=CreateComObject(CLSID_ShellLink);
    with aObj as IShellLink do
    begin
      //对MS-DOS程序,一般建议使用SetShowCmd(SW_SHOWMAXIMIZED);
      SetShowCmd(SW_NORMAL);
      SetArguments(Pchar(LinkArgs));
      SetDescription(Pchar(Description));
      SetPath(Pchar(LinkAppPath));
      SetWorkingDirectory(Pchar(ExtractFilePath(LinkAppPath)));
      SetIconLocation(PAnsiChar(LinkAppPath),IconIndex)
    end;
    //将一个String赋给WideString，转换过程由Delphi自动完成
    WFileName:=DestPath+'\'+LinkName;
    (aObj as IPersistFile).Save(PWChar(WFileName),False);
  except
  end;
end;

function InternetConnected():Boolean;
const
  // local system uses a modem to connect to the Internet.
  INTERNET_CONNECTION_MODEM      = 1;
  // local system uses a local area network to connect to the Internet.
  INTERNET_CONNECTION_LAN        = 2;
  // local system uses a proxy server to connect to the Internet.
  INTERNET_CONNECTION_PROXY      = 4;
  // local system's modem is busy with a non-Internet connection.
  INTERNET_CONNECTION_MODEM_BUSY = 8;
var
  dwConnectionTypes:DWORD;
begin
  dwConnectionTypes:=INTERNET_CONNECTION_MODEM+INTERNET_CONNECTION_LAN+INTERNET_CONNECTION_PROXY;
  Result:=InternetGetConnectedState(@dwConnectionTypes,0);
end;
//下载文件
function DownloadFile(const URL,FileName:String):Boolean;
var
  FilePath:String;
begin
  Result:=False;
  try
    FilePath:=ExtractFilePath(FileName);
    while RightStr(FilePath,1)='\' do
      FilePath:=Copy(FilePath,1,Length(FilePath)-1);
    if not DirectoryExists(FilePath) then
    if not MkDirEx(FilePath) then exit;
    Result:=(UrlDownloadToFile(nil,PChar(URL),PChar(FileName),0,nil)=0);
  except
  end;
end;
{
function DownloadFile(const URL,FileName:String):Boolean;
var
  Stream:TFileStream;
  FilePath:String;
  Content:String;
  NetHandle:HINTERNET;
  UrlHandle:HINTERNET;
  BytesRead:DWORD; // DWORD, not cardinal
  Buffer:array[0..1024] of Char;
begin
  Result:=False;
  try
    //检查目录(如果不存在就创建它)
    FilePath:=ExtractFilePath(FileName);
    while RightStr(FilePath,1)='\' do
      FilePath:=Copy(FilePath,1,Length(FilePath)-1);
    if not DirectoryExists(FilePath) then
    if not MkDirEx(FilePath) then exit;
    //开始下载
    NetHandle:=InternetOpen(nil, //'Delphi 7.x',
                            INTERNET_OPEN_TYPE_DIRECT, //INTERNET_OPEN_TYPE_PRECONFIG, // does'nt work for me
                            nil,nil,0);
    if Assigned(NetHandle) then
    begin
      UrlHandle:=InternetOpenUrl(NetHandle,PChar(url),nil,0,INTERNET_FLAG_RELOAD,0);
      if Assigned(UrlHandle) then
      begin
        Content:='';
        FillChar(Buffer,SizeOf(Buffer),0);
        repeat
          Content:=Content+Buffer;
          FillChar(Buffer,SizeOf(Buffer),0);
          InternetReadFile(UrlHandle,@Buffer,SizeOf(Buffer),BytesRead);
          //BytesRead=本次读取的字节数
        until (BytesRead=0);
        DeleteFile(PAnsiChar(FileName));
        try
          Stream:=TFileStream.Create(FileName,fmCreate);
          Stream.Write(Pointer(content)^,Length(content));
          Stream.Free;
          Result:=True;
        except
          Stream.Free;
        end;
      end; // if Assigned(UrlHandle)
      InternetCloseHandle(UrlHandle);
    end ;
    InternetCloseHandle(NetHandle);
  except
  end;
end;
}
function ClearIECache():Boolean;
var //Cookies也一起清空
  lpEntryInfo:PInternetCacheEntryInfo;
  hCacheDir:LongWord;
  dwEntrySize:LongWord;
begin
  try
    dwEntrySize:=0;
    FindFirstUrlCacheEntry(nil,TInternetCacheEntryInfo(nil^),dwEntrySize);
    GetMem(lpEntryInfo,dwEntrySize);
    if dwEntrySize>0 then lpEntryInfo^.dwStructSize:=dwEntrySize;
    hCacheDir:=FindFirstUrlCacheEntry(nil,lpEntryInfo^,dwEntrySize);
    if hCacheDir<>0 then
    begin
      repeat
        DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
        FreeMem(lpEntryInfo,dwEntrySize);
        dwEntrySize:=0;
        FindNextUrlCacheEntry(hCacheDir,TInternetCacheEntryInfo(nil^),dwEntrySize);
        GetMem(lpEntryInfo,dwEntrySize);
        if dwEntrySize>0 then lpEntryInfo^.dwStructSize:=dwEntrySize;
      until not FindNextUrlCacheEntry(hCacheDir,lpEntryInfo^,dwEntrySize);
    end;
    FreeMem(lpEntryInfo,dwEntrySize);
    FindCloseUrlCache(hCacheDir);
    Result:=True;
  except
    Result:=False;
  end;
end;

function SetFileAssociate(FileExt,FileType,Description,ExeFile:String):Boolean;
begin //SetFileAssociate('.lan','Language','Language File',Application.ExeName);
  try
    with TRegistry.Create do
    try
      RootKey:=HKEY_CLASSES_ROOT;
      OpenKey(FileExt,True);
      WriteString('',FileType);
      CloseKey;
      OpenKey(FileType,True);
      WriteString('',Description);
      CloseKey;
      OpenKey(FileType+'\DefaultIcon',True);
      WriteString('',Format('"%s",%d',[ExeFile,1]));
      CloseKey;
      OpenKey(FileType+'\Shell\Open',True);
      WriteString('','&Open');
      CloseKey;
      OpenKey(FileType+'\Shell\Open\Command',True);
      WriteString('',Format('"%s" "%%%d"',[ExeFile,1]));
      CloseKey;
      //SHChangeNotify(SHCNE_ASSOCCHANGED,SHCNF_IDLIST,nil,nil);
    finally
      Free;
    end;
    Result:=True;
  except
    Result:=False;
  end;
end;
//查找并替换子串
function SimString(SubStr,NewStr,Str:String):String;
var
  iIndex:Integer;
  sText:String;
begin
  if (SubStr<>'') and (Str<>'') then
  begin //待查字串和原字符串都不能为空
    sText:=Str;
    iIndex:=Pos(SubStr,sText);
    while iIndex>0 do
    begin
      Result:=Result+Copy(sText,1,iIndex-1)+NewStr; //把换行标志(\n)替换成换行符#13#10
      Delete(sText,1,iIndex+Length(SubStr)-1);
      iIndex:=Pos(SubStr,sText);
    end;
    Result:=Result+sText;
  end
  else Result:=Str; //否则什么也不改变
end;

end.