home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2.0 - Programmer's Utilities Power Pack / Delphi 2.0 Programmer's Utilities Power Pack.iso / a_to_d / colorbox / colorbox.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-09-15  |  7.1 KB  |  363 lines
  1. program ColorBox;
  2.  
  3. {$G+} {$S-}
  4.  
  5. {$M 10240,1024}
  6.  
  7. {$R ColorBox}
  8.  
  9. uses WinTypes,WinProcs,win31;
  10.  
  11. CONST
  12.  AppName='ColorBox';
  13.  eraser:hbrush=0;
  14.  Wi:HWnd=0;
  15.  tc:array[0..15] of tcolorref=
  16.  ($000000,$800000,$008000,$808000,   
  17.   $000080,$800080,$008080,$808080,   
  18.   $C0C0C0,$FF0000,$00FF00,$FFFF00,   
  19.   $0000FF,$FF00FF,$00FFFF,$FFFFFF);
  20.  tcn:array[0..15] of string[7]=
  21.   ('Black','Navy','Green','Teal',
  22.    'Maroon','Purple','Olive','Gray',
  23.    'Silver','Blue','Lime','Aqua',
  24.    'Red','Fuscia','Yellow','White');
  25.  color:array[1..2] of byte=(15,0);
  26.  
  27.  first:boolean=false;
  28.  w:hwnd=0;
  29.  itm:byte=65;
  30.  
  31. VAR
  32.  hinst1:THandle;  
  33.  hicon1:hicon;
  34.  mwid,mht:integer;
  35.  
  36.  hkk:hhook; 
  37.  hkproc:thookproc;
  38.  proc1,proc2,aproc:tfarproc;
  39.  
  40. FUNCTION num(xx:longint):string;
  41. var aa:string[30];
  42. BEGIN
  43. str(xx,aa);
  44. num:=aa;
  45. END;
  46.  
  47. function p(s:string):pchar;assembler;
  48. asm 
  49. push ds
  50. cld
  51. lds si,s
  52. lodsb
  53. xor ah,ah
  54. les di,s
  55. inc di
  56. add di,ax
  57. xor al,al
  58. stosb
  59. mov ax,si
  60. mov dx,ds
  61. pop ds
  62. end;
  63.  
  64. function pas(s:string):string;assembler;
  65. asm
  66. push ds
  67. cld
  68. les di,s
  69. inc di
  70. mov dx,di
  71. mov cx,255
  72. xor al,al
  73. repne scasb
  74. dec di
  75. sub di,dx
  76. mov ax,di
  77. les di,s
  78. stosb
  79. lds si,s
  80. les di,@result
  81. movsb
  82. mov cl,al
  83. xor ch,ch
  84. inc cx
  85. rep movsb
  86. pop ds
  87. end;
  88.  
  89. procedure WriteColors;
  90. var
  91.  s:string;
  92. begin
  93. s:=num(color[1]);
  94. WriteProfileString(AppName,'Background',p(s));
  95. s:=num(color[2]);
  96. WriteProfileString(AppName,'Text',p(s));
  97. end;
  98.  
  99. procedure makenewcolors;
  100. begin
  101. if eraser<>0 then deleteobject(eraser);
  102. eraser:=createsolidbrush(tc[color[1]]);
  103. end;
  104.  
  105. procedure centerw(w:hwnd);
  106. var r:TRect;
  107. begin
  108. getwindowrect(w,r);
  109. with r do
  110.  begin
  111.  right:=right-left;
  112.  bottom:=bottom-top;
  113.  movewindow(w,(mwid-right) div 2,(mht-bottom) div 2,right,bottom,false);
  114.  end;
  115. end;
  116.  
  117. function ans2(hDlg:hWnd;message,
  118.  wParam:Word;lParam:LongInt):Longint;Export;
  119. var i:integer;
  120. begin
  121.  case message of
  122.  WM_CTLCOLOR:
  123.   begin
  124.   SetBkMode(HDC(wParam),TRANSPARENT);
  125.   SetBkColor(HDC(wParam),tc[color[1]]);
  126.   SetTextColor(HDC(wParam),tc[color[2]]);
  127.   ans2:=eraser;
  128.   exit;
  129.   end;
  130.  wm_initdialog:centerw(w);
  131.  end;
  132. ans2:=CallWindowProc(proc2,hdlg,message,wParam,lParam);
  133. end;
  134.  
  135. procedure unhook;
  136. begin
  137. if w=0 then exit;
  138. SetWindowLong(w,GWL_WNDPROC,longint(proc2));
  139. w:=0;
  140. end;
  141.  
  142. function CBTProc(Code:Integer;wParam:Word;
  143.  lParam:LongInt):longint;Export;
  144. var
  145.  lpcbtcreate:PCBT_CREATEWND;
  146. begin
  147.  case code of
  148.   HCBT_CREATEWND:
  149.    begin
  150.    lpcbtcreate:=PCBT_CREATEWND(lParam);
  151.    if lpcbtcreate^.lpcs^.lpszClass=wc_dialog then
  152.     begin
  153.     w:=HWND(wParam);
  154.     first:=TRUE;
  155.     end else if first then
  156.     begin
  157.     proc2:=tfarproc(SetWindowLong(w,GWL_WNDPROC,longint(proc1)));
  158.     first:=false;
  159.     end;
  160.    end;
  161.  HCBT_DESTROYWND:if HWND(wParam)=w then unhook;
  162.  end;
  163. CBTProc:=CallNextHookEx(hkk,Code,wParam,lParam);
  164. end;
  165.  
  166. procedure paintboxes;
  167. var
  168.  w1,w2:hwnd;
  169.  s:string;
  170. begin
  171. w1:=findwindow(wc_dialog,nil);
  172. if w1<>0 then
  173.  repeat
  174.  getclassname(w1,@s[1],250);
  175.  if pas(s)='#32770' then invalidaterect(w1,nil,true);
  176.  w2:=w1;
  177.  w1:=getnextwindow(w2,gw_HWndNext);
  178.  until w1=0;
  179. end;
  180.  
  181. procedure ClrOut(i:integer;ss:string);
  182. begin
  183. ss:='  '+ss+': '+num(color[i])+' ('+tcn[color[i]]+')  ';
  184. setdlgitemtext(wi,99+i,p(ss));
  185. end;
  186.  
  187. function WinProc(Wi:HWnd;Message,WParam:Word;
  188.  LParam:Longint):Longint;export;
  189. var
  190.  i:integer;
  191.  r:TRect;
  192.  w2:hwnd;
  193.  
  194. begin
  195. WinProc:=0;
  196.  case Message of
  197.  wm_Command:
  198.   case wParam of
  199.   8:showwindow(wi,sw_hide);
  200.   9:
  201.          begin
  202.             messagebox(wi,
  203.     'This program to color dialog boxes is '+
  204.        'freeware by Harry Gensler '+
  205.     '(Philosophy Department, Loyola University, '+
  206.     '6525 North Sheridan, Chicago, IL 60626).'#13#10#13#10+
  207.              'Put in your StartUp group to run automatically; use '+
  208.              '"HIDE" command-line parameter to start hidden.',
  209.               'About Color Dialog Boxes',mb_ok);
  210.    setfocus(GetDlgItem(wi,itm));
  211.    end;
  212.   2:
  213.    begin
  214.    EndDialog(wi,0);
  215.    Exit;
  216.    end;
  217.   65..68:
  218.    begin
  219.    itm:=wParam;
  220.    setfocus(GetDlgItem(wi,itm));
  221.     case wparam of
  222.     65:
  223.                  begin
  224.                     if color[1]=0 then color[1]:=15 else dec(color[1]);
  225.                     makenewcolors;
  226.                     end;
  227.     66:
  228.                  begin
  229.         if color[1]=15 then color[1]:=0 else inc(color[1]);
  230.                     makenewcolors;
  231.                     end;
  232.     67:if color[2]=0 then color[2]:=15 else dec(color[2]);
  233.     68:if color[2]=15 then color[2]:=0 else inc(color[2]);
  234.     end;
  235.    sendmessage(wi,wm_setredraw,0,0);
  236.    ClrOut(1,'BACKGROUND');
  237.    ClrOut(2,'TEXT');
  238.    getclientrect(getdlgitem(Wi,9),r);
  239.    i:=r.right-r.left;
  240.    getclientrect(Wi,r);
  241.    with r do
  242.     begin
  243.     right:=right-i;
  244.     left:=left+i;
  245.     end;
  246.    sendmessage(wi,wm_setredraw,1,0);
  247.    invalidaterect(wi,@r,true);
  248.    updatewindow(wi);
  249.    paintboxes;
  250.    end;
  251.   end;
  252.  wm_setfocus:
  253.      begin
  254.         showwindow(wi,sw_show);
  255.   setfocus(GetDlgItem(wi,itm));
  256.   end;
  257.  wm_ctlcolor:
  258.   begin
  259.   SetBkColor(wParam,tc[color[1]]);
  260.   SetTextColor(wParam,tc[color[2]]);
  261.   winproc:=eraser;
  262.   exit;   
  263.   end;
  264.  wm_EraseBkGnd:
  265.   begin
  266.   getclientrect(wi,r);
  267.   fillrect(wParam,r,eraser);
  268.   winproc:=eraser;
  269.   exit;
  270.   end;
  271.  wm_Destroy:
  272.   begin
  273.   if eraser<>0 then deleteobject(eraser);
  274.   writecolors;
  275.   DestroyIcon(hicon1);
  276.   if w<>0 then
  277.    begin
  278.    w2:=w;
  279.    unhook;
  280.    invalidaterect(w2,nil,true);
  281.    end;
  282.   UnhookWindowsHookEx(hkk);
  283.   FreeProcInstance(AProc);
  284.         FreeProcInstance(proc1);
  285.   PostQuitMessage(0);
  286.   exit;
  287.   end;
  288.  wm_QueryEndSession:writecolors;
  289.  else;
  290.  end;
  291. WinProc:=DefWindowProc(Wi,Message,WParam,LParam);
  292. end;
  293.  
  294. procedure WinInit;
  295. var
  296.  dc:hdc;
  297.  s:string;
  298.  i:byte;
  299. const
  300.  WClass:TWndClass=(
  301.   Style:0;
  302.   lpfnWndProc:@WinProc;
  303.   cbClsExtra:0;
  304.   cbWndExtra:DlgWindowExtra;  
  305.   hInstance:0;
  306.   hIcon:0;
  307.   hCursor:0;
  308.   hbrBackground:0;
  309.   lpszMenuName:nil;
  310.   lpszClassName:AppName);
  311. begin
  312. wi:=findwindow(AppName,nil);
  313. if wi<>0 then
  314.  begin
  315.  showwindow(wi,sw_shownormal);
  316.     setfocus(wi);
  317.  exit;
  318.  end;
  319. dc:=getdc(getdesktopwindow);
  320. for i:=0 to 15 do tc[i]:=getnearestcolor(dc,tc[i]);
  321. releasedc(getdesktopwindow,dc);
  322. eraser:=getstockobject(gray_brush);
  323. WClass.hInstance:=HInstance;
  324. WClass.hIcon:=LoadIcon(hinstance,'W');
  325. WClass.hCursor:=LoadCursor(0,idc_Arrow);
  326. WClass.hbrBackground:=eraser;  
  327. if not RegisterClass(WClass) then halt(255);
  328. hinst1:=WClass.hInstance;
  329. hicon1:=WClass.hIcon; 
  330. mwid:=getsystemmetrics(sm_cxscreen);
  331. mht:=getsystemmetrics(sm_cyscreen);
  332. i:=GetProfileInt(AppName,'Background',15);
  333. if (i>=0) and (i<=15) then color[1]:=i;
  334. i:=GetProfileInt(AppName,'Text',0);
  335. if (i>=0) and (i<=15) then color[2]:=i;
  336. makenewcolors;
  337. Wi:=CreateDialog(hinstance,'W',0,nil);
  338. centerw(wi);
  339. ClrOut(1,'BACKGROUND');
  340. ClrOut(2,'TEXT');
  341. if CmdShow=6 then CmdShow:=sw_hide;
  342. aproc:=MakeProcInstance(@CBTProc,HInstance);
  343. hkproc:=THookProc(aproc);
  344. hkk:=SetWindowsHookEx(WH_CBT,hkproc,hinstance,0);
  345. proc1:=MakeProcInstance(@ans2,hinstance);
  346. s:='x';
  347. if paramcount>0 then s:=paramstr(1);
  348. if upcase(s[1])='H' then showwindow(wi,sw_hide)
  349.  else ShowWindow(Wi,CmdShow);
  350. end;
  351.  
  352. var
  353.  M:TMsg;
  354. begin
  355. WinInit;
  356. while GetMessage(M,0,0,0) do if not isdialogmessage(wi,M) then
  357.  begin
  358.  TranslateMessage(M);
  359.  DispatchMessage(M);
  360.  end;
  361. UnregisterClass(AppName,hinst1);
  362. Halt(m.wParam);
  363. end.