最近在做收藏夹的软件,由于微软提供的ImportExportFavorites函数必须确认,所以我自己做了个,希望大家指正其中的错误(15分)

myqq · 2004-02-25

use   SHLObj; procedure MyImportExportFavorites(t:boolean;dir:string); var bar:string; OutPut: Text; pidl: PItemIDList; FavPath: array[0..MAX_PATH] of char ; procedure GetIEFavourites(const favpath: string; var f: Text); var    searchrec:TSearchrec;    path,dir,filename:String;    Buffer: array[0..2047] of Char;    found:Integer; begin if bar ='' then begin filename:='<!DOCTYPE NETSCAPE-Bookmark-file-1>'+#13#10+ ''+#13#10+ '<TITLE>Bookmarks</TITLE>'+#13#10+ '<H1>Bookmarks</H1>'+#13#10+ '<DL>'; writeln(f,filename); end; bar:=bar+'    ';    path:=FavPath+'/*.url';    dir:=ExtractFilepath(path) ;    found:=FindFirst(path,faAnyFile,searchrec) ;    while found=0 do begin     SetString(filename, Buffer,             GetPrivateProfileString('InternetShortcut',             PChar('URL'), NIL, Buffer, SizeOf(Buffer),             PChar(dir+searchrec.Name))) ;     filename:=bar+'<DT><A HREF="'+filename+'" ADD_DATE="1073605689" LAST_VISIT="1073605695" LAST_MODIFIED="1076514206">'+changefileext(searchrec.Name,'')+'</A>';     writeln(f,filename);     found:=FindNext(searchrec) ;    end;    found:=FindFirst(dir+'/*.*',faAnyFile,searchrec) ;    while found=0 do begin     if ((searchrec.Attr and faDirectory) > 0)       and (searchrec.Name[1]<>'.') then       begin     filename:=bar+'<DT><H3 FOLDED ADD_DATE="1073605693">'+searchrec.Name+'</H3><DL>';     writeln(f,filename);     GetIEFavourites (dir+'/'+searchrec.name,f) ;     filename:='</DL>';     writeln(f,filename);     end;     found:=FindNext(searchrec) ;    end;    SysUtils.FindClose(searchrec) ; end; begin if t=true then begin   SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, pidl) ;   SHGetPathFromIDList(pidl, favpath) ;   Assign(Output,dir);   Rewrite(output);   try   GetIEFavourites(StrPas(FavPath),OutPut) ;   finally   Close(Output);   end;   end; end; //函数只做好了导出部分,谁能帮忙做下导入部分

刀剑如梦 · 2004-02-25

unit F2BMain; interface uses   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,   StdCtrls, Registry; type   // Record for use as list element   PUrlRec = ^TUrlRec;   TUrlRec = record     Rep:     String;         // Folder name (folders and links)     UrlName: String;         // Logical URL name (links only)     UrlPath: String;         // www URL name (links only)     Level: Integer;          // Folder level (position in folder tree)   end; type   TMainForm = class(TForm)     Button1: TButton;     Button2: TButton;     Button3: TButton;     Label1: TLabel;     Edit1: TEdit;     CheckBox1: TCheckBox;     procedure Button1Click(Sender: TObject);     procedure Button2Click(Sender: TObject);     procedure Button3Click(Sender: TObject);   private     FavFolder: String;       // Path of the favorites folder     FavList: TList;          // List of the favorite links     BmkList: TStringList;    // Favorites converted into bookmarks     procedure GetFavoritesFolder;     procedure SearchURL(Folder: String; Level: Integer);     procedure MakeBookmarkFile;     procedure TraverseFavList(Idx, PrevIdx: Integer);   protected     procedure MakeDocumentTop;     procedure MakeDocumentBottom;     procedure MakeHeaderTop(UrlRec: PUrlRec);     procedure MakeHeaderBottom(UrlRec: PUrlRec);     procedure MakeBookmark(UrlRec: PUrlRec);   end; var   MainForm: TMainForm; implementation {$R *.DFM} uses   IniFiles, ShellApi, F2BAbout; {---------------------- TMainForm ---------------------} procedure TMainForm.GetFavoritesFolder; // Find the directory of the Internet Explorer favorites var   Registry: TRegistry; begin   Registry := TRegistry.Create;   Registry.RootKey := HKEY_CURRENT_USER;   Registry.OpenKey('Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders', False);   FavFolder := Registry.ReadString('Favorites');   Registry.Free; end; procedure TMainForm.SearchURL(Folder: String; Level: Integer); // Research and create the list of the favorites files found. // This method uses recursion to get all the subfolders. var   Found: Integer;   SearchRec: TSearchRec;   UrlFile: TIniFile;   UrlRec: PUrlRec; begin   // First File   Found := FindFirst(Folder+'/*.*', faAnyFile, SearchRec);   // Research other file   while Found = 0 do   begin     // Don't get the special directories ('.' and '..')     if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then       // Change directory       if (SearchRec.Attr and faDirectory > 0) then         begin           if not (SearchRec.Attr and faSysFile > 0) then           begin             UrlRec := New(PUrlRec);             UrlRec.Rep := Copy(Folder+'/'+SearchRec.Name, Length(FavFolder)+2, Length(Folder+'/'+SearchRec.Name)); ///            UrlRec.Rep := SearchRec.Name;             UrlRec.UrlName := '';             UrlRec.UrlPath := '';             UrlRec.Level := Level;             FavList.Add(UrlRec);           end;           SearchURL(Folder+'/'+SearchRec.Name, Level+1);   // Recursion         end       else         begin           // Get the file extension           if UpperCase(ExtractFileExt(SearchRec.Name)) = '.URL' then           begin             UrlRec := New(PUrlRec);             UrlRec.Rep := Copy(Folder, Length(FavFolder)+2, Length(Folder));             UrlRec.UrlName:= Copy(SearchRec.Name, 0, Length(SearchRec.Name)-3);             { A URL-file has the structure of an INI-file with just one section.               Open the file as an INI-file to read the URL path. }             UrlFile := TIniFile.Create(Folder+'/'+SearchRec.Name);             UrlRec.UrlPath := UrlFile.ReadString('InternetShortcut', 'URL', 'no path');             UrlRec.Level := Level;             UrlFile.Free;             FavList.Add(UrlRec);       // Add to list of favorites           end;         end;       // other file       Found := FindNext(SearchRec);   end; {   // Add a dummy record        UrlRec := New(PUrlRec);        UrlRec.Rep := '';        UrlRec.UrlName := '';        UrlRec.UrlPath := '';        UrlRec.Level := 0;        FavList.Add(UrlRec); } end; procedure TMainForm.MakeBookmarkFile; // Create the bookmark file with the internet favorites files found begin   BmkList := TStringList.Create;   MakeDocumentTop;   TraverseFavList(0, -1);    // Called recursively ///  MakeHeaderBottom(FavList[FavList.Count-1]);   MakeDocumentBottom;   try     BmkList.SaveToFile(Edit1.Text);   except on EFCreateError do     begin       MessageDlg('The target file name you specified is invalid.', mtError, [MbOk], 0);       Edit1.SetFocus;     end;   end;   BmkList.Free;   MessageDlg('Your favorites have been copied to the bookmark file you specified.',              mtInformation, [MbOk], 0); end; procedure TMainForm.TraverseFavList(Idx, PrevIdx: Integer); // Recursive method to obtain all URLs in their respective folders var   UrlRec, PrevUrlRec: PUrlRec;   X: Integer; begin   if Idx < FavList.Count then   begin     UrlRec := FavList[Idx];     if PrevIdx = -1 then       PrevUrlRec := nil     else       PrevUrlRec := FavList[PrevIdx];     if UrlRec.UrlName = '' then   // Folder found (not a URL)     begin       if PrevUrlRec <> nil then       begin         X := PrevUrlRec.Level;         while UrlRec.Level <= X do         begin           MakeHeaderBottom(PrevUrlRec);      // End section           Dec(PrevUrlRec.Level);           // dirty!           Dec(X);         end;       end;       MakeHeaderTop(UrlRec);      // Make a new header       PrevIdx := Idx;     end     else       MakeBookmark(UrlRec);       // Insert bookmark     TraverseFavList(Idx+1, PrevIdx);   end; end; procedure TMainForm.MakeDocumentTop; begin   BmkList.Add('');   BmkList.Add('');   BmkList.Add('<TITLE>' + 'Converted Bookmarks' + '</TITLE>');   BmkList.Add('<H1>' + 'Converted Bookmarks' + '</H1>');   BmkList.Add('');   BmkList.Add('<DL>'); end; procedure TMainForm.MakeDocumentBottom; begin ///  BmkList.Add(''); //  BmkList.Add('    </DL>');   BmkList.Add('');   BmkList.Add('</DL>'); end; procedure TMainForm.MakeHeaderTop(UrlRec: PUrlRec); // Add header name to the start of the section var   I, Idx: Integer;   S: String;   A: array[0..255] of Char; begin   // Change names of subfolders   FillChar(A, SizeOf(A), 0);   Idx := 1;   for I := 1 to Length(UrlRec.Rep) do     if UrlRec.Rep = '/' then       Idx := I+1;   for I := Idx to Length(UrlRec.Rep) do     A[I-Idx] := UrlRec.Rep;   // Add the name to the header   BmkList.Add(''); ///  BmkList.Add('Level: ' + IntToStr(UrlRec.Level));   for I := 1 to UrlRec.Level do     S := S + '    ';   BmkList.Add(S + '<DT><H3>' + A + '</H3>');   BmkList.Add(S + '<DL>'); end; procedure TMainForm.MakeHeaderBottom(UrlRec: PUrlRec); // End section containing bookmarks var   I: Integer;   S: String; begin   for I := 1 to UrlRec.Level do     S := S + '    ';   BmkList.Add(S + '</DL>');   BmkList.Add(''); end; procedure TMainForm.MakeBookmark(UrlRec: PUrlRec); var   I: Integer;   S: String; begin   { For some reason the names of all the favorite links retrieved     have an extra dot in the end. Remove this dot. }   Delete(UrlRec.UrlName, Length(UrlRec.UrlName), 1);   // Now add the path and name   for I := 1 to UrlRec.Level do     S := S + '    '; ///  BmkList.Add('Level: ' + IntToStr(UrlRec.Level));   BmkList.Add(S + '<DT><A HREF="' + UrlRec.UrlPath + '">' +               UrlRec.UrlName + '</A>' + ' '); end; function SortFunction(Item1, Item2: Pointer): Integer; // Function to sort the list of favorites alphabetically var   Rec1, Rec2: PUrlRec; begin   Result := 0;   Rec1 := Item1;   Rec2 := Item2;   if Rec1.Rep < Rec2.Rep then Result := -1;   if Rec1.Rep > Rec2.Rep then Result := 1;   if Rec1.Rep = Rec2.Rep then   begin     if Rec1.UrlName < Rec2.UrlName then Result := -1;     if Rec1.UrlName > Rec2.UrlName then Result := 1;     if Rec1.UrlName = Rec2.UrlName then Result := 0;   end; end; procedure TMainForm.Button1Click(Sender: TObject); var   I: Integer; begin   FavList := TList.Create;   GetFavoritesFolder;   if FavFolder <> '' then   begin     SearchURL(FavFolder, 1);      // Get all links     FavList.Sort(SortFunction);   // Sort the resulting list     MakeBookmarkFile;             // Make bookmark file from links   end;   // Clean up   for I := 0 to FavList.Count -1 do     Dispose(PUrlRec(FavList));   FavList.Free;   // Open the new bookmark file if user wants it   if CheckBox1.Checked then     if ShellExecute(Application.MainForm.Handle, nil, PChar(Edit1.Text),                     nil, nil, SW_SHOWNORMAL) <= 32 then       MessageDlg('Error: Could not start your Internet browser.', mtError, [mbOk], 0); // Alternatively you could use ExecuteFile end; procedure TMainForm.Button2Click(Sender: TObject); begin   Close; end; procedure TMainForm.Button3Click(Sender: TObject); begin   AboutBox.ShowModal; end; end.

刀剑如梦 · 2004-02-25

unit B2FMain; interface uses   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,   StdCtrls, Registry; type   // Record for use as list element   PUrlRec = ^TUrlRec;   TUrlRec = record     Rep:     String;         // Folder name (folders and links)     UrlName: String;         // Logical URL name (links only)     UrlPath: String;         // www URL name (links only)     Level: Integer;          // Folder level (position in folder tree)   end; type   TMainForm = class(TForm)     Button1: TButton;     Button2: TButton;     Button3: TButton;     Label1: TLabel;     Edit1: TEdit;     Label2: TLabel;     Edit2: TEdit;     OpenDialog1: TOpenDialog;     Button4: TButton;     procedure Button1Click(Sender: TObject);     procedure Button2Click(Sender: TObject);     procedure Button3Click(Sender: TObject);     procedure Button4Click(Sender: TObject);   private     BookmarkList: TStringList;     L: TList;     LastFolder: String;     TargetFolder: String;     LvlList: TStringList;     procedure GetFavoritesFolder(var Folder: String);     procedure Convert(Folder: String);     procedure ScanBmkLine(I: Integer; Lvl: Integer);     function FindFolder(HtmlStr: String; var Lvl: Integer): Boolean;     function FindUrl(HtmlStr: String; Lvl: Integer): Boolean;     function FindSectionEnd(HtmlStr: String; var Lvl: Integer): Boolean;     procedure MakeFavorites;     function MakeFolder(Folder: String): Boolean;     function MakeUrlFile(UrlName, UrlPath: String): Boolean;     procedure ReplaceIllChars(var S: String);   end; var   MainForm: TMainForm; implementation {$R *.DFM} uses   IniFiles, B2FAbout; {---------------------- TMainForm ---------------------} procedure TMainForm.GetFavoritesFolder(var Folder: String); // Find the directory of the Internet Explorer favorites var   Registry: TRegistry; begin   Registry := TRegistry.Create;   Registry.RootKey := HKEY_CURRENT_USER;   Registry.OpenKey('Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders', False);   Folder := Registry.ReadString('Favorites');   Registry.Free; end; function SortFunction(Item1, Item2: Pointer): Integer; // Function to sort the list of bookmarks alphabetically var   Rec1, Rec2: PUrlRec; begin   Result := 0;   Rec1 := Item1;   Rec2 := Item2;   if Rec1.Rep < Rec2.Rep then Result := -1;   if Rec1.Rep > Rec2.Rep then Result := 1;   if Rec1.Rep = Rec2.Rep then   begin     if Rec1.UrlName < Rec2.UrlName then Result := -1;     if Rec1.UrlName > Rec2.UrlName then Result := 1;     if Rec1.UrlName = Rec2.UrlName then Result := 0;   end; end; procedure TMainForm.Convert(Folder: String); var   I: Integer; begin   L := TList.Create;   LvlList := TStringList.Create;   LvlList.Add('');   try     ScanBmkLine(0, 0);       // Find all bookmarks recursively   finally     L.Sort(SortFunction);    // Sort the resulting list     MakeFavorites;           // Make favorites from the list     // Clean up     for I := 0 to L.Count -1 do       Dispose(PUrlRec(L));     L.Free;     LvlList.Free;   end; end; procedure TMainForm.ScanBmkLine(I: Integer; Lvl: Integer); // Recursive method to scan all lines in the bookmark file begin   if I < BookmarkList.Count -1 then   begin     if not FindSectionEnd(BookmarkList, Lvl) then       if not FindUrl(BookmarkList, Lvl) then         FindFolder(BookmarkList, Lvl);     ScanBmkLine(I+1, Lvl);   end; end; function TMainForm.FindFolder(HtmlStr: String; var Lvl: Integer): Boolean; // Retrive folder name (if any) from HTML string const   FolderSubStr: String = '<H3'; var   J, Idx: Integer;   S: array[0..255] of Char;   UrlRec: PUrlRec;   I: Integer;   Folder: String;   FName: String; begin   J := Pos(FolderSubStr, HtmlStr);   Result := (J <> 0);   if J <> 0 then             // Substring found, retrieve folder name   begin     Inc(Lvl);                // 1 level up     FillChar(S, SizeOf(S), 0);     Idx := 1;     for J := 1 to Length(HtmlStr)-1 do       if HtmlStr[J] = '>' then         Idx := J+1;     for J := Idx to Length(HtmlStr)-5 do       S[J-Idx] := HtmlStr[J];     Folder := S;     ReplaceIllChars(Folder);     if LvlList.Count > Lvl then       LvlList[Lvl] := Folder          // Replace folder hierarchy     else       LvlList.Add(Folder);     FName := LvlList[Lvl];     for I := Lvl-1 downto 1 do       FName := LvlList + '/' + FName; //    FName := FName + '/' + Folder;     // Finally store a record with the data     UrlRec := New(PUrlRec);     UrlRec.Rep := FName;     UrlRec.UrlName := '';     UrlRec.UrlPath := '';     UrlRec.Level := Lvl;     L.Add(UrlRec);   end; end; function TMainForm.FindUrl(HtmlStr: String; Lvl: Integer): Boolean; // Retrive URL name and path (if any) from HTML string const   UrlSubStr: String = 'http://'; var   J, K: Integer;   S1, S2, S3: array[0..255] of Char;   Apo1, Apo2: PChar;   I: Integer;   SPath, SName: String;   FName: String;   UrlRec: PUrlRec; begin   J := Pos(UrlSubStr, HtmlStr);   Result := (J <> 0);   if J <> 0 then             // Substring found, retrieve URL path   begin     FillChar(S1, SizeOf(S1), 0);     FillChar(S2, SizeOf(S2), 0);     FillChar(S3, SizeOf(S3), 0);     SPath := HtmlStr;     Apo1 := StrScan(PChar(SPath), '"');     // Requires " !!!!!     for K := 1 to StrLen(Apo1) do       S1[K-1] := Apo1[K];     for K := 0 to Pos('"', S1) -2 do       S2[K] := S1[K];     SPath := S2;     // SPath should now hold the proper URL path     // Now retrieve URL name     Apo2 := StrScan(Apo1, '>');     for K := 1 to StrLen(Apo2) do       S1[K-1] := Apo2[K];     for K := 0 to Pos('<', S1) -2 do       S3[K] := S1[K];     // Convert illegal characters     SName := S3;     ReplaceIllChars(SName);     FName := LvlList[Lvl];     for I := Lvl-1 downto 1 do       FName := LvlList + '/' + FName;     // Finally store a record with the data     UrlRec := New(PUrlRec);     UrlRec.Rep := FName;     UrlRec.UrlName:= SName;     UrlRec.UrlPath := SPath;     UrlRec.Level := Lvl;     L.Add(UrlRec);   end; end; function TMainForm.FindSectionEnd(HtmlStr: String; var Lvl: Integer): Boolean; // Return whether the current section ends const   EndSubStr: String = '</DL>'; var   J, Idx: Integer;   UrlRec: PUrlRec; begin   J := Pos(EndSubStr, HtmlStr);   Result := (J <> 0);   if J <> 0 then             // Substring found, end of section   begin     Dec(Lvl);                // 1 level down   end; end; procedure TMainForm.MakeFavorites; // Create the favorites and their folders var   I: Integer;   UrlRec: PUrlRec; begin   for I := 0 to L.Count -1 do   begin     UrlRec := L;     if UrlRec.UrlName = '' then       MakeFolder(TargetFolder + '/' + UrlRec.Rep)     else       MakeUrlFile(TargetFolder + '/' + UrlRec.Rep + '/' {+IntToStr(UrlRec.Level)+' - '} + UrlRec.UrlName + '.url', UrlRec.UrlPath);   end; end; function TMainForm.MakeFolder(Folder: String): Boolean; begin   CreateDirectory(PChar(Folder), nil); end; function TMainForm.MakeUrlFile(UrlName, UrlPath: String): Boolean; var   UrlFile: TIniFile; begin   { A URL-file has the structure of an INI-file with just one section.     Create the file as an INI-file and save the URL path. }   UrlFile := TIniFile.Create(UrlName);   UrlFile.WriteString('InternetShortcut', 'URL', UrlPath);   UrlFile.Free; end; procedure TMainForm.ReplaceIllChars(var S: String); { Replace illegal chars in filenames. This is necessary since   Internet Explorer stores the names as files and folders. } const   ReplacedChar: Char = '-'; var   I: Integer; begin   for I := 1 to Length(S) do     if S in ['/', '/', ':', '*', '?', '"', '<', '>', '|'] then       S := ReplacedChar; end; procedure TMainForm.Button1Click(Sender: TObject); var   R: TSearchRec;   FavFolder: String;         // Path of the favorites folder begin   if not FileExists(Edit2.Text) then   begin     MessageDlg('The bookmark file you specified does not exist.',                mtError, [MbOk], 0);     Edit2.SetFocus;   end   else   begin     BookmarkList := TStringList.Create;     // Load the bookmarks into the stringlist     BookmarkList.LoadFromFile(Edit2.Text);     GetFavoritesFolder(FavFolder);     if FavFolder <> '' then     begin       // First make the appropriate favorites subfolder       CreateDirectory(PChar(FavFolder+'/'+Edit1.Text), nil);       // Make sure the folder actually exists       if FindFirst(FavFolder+'/'+Edit1.Text, faDirectory, R) = 0 then       begin         // Now convert all the bookmark links         TargetFolder := FavFolder+'/'+Edit1.Text;         Convert(FavFolder+'/'+Edit1.Text);         MessageDlg('The bookmarks have been copied to your favorites.',                    mtInformation, [MbOk], 0);       end       else       begin         MessageDlg('The subfolder name you specified is invalid.',                    mtError, [MbOk], 0);         Edit1.SetFocus;       end;       FindClose(R);     end;     BookmarkList.Free;   end; end; procedure TMainForm.Button2Click(Sender: TObject); begin   Close; end; procedure TMainForm.Button3Click(Sender: TObject); begin   AboutBox.ShowModal; end; procedure TMainForm.Button4Click(Sender: TObject); begin   if OpenDialog1.Execute then     Edit2.Text := OpenDialog1.FileName; end; end.

刀剑如梦 · 2004-02-25

unit B2FAbout; interface uses   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,   StdCtrls, ExtCtrls; type   TAboutBox = class(TForm)     Button1: TButton;     Image1: TImage;     Version: TLabel;     Author: TLabel;     Freeware: TLabel;     Product: TLabel;     HtmlLink: TLabel;     procedure HtmlLinkClick(Sender: TObject);   end; var   AboutBox: TAboutBox; implementation {$R *.DFM} uses   ShellAPI; procedure TAboutBox.HtmlLinkClick(Sender: TObject); begin   ShellExecute(Application.MainForm.Handle, nil,                PChar('http://'+HtmlLink.Caption), nil, '.', SW_RESTORE); { Alternatively you could use:   ExecuteFile('http://'+HtmlLink.Caption, '.', 'c:/', SW_RESTORE);   Remember to get the FMXUtils unit from the Delphi Demo folder. } end; end.

最近在做收藏夹的软件,由于微软提供的ImportExportFavorites函数必须确认,所以我自己做了个,希望大家指正其中的错误(15分)

myqq

Unregistered / Unconfirmed

刀剑如梦

Unregistered / Unconfirmed

刀剑如梦

Unregistered / Unconfirmed

刀剑如梦

Unregistered / Unconfirmed

Similar threads