mbxsub1.pas

ics Internet 控件

        Month := 8
    else if Token = 'sep' then
        Month := 9
    else if Token = 'oct' then
        Month := 10
    else if Token = 'nov' then
        Month := 11
    else if Token = 'dec' then
        Month := 12
    else
        raise Exception.Create('Invalid month name: ' + S);

    // get year
    GetToken(' ', P, Token);
    Year := StrToInt(Trim(Token));

    Result := EncodeDate(Year, Month, Day);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TAppBaseForm.ScanButtonClick(Sender: TObject);
var
    Subject         : String;
    Token           : String;
    List            : String;
    EMail           : String;
    P               : PChar;
    MsgDate         : String;
    MsgCount        : Integer;
    NewCount        : Integer;
    FieldEMail      : TField;
    FieldSubDate    : TField;
//  FieldUnsDate    : TField;
//  FieldName       : TField;
begin
    Display('Scanning ' + MbxHandler1.FileName);
    PageControl1.ActivePage := ScanTabSheet;
    MsgCount                := 0;
    NewCount                := 0;
    EMailTable.Active       := TRUE;
    EMailTable.IndexName    := 'EMAIL';
    FieldEMail              := EMailTable.FieldByName('EMail');
    FieldSubDate            := EMailTable.FieldByName('SubDate');
//  FieldName               := EMailTable.FieldByName('Name');
//  FieldUnsDate            := EMailTable.FieldByName('UnsDate');

    MbxHandler1.Active := TRUE;
    MbxHandler1.First;
    while not MbxHandler1.Eof do begin
        Inc(MsgCount);
        Subject := Extract('Subject');
//        Display(Subject);
        P := PChar(Subject);
        P := GetToken(' ', P, Token);
        Token := LowerCase(Trim(Token));
        if Token = 'subscribe' then begin
            P := GetToken(' ', P, List);
            List := LowerCase(Trim(List));
            if (List = 'twsocket') or
               (List = 'twsocket-announce') or
               (List = 'midware') then begin
                GetToken(' ', P, EMail);
                EMail := LowerCase(Trim(EMail));
if Copy(Email, 1, 5) = 'napol' then
    MessageBeep(MB_OK);
                EMailTable.SetKey;
                FieldEMail.AsString := EMail;
                EMailTable.GotoNearest;
                if FieldEMail.AsString <> EMail then begin
                    // Do not exists yet, will create
                    Inc(NewCount);
                    MsgDate := Extract('Date');
                    Display(List + ' ' + EMail);
                    EMailMemo.Lines.Add(EMail + ';');
                    EMailTable.Append;
                    FieldEMail.AsString := EMail;
                    FieldSubDate.AsString := FormatDateTime('YYYYMMDD', ExtractDate(MsgDate));
                    EMailTable.Post;
                end;
            end;
        end;
        MbxHandler1.Next;
    end;
    MbxHandler1.Active := FALSE;
    EMailTable.Active  := FALSE;
    Display('Done ' + IntToStr(MsgCount) + '/' + IntToStr(NewCount));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TAppBaseForm.Extract(Item : String) : String;
var
    P, Q, R : PChar;
begin
    Result := '';
    P := MbxHandler1.MsgStream.Memory;
    Q := StrPos(P, PChar(#13#10 + Item + ': '));
    if Q <> nil then begin
        R := StrPos(Q + 2, #13#10);
        if R > Q then begin
            SetLength(Result, R - Q - 2 - Length(Item) - 2);
            if Length(Result) > 0 then
                Move(Q[2 + Length(Item) + 2], Result[1], Length(Result));
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TAppBaseForm.PackTable(aTable : TTable);
var
    Status : Integer;
begin
    aTable.Active    := FALSE;
    aTable.Exclusive := TRUE;
    aTable.Active    := TRUE;

    Status := DbiPackTable(aTable.DataBase.Handle,
                           aTable.Handle,
                           nil, nil, TRUE);

    if Status <> DBIERR_NONE then
        DbiError(Status);
    aTable.Active := FALSE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TAppBaseForm.CreateDataTable;
var
    Table : TTable;
begin
    Table := TTable.Create(nil);
    try
        Table.TableType    := ttDBase;
        Table.DatabaseName := FDatabaseName;
        Table.TableName    := FTableName;
        with Table.FieldDefs do begin
            Clear;

            Add('SubDate',    ftString, 8,                              FALSE);
            Add('UnsDate',    ftString, 8,                              FALSE);
            Add('EMail',      ftString, 64,                             FALSE);
            Add('Name',       ftString, 64,                             FALSE);
        end;

        // A bug in D3 prevent us from defining the indexes before calling
        // CreateTable. We will just add the indexes after creation.
        Table.CreateTable;
        Table.AddIndex('EMail',   'EMAIL+SUBDATE', [ixExpression]);
        Table.AddIndex('SubDate', 'SUBDATE', []);

    finally
        Table.Free;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// Replace any existing file extension, or add an extension is none exists.
// The extension is a 3 digits number, with leading zeros, build to make
// it unique. Numbering start at 001 and increment until an unused number
// is found. If 1000 is reached, then an exception will be triggered.
function RenameToNumberedFile(From : String) : String;
var
    FPath                : String;
    FDir                 : String;
    FName                : String;
    FExt                 : String;
    FBaseName            : String;
    FileHandle           : DWORD;
    Count                : Integer;
begin
    FExt  := ExtractFileExt(From);
    FName := Copy(From, 1, Length(From) - Length(FExt));
    FName := ExtractFileName(FName);
    FDir  := ExtractFilePath(From);
    if FDir[Length(FDir)] <> '\' then
        FDir := FDir + '\';

    Count := 1;
    while TRUE do begin
        FBaseName := FName + '.' + Format('%3.3d', [Count]);
        FPath     := FDir + FBaseName;
        FileHandle := CreateFile(PChar(FPath),
                                 GENERIC_READ or GENERIC_WRITE,
                                 0,                                // ShareMode
                                 nil,                              // SecurityAttributes
                                 OPEN_EXISTING,
                                 FILE_ATTRIBUTE_NORMAL,
                                 0);                               // TemplateFile
        if FileHandle = INVALID_HANDLE_VALUE then begin
            RenameFile(From, FPath);
            Result := FPath;
            Exit;
        end;
        // File exists, close it and continue
        Windows.CloseHandle(FileHandle);

        // Be sure to not loop forever here !
        Inc(Count);
        if Count >= 1000 then
            raise Exception.Create('RenameToNumberedFile failed');
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function GetToken(pDelim : PChar; Src : PChar; var Dst : String): PChar;
var
    FldSep  : Char;
    RecSep  : Char;
begin
    Dst    := '';
    if Src = nil then begin
        Result := nil;
        Exit;
    end;

    FldSep := pDelim[0];
    RecSep := pDelim[1];
    Result := Src;

    while (Result^ <> FldSep) and (Result^ <> RecSep) do begin
        Dst := Dst + Result^;
        Inc(Result);
    end;
    Inc(Result);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TAppBaseForm.PageControl1Change(Sender: TObject);
begin
    if PageControl1.ActivePage = ViewTabSheet then begin
        EMailTable.Active := TRUE;
        SelectIndex;
    end
    else
        EMailTable.Active := FALSE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TAppBaseForm.SelectIndex;
begin
    if SortByEmailRadioButton.Checked then
        EMailTable.IndexName := 'EMAIL'
    else
        EMailTable.IndexName := 'SUBDATE';
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TAppBaseForm.FindEditChange(Sender: TObject);
var
    FldName : String;
begin
    if not EMailTable.Active then
        Exit;
    SelectIndex;
    if SortByEmailRadioButton.Checked then
        FldName := 'EMAIL'
    else
        FldName := 'SUBDATE';
    EMailTable.SetKey;
    EMailTable.FieldByName(FldName).AsString := LowerCase(Trim(FindEdit.Text));
    EMailTable.GotoNearest;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TAppBaseForm.SortByDateRadioButtonClick(Sender: TObject);
begin
    SelectIndex;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TAppBaseForm.SortByEmailRadioButtonClick(Sender: TObject);
begin
    SelectIndex;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TAppBaseForm.BrowseButtonClick(Sender: TObject);
var
    IniFile         : TIniFile;
begin
    OpenDialog1.DefaultExt := 'mbx';
    OpenDialog1.InitialDir := ExtractFilePath(MbxHandler1.FileName);
    OpenDialog1.FileName   := ExtractFileName(MbxHandler1.FileName);
    OpenDialog1.Filter     := 'Mailbox files (*.mbx)|*.mbx|All files (*.*)|*.*';
    if not OpenDialog1.Execute then
        Exit;
    MbxHandler1.Close;
    MbxHandler1.FileName := OpenDialog1.FileName;
    IniFile := TIniFile.Create(FIniFileName);
    IniFile.WriteString(SectionData, KeyMbxFile, MbxHandler1.FileName);
    IniFile.Free;
    Caption := 'MbxSub - ' + ExtractFileName(MbxHandler1.FileName);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

end.