Check-in [d70d29a14f]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Added info button showing the current VCS's icon, which drops down the color key when clicked.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: d70d29a14fe6b0fe24375ff5496a0275efba46ac
User & Date: tinus 2015-11-21 00:35:12
Context
2015-11-21
01:11
Added menu item for key, showing either the wizard's name and version, or the name and version of the VCS. Also extended the expiry time for repo information to 15 seconds. check-in: 813ffc57df user: tinus tags: trunk
00:35
Added info button showing the current VCS's icon, which drops down the color key when clicked. check-in: d70d29a14f user: tinus tags: trunk
2015-11-20
21:12
Adjusted plans. check-in: f4cbf644f9 user: tinus tags: trunk
Changes

Changes to src/VCSInfoMenuWzrd.pas.

1
2
3
4
5
6

7
8
9
10
11
12
13
..
23
24
25
26
27
28
29



30
31
32
33
34
35
36
..
62
63
64
65
66
67
68


69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
...
378
379
380
381
382
383
384
385
386


387

388
389
390
391








392
393
394
395








396
397
398
399
400
401
402

403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
...
428
429
430
431
432
433
434






































435
436
437
438
439
440
441
...
541
542
543
544
545
546
547









































548
549
550
551
552
553
554
unit VCSInfoMenuWzrd;

interface
uses
  System.Generics.Collections,
  ToolsAPI, Vcl.ComCtrls, Vcl.Controls, Vcl.ActnList;



type
  TRepoInfo = record
    Root: string;
    RepoType: string;
    Branch: string;
................................................................................
    private
      FRepos: TDictionary<string,TRepoInfo>;

      FToolbar: TToolBar;
      FButtonBranch: TToolButton;
      FButtonSync: TToolButton;




      FImgUnknown: integer;
      FImgSyncNone: integer;
      FImgSyncPull: integer;
      FImgSyncPush: integer;
      FImgSyncBoth: integer;
      FImgClean: integer;
      FImgPending: integer;
................................................................................

      procedure actBranchExecute(Sender: TObject);
      procedure actBranchUpdate(Sender: TObject);
      procedure actBranchMenuPopup(Sender: TObject);
      procedure actBranchMenuClick(Sender: TObject);
      procedure actSyncExecute(Sender: TObject);
      procedure actSyncUpdate(Sender: TObject);


  end;

procedure Register;

implementation
uses
  System.SysUtils, System.UITypes, System.Classes, System.StrUtils,
  Vcl.Forms, Vcl.Dialogs,
  Winapi.Windows,
  u_FinalPathName, Vcl.Graphics, Vcl.Menus;

const
  scMenuIDString = 'net.2of4.VCSInfoWizard';

{ ------------------------------------------------------------------------------------------------ }
procedure Register;
begin
................................................................................
    bmp.Canvas.Brush.Color := Color;
    bmp.Canvas.Brush.Style := bsSolid;
    bmp.Canvas.FillRect(Rect(0, 0, bmp.Width, bmp.Height));
    bmp.TransparentColor := TransparentColor;
    Result := Services.AddMasked(bmp, bmp.TransparentColor);
  end;
  { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  function AddButtonIcon(const ResourceName: string): Integer;
  var


    Icon: TIcon;

  begin
    Icon := TIcon.Create;
    try
      Icon.LoadFromResourceName(HInstance, ResourceName);








      Result := Services.ImageList.AddIcon(Icon);
    finally
      Icon.Free;
    end;








  end;
  { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
const
  scToolbarName = 'tlbVCSInfo';
var
  actSync: TAction;
  actBranch: TAction;

  Toolbar: TWinControl;
  i: Integer;
  Button: TToolButton;
begin
  LogMessage(StringOfChar('-', 80));

  Supports(ToolsAPI.BorlandIDEServices, INTAServices, {out}Services);

  FImgUnknown   := AddButtonImage(clBtnShadow);
  FImgSyncNone  := AddButtonImage(clGreen);
  FImgSyncPull  := AddButtonImage(clRed);
  FImgSyncPush  := AddButtonImage(clYellow);
  FImgSyncBoth  := AddButtonImage(clWebOrange);
  FImgClean     := AddButtonImage(clLime);
  FImgPending   := AddButtonImage(clBlue);
  FImgExtra     := AddButtonImage(clFuchsia, 0);

  Toolbar := nil;
  Services.ReadToolbar(Application.MainForm, Application.MainForm.FindChildControl('Controlbar1') as TWinControl, scToolbarName, Toolbar);
  if not (Toolbar is TToolBar) then begin
    FToolbar := Services.NewToolbar(scToolbarName, 'Repository');
    FToolbar.AutoSize := True;
    Services.WriteToolbar(FToolbar);
  end else begin
................................................................................
    // Remove any automatically created buttons
    for i := FToolbar.ButtonCount - 1 downto 0 do begin
      Button := FToolbar.Buttons[i];
      FToolbar.Perform(CM_CONTROLCHANGE, WPARAM(Button), 0);
      Button.Free;
    end;
  end;







































  actSync := TAction.Create(FToolbar);
  actSync.Caption := 'Nothing to sync';
  actSync.Hint := actSync.Caption;
  actSync.Enabled := True;
  actSync.ImageIndex := FImgUnknown;
  actSync.OnExecute := actSyncExecute;
................................................................................
    end;
  except
    on E: Exception do begin
      LogMessage('actBranchUpdate raised ' + E.ClassName + sLineBreak + E.ToString);
    end;
  end;
end;










































procedure TVCSInfoWizard.actBranchExecute(Sender: TObject);
var
  Repo: TRepoInfo;
begin
  Repo := GetActiveFileRepo;
  case IndexStr(Repo.RepoType, ['hg', 'fossil']) of





|
>







 







>
>
>







 







>
>







|
|
|







 







|

>
>

>



|
>
>
>
>
>
>
>
>




>
>
>
>
>
>
>
>







>








<
<
<
<
<
<
<
<
<







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
..
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
..
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
...
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436









437
438
439
440
441
442
443
...
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
...
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
unit VCSInfoMenuWzrd;

interface
uses
  System.Generics.Collections,
  Vcl.ComCtrls, Vcl.Controls, Vcl.ActnList,
  ToolsAPI;


type
  TRepoInfo = record
    Root: string;
    RepoType: string;
    Branch: string;
................................................................................
    private
      FRepos: TDictionary<string,TRepoInfo>;

      FToolbar: TToolBar;
      FButtonBranch: TToolButton;
      FButtonSync: TToolButton;

      FImgIcon: Integer;
      FImgMercurial: Integer;
      FImgFossil: Integer;
      FImgUnknown: integer;
      FImgSyncNone: integer;
      FImgSyncPull: integer;
      FImgSyncPush: integer;
      FImgSyncBoth: integer;
      FImgClean: integer;
      FImgPending: integer;
................................................................................

      procedure actBranchExecute(Sender: TObject);
      procedure actBranchUpdate(Sender: TObject);
      procedure actBranchMenuPopup(Sender: TObject);
      procedure actBranchMenuClick(Sender: TObject);
      procedure actSyncExecute(Sender: TObject);
      procedure actSyncUpdate(Sender: TObject);
      procedure actInfoExecute(Sender: TObject);
      procedure actInfoUpdate(Sender: TObject);
  end;

procedure Register;

implementation
uses
  System.SysUtils, System.UITypes, System.Classes, System.StrUtils,
  Winapi.Windows, Winapi.ShellAPI,
  Vcl.Forms, Vcl.Dialogs, Vcl.Graphics, Vcl.Menus,
  u_FinalPathName;

const
  scMenuIDString = 'net.2of4.VCSInfoWizard';

{ ------------------------------------------------------------------------------------------------ }
procedure Register;
begin
................................................................................
    bmp.Canvas.Brush.Color := Color;
    bmp.Canvas.Brush.Style := bsSolid;
    bmp.Canvas.FillRect(Rect(0, 0, bmp.Width, bmp.Height));
    bmp.TransparentColor := TransparentColor;
    Result := Services.AddMasked(bmp, bmp.TransparentColor);
  end;
  { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  function AddExeIcon(const ExeName: string): Integer;
  var
    ExePath: string;
    PFileName: PChar;
    Icon: TIcon;
    FileInfo: TSHFileInfo;
  begin
    Icon := TIcon.Create;
    try
      ExePath := StringOfChar(#0, 255);
      SetLength(ExePath, SearchPath(nil, PChar(ExeName), nil, Length(ExePath), PChar(ExePath), PFileName));
      if ExePath <> '' then begin
        FileInfo := Default(TSHFileInfo);
        SHGetFileInfo(PChar(ExePath), 0, FileInfo, SizeOf(FileInfo), SHGFI_ICON);
        Icon.Handle := FileInfo.hIcon;
      end else begin
        Icon.Handle := LoadIcon(0, IDI_APPLICATION);
      end;
      Result := Services.ImageList.AddIcon(Icon);
    finally
      Icon.Free;
    end;
  end {AddExeIcon};
  { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  function AddButtonMenuItem(const Button: TToolButton; ImageIndex: integer; Caption: string): TMenuItem;
  begin
    Result := TMenuItem.Create(Button.DropdownMenu);
    Result.Caption := Caption;
    Result.ImageIndex := ImageIndex;
    Button.DropdownMenu.Items.Add(Result);
  end;
  { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
const
  scToolbarName = 'tlbVCSInfo';
var
  actSync: TAction;
  actBranch: TAction;
  actInfo: TAction;
  Toolbar: TWinControl;
  i: Integer;
  Button: TToolButton;
begin
  LogMessage(StringOfChar('-', 80));

  Supports(ToolsAPI.BorlandIDEServices, INTAServices, {out}Services);










  Toolbar := nil;
  Services.ReadToolbar(Application.MainForm, Application.MainForm.FindChildControl('Controlbar1') as TWinControl, scToolbarName, Toolbar);
  if not (Toolbar is TToolBar) then begin
    FToolbar := Services.NewToolbar(scToolbarName, 'Repository');
    FToolbar.AutoSize := True;
    Services.WriteToolbar(FToolbar);
  end else begin
................................................................................
    // Remove any automatically created buttons
    for i := FToolbar.ButtonCount - 1 downto 0 do begin
      Button := FToolbar.Buttons[i];
      FToolbar.Perform(CM_CONTROLCHANGE, WPARAM(Button), 0);
      Button.Free;
    end;
  end;

  FImgIcon      := Services.ImageList.AddIcon(Application.Icon);
  FImgMercurial := AddExeIcon('hg.exe');
  FImgFossil    := AddExeIcon('fossil.exe');
  FImgUnknown   := AddButtonImage(clBtnShadow);
  FImgSyncNone  := AddButtonImage(clGreen);
  FImgSyncPull  := AddButtonImage(clRed);
  FImgSyncPush  := AddButtonImage(clYellow);
  FImgSyncBoth  := AddButtonImage(clWebOrange);
  FImgClean     := AddButtonImage(clLime);
  FImgPending   := AddButtonImage(clBlue);
  FImgExtra     := AddButtonImage(clFuchsia, 0);

  actInfo := TAction.Create(FToolbar);
  actInfo.Caption := '';
  actInfo.Hint := 'VCS Info';
  actInfo.ImageIndex := FImgIcon;
  actInfo.OnExecute := actInfoExecute;
  actInfo.OnUpdate := actInfoUpdate;

  Button := Services.AddToolButton(FToolbar.Name, 'btnLegend', actInfo) as TToolButton;
  Button.Style := tbsButton;
  Button.DropdownMenu := TPopupMenu.Create(Button);
  Button.DropdownMenu.AutoHotkeys := maManual;
  Button.DropdownMenu.AutoPopup := True;
  Button.DropdownMenu.Items.SubMenuImages := Services.ImageList;

  AddButtonMenuItem(Button, FImgUnknown,  'Unknown or error');
  AddButtonMenuItem(Button, -1,           '-');
  AddButtonMenuItem(Button, FImgSyncNone, 'Nothing to sync');
  AddButtonMenuItem(Button, FImgSyncPull, 'Incoming changesets (pull)');
  AddButtonMenuItem(Button, FImgSyncPush, 'Outgoing changesets (push)');
  AddButtonMenuItem(Button, FImgSyncBoth, 'Incoming and outgoing changesets');
  AddButtonMenuItem(Button, -1,           '-');
  AddButtonMenuItem(Button, FImgClean,    'Working dir is clean');
  AddButtonMenuItem(Button, FImgPending,  'Working dir has changes');
  AddButtonMenuItem(Button, FImgExtra,    'Working dir has untracked files');


  actSync := TAction.Create(FToolbar);
  actSync.Caption := 'Nothing to sync';
  actSync.Hint := actSync.Caption;
  actSync.Enabled := True;
  actSync.ImageIndex := FImgUnknown;
  actSync.OnExecute := actSyncExecute;
................................................................................
    end;
  except
    on E: Exception do begin
      LogMessage('actBranchUpdate raised ' + E.ClassName + sLineBreak + E.ToString);
    end;
  end;
end;

procedure TVCSInfoWizard.actInfoExecute(Sender: TObject);
begin
  // TODO?
end;

procedure TVCSInfoWizard.actInfoUpdate(Sender: TObject);
var
  actInfo: TAction;
  Repo: TRepoInfo;
  NewImageIndex: integer;
  NewCaption: string;
begin
  try
    actInfo := Sender as TAction;
    Repo := GetActiveFileRepo;
    case IndexStr(Repo.RepoType, ['hg', 'fossil']) of
      0: begin
        NewImageIndex := FImgMercurial;
        NewCaption := 'Mercurial';
      end;
      1: begin
        NewImageIndex := FImgFossil;
        NewCaption := 'Fossil';
      end;
      else begin
        NewImageIndex := FImgIcon;
        NewCaption := 'VCS Info';
      end;
    end;

    if (NewImageIndex <> actInfo.ImageIndex) or (NewCaption <> actInfo.Hint) then begin
      actInfo.ImageIndex := NewImageIndex;
      actInfo.Hint := NewCaption;
    end;
  except
    on E: Exception do begin
      LogMessage('actInfoUpdate raised ' + E.ClassName + sLineBreak + E.ToString);
    end;
  end;
end;

procedure TVCSInfoWizard.actBranchExecute(Sender: TObject);
var
  Repo: TRepoInfo;
begin
  Repo := GetActiveFileRepo;
  case IndexStr(Repo.RepoType, ['hg', 'fossil']) of