Changeset 6 for trunk/Messg.pas
- Timestamp:
- Jan 7, 2017, 11:32:14 AM (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/Messg.pas
r2 r6 1 1 {$INCLUDE switches} 2 3 2 unit Messg; 4 3 … … 8 7 ScreenTools, 9 8 10 Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms,ButtonBase,ButtonA, 11 ButtonB,Area; 9 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ButtonBase, 10 ButtonA, 11 ButtonB, Area; 12 12 13 13 const 14 WM_PLAYSOUND=WM_USER;14 WM_PLAYSOUND = WM_USER; 15 15 16 16 type … … 20 20 procedure SmartInvalidate; virtual; 21 21 protected 22 TitleHeight: integer; // defines area to grip the window for moving (from top) 22 TitleHeight: integer; 23 // defines area to grip the window for moving (from top) 23 24 procedure InitButtons(); 24 procedure OnEraseBkgnd(var m: TMessage); message WM_ERASEBKGND;25 procedure OnHitTest(var Msg: TMessage); message WM_NCHITTEST;25 procedure OnEraseBkgnd(var m: TMessage); message WM_ERASEBKGND; 26 procedure OnHitTest(var Msg: TMessage); message WM_NCHITTEST; 26 27 end; 27 28 28 29 TBaseMessgDlg = class(TDrawDlg) 29 30 procedure FormCreate(Sender: TObject); 30 procedure FormPaint(Sender: TObject);31 procedure FormPaint(Sender: TObject); 31 32 public 32 33 MessgText: string; … … 40 41 Button1: TButtonA; 41 42 Button2: TButtonA; 42 procedure FormCreate(Sender: TObject);43 procedure FormPaint(Sender: TObject);43 procedure FormCreate(Sender: TObject); 44 procedure FormPaint(Sender: TObject); 44 45 procedure FormShow(Sender: TObject); 45 46 procedure Button1Click(Sender: TObject); … … 50 51 OpenSound: string; 51 52 private 52 procedure OnPlaySound(var Msg: TMessage); message WM_PLAYSOUND;53 procedure OnPlaySound(var Msg: TMessage); message WM_PLAYSOUND; 53 54 end; 54 55 55 56 const 56 // message kinds 57 mkOK=1; mkOKCancel=2; mkYesNo=3; 58 59 Border=3; 60 MessageLineSpacing=20; 61 62 var 63 MessgDlg:TMessgDlg; 57 // message kinds 58 mkOK = 1; 59 mkOKCancel = 2; 60 mkYesNo = 3; 61 62 Border = 3; 63 MessageLineSpacing = 20; 64 65 var 66 MessgDlg: TMessgDlg; 64 67 65 68 procedure SimpleMessage(SimpleText: string); 66 69 procedure SoundMessage(SimpleText, SoundItem: string); 67 70 68 69 71 implementation 70 72 … … 73 75 constructor TDrawDlg.Create(AOwner: TComponent); 74 76 begin 75 inherited; 76 TitleHeight:=0; 77 end; 78 79 procedure TDrawDlg.OnEraseBkgnd(var m:TMessage); 80 begin 81 end; 82 83 procedure TDrawDlg.OnHitTest(var Msg:TMessage); 84 var 85 i: integer; 86 ControlBounds: TRect; 87 begin 88 if BorderStyle<>bsNone then 89 inherited 90 else 91 begin 92 if integer(Msg.LParamHi)>=Top+TitleHeight then 93 Msg.result:=HTCLIENT 77 inherited; 78 TitleHeight := 0; 79 end; 80 81 procedure TDrawDlg.OnEraseBkgnd(var m: TMessage); 82 begin 83 end; 84 85 procedure TDrawDlg.OnHitTest(var Msg: TMessage); 86 var 87 i: integer; 88 ControlBounds: TRect; 89 begin 90 if BorderStyle <> bsNone then 91 inherited 94 92 else 95 begin 96 for i:=0 to ControlCount-1 do if Controls[i].Visible then 97 begin 98 ControlBounds:=Controls[i].BoundsRect; 99 if (integer(Msg.LParamLo)>=Left+ControlBounds.Left) 100 and (integer(Msg.LParamLo)<Left+ControlBounds.Right) 101 and (integer(Msg.LParamHi)>=Top+ControlBounds.Top) 102 and (integer(Msg.LParamHi)<Top+ControlBounds.Bottom) then 93 begin 94 if integer(Msg.LParamHi) >= Top + TitleHeight then 95 Msg.result := HTCLIENT 96 else 97 begin 98 for i := 0 to ControlCount - 1 do 99 if Controls[i].Visible then 103 100 begin 104 Msg.result:=HTCLIENT; 105 exit; 101 ControlBounds := Controls[i].BoundsRect; 102 if (integer(Msg.LParamLo) >= Left + ControlBounds.Left) and 103 (integer(Msg.LParamLo) < Left + ControlBounds.Right) and 104 (integer(Msg.LParamHi) >= Top + ControlBounds.Top) and 105 (integer(Msg.LParamHi) < Top + ControlBounds.Bottom) then 106 begin 107 Msg.result := HTCLIENT; 108 exit; 109 end; 106 110 end; 107 end; 108 Msg.result:=HTCAPTION 111 Msg.result := HTCAPTION 109 112 end; 110 113 end … … 113 116 procedure TDrawDlg.InitButtons(); 114 117 var 115 cix: integer;116 //ButtonDownSound, ButtonUpSound: string;117 begin 118 //ButtonDownSound:=Sounds.Lookup('BUTTON_DOWN');119 //ButtonUpSound:=Sounds.Lookup('BUTTON_UP');120 for cix:=0 to ComponentCount-1 do121 if Components[cix] is TButtonBase then122 begin 123 TButtonBase(Components[cix]).Graphic:=GrExt[HGrSystem].Data;124 //if ButtonDownSound<>'*' then125 //DownSound:=HomeDir+'Sounds\'+ButtonDownSound+'.wav';126 //if ButtonUpSound<>'*' then127 //UpSound:=HomeDir+'Sounds\'+ButtonUpSound+'.wav';128 if Components[cix] is TButtonA then129 TButtonA(Components[cix]).Font:=UniFont[ftButton];130 if Components[cix] is TButtonB then131 TButtonB(Components[cix]).Mask:=GrExt[HGrSystem].Mask;118 cix: integer; 119 // ButtonDownSound, ButtonUpSound: string; 120 begin 121 // ButtonDownSound:=Sounds.Lookup('BUTTON_DOWN'); 122 // ButtonUpSound:=Sounds.Lookup('BUTTON_UP'); 123 for cix := 0 to ComponentCount - 1 do 124 if Components[cix] is TButtonBase then 125 begin 126 TButtonBase(Components[cix]).Graphic := GrExt[HGrSystem].Data; 127 // if ButtonDownSound<>'*' then 128 // DownSound:=HomeDir+'Sounds\'+ButtonDownSound+'.wav'; 129 // if ButtonUpSound<>'*' then 130 // UpSound:=HomeDir+'Sounds\'+ButtonUpSound+'.wav'; 131 if Components[cix] is TButtonA then 132 TButtonA(Components[cix]).Font := UniFont[ftButton]; 133 if Components[cix] is TButtonB then 134 TButtonB(Components[cix]).Mask := GrExt[HGrSystem].Mask; 132 135 end; 133 136 end; … … 135 138 procedure TDrawDlg.SmartInvalidate; 136 139 var 137 i: integer;138 r0,r1: HRgn;139 begin 140 r0:=CreateRectRgn(0,0,ClientWidth,ClientHeight);141 for i:=0 to ControlCount-1 do142 if not(Controls[i] is TArea) and Controls[i].Visible then143 begin 144 with Controls[i].BoundsRect do145 r1:=CreateRectRgn(Left,Top,Right,Bottom);146 CombineRgn(r0,r0,r1,RGN_DIFF);147 DeleteObject(r1);148 end; 149 InvalidateRgn(Handle,r0,false);150 DeleteObject(r0);140 i: integer; 141 r0, r1: HRgn; 142 begin 143 r0 := CreateRectRgn(0, 0, ClientWidth, ClientHeight); 144 for i := 0 to ControlCount - 1 do 145 if not(Controls[i] is TArea) and Controls[i].Visible then 146 begin 147 with Controls[i].BoundsRect do 148 r1 := CreateRectRgn(Left, Top, Right, Bottom); 149 CombineRgn(r0, r0, r1, RGN_DIFF); 150 DeleteObject(r1); 151 end; 152 InvalidateRgn(Handle, r0, false); 153 DeleteObject(r0); 151 154 end; 152 155 153 156 procedure TBaseMessgDlg.FormCreate(Sender: TObject); 154 157 begin 155 Left:=(Screen.Width-ClientWidth) div 2; 156 Canvas.Font.Assign(UniFont[ftNormal]); 157 Canvas.Brush.Style:=bsClear; 158 MessgText:=''; 159 TopSpace:=0; 160 TitleHeight:=Screen.Height; 161 InitButtons(); 162 end; 163 164 procedure TBaseMessgDlg.FormPaint(Sender:TObject); 165 var 166 i,cix: integer; 167 begin 168 PaintBackground(self,3+Border,3+Border,ClientWidth-(6+2*Border), 169 ClientHeight-(6+2*Border)); 170 for i:=0 to Border do 171 Frame(Canvas,i,i,ClientWidth-1-i,ClientHeight-1-i, 172 $000000,$000000); 173 Frame(Canvas,Border+1,Border+1,ClientWidth-(2+Border),ClientHeight-(2+Border), 174 MainTexture.clBevelLight,MainTexture.clBevelShade); 175 Frame(Canvas,2+Border,2+Border,ClientWidth-(3+Border),ClientHeight-(3+Border), 176 MainTexture.clBevelLight,MainTexture.clBevelShade); 177 SplitText(false); 178 179 for cix:=0 to ControlCount-1 do 180 if (Controls[cix].Visible) and (Controls[cix] is TButtonBase) then 181 BtnFrame(Canvas,Controls[cix].BoundsRect,MainTexture); 158 Left := (Screen.Width - ClientWidth) div 2; 159 Canvas.Font.Assign(UniFont[ftNormal]); 160 Canvas.Brush.Style := bsClear; 161 MessgText := ''; 162 TopSpace := 0; 163 TitleHeight := Screen.Height; 164 InitButtons(); 165 end; 166 167 procedure TBaseMessgDlg.FormPaint(Sender: TObject); 168 var 169 i, cix: integer; 170 begin 171 PaintBackground(self, 3 + Border, 3 + Border, ClientWidth - (6 + 2 * Border), 172 ClientHeight - (6 + 2 * Border)); 173 for i := 0 to Border do 174 Frame(Canvas, i, i, ClientWidth - 1 - i, ClientHeight - 1 - i, 175 $000000, $000000); 176 Frame(Canvas, Border + 1, Border + 1, ClientWidth - (2 + Border), 177 ClientHeight - (2 + Border), MainTexture.clBevelLight, 178 MainTexture.clBevelShade); 179 Frame(Canvas, 2 + Border, 2 + Border, ClientWidth - (3 + Border), 180 ClientHeight - (3 + Border), MainTexture.clBevelLight, 181 MainTexture.clBevelShade); 182 SplitText(false); 183 184 for cix := 0 to ControlCount - 1 do 185 if (Controls[cix].Visible) and (Controls[cix] is TButtonBase) then 186 BtnFrame(Canvas, Controls[cix].BoundsRect, MainTexture); 182 187 end; 183 188 184 189 procedure TBaseMessgDlg.SplitText(preview: boolean); 185 190 var 186 Start,Stop,OrdinaryStop,LinesCount: integer; 187 s: string; 188 begin 189 Start:=1; 190 LinesCount:=0; 191 while Start<Length(MessgText) do 192 begin 193 Stop:=Start; 194 while(Stop<Length(MessgText)) and (MessgText[Stop]<>'\') 195 and (BiColorTextWidth(Canvas,Copy(MessgText,Start,Stop-Start+1)) 196 <ClientWidth-56) do 197 inc(Stop); 198 if Stop<>Length(MessgText) then 199 begin 200 OrdinaryStop:=Stop; 201 repeat dec(OrdinaryStop) 202 until (MessgText[OrdinaryStop+1]=' ') or (MessgText[OrdinaryStop+1]='\'); 203 if (OrdinaryStop+1-Start)*2>=Stop-Start then 204 Stop:=OrdinaryStop 205 end; 206 if not preview then 207 begin 208 s:=Copy(MessgText,Start,Stop-Start+1); 209 LoweredTextOut(Canvas,-1,MainTexture, 210 (ClientWidth-BiColorTextWidth(Canvas,s)) div 2,19+Border+TopSpace+LinesCount*MessageLineSpacing,s); 211 end; 212 Start:=Stop+2; 213 inc(LinesCount) 214 end; 215 if preview then Lines:=LinesCount; 191 Start, Stop, OrdinaryStop, LinesCount: integer; 192 s: string; 193 begin 194 Start := 1; 195 LinesCount := 0; 196 while Start < Length(MessgText) do 197 begin 198 Stop := Start; 199 while (Stop < Length(MessgText)) and (MessgText[Stop] <> '\') and 200 (BiColorTextWidth(Canvas, Copy(MessgText, Start, Stop - Start + 1)) < 201 ClientWidth - 56) do 202 inc(Stop); 203 if Stop <> Length(MessgText) then 204 begin 205 OrdinaryStop := Stop; 206 repeat 207 dec(OrdinaryStop) 208 until (MessgText[OrdinaryStop + 1] = ' ') or 209 (MessgText[OrdinaryStop + 1] = '\'); 210 if (OrdinaryStop + 1 - Start) * 2 >= Stop - Start then 211 Stop := OrdinaryStop 212 end; 213 if not preview then 214 begin 215 s := Copy(MessgText, Start, Stop - Start + 1); 216 LoweredTextOut(Canvas, -1, MainTexture, 217 (ClientWidth - BiColorTextWidth(Canvas, s)) div 2, 218 19 + Border + TopSpace + LinesCount * MessageLineSpacing, s); 219 end; 220 Start := Stop + 2; 221 inc(LinesCount) 222 end; 223 if preview then 224 Lines := LinesCount; 216 225 end; 217 226 218 227 procedure TBaseMessgDlg.CorrectHeight; 219 228 var 220 i: integer;221 begin 222 ClientHeight:=72+Border+TopSpace+Lines*MessageLineSpacing;223 Top:=(Screen.Height-ClientHeight) div 2;224 for i:=0 to ControlCount-1 do225 Controls[i].Top:=ClientHeight-(34+Border);226 end; 227 228 procedure TMessgDlg.FormCreate(Sender: TObject);229 begin 230 inherited;231 OpenSound:='';229 i: integer; 230 begin 231 ClientHeight := 72 + Border + TopSpace + Lines * MessageLineSpacing; 232 Top := (Screen.Height - ClientHeight) div 2; 233 for i := 0 to ControlCount - 1 do 234 Controls[i].Top := ClientHeight - (34 + Border); 235 end; 236 237 procedure TMessgDlg.FormCreate(Sender: TObject); 238 begin 239 inherited; 240 OpenSound := ''; 232 241 end; 233 242 234 243 procedure TMessgDlg.FormShow(Sender: TObject); 235 244 begin 236 Button1.Visible:=true; 237 Button2.Visible:= not (Kind in [mkOK]); 238 if Button2.Visible then Button1.Left:=101 239 else Button1.Left:=159; 240 if Kind=mkYesNo then 241 begin 242 Button1.Caption:=Phrases.Lookup('BTN_YES'); 243 Button2.Caption:=Phrases.Lookup('BTN_NO') 245 Button1.Visible := true; 246 Button2.Visible := not(Kind in [mkOK]); 247 if Button2.Visible then 248 Button1.Left := 101 249 else 250 Button1.Left := 159; 251 if Kind = mkYesNo then 252 begin 253 Button1.Caption := Phrases.Lookup('BTN_YES'); 254 Button2.Caption := Phrases.Lookup('BTN_NO') 244 255 end 245 else 246 begin 247 Button1.Caption:=Phrases.Lookup('BTN_OK'); 248 Button2.Caption:=Phrases.Lookup('BTN_CANCEL'); 249 end; 250 251 SplitText(true); 252 CorrectHeight; 253 end; 254 255 procedure TMessgDlg.FormPaint(Sender:TObject); 256 begin 257 inherited; 258 if OpenSound<>'' then PostMessage(Handle, WM_PLAYSOUND, 0, 0); 259 end; {FormPaint} 256 else 257 begin 258 Button1.Caption := Phrases.Lookup('BTN_OK'); 259 Button2.Caption := Phrases.Lookup('BTN_CANCEL'); 260 end; 261 262 SplitText(true); 263 CorrectHeight; 264 end; 265 266 procedure TMessgDlg.FormPaint(Sender: TObject); 267 begin 268 inherited; 269 if OpenSound <> '' then 270 PostMessage(Handle, WM_PLAYSOUND, 0, 0); 271 end; { FormPaint } 260 272 261 273 procedure TMessgDlg.Button1Click(Sender: TObject); 262 274 begin 263 ModalResult:=mrOK;275 ModalResult := mrOK; 264 276 end; 265 277 266 278 procedure TMessgDlg.Button2Click(Sender: TObject); 267 279 begin 268 ModalResult:=mrIgnore;280 ModalResult := mrIgnore; 269 281 end; 270 282 271 283 procedure TMessgDlg.FormKeyPress(Sender: TObject; var Key: char); 272 284 begin 273 if Key=#13 then ModalResult:=mrOK 274 //else if (Key=#27) and (Button2.Visible) then ModalResult:=mrCancel 285 if Key = #13 then 286 ModalResult := mrOK 287 // else if (Key=#27) and (Button2.Visible) then ModalResult:=mrCancel 275 288 end; 276 289 277 290 procedure SimpleMessage(SimpleText: string); 278 291 begin 279 with MessgDlg do280 begin 281 MessgText:=SimpleText;282 Kind:=mkOK;283 ShowModal;292 with MessgDlg do 293 begin 294 MessgText := SimpleText; 295 Kind := mkOK; 296 ShowModal; 284 297 end 285 298 end; … … 287 300 procedure SoundMessage(SimpleText, SoundItem: string); 288 301 begin 289 with MessgDlg do290 begin 291 MessgText:=SimpleText;292 OpenSound:=SoundItem;293 Kind:=mkOK;294 ShowModal;302 with MessgDlg do 303 begin 304 MessgText := SimpleText; 305 OpenSound := SoundItem; 306 Kind := mkOK; 307 ShowModal; 295 308 end 296 309 end; 297 310 298 procedure TMessgDlg.OnPlaySound(var Msg: TMessage);299 begin 300 Play(OpenSound);301 OpenSound:='';311 procedure TMessgDlg.OnPlaySound(var Msg: TMessage); 312 begin 313 Play(OpenSound); 314 OpenSound := ''; 302 315 end; 303 316 304 317 end. 305
Note:
See TracChangeset
for help on using the changeset viewer.