| blob | ee7ff978a8be779d5257c6ecdd551418d94a2f5a |
1 unit KOLSIZER;\r
2 //\r
3 // purpose: KOL control sizercontrol and design grid\r
4 // author: © 2004, Thaddy de Koning\r
5 // Remarks: Tnx in part to Marco Cantu for the sizer idea in DDH3\r
6 // copyrighted freeware.\r
7 //\r
8 interface\r
9 \r
10 uses\r
11 Windows, Messages, Kol;\r
12 \r
13 const\r
14 // Size and move commands for SysCommand\r
15 SZ_LEFT = $F001;\r
16 SZ_RIGHT = $F002;\r
17 SZ_TOP = $F003;\r
18 SZ_TOPLEFT = $F004;\r
19 SZ_TOPRIGHT = $F005;\r
20 SZ_BOTTOM = $F006;\r
21 SZ_BOTTOMLEFT = $F007;\r
22 SZ_BOTTOMRIGHT = $F008;\r
23 SZ_MOVE = $F012;\r
24 \r
25 \r
26 type\r
27 TPosInfo = record\r
28 Rect:Trect;\r
29 Pos:integer;\r
30 Direction:integer;\r
31 end;\r
32 \r
33 PSizerdata=^ TSizerdata;\r
34 TSizerdata= object(Tobj)\r
35 FControl:PControl;\r
36 FPosInfo: array [0..7] of TPosInfo;\r
37 Direction:longint;\r
38 procedure Dopaint(sender:pControl;DC:HDC);\r
39 end;\r
40 \r
41 \r
42 \r
43 PHack =^ THack;\r
44 THack = object(Tcontrol)\r
45 end;\r
46 \r
47 PDesigner=^TDesigner;\r
48 TDesigner=object(TStrlistEx)\r
49 private\r
50 FOwner:pControl;\r
51 FSpacing:Cardinal;\r
52 FOldPaint:TOnPaint;\r
53 FActive: boolean;\r
54 FSizer:PControl;\r
55 FOnControlChange: TonEvent;\r
56 FOnDblClick:TOnEvent;\r
57 FOnMouseDown:TOnMouse;\r
58 FCurrent: pControl;\r
59 FAction:integer;\r
60 procedure setactive(const Value: boolean);\r
61 function PrepareClassname(aControl: PControl): String;\r
62 function UniqueName(aName: String): String;\r
63 procedure SetCurrent(const Value: pControl);\r
64 procedure InternalControlChange(sender:pObj);\r
65 procedure Setspacing(Space:cardinal = 8);\r
66 protected\r
67 procedure init;virtual;\r
68 procedure DoKeyUp( Sender: PControl; var Key: Longint; Shift: DWORD );\r
69 public\r
70 destructor destroy;virtual;\r
71 procedure Connect(aName: String; aControl: pControl);\r
72 procedure DisConnect(aControl: pControl);\r
73 procedure Paintgrid(sender:pControl;DC:HDC);\r
74 property Spacing:cardinal read FSpacing write setspacing;\r
75 property Active:boolean read FActive write setactive;\r
76 property Action:integer read FAction write Faction;\r
77 property Current:pControl read FCurrent write SetCurrent;\r
78 property OnControlChange:TOnEvent Read FOnControlchange write FOnControlChange;\r
79 property OnDblClick:TonEvent read fOnDblClick write FOnDblClick;\r
80 property OnMouseDown:TOnMouse read FOnMouseDown write FOnMouseDown;\r
81 end;\r
82 \r
83 function NewSizerControl(AControl: PControl;aDesigner:PDesigner):PControl;\r
84 function NewDesigner(aOwner:pControl):pDesigner;\r
85 var\r
86 LocalDesigner:PDesigner;\r
87 \r
88 implementation\r
89 \r
90 \r
91 function DesignHandlerProc(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;\r
92 var MouseData:TMouseEventData;\r
93 begin\r
94 Result:=false;\r
95 case msg.message of\r
96 WM_LBUTTONDOWN:\r
97 begin\r
98 if Localdesigner.FOwner<> sender then LocalDesigner.current:=sender;\r
99 Result:=true;\r
100 {\r
101 if assigned(Localdesigner.OnMousedown) then\r
102 // Borrowed from KOL.pas\r
103 // enables us to pass on KOL mouse events back to the designer\r
104 // without having to connect to true KOL eventproperties.\r
105 with MouseData do\r
106 begin\r
107 Shift := Msg.wParam;\r
108 if GetKeyState(VK_MENU) < 0 then\r
109 Shift := Shift or MK_ALT;\r
110 X := LoWord(Msg.lParam);\r
111 Y := HiWord(Msg.lParam);\r
112 Button := mbNone;\r
113 StopHandling := true;\r
114 Rslt := 0; // needed ?\r
115 LocalDesigner.OnMousedown(sender,Mousedata);\r
116 Result:=true\r
117 end;\r
118 }\r
119 end\r
120 \r
121 end;\r
122 end;\r
123 \r
124 // TSizerControl methods\r
125 function WndProcSizer( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;\r
126 var\r
127 Pt: TPoint;\r
128 I: Integer;\r
129 R:Trect;\r
130 Data:PSizerdata;\r
131 begin\r
132 Data:=PSizerdata(sender.CustomObj);\r
133 Result:=True;\r
134 with sender^, Data^ do\r
135 begin\r
136 case msg.message of\r
137 WM_NCHITTEST:\r
138 begin\r
139 Pt := MakePoint(loword(Msg.lparam), hiword(Msg.lparam));\r
140 Pt := Screen2Client (Pt);\r
141 Rslt:=0;\r
142 for I := 0 to 7 do\r
143 if PtInRect (FPosInfo [I].rect, Pt) then\r
144 begin\r
145 // The value of rslt is passed on and makes\r
146 // the system select the correct cursor\r
147 // without us having to do anything more.\r
148 Rslt := FPosInfo [I].pos;\r
149 Direction:=FPosInfo[i].direction;\r
150 end;\r
151 if Rslt = 0 then\r
152 Result:=False;\r
153 end;\r
154 WM_SIZE:\r
155 begin\r
156 R := BoundsRect;\r
157 InflateRect (R, -2, -2);\r
158 Fcontrol.BoundsRect := R;\r
159 FPosInfo [0].rect := MakeRect (0, 0, 5, 5);\r
160 FPosInfo [1].rect := MakeRect (Width div 2 - 3, 0,\r
161 Width div 2 + 2, 5);\r
162 FPosInfo [2].rect := MakeRect (Width - 5, 0, Width, 5);\r
163 FPosInfo [3].rect := MakeRect (Width - 5, Height div 2 - 3,\r
164 Width, Height div 2 + 2);\r
165 FPosInfo [4].rect := MakeRect (Width - 5, Height - 5,\r
166 Width, Height);\r
167 FPosInfo [5].rect := MakeRect (Width div 2 - 3, Height - 5,\r
168 Width div 2 + 2, Height);\r
169 FPosInfo [6].rect := MakeRect (0, Height - 5, 5, Height);\r
170 FPosInfo [7].rect := MakeRect (0, Height div 2 - 3,\r
171 5, Height div 2 + 2);\r
172 end;\r
173 WM_NCLBUTTONDOWN:\r
174 Perform (wm_SysCommand, Direction, 0);\r
175 WM_LBUTTONDOWN:\r
176 Perform (wm_SysCommand, sz_move, 0);\r
177 WM_MOVE:\r
178 begin\r
179 R := BoundsRect;\r
180 InflateRect (R, -2, -2);\r
181 Fcontrol.Invalidate;\r
182 Fcontrol.BoundsRect := R;\r
183 end;\r
184 else\r
185 Result:=false;\r
186 end;\r
187 end;\r
188 end;\r
189 \r
190 function NewSizerControl(AControl: PControl;aDesigner:PDesigner):PControl;\r
191 var\r
192 R: TRect;\r
193 Data:PSizerdata;\r
194 begin\r
195 New(Data,Create);\r
196 Result:=NewPaintBox(aControl);\r
197 Result.ExStyle :=Result.ExStyle or ws_ex_transparent;\r
198 Result.OnKeyUp:=aDesigner.DoKeyUp;\r
199 if aDesigner.fowner<>aControl then\r
200 With result^, Data^ do\r
201 begin\r
202 FControl := AControl;\r
203 // set the size and position\r
204 R := aControl.BoundsRect;\r
205 InflateRect (R, 2, 2);\r
206 BoundsRect := R;\r
207 // set the parent\r
208 Parent := aControl.Parent;\r
209 // create the list of positions\r
210 FPosInfo [0].pos := htTopLeft;\r
211 FPosInfo [0].direction := sz_TopLeft;\r
212 FPosInfo [1].pos := htTop;\r
213 FPosInfo [1].direction := sz_Top;\r
214 FPosInfo [2].pos := htTopRight;\r
215 FPosInfo [2].direction := sz_TopRight;\r
216 FPosInfo [3].pos := htRight;\r
217 FPosInfo [3].direction := sz_Right;\r
218 FPosInfo [4].pos := htBottomRight;\r
219 FPosInfo [4].direction := sz_BottomRight;\r
220 FPosInfo [5].pos := htBottom;\r
221 FPosInfo [5].direction := sz_Bottom;\r
222 FPosInfo [6].pos := htBottomLeft;\r
223 FPosInfo [6].direction := sz_BottomLeft;\r
224 FPosInfo [7].pos := htLeft;\r
225 FPosInfo [7].direction := sz_Left;\r
226 CustomObj:=Data;\r
227 OnPaint:=DoPaint;\r
228 AttachProc(WndProcSizer);\r
229 Bringtofront;\r
230 Focused:=true\r
231 end;\r
232 end;\r
233 \r
234 procedure TSizerData.DoPaint(sender:pControl;DC:HDC);\r
235 var\r
236 I: Integer;\r
237 begin\r
238 // I simply use the current pen and brush\r
239 with pSizerdata(sender.Customobj)^ do\r
240 for I := 0 to 7 do\r
241 Rectangle(dc,FPosInfo [I].rect.Left, FPosInfo [I].rect.Top,\r
242 FPosInfo [I].rect.Right, FPosInfo [I].rect.Bottom);\r
243 end;\r
244 \r
245 procedure TDesigner.init;\r
246 begin\r
247 inherited;\r
248 Fspacing:=8;\r
249 end;\r
250 \r
251 procedure TDesigner.Paintgrid(sender: pControl; DC: HDC);\r
252 var\r
253 i, j: Integer;\r
254 begin\r
255 i := 0;\r
256 j := 0;\r
257 sender.canvas.FillRect(sender.canvas.cliprect);\r
258 if Assigned(FOldPaint) then FOldPaint(sender,DC);\r
259 repeat\r
260 repeat\r
261 MoveToEx(Dc,i, j,nil);\r
262 LineTo(Dc,i + 1,j);\r
263 inc(i, Fspacing);\r
264 until i > sender.ClientWidth;\r
265 i := 0;\r
266 inc(j, Fspacing);\r
267 until j > sender.Clientheight;\r
268 end;\r
269 \r
270 procedure TDesigner.Setspacing(Space: cardinal);\r
271 begin\r
272 Fspacing:=Space;\r
273 FOwner.invalidate;\r
274 end;\r
275 \r
276 { TDesigner }\r
277 function NewDesigner(aOwner:pControl):pDesigner;\r
278 begin\r
279 if Assigned(LocalDesigner) then\r
280 begin\r
281 result:=LocalDesigner;\r
282 MsgOk(' Exists' );\r
283 end else\r
284 begin\r
285 New(Result,Create);\r
286 with result^ do\r
287 begin\r
288 Fowner:=aOwner;\r
289 Connect('',Fowner);\r
290 FOldPaint:=Fowner.OnPaint;\r
291 LocalDesigner:=Result;\r
292 //Result.Current:=aOwner;\r
293 end\r
294 end\r
295 end;\r
296 \r
297 destructor TDesigner.destroy;\r
298 begin\r
299 setactive(false);\r
300 FOwner.OnPaint:=FOldPaint;\r
301 inherited;\r
302 end;\r
303 \r
304 //Note: Make shure that whatever happens, all pointers are nil or valid!\r
305 // Took a long time to debug spurious crashes.\r
306 // So this is not excessively safe.\r
307 procedure TDesigner.setactive(const Value: boolean);\r
308 var\r
309 i:integer;\r
310 begin\r
311 FActive := Value;\r
312 if FActive then\r
313 begin\r
314 FOwner.OnPaint:=Paintgrid;\r
315 if count > 1 then\r
316 begin\r
317 if assigned(Fcurrent) then\r
318 Fsizer:=NewSizerControl(Fcurrent,@self);\r
319 for i:=0 to count -1 do\r
320 if not Pcontrol(Objects[i]).IsprocAttached(DesignHandlerProc) then\r
321 PControl(Objects[i]).AttachProc(DesignHandlerProc);\r
322 end;\r
323 end\r
324 else\r
325 begin\r
326 if count > 0 then\r
327 for i:=0 to count -1 do\r
328 PControl(Objects[i]).DetachProc(DesignHandlerProc);\r
329 if assigned(Fsizer) then\r
330 begin\r
331 Fsizer.free;\r
332 Fsizer:=nil;\r
333 end;\r
334 Fcurrent:=nil;\r
335 FOwner.OnPaint:=FOldPaint;\r
336 end;\r
337 Fowner.invalidate;\r
338 end;\r
339 \r
340 procedure TDesigner.Connect(aName: String; aControl: pControl);\r
341 begin\r
342 if (IndexofObj(aControl) = -1) then\r
343 begin\r
344 if aName = '' then\r
345 aname := prepareClassname(aControl);\r
346 AddObject(uniquename(aName), Cardinal(aControl));\r
347 InternalControlChange(aControl);\r
348 setcurrent(aControl);\r
349 end;\r
350 end;\r
351 \r
352 procedure TDesigner.DisConnect(aControl: pControl);\r
353 var\r
354 Index: Integer;\r
355 begin\r
356 Index := IndexOfObj(aControl);\r
357 if index = -1 then\r
358 exit;\r
359 Delete(IndexOfObj(aControl));\r
360 aControl:=nil;\r
361 InternalControlChange(nil);\r
362 end;\r
363 \r
364 procedure TDesigner.SetCurrent(const Value: pControl);\r
365 begin\r
366 if assigned(Fsizer) then\r
367 begin\r
368 FSizer.free;\r
369 Fsizer:=nil;\r
370 end;\r
371 if value <> nil then\r
372 begin\r
373 FCurrent := Value;\r
374 if (FActive =true) and (Fcurrent<>nil) and (Fcurrent<>FOwner) then\r
375 Fsizer:=Newsizercontrol(Value,@self);\r
376 InternalControlChange(Value);\r
377 end;\r
378 end;\r
379 \r
380 procedure TDesigner.InternalControlChange(sender: pObj);\r
381 begin\r
382 if FActive then\r
383 if Assigned(OnControlChange)then\r
384 FOnControlChange(sender);\r
385 end;\r
386 \r
387 procedure TDesigner.DoKeyUp(Sender: PControl; var Key: Integer;\r
388 Shift: DWORD);\r
389 var\r
390 i:integer;\r
391 procedure DeleteControl(Index:integer);\r
392 var\r
393 i: Integer;\r
394 C:Pcontrol;\r
395 begin\r
396 C:=Pcontrol(Objects[index]);\r
397 if C.ChildCount > 0 then\r
398 for i := c.Childcount - 1 downto 0 do\r
399 if c <> Fowner then Deletecontrol(i);\r
400 if C<> FOwner then\r
401 begin\r
402 C.free;\r
403 C:=nil;\r
404 Delete(0);\r
405 end;\r
406 end;\r
407 begin\r
408 if Key = VK_DELETE then\r
409 begin\r
410 i:=IndexOfObj(LocalDesigner.Current);\r
411 if i<> -1 then\r
412 begin\r
413 Deletecontrol(i);\r
414 internalControlchange(nil);\r
415 postmessage(sender.Handle,WM_CLOSE,0,0);\r
416 end;\r
417 end;\r
418 end;\r
419 \r
420 \r
421 \r
422 \r
423 \r
424 // Converts an object name to a Delphi compatible control name that\r
425 // is unique for the designer, i.e 'Button' becomes 'Button1',\r
426 // the next button becomes 'Button2', always unless the\r
427 // control is already named by the user in which case the name is preserved\r
428 // unless there are conficts. In that case the control is silently\r
429 // renamed with a digit suffix without raising exceptions.\r
430 // Deleted names are re-used.\r
431 // It's not a beauty but it works.\r
432 // (A severe case of programming 48 hours without sleep)\r
433 \r
434 function TDesigner.UniqueName(aName: String): String;\r
435 var\r
436 I, J: Integer;\r
437 T: String;\r
438 begin\r
439 // Strip obj_ prefix and all other prefix+underscores from\r
440 // subclassname property: 'obj_BUTTON' becomes 'Button'\r
441 T := Lowercase(aName);\r
442 while T <> '' do aName := Parse(T, '_');\r
443 //Propercase it.\r
444 T := aName[1];\r
445 T := UpperCase(T);\r
446 aName[1] := T[1];\r
447 Result := aName;\r
448 // Add at least a 1 to the name if the last char\r
449 // is not a digit.\r
450 if not (aName[length(aName)] in ['0'..'9']) then\r
451 Result := Format('%s%d', [aName, 1]);\r
452 J := 1;\r
453 repeat\r
454 I := IndexOf(Result);\r
455 if I > -1 then\r
456 begin\r
457 inc(J);\r
458 Result := Format('%s%d', [aName, J]);\r
459 end;\r
460 until I = -1;\r
461 end;\r
462 \r
463 // This is probably not complete yet.\r
464 function TDesigner.PrepareClassname(aControl: PControl): String;\r
465 begin\r
466 Result := aControl.subclassname;\r
467 with aControl^ do\r
468 if subClassname = 'obj_STATIC' then\r
469 begin\r
470 // Only place where panel and label differ\r
471 // consistently???\r
472 if pHack(aControl).fSizeRedraw = True then\r
473 Result := 'obj_LABEL'\r
474 else\r
475 Result := 'obj_PANEL'\r
476 end\r
477 else if subclassname = 'obj_BUTTON' then\r
478 begin\r
479 if Boolean(Style and BS_AUTOCHECKBOX) then\r
480 Result := 'obj_CHECKBOX'\r
481 else if Boolean(style and BS_RADIOBUTTON) then\r
482 Result := 'obj_RADIOBOX'\r
483 else if Boolean(style and BS_OWNERDRAW) then\r
484 Result := 'obj_BITBTN'\r
485 else if Boolean(style and BS_GROUPBOX) then\r
486 Result := 'obj_GROUPBOX';\r
487 end\r
488 else if indexofstr(Uppercase(subclassname), 'RICHEDIT')>-1 then\r
489 Result := 'obj_RICHEDIT';\r
490 end;\r
491 \r
492 \r
493 end.\r