(RU) KinoExpert - http://www.kinoexpert.ru

REALexMSG · Post by **REALexMSG** » 2005-03-14 12:20:09

под новый ант версии 3.5.
за основу был взят скрипт НашеКино

(***************************************************

Ant Movie Catalog importation script
www.antp.be/software/moviecatalog/

[Infos]
Authors=REALexMSG (realexmsg@mail.ru) 2005
Title=KinoExpert.ru
Description=Import data from KinoExpert.ru
Site=http://www.kinoexpert.ru/
Language=RU
Version=1.01
Requires=3.5.0
Comments= модифицированный скрипт NasheKino
License=This program is free software; you can redistribute it and/or modify it under the  terms of the GNU General Public License as published by the Free Software Foundation;  either version 2 of the License, or (at your option) any later version. |
GetInfo=1

[Options]

***************************************************)

program KinoExpert;
const
  BaseAddress = 'http://www.kinoexpert.ru/';
var
  MovieName: string;

function TextBetween(var S: string; StartTag: string; EndTag: string): string;
var
  InitialPos: Integer;
begin
  InitialPos := Pos(StartTag, S);
  Delete(S, 1, InitialPos + Length(StartTag) - 1);
  InitialPos := Pos(EndTag, S);
  result := copy(S, 1, InitialPos - 1);
  Delete(S, 1, InitialPos + 1);
end;

function GetTextBlockFrom(Text: string; StartAt: string): string;
var
  TextBlock: string;
  StartPos, EndPos: Integer;
begin
  TextBlock := Text;
  StartPos := pos(StartAt, TextBlock);
  if StartPos > 0 then
  begin
    Delete(TextBlock, 1, StartPos - 1);
    result := TextBlock;
  end;
end;

function FindLine(Pattern: string; List: TStringList; StartAt: Integer): Integer;
var
  i: Integer;
begin
  result := -1;
  if StartAt < 0 then
    StartAt := 0;
  for i := StartAt to List.Count-1 do
    if Pos(Pattern, List.GetString(i)) <> 0 then
    begin
      result := i;
      Break;
    end;
end;

procedure AnalyzePage(Address: string);
var
  Page: TStringList;
  LineNr: Integer;
  Line: string;
  TextBlock: string;
begin
  Page := TStringList.Create;
  Page.Text := GetPage(Address);
  if pos('></td></tr><tr><td><a ', Page.Text) = 0 then
  begin
    ShowMessage('No movies found');
  end else
  begin
    PickTreeClear;
    LineNr := FindLine('</b></td></tr><tr><td><', Page, 0);
    if LineNr > -1 then
    begin
      PickTreeAdd('Movies', '');
      AddMoviesTitles(Page, LineNr);
    end;
    if PickTreeExec(Address) then
      SetField(fieldURL, Address);
      Page.Free;
      Page := TStringList.Create;
      Page.Text := GetPage(Address);
      AnalyzeMoviePage(Page);
  end;
  Page.Free;
end;

procedure AnalyzeMoviePage(Page: TStringList);
var
  Value, Value1, Value2, Value3, PageText, Text: string;
  LineNr, MovieLength: Integer;
  BeginPos, EndPos: Integer;
begin

// Original Title and Translated Title and Country
  PageText := GetTextBlockFrom( Page.Text, '="#666633' );
  if Length(PageText) > 0 then
  begin
    EndPos := pos('="#666633',PageText) +10;
    Delete(PageText, 1, EndPos);

    EndPos := pos('</b></font', PageText);
    Value := copy(PageText, 1, EndPos);

    EndPos := pos('</font>',PageText) -1;
    Value1 := copy(PageText,1,EndPos);
    Delete(PageText, 1, EndPos);
    Value2 := Value1;

    if pos(' / ', Value) > 1 then
     begin
       EndPos := pos('#666633',PageText) +7;
       Delete(PageText, 1, EndPos);
       EndPos := pos('</font><b><', PageText)-1;
       Value2 := copy(PageText, 1, EndPos);
     end;

    EndPos := pos('<BR>',PageText) +3;
    Delete(PageText, 1, EndPos);
    EndPos := pos('</b></font', PageText)-1;
    Value3 := copy(PageText, 1, EndPos);

    SetField(fieldOriginalTitle, Value2);
    SetField(fieldTranslatedTitle, Value1);
    SetField(fieldCountry, Value3);

    Delete(PageText, 1, EndPos);
// Year
    EndPos := pos('<BR>', PageText) +4;
    Delete(PageText, 1, EndPos);
    EndPos := pos('#00', PageText) +8;
    Delete(PageText, 1, EndPos);
    Value := copy(PageText,1,4);
    SetField(fieldYear, Value);
  end;

// Actors
  PageText := GetTextBlockFrom( Page.Text, 'В ролях:' );
  if Length(PageText) > 0 then
  begin
    EndPos := pos('title=', PageText) +6;
    Delete(PageText, 1, EndPos);
    EndPos := pos('<b>', PageText);
    Value := copy(PageText,1,EndPos);
    Value2 := '';
    repeat
      if length(Value2) > 0 then Value2 := Value2 + ', ';
      EndPos := pos('</a>', Value) -1;
      Value1 := copy (Value, 1, EndPos);
      Delete (Value, 1, pos('</a>', Value) -1);
      Delete (Value, 1, pos('title=', Value) +6);

      if copy(Value1,2,1) = '>' then
         begin
          Value1 := copy(Value1,3,length(Value1)-2);
         end
        else
         begin
          if pos('>', Value1) >1 then Value1 := copy(Value1, pos('>',Value1) +1, length(Value1) -pos('>',Value1)) +' /' + copy(Value1, 1, pos('>',Value1) -2) +'/';
         end;
      Value2 := Value2 + Value1;
    until pos('</a>', Value) < 1;
    SetField(fieldActors, Value2);
  end;

// Director
  PageText := GetTextBlockFrom( Page.Text, 'Режиссер:<' );
  if Length(PageText) > 0 then
  begin
    EndPos := pos('title=', PageText) +6;
    Delete(PageText, 1, EndPos);
    EndPos := pos('</a>', PageText)-1;
    Value := copy(PageText,1,EndPos);
    if copy(Value,2,1) = '>' then
       begin
        Value := copy(Value,3,length(Value)-2);
       end
      else
       begin
        if pos('>', Value) >1 then Value := copy(Value, pos('>',Value) +1, length(Value) -pos('>',Value)) +' /' + copy(Value, 1, pos('>',Value) -2) +'/';
       end;
    SetField(fieldDirector, Value);
  end;

// Description
  PageText := GetTextBlockFrom( Page.Text, 'Краткое содержание' );
  if Length(PageText) > 0 then
  begin
    EndPos := pos(':</b><br>', PageText) +8;
    Delete(PageText, 1, EndPos);
    EndPos := pos('</div><BR>', PageText) -1;
    Value := copy(PageText, 1, EndPos);
    HTMLDecode(Value);
    Value := StringReplace(Value, '<br>', #13#10);
    Value := StringReplace(Value, '<p', #13#10#13#10 + '<p');
    HTMLRemoveTags(Value);
    SetField(fieldDescription, Value);
  end;

// Category
  PageText := GetTextBlockFrom( Page.Text, 'Жанр</b></td>' );
  if Length(PageText) > 0 then
  begin
    EndPos := pos('008000', PageText);
    Delete(PageText, 1, EndPos);
    Delete(PageText, 1, EndPos);
    EndPos := pos('008000', PageText) +7;
    Delete(PageText, 1, EndPos);
    EndPos := pos('&nbsp', PageText) -1;
    Value := copy(PageText, 1, EndPos);
    HTMLDecode(Value);
    HTMLRemoveTags(Value);
    SetField(fieldCategory, Value);
  end;

end;

procedure AddMoviesTitles(Page: TStringList; var LineNr: Integer);
var
  Line: string;
  MovieTitle, MovieAddress, AddrPrefix: string;
  StartPos, EndPos: Integer;
begin

    Line := Page.GetString(LineNr);

  repeat  
    StartPos := pos('href=', Line) +6;
    EndPos := pos('#1"', Line) +2;
    MovieAddress := copy(Line, StartPos,  EndPos - StartPos);
    MovieTitle := copy(Line, EndPos+2, pos('</td><td>', Line) - EndPos-2);
    HTMLDecode(Movietitle);
    HTMLRemoveTags(MovieTitle);
    MovieTitle:= StringReplace(MovieTitle, '     ', '');
    PickTreeAdd(MovieTitle, BaseAddress + MovieAddress);
    Delete (Line, 1, EndPos);
    Delete (Line, 1, pos('</td></tr>', Line) );
  until pos ('</td></tr>', Line) <1;

end;

begin
  if CheckVersion(3,5,0) then
  begin
    MovieName := GetField(fieldOriginalTitle);
    if MovieName = '' then
      MovieName := GetField(fieldTranslatedTitle);

    if Input('Import from KinoExpert', 'Enter the title of the movie:', MovieName) then
    begin
      AnalyzePage('http://www.kinoexpert.ru/index.asp?comm=1&kw='+UrlEncode(MovieName)+'&fop=false&pack=0#1');
    end;
  end else
  ShowMessage('This script requires a newer version of Ant Movie Catalog (at least the version 3.5.0)');
end.

Post by **antp** » 2005-03-14 13:05:49

I added

Code: Select all

 tags ;)
There was already a script for this site with AMC, what's new with this script?

REALexMSG · Post by **REALexMSG** » 2005-03-14 14:04:08

Thank you for tags :-)

What's new - hmmm - more correct processing of various combinations of answers of this server (actors, answers to foreign films, etc.) When I wrote my script, I did not know that already there is a script for this server :-)

Post by **antp** » 2005-03-14 16:29:49

OK, I'll include it instead of the current one if you're sure that yours is more complete

Post by **antp** » 2005-03-14 16:31:34

One problem : I can't copy/paste russian unicode text to a simple text file (my Windows is configured for western europe). Can you send it to me by e-mail plase ?

REALexMSG · Post by **REALexMSG** » 2005-03-15 09:56:41

yea
sent file by email

Norst · Post by **Norst** » 2006-08-28 19:01:19

The following script works incorrently (is invalid) due to site update. New version (modified REALexMSG script) - download

Post by **antp** » 2006-08-28 19:58:52

Thanks. I uploaded it to www.antp.be/temp/scripts so other people can download it easier