40tude Dialog: Export Script for current group or folder (including Sent)

After the quick & dirty solution I created yesterday for Mickey follows here
a bit more sophisticated script version. It still does not (can not!) take
all eventualities into account. But in trying to recreate an envelope-From
(with specific settings mentioned in the comment header of the script) and
escaping (including already escaped) occurrences of "From " inside the
body text (only after empty lines) it also can be used to export into more
or less *.mbox compatible files. (Even from Sent folder, which is excluded
from normal *.mbox export in Dialog.)

Maybe, this script is useful for some other Dialog users, as well...  ;-)
Bernd

-----------------------------------------------------------------------------

// Export messages from current Dialog folder to text file.
//
// View and filter settings are respected. Collapsed threads are
// (temporarily) expanded to include all messages.
//
// Empty messages (= without body etc.) are skipped. If the last
// message in the current header list is empty, the export is
// likely to be incomplete. (Stops at the first _other_ message
// without body.)
//
// Appropriate message viewing options should be activated before
// executing the script (= "text/plain" with "Show all Headers" or
// "Raw message view" activated or off).
//
// Settings [DividerChar = ' '], [EmptyRows = 0] and [IsRaw = True]
// should create an (more or less) *.mbox-compatible file, when the
// "Raw message view" style is activated prior to the export. 
// ("Show all message headers" style for Sent folder.)

Program ExportMessages;
Uses
  StdCtrls, Forms, Textfile;

Const
  FilePath = 'C:\Temp\';       // include backslash last character
  FileExtension = '.txt';      // include leading dot character
  FileNamePrefix = '4D_';
  DividerChar = '=';   // use ' ' for omitting (EmptyRows will only applied once)
  EmptyRows = 1;       // number of empty rows prior and after divider line
  IsRaw = False;       // True: swap rows 1 and 2 (to get From before Path)
  SeeProgress = True;  // False: display updates are disabled
                       // (faster, but somewhat intrasparent)

Var
  iCount: Integer;
  iCountEmpty: Integer;
  bFirst: Boolean;
  bLastIsEmpty: Boolean;
  sGroupName: String;
  sFileName: String;
  sDateTime: String;
  sDivider: String;
  txtForm: TForm;
  txtMemo: TMemo;
  txtMemo_Last: TMemo;
  txtMemo_Print: TMemo;
  sMsg: String;

Function EmptyClipboard:boolean; external 'EmptyClipboard@user32.dll stdcall';
Function OpenClipboard(hWndNewOwner: INTEGER):boolean; external 'OpenClipboard@user32.dll stdcall';
Function CloseClipboard:boolean; external 'CloseClipboard@user32.dll stdcall';

Procedure ClearClipboard;
Begin
 OpenClipboard(0);
 EmptyClipboard;
 CloseClipboard;
end;

Procedure InitMemos;
Begin
  txtForm := TForm.Create(Nil);
  txtMemo := TMemo.Create(txtForm);
  txtMemo.Parent := txtForm;
  txtMemo.Width := 30000;   // max [pixels] (reduces auto-wrap for long lines)
  txtMemo_Last := TMemo.Create(txtForm);
  txtMemo_Last.Parent := txtForm;
  txtMemo_Last.Width := 30000;
  txtMemo_Print := TMemo.Create(txtForm);
  txtMemo_Print.Parent := txtForm;
  txtMemo_Print.Width := 30000;
End;

Function DividerLines(): String;
var
  iCnt: Integer;
  sTmp: String;
Begin
  For iCnt := 1 To EmptyRows Do
    sTmp := sTmp + #13 + #10;
  If DividerChar = ' ' Then
    Result := sTmp + #13 + #10
  Else
    Result := sTmp + StringOfChar(DividerChar, 80) + sTmp + #13 + #10;
End;

Function GetGroupName(): String;
Var
  sTmp: String;
  iPos: Integer;
Begin
  ADo('NewgroupPane');
  ClearClipboard;
  ADo('Copy');
  txtMemo.Clear;
  txtMemo.PasteFromClipboard;
  sTmp := txtMemo.Lines[0];
  Repeat
    iPos := Pos(#09, sTmp);
    sTmp := Copy(sTmp, iPos + 1, Length(sTmp) - iPos);
  Until iPos = 0;
  Result := sTmp;
End;

Procedure InitPrintMemo;
Var
  iRow: Integer; 
  iCnt: Integer;
  iLength: Integer;
  bEmpty: Boolean;
  sPrefix: String;
  sFrom: String;
  sDate: String;
Begin
  txtMemo_Print.Text := txtMemo.Text;
  If IsRaw Then
    Begin
      bEmpty := False;
      // Escape Pseudo-Envelope-From in message body
      For iRow := 0 To txtMemo.Lines.Count - 1 Do
        Begin
          iLength := Length(txtMemo.Lines[iRow]);
          If bEmpty And (iLength > 4) Then
            For iCnt := iLength - 4 DownTo 0 Do
              Begin
                sPrefix := StringOfChar('>', iCnt) + 'From '
                If Pos(sPrefix, txtMemo.Lines[iRow]) = 1 Then
                  Begin
                    txtMemo_Print.Lines[iRow] := '>' + txtMemo.Lines[iRow];
                    Break;
                  End;
              End;
          bEmpty := iLength = 0;
        End;
      // Try to recreate an Envelope-From:
      For iRow := 0 To txtMemo.Lines.Count - 1 Do
        If Pos('From: ', txtMemo.Lines[iRow]) = 1 Then
          Begin
            sFrom := txtMemo.Lines[iRow];
            sFrom := 'From ' + Copy(sFrom, 7, Length(sFrom) - 6);
            Break;
          End;
      For iRow := 0 To txtMemo.Lines.Count - 1 Do
        If Pos('Date: ', txtMemo.Lines[iRow]) = 1 Then
          Begin
            sDate := txtMemo.Lines[iRow];
            sDate := Copy(sDate, 7, Length(sDate) - 6);
            Break;
          End;
      txtMemo_Print.Lines.Insert(0, sFrom + ' ' + sDate);
    End;
End;

Procedure WriteTxtFile;
Var
  txtFile: TextFile;
Begin
  AssignFile(txtFile, sFileName); 
  If FileExists(sFileName)
    Then Append(txtFile)
    Else Rewrite(txtFile);
  If Not bFirst Then TextWrite(txtFile, sDivider);
  InitPrintMemo;
  TextWrite(txtFile, txtMemo_Print.text);
  CloseFile(txtFile);
End;

Begin
  InitMemos;
  iCount := 0;
  iCountEmpty := 0;
  bFirst := True;
  sDivider := DividerLines();
  sGroupName := GetGroupName();
  If Not SeeProgress Then LockDisplay;
  sDateTime := FormatDateTime('yyyymmdd_hhnn', Now);
  sFileName := FilePath + FileNamePrefix + sGroupName + '_' + sDateTime + FileExtension;
  txtMemo.Clear;
  txtMemo.Lines.Add(StringOfChar('§', 20) + ' DUMMY ' + StringOfChar('§', 20));

  Try
    ADo('ExpandAllThreads');
    ADo('ArticlePane');
    ADo('LastMessage');
    ADo('SelectAll');
    ClearClipboard;
    Ado('Copy');
    txtMemo_Last.Clear;
    txtMemo_Last.PasteFromClipboard;
    bLastIsEmpty := txtMemo_Last.Lines.Count = 0;
    If bLastIsEmpty Then
        txtMemo_Last.Lines.Add(StringOfChar('§', 20) + ' EMPTY MESSAGE ' + StringOfChar('§', 20));
    ADo('FirstMessage');
    While txtMemo.Text <> txtMemo_Last.Text Do
      Begin
        If Not bFirst Then ADo('NextMessage');
        ADo('SelectAll');
        ClearClipboard;
        Ado('Copy');
        txtMemo.Clear;
        txtMemo.PasteFromClipboard;
        If txtMemo.Lines.Count = 0 Then
          Begin
            txtMemo.Lines.Add(StringOfChar('§', 20) + ' EMPTY MESSAGE ' + StringOfChar('§', 20));
            iCountEmpty := iCountEmpty + 1;
          End
        Else
          WriteTxtFile;
        iCount := iCount + 1;
        bFirst := False;
      End;
  Finally
    // Clean up (Expanded thread state likely differs from start situation,
    // but the thread list should at least look reasonably tidy...)
    ADo('CollapseAllThreads');
    ADo('FirstMessage');
    UnlockDisplay;
    txtForm.Free;
  End;
  sMsg := IntToStr(iCount) + ' messge(s) exported to: ' + #10 + sFileName;
  sMsg := sMsg + #10+#10 + IntToStr(iCountEmpty) + ' empty message(s) [= without body etc.] skipped.';
  Application.MessageBox(sMsg, 'Export finished', 0);
  If bLastIsEmpty Then
    Begin
      sMsg := 'Please note: Last message in list was empty.' + #10 + 'Therefore, the export is probably incomplete.';
      Application.MessageBox(sMsg, 'Warning!', 1);
    End;
End.