Unit CContr; INTERFACE Uses Win2K2,Graph,CoolKey; Function InitCommonControls:INT16; IMPLEMENTATION Type PButSet = ^TButtonSettings; TButtonSettings = record bPressed, bEnabled, bVisible,bInside : boolean; Handle : HWND; ID : UINT16; Next : PButSet; end; const AllButtons : PButSet = nil; Function ButtonProc(ahWnd:HWND;aMsg,wParam,lParam:UINT32):UINT32;far; var c1,c2:UINT8; nB,c : PButSet; ps : LPPAINTSTRUCT; Txt : String[100]; box : RECT; begin case aMsg of WM_CREATE: begin if AllButtons = nil then begin New(AllButtons); AllButtons^.Next := nil; end; New(nB); with nB^ do begin bPressed := false;bEnabled := true; bVisible := true; bInside := false; ID := 0; Handle := ahWnd; Next := nil; end; c := AllButtons; while c^.next <> nil do c := c^.Next; c^.Next := nB; PostMessage(ahWnd,WM_PAINT,0,0); end; WM_DESTROY: begin if AllButtons^.Next <> nil then begin c := AllButtons; while c^.next^.Handle <> ahWnd do c := c^.next; nB := c^.next;c^.next := nB^.Next; Dispose(nB); end else begin Dispose(AllButtons); AllButtons := nil; end; PostQuitMessage(ahWnd); end; WM_GETVISIBLE: begin if AllButtons = nil then exit; c:=AllButtons^.next; while c^.Handle <> aHwnd do c := c^.next; ButtonProc := UINT32(C^.bVisible); end; WM_SETVISIBLE: begin if AllButtons = nil then exit; c:=AllButtons^.next; while c^.Handle <> aHwnd do c := c^.next; C^.bVisible := boolean(wParam); PostMessage(ahWnd,WM_PAINT,0,0); end; WM_LBUTTONDOWN: begin c := AllButtons^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do begin if bEnabled and bVisible then begin bPressed := true; PostMessage(ahWnd,WM_PAINT,0,0); PostMessage(GetParent(ahWnd),WM_COMMAND,ID,1); end; end; end; CB_SETID: begin c := AllButtons^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do ID := wParam; end; CB_GETID: begin c := AllButtons^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do ButtonProc := ID; end; WM_LBUTTONUP: begin c := AllButtons^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do begin if bEnabled and bVisible and bPressed and bInside then begin PostMessage(GetParent(ahWnd),WM_COMMAND,ID,0); PostMessage(ahWnd,WM_PAINT,0,0); bPressed := false; end; end; end; WM_MOUSEIN: begin c := AllButtons^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do begin bInside := true; PostMessage(ahWnd,WM_PAINT,0,0); end; end; WM_MOUSEOUT: begin c := AllButtons^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do begin bInside := false; PostMessage(ahWnd,WM_PAINT,0,0); end; end; WM_KEYDOWN: begin c := AllButtons^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do begin if (wParam = ord(SC_ENTER)) and bEnabled and bVisible then PostMessage(GetParent(ahWnd),WM_COMMAND,ID,1); end; end; WM_KEYUP: begin c := AllButtons^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do begin if (wParam = ord(SC_ENTER)) and bEnabled and bVisible then PostMessage(GetParent(ahWnd),WM_COMMAND,ID,0); end; end; WM_PAINT: begin c := AllButtons^.Next; if c = nil then exit; while c^.Handle <> ahWnd do c := c^.next; with c^ do begin ps := BeginPaint(ahWnd); wSetBGColor(ps,GlobalPalette.ThreeDColor1); wSetStyle(ps,SolidFill); wSetColor(ps,GlobalPalette.WindowFontColor); wSetFontJustify(ps,CenterText,CenterText); GetClientRect(ahWnd,@box); GetWindowText(ahWnd,@Txt,100); wBar(ps,0,0,box.b.x,box.b.y); if bVisible then begin if bInside then begin if bPressed then begin c1:=Black; c2:=White; wTextOut(ps,(Box.B.X shr 1)+1,(Box.B.Y shr 1)+1, @Txt); end else begin c2:=Black; c1:=White; wTextOut(ps,(Box.B.X shr 1),(Box.B.Y shr 1), @Txt); end; wSetColor(ps,c1); wLine(ps,0,0,Box.B.X-1,0); wLine(ps,0,0,0,Box.B.Y-1); wSetColor(ps,c2); wLine(ps,0,Box.B.Y,Box.B.X-1,Box.B.Y); wLine(ps,Box.B.X,0,Box.B.X,Box.B.Y); end else wTextOut(ps,Box.B.X shr 1,Box.B.Y shr 1, @Txt); end; EndPaint(ps); end; end; end; end; type PCheckSet = ^TCheckSet; TCheckSet = record bChecked, bEnabled, bVisible : boolean; ID : UINT32; Handle : HWND; Next : PCheckSet; end; const AllChecks : PCheckSet = nil; Function CheckProc(ahWnd:HWND;aMsg,wParam,lParam:UINT32):UINT32;far; var nB,c : PCheckSet; ps : LPPAINTSTRUCT; Txt : String; box : RECT; begin case aMsg of WM_CREATE: begin if AllChecks = nil then begin New(AllChecks); AllChecks^.Next := nil; end; New(nB); with nB^ do begin bChecked := false;bEnabled := true; bVisible := true; Handle := ahWnd; ID := UINT32(ahWnd); Next := nil; end; c := AllChecks; while c^.next <> nil do c := c^.Next; c^.Next := nB; PostMessage(ahWnd,WM_PAINT,0,0); end; WM_DESTROY: begin if AllChecks^.Next <> nil then begin c := AllChecks; while c^.next^.Handle <> ahWnd do c := c^.next; nB := c^.next;c^.next := nB^.Next; Dispose(nB); end else begin Dispose(AllChecks); AllChecks := nil; end; PostQuitMessage(ahWnd); end; CB_SETID: begin c := AllChecks^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do ID := wParam; end; CB_GETID: begin c := AllChecks^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do CheckProc := ID; end; WM_GETVISIBLE: begin if AllChecks = nil then exit; c:=AllChecks^.next; while c^.Handle <> aHwnd do c := c^.next; CheckProc := UINT32(C^.bVisible); end; WM_SETVISIBLE: begin if AllChecks = nil then exit; c:=AllChecks^.next; while c^.Handle <> aHwnd do c := c^.next; C^.bVisible := boolean(wParam); PostMessage(ahWnd,WM_PAINT,0,0); end; WM_LBUTTONDOWN: begin c := AllChecks^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do begin if bEnabled and bVisible then begin PostMessage(GetParent(ahWnd),WM_COMMAND,ID,1); end; end; end; WM_LBUTTONUP: begin c := AllChecks^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do if bEnabled and bVisible then begin bChecked := not bChecked; PostMessage(ahWnd,WM_PAINT,0,0); PostMessage(GetParent(ahWnd),WM_COMMAND,ID,0); end; end; WM_KEYDOWN: begin c := AllChecks^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do begin if (wParam = ord(SC_SPACE)) and bEnabled and bVisible then begin bChecked := not bChecked; PostMessage(ahWnd,WM_PAINT,0,0); end; end; end; CB_GETCHECK: begin c := AllChecks^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do CheckProc := UINT32(bChecked); end; CB_SETCHECK: begin c := AllChecks^.Next; while c^.Handle <> ahWnd do c := c^.next; with c^ do bChecked := boolean(wParam); PostMessage(ahWnd,WM_PAINT,0,0); end; WM_PAINT: begin if AllChecks = nil then exit; c := AllChecks^.Next; if c = nil then exit; while c^.Handle <> ahWnd do c := c^.next; with c^ do begin ps := BeginPaint(ahWnd); wSetBGColor(ps,GlobalPalette.ThreeDColor1); wSetStyle(ps,SolidFill); GetClientRect(ahWnd,@box); wBar(ps,0,0,box.b.x,box.b.y); if bVisible then begin wSetColor(ps,GlobalPalette.ThreeDColor2); wRectangle(ps,1,1,box.b.y-2,box.b.y-2); wSetColor(ps,Black); if bChecked then begin wLine(ps,2,2,(box.b.y-2) shr 1, box.b.y-3); wLine(ps,(box.b.y-2) shr 1,box.b.y-3,box.b.y-3,2); end; wSetColor(ps,GlobalPalette.WindowFontColor); wSetFontJustify(ps,LeftText,CenterText); GetWindowText(ahWnd,@Txt,255); wTextOut(ps,box.b.y+1,box.b.y shr 1,@Txt); end; EndPaint(ps); end; end; end; end; Type PEditSet = ^TEditSettings; TEditSettings = record bEnabled, bVisible : boolean; CurPos,fVis,MaxLen : INT16; Handle : HWND; Next : PEditSet; end; const AllEdits : PEditSet = nil; Function EditProc(ahWnd:HWND;aMsg,wParam,lParam:UINT32):UINT32;far; var x : INT16; c1 : UINT8; ps : LPPAINTSTRUCT; nE,c : PEditSet; Txt : String; cc : char; box : RECT; begin case aMsg of WM_CREATE: begin if AllEdits = nil then begin New(AllEdits); AllEdits^.Next := nil; end; New(nE); with nE^ do begin bEnabled := true; bVisible := true; CurPos := 0;fVis := 0; MaxLen := Round(PWindow(lParam)^.Pos.B.X / TextWidth('H')); Handle := ahWnd; Next := nil; end; c := AllEdits; while c^.next <> nil do c:=c^.next; c^.Next := nE; PostMessage(ahWnd,WM_PAINT,0,0); end; WM_DESTROY: begin if AllEdits^.Next <> nil then begin c := AllEdits; while c^.next^.Handle <> ahWnd do c := c^.next; nE := c^.next;c^.next := nE^.Next; Dispose(nE); end else begin Dispose(AllEdits); AllEdits := nil; end; PostQuitMessage(ahWnd); end; WM_GETVISIBLE: begin if AllEdits = nil then exit; c:=AllEdits^.next; while c^.Handle <> aHwnd do c := c^.next; EditProc := UINT32(C^.bVisible); end; WM_SETVISIBLE: begin if AllEdits = nil then exit; c:=AllEdits^.next; while c^.Handle <> aHwnd do c := c^.next; C^.bVisible := boolean(wParam); PostMessage(ahWnd,WM_PAINT,0,0); end; WM_LOSTFOCUS: PostMessage(aHWnd,WM_PAINT,0,0); WM_LBUTTONDOWN: begin c := AllEdits^.next; while c^.handle <> aHWnd do c := c^.next; with c^ do begin if bEnabled and bVisible then begin GetWindowText(ahWnd,@Txt,255); x := lParam AND $FFFF; if x > 5 then begin CurPos := fVis + round((1.0*x-5) / TextWidth('H')); if CurPos > Length(Txt) then CurPos := Length(Txt); PostMessage(ahWnd,WM_PAINT,0,0); end; end; end; end; WM_KEYDOWN: begin c := AllEdits^.next; while c^.handle <> aHWnd do c := c^.next; with c^ do begin if bEnabled and bVisible then begin GetWindowText(ahWnd,@Txt,255); if ((wParam = ord(SC_LEFT)) or ((wParam = ord (SC_PAD_HOME)) AND ifNum)) AND (CurPos > 0) then begin Dec(CurPos); if CurPos < fVis then fVis := CurPos; end else if ((wParam = ord(SC_RIGHT)) or ((wParam = ord (SC_PAD_RIGHT)) AND ifNum)) AND (CurPos <> Length(Txt)) and (Length(Txt) <> 0) then begin if CurPos <> Length(Txt) then inc(CurPos); if (CurPos-fVis) >= MaxLen then inc(fVis); end else if (wParam = ord(SC_HOME)) or ((wParam = ord (SC_PAD_HOME)) AND ifNum) then begin CurPos := 0; fVis := 0; end else if (wParam = ord(SC_END)) or ((wParam = ord (SC_PAD_END)) AND ifNum) then begin CurPos := Length(Txt); if (CurPos-fVis) >= MaxLen then fVis := CurPos-MaxLen+1; end else if (wParam = ord(SC_DELETE)) or ((wParam = ord (SC_PAD_DEL)) AND ifNum) then begin Delete(Txt,CurPos+1,1); SetWindowText(ahWnd,@Txt); end else if wParam = ord(SC_BACKSPACE) then begin if CurPos > 0 then begin Delete(Txt,Curpos,1); Dec(Curpos); if CurPos < fVis then fVis := CurPos; SetWindowText(ahWnd,@Txt); end; end else if PrintChar(wParam AND $FF) then begin Insert(Char(lParam AND $FF),Txt,CurPos+1); {if CurPos = Length(Txt)-1 then} Inc(CurPos); if (CurPos-fVis) >= MaxLen then inc(fVis); SetWindowText(ahWnd,@Txt); end; PostMessage(ahWnd,WM_PAINT,0,0); end; end; end; WM_PAINT: begin c := AllEdits^.next; if C = nil then exit; while c^.handle <> aHWnd do c := c^.next; with c^ do begin ps := BeginPaint(ahWnd); wSetBGColor(ps,GlobalPalette.WindowBGColor); wSetStyle(ps,SolidFill); GetClientRect(ahWnd,@box); wBar(ps,0,0,box.b.x,box.b.y); if bVisible then begin wSetBGColor(ps,GlobalPalette.ThreeDColor1); wBar(ps,1,1,box.b.x-1,box.b.y-1); GetWindowText(ahWnd,@Txt,255); Txt := Copy(Txt,fVis+1,MaxLen); wSetFontJustify(ps,LeftText,CenterText); wSetColor(ps,GlobalPalette.WindowFontColor); wTextOut(ps,5,Box.B.Y shr 1, @Txt); if IsKeyActive(ahWnd) then wLine(ps,4+(CurPos-fVis)*TextWidth('H'), (Box.B.Y shr 1) - (TextHeight('H') shr 1) - 1, 4+(CurPos-fVis)*TextWidth('H'), (Box.B.Y shr 1) + (TextHeight('H') shr 1) + 1); end; EndPaint(ps); end; end; end; end; Function LabelProc(ahWnd:HWND;aMsg,wParam,lParam:UINT32):UINT32;far; var ps : LPPAINTSTRUCT; Txt : String; box : RECT; begin case aMsg of WM_PAINT: begin ps := BeginPaint(ahWnd); GetClientRect(ahWnd,@box); wSetStyle(ps,SolidFill); wSetBGColor(ps,GlobalPalette.ThreeDColor1); wBar(ps,1,1,box.b.x-1,box.b.y-1); GetWindowText(ahWnd,@Txt,255); wSetFontJustify(ps,LeftText,CenterText); wSetColor(ps,GlobalPalette.WindowFontColor); Txt := Copy(Txt,1,round((Box.B.X-5) / TextWidth('H'))); wTextOut(ps,3,Box.B.Y shr 1, @Txt); EndPaint(ps); end; else LabelProc:=DefWindowProc(aHwnd,aMsg,wParam,lParam); end; end; Type PPointList = ^TPointList; TPointList = record X,Y : real; Next : PPointList; end; TPlotData = record Color : UINT8; Render : boolean; MaxX,MinX,MaxY,MinY : real; Points : PPointList; end; TPlotDataArr = array [0..10] of TPlotData; PPlotDataArr = ^TPlotDataArr; PPlotSet = ^XYPlotSettings; XYPlotSettings = record Handle : HWND; bVisible : boolean; BgColor : UINT8; XYCnt : UINT8; Plots : PPlotDataArr; Next : PPlotSet; end; const AllPlots : PPlotSet = nil; Procedure InitPlot(var aP:TPlotData;aColor:UINT8); begin with aP do begin MaxX:=0;MinX:=0;MaxY:=0;MinY:=0;Color:=aColor; Render := true; New(Points); Points^.X:=0; Points^.Y:=0; Points^.Next:=nil; end; end; Function XYPlotProc(ahWnd:HWND;aMsg,wParam,lParam:UINT32):UINT32;far; var i : UINT16; px,py: int16; SX,SY: real; ps : LPPAINTSTRUCT; nB,c : PPlotSet; nP : PPlotDataArr; cp,cc: PPointList; box : RECT; begin case aMsg of WM_CREATE: begin if AllPlots = nil then begin New(AllPlots); AllPlots^.next := nil; end; New(nB); with nB^ do begin Handle := ahWnd; bVisible := true; BGColor := Black; XYCnt := 1; Plots := Alloc(Sizeof(TPlotData)); InitPlot(Plots^[0],Red); end; c := AllPlots; while c^.next <> nil do c:=c^.next; c^.Next := nB; end; WM_DESTROY: begin if AllPlots^.next <> nil then begin c:=AllPlots; while c^.next^.handle <> aHWND do c := c^.next; nB := c^.next; c^.next := nB^.next; with nB^ do begin for i := 0 to XYCnt-1 do with Plots^[i] do while Points <> nil do begin cP := Points^.next; Dispose(Points); Points := cP; end; FreeMem(Plots,SizeoF(TPlotData)*XYCnt); end; Dispose(nB); end else begin Dispose(AllPlots); AllPlots:=nil; end; PostQuitMessage(ahWnd); end; XP_SETPLOTCOUNT: begin if AllPlots = nil then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; with c^ do begin if wParam < XYCnt then exit; GetMem(nP,Sizeof(TPlotData)*wParam); FillChar(np^,Sizeof(TPlotData)*wParam,0); Move(Plots^,nP^,Sizeof(TPlotData)*XYCnt); FreeMem(Plots,Sizeof(TPlotData)*XYCnt); Plots := nP; for i := XYCnt to wParam-1 do InitPlot(Plots^[i],i+1-XYCnt); XYCnt := wParam; end; end; XP_GETPLOTCOUNT: begin if AllPlots = nil then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; with c^ do XYPlotProc := XYCnt; end; XP_SETCOLOR: begin if AllPlots = nil then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; with c^ do if wParam < XYCnt then Plots^[wParam].Color := lParam; end; XP_GETCOLOR: begin if AllPlots = nil then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; with c^ do if wParam < XYCnt then XYPlotProc := Plots^[wParam].Color; end; XP_SETXRANGE: begin if AllPlots = nil then exit; if lParam = 0 then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; with c^ do if wParam < XYCnt then with Plots^[wParam] do begin MinX := PRPoint(lParam)^.X; MaxX := PRPoint(lParam)^.Y; end; end; XP_GETXRANGE: begin if AllPlots = nil then exit; if lParam = 0 then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; with c^ do if wParam < XYCnt then with Plots^[wParam] do begin PRPoint(lParam)^.X := MinX; PRPoint(lParam)^.Y := MaxX; end; end; XP_SETYRANGE: begin if AllPlots = nil then exit; if lParam = 0 then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; with c^ do if wParam < XYCnt then with Plots^[wParam] do begin MinY := PRPoint(lParam)^.X; MaxY := PRPoint(lParam)^.Y; end; end; WM_SETVISIBLE: begin if AllPlots = nil then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; with c^ do if wParam < XYCnt then with Plots^[wParam] do begin Render := boolean(lParam); PostMessage(ahwnd,WM_PAINT,0,0); end; end; WM_GETVISIBLE: begin if AllPlots = nil then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; with c^ do if wParam < XYCnt then with Plots^[wParam] do XYPlotProc := UINT32(Render); end; XP_GETYRANGE: begin if AllPlots = nil then exit; if lParam = 0 then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; with c^ do if wParam < XYCnt then with Plots^[wParam] do begin PRPoint(lParam)^.X := MinY; PRPoint(lParam)^.Y := MaxY; end; end; XP_ADDPOINT: begin if AllPlots = nil then exit; if lParam = 0 then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; if wParam < c^.XYCnt then with c^.Plots^[wParam] do begin New(cP); with cP^ do begin X:=PRPoint(lParam)^.X; Y:=PRPoint(lParam)^.Y; next := nil; end; if cp^.X < MinX then MinX:=cp^.X; if cp^.X > MaxX then MaxX:=cp^.X; if cp^.Y < MinY then MinY:=cp^.Y; if cp^.Y > MaxY then MaxY:=cp^.Y; cc := Points; while (cc^.next <> nil) and (cc^.next^.x < cP^.X) do cc := cc^.next; cP^.Next := cc^.next; cc^.next := cP; {PostMessage(aHWnd,WM_PAINT,0,0);} end; end; XP_DELPOINT: begin if AllPlots = nil then exit; if lParam = 0 then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; if wParam < c^.XYCnt then with c^.Plots^[wParam] do begin cc := Points; while (cc^.next<>nil) and not ( (cc^.Next^.x = PRPoint(lParam)^.X) AND (cc^.Next^.Y = PRPoint(lParam)^.Y)) do cc := cc^.next; if cc^.next <> nil then begin cP := cc^.next; cc^.next:=cp^.next; Dispose(cP); PostMessage(aHWnd,WM_PAINT,0,0); end; end; end; XP_DELALLPOINTS: begin if AllPlots = nil then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; if wParam < c^.XYCnt then with c^.Plots^[wParam] do while Points^.next <> nil do begin cP := Points^.next^.next; Dispose(Points^.next); Points^.next := cP; end; end; WM_PAINT: begin if AllPlots = nil then exit; c:=AllPlots^.next; while c^.Handle <> aHwnd do c := c^.next; with c^ do if bVisible then begin ps := BeginPaint(ahWnd); GetClientRect(ahWnd,@box); wSetStyle(ps,SolidFill); wSetBGColor(ps,BGColor); wBar(ps,0,0,box.b.x,box.b.y); for i := 0 to XYCnt-1 do if (Plots^[i].Points^.next <> nil) AND Plots^[i].Render then with Plots^[i] do begin SX := MaxX-MinX; SY := MaxY-MinY; wSetColor(ps,Color); {wSetBGColor(ps,Color);} px := round(Box.B.X*(Points^.Next^.X-MinX)/SX); py := round(Box.B.Y*(1-(Points^.Next^.Y-MinY)/SY)); {wFillCircle(ps,px,py,2);} wMoveToEx(ps,px,py,nil); cc := Points^.next^.next; while cc<>nil do begin px := round(Box.B.X*(cc^.X-MinX)/SX); py := round(Box.B.Y*(1-(cc^.Y-MinY)/SY)); {wFillCircle(ps,px,py,2);} wLineTo(ps,px,py); cc := cc^.next; end; end; EndPaint(ps); end; end; end; end; Function InitCommonControls:INT16; begin RegisterClass('BUTTON',ButtonProc); RegisterClass('EDIT',EditProc); RegisterClass('LABEL',LabelProc); RegisterClass('XYPLOT',XYPlotProc); RegisterClass('CHECKBOX',CheckProc); end; END.