main.pas

来自「Drag files and Drop to delphi forms 0402」· PAS 代码 · 共 796 行 · 第 1/2 页

    StatusBar1.Panels[0].Text := 'Reading file from FTP server...';
    Update;

    FWriteStream := TFifoStream.CreateForWrite(RingBuffer);
    try
      FWriteStream.FakeWriteDuringAbort := True;

      IdFTP1.Get(Filename, FWriteStream);
    finally
      FWriteStream.Abort;
      FreeAndNil(FWriteStream);
    end;
  finally
    ProgressBar1.Hide;
    StatusBar1.Panels[0].Text := '';
    EndTransfer;
  end;
end;

procedure TFormMain.MsgProgress(var Message: TMessage);
begin
  SetProgress(Message.WParam, Message.LParam);
end;

procedure TFormMain.SetProgress(Count, MaxCount: integer);
begin
  // Make sure GUI updates are performed in the main thread.
  if (GetCurrentThreadID <> MainThreadID) then
  begin
    PostMessage(Handle, MSG_PROGRESS, Count, MaxCount);
    exit;
  end;

  ProgressBar1.Max := MaxCount;
  ProgressBar1.Position := Count;
end;

procedure TFormMain.MsgStatus(var Message: TMessage);
begin
  SetStatus(TDragDropStage(Message.WParam));
end;

procedure TFormMain.SetStatus(const Value: TDragDropStage);
var
  s: string;
begin
  // Make sure GUI updates are performed in the main thread.
  if (GetCurrentThreadID <> MainThreadID) then
  begin
    PostMessage(Handle, MSG_STATUS, ord(Value), 0);
    exit;
  end;

  if (FStatus <> Value) then
  begin
    FStatus := Value;
    case FStatus of
      dsIdle:
        s := 'Ready';
      dsDrag:
        s := 'Drag in progress';
      dsDragAsync:
        s := 'Asynchronous drag started';
      dsDragAsyncFailed:
        s := 'Asynchronous drag failed';
      dsDrop:
        s := 'Data dropped';
      dsGetData:
        s := 'Target reading data';
      dsGetStream:
        s := 'Source writing data';
      dsDropComplete:
        s := 'Drop completed';
    else
      s := '';
    end;

    StatusBar1.Panels[1].Text := s;
    Update;
  end;
end;

procedure TFormMain.ComboAddressKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = VK_RETURN) then
  begin
    Browse(ComboAddress.Text, [boBrowse, boUpdateCombo]);
  end;
end;

procedure TFormMain.ComboAddressCloseUp(Sender: TObject);
begin
  Browse(ComboAddress.Text);
end;

procedure TFormMain.Browse(const Address: string; Options: TBrowseOptions);
var
  i: Integer;
begin
  if (Address = '') then
    exit;

  if (boUpdateCombo in Options) then
  begin
    i := ComboAddress.Items.IndexOf(Address);
    if i = -1 then
      ComboAddress.Items.Insert(0, Address)
    else
      ComboAddress.Items.Move(i, 0);
  end;

  FAddress := Address;
  ComboAddress.Text := FAddress;

  if (boBrowse in Options) then
    PostMessage(Handle, MSG_BROWSE, ord(bkAddress), 0);
end;

procedure TFormMain.ActionBackUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled := (FHistoryIndex > 0) and (not Busy);
end;

procedure TFormMain.ActionBackExecute(Sender: TObject);
begin
  ComboAddress.Text := FHistoryList[FHistoryIndex-1];
  Browse(ComboAddress.Text);
end;

procedure TFormMain.ActionForwardUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled := (FHistoryIndex < FHistoryList.Count-1) and (not Busy);
end;

procedure TFormMain.ActionForwardExecute(Sender: TObject);
begin
  ComboAddress.Text := FHistoryList[FHistoryIndex+1];
  Browse(ComboAddress.Text);
end;

procedure TFormMain.ActionRefreshUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled := (ComboAddress.Text <> '') and (not Busy);
end;

procedure TFormMain.ActionRefreshExecute(Sender: TObject);
begin
  PostMessage(Handle, MSG_BROWSE, Ord(bkRefresh), 0);
end;

procedure TFormMain.ActionStopUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled := (not FAbort) and (Busy);
end;

procedure TFormMain.ActionStopExecute(Sender: TObject);
begin
  FAbort := True;
end;

procedure TFormMain.ActionUpUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled := (ComboAddress.Text <> '') and (not Busy);
end;

procedure TFormMain.ActionUpExecute(Sender: TObject);
begin
  PostMessage(Handle, MSG_BROWSE, Ord(bkUp), 0);
end;

procedure TFormMain.ActionHomeUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled := (not Busy);
end;

procedure TFormMain.ActionHomeExecute(Sender: TObject);
begin
  ComboAddress.Text := sAddressHome;
  Browse(ComboAddress.Text);
end;

procedure TFormMain.MsgBrowse(var Message: TMessage);
var
  URI: TIdURI;
  i: integer;
  SHFileInfo: TSHFileInfo;
  s: string;
  BrowseKind: TBrowseKind;
begin
  BrowseKind := TBrowseKind(Message.WParam);
  FAborted := False;
  BeginBusy;
  Screen.Cursor := crAppStart;
  try
    ListViewFiles.Items.Clear;

    URI := TIdURI.Create(AddTrailingSlash(FAddress));
    try
      if (IdFTP1.Host <> URI.Host) and (IdFTP1.Connected) then
      begin
        StatusBar1.Panels[0].Text := 'Disconnecting from '+IdFTP1.Host+'...';
        Update;
        IdFTP1.Disconnect;
      end;
      if (not IdFTP1.Connected) then
      begin
        StatusBar1.Panels[0].Text := 'Connecting to '+URI.Host+'...';
        Update;
        IdFTP1.Host := URI.Host;
        IdFTP1.Connect;
        // Can't go up or refresh when we have lost the connection
        BrowseKind := bkAddress;
      end;
      try
        if (FAborted) then
          Abort;
        case BrowseKind of
          bkAddress:
            begin
              StatusBar1.Panels[0].Text := 'Navigating to '+URI.Path+'...';
              Update;
              IdFTP1.ChangeDir(URI.Path);
            end;
          bkUp:
            begin
              StatusBar1.Panels[0].Text := 'Navigating to parent folder...';
              Update;
              IdFTP1.ChangeDirUp;
            end;
        end;
        if (FAborted) then
          Abort;

        URI.Path := IdFTP1.RetrieveCurrentDir;
        if (FAborted) then
          Abort;

        s := URI.URI;
        i := FHistoryList.IndexOf(s);
        if (i = -1) then
        begin
          { Remove entries in HistoryList between last address and current address }
          if (FHistoryIndex >= 0) and (FHistoryIndex < FHistoryList.Count-1) then
            while FHistoryList.Count-1 > FHistoryIndex do
              FHistoryList.Delete(FHistoryList.Count-1);
          FHistoryIndex := FHistoryList.Add(s);
        end else
          FHistoryIndex := i;

        Browse(s, []);

        StatusBar1.Panels[0].Text := 'Fetching '+URI.Path+'...';
        Update;
        IdFTP1.List(nil);
        if (FAborted) then
          Abort;

        ListViewFiles.Items.BeginUpdate;
        try
          for i := 0 to IdFTP1.DirectoryListing.Count -1 do
            with ListViewFiles.Items.Add do
            begin
              if (FAborted) then
                break;
              Caption := IdFTP1.DirectoryListing[i].FileName;
              SubItems.Add(DateTimeToStr(IdFTP1.DirectoryListing[i].ModifiedDate));
              SubItems.Add(SizeToStr(IdFTP1.DirectoryListing[i].Size));
              Data := pointer(IdFTP1.DirectoryListing[i].ItemType);
              ImageIndex := -1;
              case IdFTP1.DirectoryListing[i].ItemType of
                ditFile:
                  if (SHGetFileInfo(PChar(Caption), FILE_ATTRIBUTE_NORMAL, SHFileInfo, SizeOf(TSHFileInfo), SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX) <> 0) then
                    ImageIndex := SHFileInfo.iIcon;
                ditDirectory:
                  if (SHGetFileInfo(PChar(FTempPath), FILE_ATTRIBUTE_DIRECTORY or FILE_ATTRIBUTE_NORMAL, SHFileInfo, SizeOf(TSHFileInfo), SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX) <> 0) then
                    ImageIndex := SHFileInfo.iIcon;
              end;
            end;
        finally
          ListViewFiles.Items.EndUpdate;
          // Force recalc of auto size
          ListViewFiles.Width := ListViewFiles.Width+1;
        end;
        if (FAborted) then
          Abort;
      except
        IdFTP1.Disconnect;
        raise;
      end;
    finally
      URI.Free;
    end;
  finally
    StatusBar1.Panels[0].Text := '';
    Screen.Cursor := crDefault;
    EndBusy;
  end;
end;

procedure TFormMain.ListViewFilesDblClick(Sender: TObject);
begin
  if (ListViewFiles.Selected <> nil) then
  begin
    if (TIdDirItemType(ListViewFiles.Selected.Data) = ditDirectory) then
      Browse(AddTrailingSlash(ComboAddress.Text)+ListViewFiles.Selected.Caption);
  end;
end;

procedure TFormMain.Timer1Timer(Sender: TObject);
begin
  UpdateActions;
end;

procedure TFormMain.IdFTP1Work(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCount: Integer);
begin
  Application.ProcessMessages;
  if (FAbort) or ((FWriteStream <> nil) and (FWriteStream.Aborted)) then
  begin
    try
      StatusBar1.Panels[0].Text := 'Aborting...';
      Update;
      if (TransferInProgress) then
        IdFTP1.Abort;
      if (FWriteStream <> nil) then
        FWriteStream.Abort;
    finally
      FAbort := False;
      FAborted := True;
    end;
  end else
  if (ProgressBar1.Visible) then
  begin
    ProgressBar1.Position := AWorkCount;
    if (FCurrentFileSize > 1024*1024) then
      StatusBar1.Panels[0].Text := Format('Reading %.0n Kb of %.0n Kb', [Int(AWorkCount div 1024), Int(integer(FCurrentFileSize div 1024))])
    else
      StatusBar1.Panels[0].Text := Format('Reading %.0n of %.0n bytes', [Int(AWorkCount), Int(integer(FCurrentFileSize))]);
    Update;
    UpdateActions;
  end;
end;

procedure TFormMain.IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCountMax: Integer);
begin
  BeginTransfer;
  UpdateActions;
  Update;
end;

procedure TFormMain.IdFTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
  EndTransfer;
end;

function TFormMain.GetBusy: boolean;
begin
  Result := (FBusyCount > 0) or TransferInProgress;
end;

procedure TFormMain.BeginBusy;
begin
  inc(FBusyCount);
  if (FBusyCount = 1) then
    AnimateThrobber.Active := True;
end;

procedure TFormMain.EndBusy;
begin
  dec(FBusyCount);
  if (FBusyCount = 0) then
    AnimateThrobber.Active := False;
end;

procedure TFormMain.BeginTransfer;
begin
  inc(FTransferCount);
  if (FTransferCount = 1) then
    BeginBusy;
end;

procedure TFormMain.EndTransfer;
begin
  dec(FTransferCount);
  if (FTransferCount = 0) then
    EndBusy;
end;

function TFormMain.GetTransferInProgress: boolean;
begin
  Result := (FTransferCount > 0);
end;

end.