home *** CD-ROM | disk | FTP | other *** search
- Program UC; {UltraClip - a Clipboard Extender}
- uses WObjects, WinTypes, WinProcs,Strings,Win31,ClipObj,Buttons,Sclptext;
- {$R UC.RES}
- {$D UltraClip - Copyright (c) 1992 by Doug Overmyer}
- CONST
- AppName : PChar = 'UC';
- FrmName : PChar = 'UC';
- ChdName : PChar = 'UCChd';
- cm_Copy = cm_EditCopy; {menuitem EditCopy }
- cm_Paste = cm_EditPaste; {menuitem EditPaste }
- cm_Delete = cm_EditDelete;
- cm_Cut = cm_EditCut;
- um_ButtonU = 198;
- um_ButtonD = 199;
- id_But1 = 301;
- id_But2 = 302;
- id_But3 = 303;
- id_But4 = 304;
- id_But5 = 305;
- id_But6 = 306;
- id_ST1 = 401;
- id_D1RB1 = 451;
- id_D1RB2 = 452;
- id_D1EC1 = 453;
- id_D1EC2 = 454;
- id_D1EC3 = 455;
- id_D2LB1 = 461;
- cm_RunCB = 500;
- cm_AutoPaste = 501;
- cm_ClipClear = 502;
- cm_Configure = 503;
- cm_IconAll = 504;
- cm_RestoreAll = 505;
- cm_Exit = 24340;
- idm_About = 801;
- idm_ClipBoard = 803;
- id_Timer = 999;
- um_Copy = cm_EditCopy;
- um_Delete = cm_EditDelete;
- um_ChildExit = 901;
- um_ChildFocus = 902;
- um_GetSelf = 903;
- id_ChildMenuPos = 2;
- IniFile = 'UC.INI';
- type
- TUCApp = object(TApplication)
- procedure InitMainWindow; Virtual;
- end;
-
- PStrCollectionNS=^TStrCollectionNS;
- TStrCollectionNS = object(TStrCollection)
- procedure Insert(Item:Pointer);virtual;
- end;
-
- type
- TfR = Record
- Strings:PStrCollectionNS;
- Indexes:PMultiSelRec;
- end;
-
- PUCBtn = ^TUCBtn;
- TUCBtn = object(TODButton)
- constructor Init(AParent:PWindowsObject; AnID:Integer;ATitle:PChar;
- X1,Y1,W1,H1:Integer;IsDefault:Boolean;BMP:PChar;AGroup:PGroupBox);
- procedure WMRButtonDown(var Msg:TMessage);virtual wm_First+wm_RButtonDown;
- procedure WMRButtonUp(var Msg:TMessage);virtual wm_First+wm_RButtonUp;
- end;
-
- PUCStatic = ^TUCStatic;
- TUCStatic = object(TSText)
- constructor Init(AParent:PWindowsObject;AnID:Integer; ATitle:PChar;
- NewX,NewY,NewW,NewH:Integer; NewState,NewStyle:Integer);
- procedure WMRButtonDown(var Msg:TMessage);virtual wm_First+wm_RButtonDown;
- end;
-
- PUCWin = ^TUCWin;
- TUCWin = OBJECT(TMDIWindow)
- BN:Array[0..6] of PUCBtn;
- ST1:PUCStatic;
- NextViewer:HWnd;
- IsAutoPaste:Boolean;
- Help:Array[0..50] of Char;
- Helv:HFont;
- ThumbRect:TRect;
- Grid:TPoint;
- constructor Init(ATitle : PChar; AMenu : HMenu);
- destructor Done; Virtual;
- procedure SetupWindow; Virtual;
- function GetClassName : PChar; Virtual;
- procedure GetWindowClass(var AWndClass: TWndClass);Virtual;
- procedure InitClientWindow; Virtual;
- function InitChild : PWindowsObject; Virtual;
- procedure DispInfo;
- procedure Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
- procedure IDBut1(var Msg:TMessage);virtual id_First+id_But1;
- procedure IDBut2(var Msg:TMessage);virtual id_First+id_But2;
- procedure IDBut3(var Msg:TMessage);virtual id_First+id_But3;
- procedure IDBut4(var Msg:TMessage);virtual id_First+id_But4;
- procedure IDBut5(var Msg:TMessage);virtual id_First+id_But5;
- procedure IDBut6(var Msg:TMessage);virtual id_First+id_But6;
- procedure ODButtonD(var Msg:TMessage);virtual wm_User+um_ButtonD;
- procedure ODButtonU(var Msg:TMessage);virtual wm_User+um_ButtonU;
- procedure RetitleKids;
- procedure CMIconAll(var Msg:TMessage);virtual cm_First+cm_IconAll;
- procedure CMRestoreAll( var Msg:TMessage);virtual cm_First+cm_RestoreAll;
- procedure CMCut(var Msg:TMessage);virtual cm_First+cm_Cut;
- procedure CMCopy(var Msg:TMessage);virtual cm_First+cm_Copy;
- procedure CMPaste(var Msg:TMessage);virtual cm_First+cm_Paste;
- procedure CMDelete(var Msg:TMessage);virtual cm_First+cm_Delete;
- procedure CMAutoPaste(var Msg:TMessage);virtual cm_First+cm_AutoPaste;
- procedure CMClipClear(var Msg:TMessage);virtual cm_First+cm_ClipClear;
- procedure CMRunCB(var Msg:TMessage);virtual cm_First+cm_RunCB;
- procedure CMConfigure(var Msg:TMessage);virtual cm_First+cm_Configure;
- procedure WMChangeCBChain(var Msg:TMessage);virtual wm_First+wm_ChangeCBChain;
- procedure WMDrawClipBoard(var Msg:TMessage);virtual wm_First+wm_DrawClipBoard;
- procedure WMTimer(var Msg:TMessage);virtual wm_First+wm_Timer;
- procedure WMPaletteChanged(var Msg:TMessage);virtual wm_First+wm_PaletteChanged;
- procedure WMQueryNewPalette(var Msg:TMessage);virtual wm_first+wm_QueryNewPalette;
- procedure WMSize(var Msg:TMessage);virtual wm_First+wm_Size;
- procedure WMDrawItem(var Msg:TMessage);virtual wm_First + wm_DrawItem;
- procedure WMSysCommand(var Msg:TMessage);virtual wm_First+wm_SysCommand;
- procedure WMNCRButtonUp(var Msg:TMessage);virtual wm_First+wm_NCRButtonUp;
- procedure UMChildExit(var Msg:TMessage);virtual wm_User+um_ChildExit;
- procedure UMChildFocus(var Msg:TMessage);virtual wm_User+um_ChildFocus;
- procedure UMRButtonDown(var Msg:TMessage);virtual wm_User+wm_RButtonDown;
- end;
-
- PUCChild = ^TUCChild;
- TUCChild = OBJECT(TWindow)
- CO:PClipObj;
- IsActive:Boolean;
- ThumbRect:TRect;
- constructor Init(AParent:PWindowsObject;ATitle:PChar;SRx:TRect);
- function GetClassName : PChar; Virtual;
- procedure GetWindowClass(var AWndClass: TWndClass);Virtual;
- destructor Done;virtual;
- procedure SetupWindow;virtual;
- procedure Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
- procedure WMNCRButtonUp(var Msg:TMessage);virtual wm_First+wm_NCRButtonUp;
- procedure WMPaletteChanged(var Msg:TMessage);virtual wm_First+wm_PaletteChanged;
- procedure WMMDIActivate(var Msg:TMessage);virtual wm_First+wm_MDIActivate;
- procedure WMSize(var Msg:TMessage);virtual wm_First+wm_Size;
- procedure WMRButtonUp(var Msg:TMessage);virtual wm_First+wm_RButtonUp;
- procedure WMLButtonDown(var Msg:TMessage);virtual wm_First+wm_LButtonDown;
- procedure UMGetSelf(var Msg:TMessage);virtual wm_User+um_GetSelf;
- procedure UMCopy(var Msg:TMessage);virtual WM_USER+UM_COPY;
- procedure UMDelete(var Msg:TMessage);virtual WM_USER+UM_DELETE;
- end;
-
- PUCClient = ^TUCClient;
- TUCClient = object(TMDIClient)
- constructor Init(aParent:PMDIWindow);
- procedure WMSize(var Msg:TMessage);virtual WM_First+WM_SIZE;
- end;
-
- PUCAbout = ^TUCAbout; {about dialog}
- TUCAbout = object(TDialog)
- procedure WMCtlColor(var Msg:TMessage);virtual wm_First+wm_CtlColor;
- end;
-
- PUCdlg2 = ^TUCDlg2;
- TUCDlg2 = object(TDialog) {clipboard formats dialog}
- constructor Init(AParent: PWindowsObject; AName: PChar);
- procedure SetupWindow; virtual;
- end;
- { ******************** Functions *********************************}
- function StrTok(P:PChar;C:Char):PChar;
- const
- Next:Pchar = nil;
- begin
- if P = NIL then P := Next;
- if P <> NIL then
- begin
- Next := StrScan(P,C);
- If Next <> NIL then
- begin
- Next^ := #0;
- Next := Next+1;
- end;
- end;
- StrTok := P;
- end;
- function LongMin(A, B: LongInt): LongInt;
- begin
- if A < B then LongMin := A else LongMin := B;
- end;
-
- function LongMax(A, B: LongInt): LongInt;
- begin
- if A > B then LongMax := A else LongMax := B;
- end;
-
- {*********************** TUCApp **************************}
- procedure TUCApp.InitMainWindow;
- begin
- MainWindow := New(PUCWin, Init('UltraClip',LoadMenu(HInstance, 'UC_Menu')));
- end;
- {*********************** TUCWin ***********************************}
- constructor TUCWin.Init(ATitle : PChar;AMenu : HMenu);
- const
- BMP:Array[0..6] of PChar = ('','Btn1','Btn2','Btn3','Btn4','Btn5','Btn6');
- var
- Indx:Integer;
- LFont : TLogFont;
- TNS:Integer;
- begin
- TMDIWindow.Init(ATitle, AMenu);
- ChildMenuPos := id_ChildMenuPos;
- IsAutoPaste := False;
- NextViewer := 0;
- For Indx := 0 to 6 do BN[Indx] := nil;
- For Indx := 1 to 6 do
- BN[Indx]:=New(PUCBtn,Init(@Self,300+Indx,'',
- Pred(Indx)*32,32,32,32,False,BMP[Indx],nil));
- St1 := New(PUCStatic,Init(@Self,id_St1,'',210,5,250,23,sr_Recessed,
- dt_Left or dt_VCenter or dt_SingleLine));
- IsAutoPaste := Bool(GetPrivateProfileInt(AppName,'AutoPaste',0,INIFILE));
- TNS := GetPrivateProfileInt(AppName,'ThumbNailSize',125,INIFILE);
- Grid.X := GetPrivateProfileInt(AppName,'Across',4,INIFILE);
- Grid.Y := GetPrivateProfileInt(AppName,'Down',2,INIFILE);
- SetRect(ThumbRect,0,0,TNS,TNS);
- StrCopy(Help,'');
- GetObject(GetStockObject(System_Font),sizeof(TLogFont),@LFont);
- StrCopy(LFont.lfFaceName,'Helv');
- LFont.lfHeight := round(LFont.lfHeight * 2 / 3);
- LFont.lfWidth := 0;
- LFont.lfPitchAndFamily := 0;
- Helv := CreateFontIndirect(LFont);
- end;
-
- procedure TUCWin.SetUpWindow;
- var
- GlobMem:LongInt;
- Title:Array[0..25] of Char;
- SysMenu:HMenu;
- Mssg:PChar;
- Msg:TMessage;
- begin
- TMDIWindow.SetUpWindow;
- SetTimer(HWindow,id_Timer,5000,nil);
- WMTimer( Msg);
- Mssg := 'Start AutoPaste';
- ModifyMenu(Attr.Menu,cm_AutoPaste,mf_ByCommand+mf_String,
- cm_AutoPaste,Mssg);
- Sysmenu := GetSystemMenu(hWindow,false);
- AppendMenu(SysMenu,MF_Separator,0,nil);
- AppendMenu(Sysmenu,0,idm_About,'About');
- DispInfo;
- St1^.SetFont(Helv);
- if IsAutoPaste then
- begin
- IsAutoPaste := False;
- CMAutoPaste(Msg);
- end;
- RetitleKids;
- IDBut6(Msg);
- end;
-
- destructor TUCWin.Done;
- begin
- if IsAutoPaste then
- if NextViewer > 0 then
- ChangeClipboardChain(HWindow,NextViewer);
- KillTimer(HWindow,id_Timer);
- DeleteObject(Helv);
- TMDIWindow.Done;
- end;
-
- function TUCWin.GetClassName;
- begin
- GetClassName := AppName;
- end;
-
- procedure TUCWin.GetWindowClass(VAR AWndClass :TWndClass);
- begin
- TMDIWindow.GetWindowClass(AWndClass);
- AWndClass.hIcon := LoadIcon(HInstance, 'UC_Icon');
- end;
-
- procedure TUCWin.InitClientWindow;
- begin
- ClientWnd:= New(PUCClient,Init(@Self));
- WITH ClientWnd^.Attr DO
- Style := Style or WS_VScroll or WS_HScroll;
- end;
-
- function TUCWin.InitChild : PWindowsObject;
- begin
- InitChild := New(PUCChild, Init(@Self, 'Baby',ThumbRect));
- end;
-
- procedure TUCWin.DispInfo;
- type
- ORec = Record
- AutoP:PChar;
- Info:PChar;
- end;
- var
- ChildWin:HWnd;
- Child:PUCChild;
- Size:LongInt;
- Mssg,Stats:Array[0..100] of Char;
- O :ORec;
- begin
- fillchar(O,sizeOf(ORec),0);Child := nil;ChildWin := 0;
- StrCopy(Stats,'');
- if StrLen(Help) > 0 then
- begin
- St1^.SetText(Help);
- Exit;
- end;
- if IsAutoPaste then
- O.AutoP := 'P'
- else
- O.AutoP := '_';
- ChildWin :=GetTopWindow(ClientWnd^.HWindow);
- if ChildWin <> 0 then
- begin
- Child := PUCChild(GetObjectPtr(ChildWin));
- if Child <> nil then
- if Child^.CO <> nil then
- begin
- Child^.CO^.GetInfo(Stats,sizeof(Stats));
- O.Info := Stats;
- end;
- end;
- wvsprintf(Mssg,'%s %s',O);
- ST1^.SetText(Mssg);
- InvalidateRect(ST1^.HWindow,nil,false);
- end;
-
- procedure TUCWin.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
- var
- ob:HBrush;
- CR:TRect;
- begin
- GetClientRect(HWindow,CR);
- ob:=SelectObject(PaintDC,GetStockObject(ltGray_Brush));
- Rectangle(PaintDC,0,0,CR.Right,32);
- SelectObject(PaintDC,ob);
- end;
-
- procedure TUCWin.IDBut1(var Msg:TMessage);
- begin
- CMCut(Msg);
- end;
-
- procedure TUCWin.IDBut2(var Msg:TMessage);
- begin
- CMCopy(Msg);
- end;
-
- procedure TUCWin.IDBut3(var Msg:TMessage);
- begin
- CMPaste(Msg);
- end;
-
- procedure TUCWin.IDBut4(var Msg:TMessage);
- begin
- CMDelete(Msg);
- end;
-
- procedure TUCWin.IDBut5(var Msg:TMessage);
- begin
- CMClipClear(Msg);
- end;
-
- procedure TUCWin.IDBut6(var Msg:TMessage);
- var
- WR,CR,CW:TRect;
- X,Y,cKids:Integer;
- Res:LongInt;
- Rows,Cols:Integer;
- procedure DoChildren(Child:PUCChild);far;
- begin
- if not(Child^.IsFlagSet(wb_MDIChild)) then Exit;
- Inc(cKids);
- if X+WR.Right > CR.Right then
- begin
- X := 0;
- Y := Y+WR.Bottom;
- Inc(Rows);
- end;
- SetWindowPos(Child^.hWindow,0,X,Y,WR.Right,WR.Bottom,0{swp_NoZOrder});
- Inc(X,WR.Right);
- if Rows = 1 then Inc(Cols);
- end;
- begin
- if IsZoomed(HWindow) then
- ShowWindow(HWindow,sw_Normal);
- ClientWnd^.Scroller^.Scrollto(0,0); {restore scroller}
- Res := SendMessage(ClientWnd^.HWindow,wm_MDIGetActive,0,0);
- if LongRec(Res).Hi = 1 then {unzoom child if necessary}
- ShowWindow(LongRec(Res).Lo,sw_Normal);
- CopyRect(WR,ThumbRect); {compute child window:start with size of thumbnail}
- X:=0;Y:=0;Rows:=1;Cols:= 0;
-
- AdjustWindowRect(WR,PWindow(ChildList)^.Attr.Style,False); {add pixels for frame,captions,etc}
- WR.Right:=WR.Right+2*GetSystemMetrics(sm_CXFrame);
- WR.Right:=LongMax(WR.Right,GetSystemMetrics(SM_CXMin));
- WR.Bottom:=WR.Bottom+GetSystemMetrics(sm_CYCaption)+
- 2*GetSystemMetrics(sm_CYFrame);
-
- SetRectEmpty(CR); {compute size of client window using grid and child size}
- CR.Right := Grid.X*WR.Right;
- CR.Bottom := Grid.Y*WR.Bottom;
- AdjustWindowRect(CR,GetWindowLong(HWindow,GWL_Style),True);
- CR.Right:=(CR.Right-CR.Left+2*GetSystemMetrics(SM_CXFrame))+1;
- CR.Bottom :=CR.Bottom-CR.TOP+GetSystemMetrics(SM_CYCaption)+
- 2*GetSystemMetrics(SM_CYFrame)-1;
- SetWindowPos(HWindow,0,0,0,CR.Right,CR.Bottom,swp_NoMove + swp_DrawFrame); {resize parent}
- ForEach(@DoChildren);
- ClientWnd^.Scroller^.SetUnits(WR.Right,WR.Bottom);
- ClientWnd^.Scroller^.SetRange(Cols,Rows);
- ClientWnd^.Scroller^.XPage := 1;
- ClientWnd^.Scroller^.YPage := 1;
- end;
-
- procedure TUCWin.ODButtonD(var Msg:TMessage);
- begin
- case Msg.wParam of
- id_But1:LoadString(HInstance, 1, Help,50);
- id_But2:LoadString(HInstance, 2, Help,50);
- id_But3:LoadString(HInstance, 3, Help,50);
- id_But4:LoadString(HInstance, 4, Help,50);
- id_But5:LoadString(HInstance, 5, Help,50);
- id_But6:LoadString(HInstance, 6, Help,50);
- else StrCopy(Help,'n.a.');
- end;
- DispInfo;
- end;
-
- procedure TUCWin.ODButtonU(var Msg:TMessage);
- begin
- StrCopy(Help,'');
- DispInfo;
- end;
-
- procedure TUCWin.RetitleKids;
- var
- Kids:Array[0..5] of Char;
- Title:Array[0..25] of Char;
- Buf:Array[0..5] of Char;
- pKids : PChar;
- cKids:Word;
- procedure DoChildren(Child:PUCChild);far;
- begin
- if not(Child^.IsFlagSet(wb_MDIChild)) then Exit;
- Inc(cKids);
- Str(cKids,Kids);
- Child^.Co^.GetFormats(Buf);
- wvsprintf(Title,'C:%s',pKids);
- StrCat(Title,Buf);
- SetWindowText(Child^.HWindow,Title);
- end;
- begin
- cKids := 0;
- pKids := Kids;
- ForEach(@DoChildren);
- IF cKids>0 then
- begin
- ModifyMenu(Attr.Menu,cm_EditCopy,mf_ByCommand+mf_String+mf_Enabled,
- cm_EditCopy,'&Copy Ctrl+Ins');
- ModifyMenu(Attr.Menu,cm_EditDelete,mf_ByCommand+mf_String+mf_Enabled,
- cm_EditDelete,'&Delete Ctrl+Del');
- ModifyMenu(Attr.Menu,cm_EditCut,mf_ByCommand+mf_String+mf_Enabled,
- cm_EditCut,'Cu&t Shift+Del');
- ModifyMenu(Attr.Menu,cm_CascadeChildren,mf_ByCommand+mf_String+mf_Enabled,
- cm_CascadeChildren,'&Cascade');
- ModifyMenu(Attr.Menu,cm_TileChildren,mf_ByCommand+mf_String+mf_Enabled,
- cm_TileChildren,'&Tile');
- ModifyMenu(Attr.Menu,cm_ArrangeIcons,mf_ByCommand+mf_String+mf_Enabled,
- cm_ArrangeIcons,'&Arrange &Icons');
- ModifyMenu(Attr.Menu,cm_CloseChildren,mf_ByCommand+mf_String+mf_Enabled,
- cm_CloseChildren,'Close &All');
- ModifyMenu(Attr.Menu,cm_IconAll,mf_ByCommand+mf_String+mf_Enabled,
- cm_IconAll,'Iconize All');
- ModifyMenu(Attr.Menu,cm_RestoreAll,mf_ByCommand+mf_String+mf_Enabled,
- cm_RestoreAll,'Restore All');
- end
- else
- begin
- ModifyMenu(Attr.Menu,cm_EditCopy,mf_ByCommand+mf_String+mf_Grayed,
- cm_EditCopy,'&Copy Ctrl+Ins');
- ModifyMenu(Attr.Menu,cm_EditDelete,mf_ByCommand+mf_String+mf_Grayed,
- cm_EditDelete,'&Delete Ctrl+Del');
- ModifyMenu(Attr.Menu,cm_EditCut,mf_ByCommand+mf_String+mf_Grayed,
- cm_EditCut,'Cu&t Shift+Del');
- ModifyMenu(Attr.Menu,cm_CascadeChildren,mf_ByCommand+mf_String+mf_Grayed,
- cm_CascadeChildren,'&Cascade');
- ModifyMenu(Attr.Menu,cm_TileChildren,mf_ByCommand+mf_String+mf_Grayed,
- cm_TileChildren,'&Tile');
- ModifyMenu(Attr.Menu,cm_ArrangeIcons,mf_ByCommand+mf_String+mf_Grayed,
- cm_ArrangeIcons,'&Arrange &Icons');
- ModifyMenu(Attr.Menu,cm_CloseChildren,mf_ByCommand+mf_String+mf_Grayed,
- cm_CloseChildren,'Close &All');
- ModifyMenu(Attr.Menu,cm_IconAll,mf_ByCommand+mf_String+mf_Grayed,
- cm_IconAll,'Iconize All');
- ModifyMenu(Attr.Menu,cm_RestoreAll,mf_ByCommand+mf_String+mf_Grayed,
- cm_RestoreAll,'Restore All');
- end;
- DrawMenuBar(HWindow);
- end;
-
- procedure TUCWin.CMCut(var Msg:TMessage);
- var
- TopWin:HWnd;
- begin
- TopWin := GetTopWindow(ClientWnd^.HWindow);
- if TopWin > 0 then SendMessage(TopWin,WM_User+UM_Copy,0,0);
- if TopWin > 0 then SendMessage(TopWin,WM_User+UM_Delete,0,0);
- end;
-
- procedure TUCWin.CMCopy(var Msg:TMessage);
- var
- TopWin:HWnd;
- begin
- TopWin :=GetTopwindow(ClientWnd^.HWindow);
- if Topwin > 0 then SendMessage(Topwin,WM_User+UM_Copy,0,0);
- end;
-
- procedure TUCWin.CMPaste(var Msg:TMessage);
- var
- W:PUCChild;
- begin
- W := nil;
- if CountClipboardFormats = 0 then exit;
- W :=PUCChild(Application^.MakeWindow(New(PUCChild,Init(@Self,' ',ThumbRect ))));
- ShowWindow(W^.HWindow,SW_ShowNoActivate);
- EnableWindow(W^.HWindow,True);
- if W <> nil then
- If W^.CO = nil then
- W^.CloseWindow
- else
- RetitleKids;
- end;
-
- procedure TUCWin.CMDelete(var Msg:TMessage);
- var TopWin:HWnd;
- begin
- TopWin:=GetTopWindow(ClientWnd^.HWindow);
- if TopWin > 0 then
- SendMessage(TopWin,WM_User+UM_Delete,0,0);
- end;
-
- procedure TUCWin.CMAutoPaste(var Msg:TMessage);
- begin
- if not IsAutoPaste then
- begin
- IsAutoPaste := True;
- NextViewer := SetClipboardViewer(HWindow);
- ModifyMenu(Attr.Menu,cm_AutoPaste,mf_ByCommand+mf_String,
- cm_AutoPaste,'Stop AutoPaste');
- end
- else
- begin
- ChangeClipboardChain(HWindow,NextViewer);
- IsAutoPaste := false;
- NextViewer := 0;
- ModifyMenu(Attr.Menu,cm_AutoPaste,mf_ByCommand+mf_String,
- cm_AutoPaste,'Start AutoPaste');
- end;
- DrawMenuBar(HWindow);
- DispInfo;
- end;
-
- procedure TUCWin.CMClipClear(var Msg:TMessage);
- begin
- OpenClipboard(hWindow);
- EmptyClipboard;
- Closeclipboard;
- end;
-
- procedure TUCWin.CMRunCB(var Msg:TMessage);
- begin
- WinExec('clipbrd.exe',sw_ShowNormal);
- end;
-
- procedure TUCWin.CMConfigure(var Msg:TMessage);
- var
- TheDialog:PDialog;
- TfB :Record
- RB1,RB2:Bool;
- EC1,EC2,EC3:Array[0..4] of Char;
- end;
- RBut1,RBut2:PRadioButton;
- ECtl1,ECtl2,Ectl3:PEdit;
- FontBut:PButton;
- TNS,Error:Integer;
- begin
- TheDialog :=New(PDialog,Init(@Self,'UC_Dlg1'));
- New(RBut1,InitResource(TheDialog,id_D1RB1));
- New(RBut2,InitResource(TheDialog,id_D1RB2));
- New(ECtl1,InitResource(TheDialog,id_D1EC1,5));
- New(ECtl2,InitResource(TheDialog,id_D1EC2,5));
- New(ECtl3,InitResource(TheDialog,id_D1EC3,5));
- TfB.RB1 := False;TfB.RB2 := False;
- Str(ThumbRect.Right,TfB.EC1);
- Str(Grid.X,TfB.EC2);
- Str(Grid.Y,TfB.EC3);
- if IsAutoPaste then TfB.RB1 := True else TfB.RB2 := True;
- TheDialog^.TransferBuffer := @TfB;
- Application^.ExecDialog(TheDialog);
- If TfB.RB1 then
- WritePrivateProfileString(AppName,'AutoPaste','1',IniFile)
- else
- WritePrivateProfileString(Appname,'AutoPaste','0',IniFile);
- WritePrivateProfileString(Appname,'ThumbNailSize',TfB.EC1,IniFile);
- Val(TfB.EC1,TNS,Error);
- SetRect(ThumbRect,0,0,TNS,TNS);
- Val(TfB.EC2,Grid.X,Error);
- WritePrivateProfileString(Appname,'Across',TfB.EC2,IniFile);
- Val(TfB.EC3,Grid.Y,Error);
- WritePrivateProfileString(Appname,'Down',TfB.EC3,IniFile);
- IDBut6(Msg);
- end;
-
- procedure TUCWin.CMIconAll(var Msg:TMessage);
- procedure ShrinkKids(Child:PWindowsObject);far;
- begin
- If not(Child^.IsFlagSet(wb_MDIChild)) then Exit;
- If Child^.HWindow = 0 then EXIT;
- ShowWindow(Child^.HWindow,sw_Minimize);
- end;
- begin
- ForEach(@ShrinkKids);
- end;
-
- procedure TUCWin.CMRestoreAll(var Msg:TMessage);
- procedure RestoreKids(Child:PWindowsObject);far;
- begin
- If not(Child^.IsFlagSet(wb_MDIChild)) then Exit;
- If Child^.HWindow = 0 then EXIT;
- ShowWindow(Child^.HWindow,sw_Normal);
- end;
- begin
- ForEach(@RestoreKids);
- end;
-
- procedure TUCWin.WMChangeCBChain(var Msg:TMessage);
- begin
- if Msg.wParam = NextViewer then
- begin
- NextViewer := Msg.lParamLo;
- SendMessage(NextViewer,wm_ChangeCBChain,Msg.wParam,Msg.lParam);
- end;
- end;
-
- procedure TUCWin.WMSysCommand(var Msg:TMessage);
- begin
- case Msg.Wparam of
- idm_About:
- Application^.ExecDialog(New(PUCAbout,Init(@Self,'UC_About')));
- idm_ClipBoard:
- WinExec('clipbrd.exe',sw_ShowNormal);
- else
- DefWndProc(Msg);
- end;
- end;
-
- procedure TUCWin.WMDrawClipBoard(var Msg:TMessage);
- var
- ClipOwner :HWnd;
- IsItOurs:Bool;
-
- procedure IsKid(Child:PWindowsObject);far;
- begin
- if Child^.HWindow = ClipOwner then IsItOurs := True;
- end;
-
- begin
- ClipOwner := GetClipboardOwner; IsItOurs := False;
- ForEach(@IsKid);
- if not IsItOurs then
- CMPaste(Msg);
- if NextViewer <> 0 then
- SendMessage(NextViewer,wm_DrawClipboard,Msg.wParam,Msg.lParam);
- IF CountClipBoardFormats>0 then
- begin
- ModifyMenu(Attr.Menu,cm_EditPaste,mf_ByCommand+mf_String+mf_Enabled,
- cm_EditPaste,'&Paste Shift+Ins');
- ModifyMenu(Attr.Menu,cm_ClipClear,mf_ByCommand+mf_String+mf_Enabled,
- cm_ClipClear,'Clea&r Clipboard');
- end
- else
- begin
- ModifyMenu(Attr.Menu,cm_EditPaste,mf_ByCommand+mf_String+mf_Grayed,
- cm_EditPaste,'&Paste Shift+Ins');
- ModifyMenu(Attr.Menu,cm_ClipClear,mf_ByCommand+mf_String+mf_Grayed,
- cm_ClipClear,'Clea&r Clipboard');
- end;
- DrawMenuBar(HWindow);
- end;
-
- procedure TUCWin.WMTimer(var Msg:TMessage);
- var
- GlobMem:LongInt;
- Title:Array[0..25] of Char;
- begin
- GlobMem := GetFreeSpace(0);
- GlobMem := GlobMem div 1024 div 1024;
- wvsprintf(Title,'UltraClip: %li MB Free',GlobMem);
- SetWindowText(HWindow,Title);
- end;
-
- procedure TUCWin.WMPaletteChanged(var Msg:TMessage);
- var
- IsChild:Boolean;
- Ret:LongRec;
-
- procedure IsKid(Child:PWindowsObject);far;
- begin
- if Child^.HWindow = Msg.wParam
- then IsChild := True;
- end;
-
- begin {only respond to changes from other apps}
- IsChild := False;
- ForEach(@IsKid);
- if not IsChild then
- InvalidateRect(HWindow,nil,false);
- end;
-
- procedure TUCWin.WMQueryNewPalette(var Msg:TMessage);
- begin
- InvalidateRect(HWindow,nil,false);
- end;
-
- procedure TUCWin.WMSize(var Msg:TMessage);
- var
- Indx:Integer;
- CR:TRect;
- begin
- GetClientRect(HWindow,CR);
- if (ClientWnd <> nil) and (ClientWnd^.HWindow <> 0) then
- MoveWindow(ClientWnd^.HWindow,0,33,Msg.lParamLo,Msg.LParamHi-33,True);
- for Indx := 1 to 6 do
- begin
- if (BN[Indx] <> nil) and (BN[Indx]^.HWindow <> 0) then
- MoveWindow(BN[Indx]^.HWindow,(Indx-1)*33,0,32,32,True);
- end;
- If (ST1 <> nil) and (ST1^.HWindow <> 0) then
- ST1^.MoveWin(210,5,Cr.Right-220,23);
- CR.Bottom := 32;
- InvalidateRect(HWindow,@CR,True);
- end;
-
- procedure TUCWin.WMDrawItem(var Msg:TMessage);
- var
- PDIS : ^TDrawItemStruct;
- begin
- PDIS := Pointer(Msg.lParam);
- case PDIS^.CtlType of
- odt_Button:
- case PDIS^.CtlID of
- id_But1..id_But6:Bn[PDIS^.CtlID-Pred(id_But1)]^.DrawItem(Msg);
- end;
- end;
- end;
-
- procedure TUCWin.WMNCRButtonUp(var Msg:TMessage);
- begin
- CMConfigure(Msg);
- end;
-
- procedure TUCWin.UMChildExit(var Msg:TMessage);
- begin
- RetitleKids;
- DispInfo;
- end;
-
- procedure TUCWin.UMChildFocus(var Msg:TMessage);
- begin
- DispInfo;
- end;
-
- procedure TUCWin.UMRButtonDown(var Msg:TMessage);
- begin
- if Msg.wParam <> id_ST1 then EXIT;
- CMAutoPaste(Msg);
- DispInfo;
- end;
- {*********************** TUCChild ***********************************}
- constructor TUCChild.Init(AParent:PWindowsObject;ATitle:PChar;SRx:TRect);
- var Stat:Word;
- begin
- TWindow.Init(AParent,ATitle);
- ThumbRect:=SRx;
- Attr.Style := Attr.Style or ws_Disabled;
- end;
-
- destructor TUCChild.Done;
- begin
- if CO <> nil then Dispose(CO,Done);
- if Parent^.HWindow <> 0 then
- PostMessage(Parent^.HWindow,wm_User+um_ChildExit,0,0);
- TWindow.Done;
- end;
-
- procedure TUCChild.SetupWindow;
- var
- CR:TRect;
- tb:TBitmap;
- Stat:Word;
- WR:TREct;
- begin
- TWindow.SetupWindow;
- GetClientRect(PMDIWindow(Parent)^.ClientWnd^.HWindow,CR);
- InflateRect(CR, -(CR.Right div 20), -(CR.Bottom div 20));
- SetWindowPos(HWindow,HWND_BOTTOM,0,0,CR.Right,CR.Bottom,swp_NoActivate );
- CO :=New(PClipObj,Init(HWindow,Stat,ThumbRect));
- if Stat <> st_OK then
- MessageBox(Parent^.HWindow,'Error Pasting from Clipboard ',
- 'UltraClip Alert',mb_systemmodal or mb_iconExclamation)
- else
- IsActive := True;
- CopyRect(WR,ThumbRect);
- AdjustWindowRect(WR,Attr.Style,False);
- SetWindowPos(hWindow,0,0,0,WR.Right+2*GetSystemMetrics(sm_CXFrame),
- WR.Bottom+GetSystemMetrics(sm_CYCaption)+2*GetSystemMetrics(sm_CYFrame),
- swp_NoZOrder or swp_NoMove);
- end;
-
- procedure TUCChild.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
- var
- oc:HCursor;
- begin
- if CO = nil then Exit;
- oc := SetCursor(LoadCursor(0,IDC_WAIT));
- if IsActive then
- CO^.RenderSelf(PaintDC,HWindow,IsZoomed(HWindow))
- else
- CO^.RedrawSelf(PaintDC,HWindow,IsZoomed(HWindow));
- SetCursor(oc);
- end;
-
- function TUCChild.GetClassName;
- begin
- GetClassName := ChdName;
- end;
-
- procedure TUCChild.GetWindowClass(VAR AWndClass:TWndClass);
- begin
- TWindow.GetWindowClass(AWndClass);
- AWndClass.hIcon := LoadIcon(HInstance, 'UC_IconC');
- AWndClass.hBrBackground := GetStockObject(ltGray_Brush);
- end;
-
- procedure TUCChild.WMNCRButtonUp(var Msg:TMessage);
- begin
- SetFocus(HWindow);
- InvalidateRect(HWindow,nil,false);
- PostMessage(HWindow,wm_User+um_Copy,Msg.wParam,Msg.lParam);
- end;
-
- procedure TUCChild.WMPaletteChanged(var Msg:TMessage);
- var
- DC:HDC;
- begin
- if Msg.wParam <> HWindow then
- if IsActive then
- begin
- GetDC(HWindow);
- CO^.RenderSelf(DC,HWindow,IsZoomed(HWindow));
- ReleaseDC(HWindow,DC);
- end;
- end;
-
- procedure TUCChild.WMMDIActivate(var Msg:TMessage);
- var
- DC:HDC;
- begin
- IsActive := Bool(Msg.wParam);
- if IsActive then
- begin
- SetFocus(HWindow);
- InvalidateRect(HWindow,nil,True);
- PostMessage(Parent^.HWindow,wm_User+um_ChildFocus,0,LongInt(@Self));
- end;
- end;
-
- procedure TUCChild.WMSize(var Msg:TMessage);
- begin
- if (Msg.wParam <> size_MaxHide) and (Msg.wParam <> size_MaxShow)
- and IsActive then
- PostMessage(Parent^.HWindow,wm_User+um_ChildFocus,0,LongInt(@Self));
- DefWndProc(Msg);
- end;
-
- procedure TUCChild.WMRButtonUp(var Msg:TMessage);
- var
- Dlg2:PUCDlg2;
- Ctrl:PControl;
- Indx:Integer;
- Clip:PClipItem;
- Clips:PCollection;
- Ret:Integer;
- TfB:TfR;
- begin {dlg with listbox of available formats}
- TfB.Strings :=New(PStrCollectionNS,Init(10,10));
- TfB.Indexes:=nil;
- Dlg2 := New(PUCDlg2,Init(@Self,'UC_Dlg2'));
- Ctrl:=New(PListBox,InitResource(Dlg2,id_D2LB1));
- Clips:=CO^.GetClips;
- for Indx := 0 to (Clips^.Count-1) do
- begin
- Clip:=Clips^.At(Indx);
- TfB.Strings^.Insert(StrNew(Clip^.CName));
- end;
- Dlg2^.TransferBuffer := @TfB;
- Ret := Application^.ExecDialog(Dlg2);
- if (Ret = id_OK) and (TfB.Indexes <> nil) then
- begin
- CO^.CopyClipS(HWindow,TfB.Indexes);
- FreeMultiSel(TfB.Indexes);
- TfB.Indexes := nil;
- end;
- Dispose(TfB.Strings,Done);
- end;
-
- procedure TUCChild.WMLButtonDown(var Msg:TMessage);
- var
- Dlg2:PUCDlg2;
- Buf:Array[0..2] of Char;
- begin {toggle display format if graphics & text}
- StrCopy(Buf,'');
- CO^.ToggleIsPrefText;
- CO^.GetFormats(Buf);
- if Buf[0] = '*' then
- InvalidateRect(HWindow,nil,True);
- end;
-
- procedure TUCChild.UMGetSelf(var Msg:TMessage);
- begin {use getobjptr() instead}
- Msg.Result := LongInt(@Self);
- end;
-
- procedure TUCChild.UMCopy(var Msg:TMessage);
- var
- TfB:TfR;
- begin {cc_CopyAll a local convention;Strings pointer not used}
- TfB.Strings :=nil;
- TfB.Indexes:=AllocMultiSel(cc_CopyAll);
- if CO <> nil then
- CO^.CopyClipS(HWindow,TfB.Indexes);
- FreeMultiSel(TfB.Indexes);
- end;
-
- procedure TUCChild.UMDelete(var Msg:TMessage);
- begin
- CloseWindow;
- end;
-
- {************************ TUCClient *******************************}
- constructor TUCClient.Init(AParent:PMDIWindow);
- begin
- TMDIClient.Init(AParent);
- Scroller :=New(PScroller,Init(@self,125,125,200,200));
- Scroller^.XPage := 1;
- Scroller^.YPage := 1;
- end;
-
- procedure TUCClient.WMSize(var Msg:TMessage);
- begin
- DefWndProc(Msg);
- end;
- {************************ TUCBtn *********************************}
- constructor TUCBtn.Init(AParent:PWindowsObject; AnID:Integer;ATitle:PChar;
- X1,Y1,W1,H1:Integer;IsDefault:Boolean;BMP:PChar;AGroup:PGroupBox);
- begin
- TODButton.Init(AParent,AnID,ATitle,X1,Y1,W1,H1,IsDefault,BMP,AGroup);
- SetFlags(wb_MDIChild,False);
- DefaultProc := @DefWindowProc;
- end;
-
- procedure TUCBtn.WMRButtonDown(var Msg:TMessage);
- begin
- SendMessage(Parent^.HWindow,wm_User+um_ButtonD,GetID,0);
- end;
-
- procedure TUCBtn.WMRButtonUp(var Msg:TMessage);
- begin
- SendMessage(Parent^.HWindow,wm_User+um_ButtonU,GetID,0);
- end;
- {*********************** TUCStatic ********************************}
- constructor TUCStatic.Init(AParent:PWindowsObject;AnID:Integer; ATitle:PChar;
- NewX,NewY,NewW,NewH:Integer; NewState,NewStyle:Integer);
- begin
- TSText.Init(AParent,AnID, ATitle,NewX,NewY,NewW,NewH,NewState,NewStyle);
- SetFlags(wb_MDIChild,False);
- DefaultProc := @DefWindowProc;
- end;
-
- procedure TUCStatic.WMRButtonDown(var Msg:TMessage);
- begin
- SendMessage(Parent^.HWindow,wm_User+wm_RButtonDown,GetID,0);
- end;
- {********************** TUCAbout ********************************}
- procedure TUCAbout.WMCTLCOLOR(var Msg: TMessage);
- begin
- case Msg.LParamHi of
- ctlColor_Static,ctlcolor_Dlg:
- begin
- SetBkMode(Msg.WParam, Transparent);
- Msg.Result := GetStockObject(ltGray_Brush);
- end;
- else
- DefWndProc(Msg);
- end;
- end;
- {************************* TUCDlg2 *********************************}
- constructor TUCDlg2.Init(AParent: PWindowsObject; AName: PChar);
- begin
- TDialog.Init(AParent,AName);
- end;
-
- procedure TUCDlg2.SetupWindow;
- begin
- TDialog.SetupWindow;
- end;
- {*********************** TStrCollectionNS ****************************}
- procedure TStrCollectionNS.Insert(Item:Pointer);
- begin
- AtInsert(Count,Item);
- end;
- {*********************** Main Line **********************************}
- var
- TheApp: TUCApp;
- begin
- TheApp.Init(AppName);
- TheApp.Run;
- TheApp.Done;
- end.
-