OpenEuphoria

Re: Similar a message_box() function

• Posted by DerekParnell (admin) Feb 25, 2014
• 1522 views

I've had a chance now to update your code. I've removed the looping and checking for multiple instances, and replaced the openWindow() with openDialog(). The library could look more like this now ...

-- 22/02/14 mBox.ew - box de mensagem bloqueando avanço do programa chamador 
global constant   
 WIN2 =create(       Window,"Mensagem",   0,536, Center,  0,  0,{WS_POPUP}) 
,CLOSE=create(DefPushButton,   "Close",WIN2,002,    002, 60,020,0) 
,MESS1=create(        LText,        "",WIN2,002,     02, 00, 20,00) 
 
------------------------------------------------------------------------------------------------------------------ 
setWindowBackColor(WIN2,{255,0,0})--4020095 ) 
---------------------------------------------------------------------------------------------------------------------------------- 
procedure onclick_CLOSE(atom id, atom event, sequence params) 
	closeWindow(WIN2) 
end procedure 
 
---------------------------------------------------------------------------------------------------------------------------------- 
procedure msb(object men1) 
 sequence lis1,sFont 
 integer nCl1,nLi 
  
 nCl1=1 
 lis1={} 
 setFont(MESS1, "Courier New", 14,Bold) 
 
 sFont=getFontSize(MESS1)+1             -- Returns: { width, height } of average character. 
 if not sequence(men1) then 
  -- se recebeu um atom 
  men1=sprintf("%d",men1)               -- agora é sequencia 
 end if 
  
 if sequence(men1[1]) then 
	 -------- tem mais que uma linha, calcula linhas 
  nLi=40               -- minimo pix 
  for i=1 to length(men1) do 
	  nLi+=sFont[2] 
	 end for 
 else 
	 ------- tem só uma linha 
  if find('\n',men1) then 
   ----- encontrou caracter de linha nova 
   for i=1 to length(men1) do 
  	 lis1&=men1[i] 
  	 if men1[i]='\n' then 
  	  if length(lis1)>nCl1 then 
  	   nCl1=length(lis1) 
  	  end if 
  	  lis1={} 
  	 end if 
  	end for 
 	else 
	  ------ é só uma linha e não tem caracter de linha nova 
 		nCl1=length(men1) 
 		if nCl1>80 then      -- linha longa 
 		 nLi=0               -- conta caracter até achar um espaço 
 		 for i=1 to nCl1 do    
 			 nLi+=1             -- conta caracter até achar um espaço 
 			 if men1[i]=32 and nLi>39 then    
      ------- faz frases de até 40 caracteres 
 		   men1[i]='\n'     -- faz blocos com 40 caracteres 
      --"1234567891123456789212345678931234567894" 
 		   nLi=0 
 		  end if 
 		 end for 
 			msb(men1)          -- usa msb() recursivamente 
 			return             -- recursivamente ja fez a tarefa  
 		end if 
  end if 
	 -------- calcula linhas 
  nLi=sFont[2]*2              -- minimo 
  for i=1 to length(men1) do 
	  if men1[i]='\n' then 
	   nLi+=sFont[2]+2 
	  end if 
	 end for  
 
 end if 
	nCl1=(nCl1*sFont[1])+sFont[1] 
--	if nLi<30 then nLi=30 end if 
	if nCl1<70 then nCl1=70 end if 
 if atom(men1[1]) then 
  nLi+=sFont[2]*2 
  setText(MESS1,men1) 
 else 
	 for i=1 to length(men1) do 
   lis1&=men1[i] 
   if length(men1[i])>nCl1 then 
  	 nCl1=length(men1[i]) 
   end if 
   nLi+=sFont[2] 
		end for 
		nCl1=(nCl1*sFont[1])+sFont[1] 
  setText(MESS1,lis1) 
	end if 
 -- setFont(MESS1, "Courier New", 14, {"ALL",Bold} )  -- only with richEdit 
	if nLi>800 then  
	 nLi=800 
--  addStyle ( MESS1,WS_VSCROLL)   -- to MLeText but has problems while working 
--	else                            -- to MLeText but has problems while working 
--  removeStyle (MESS1,WS_VSCROLL) -- to MLeText but has problems while working 
 end if 
	if nCl1>1100 then 
  nCl1=1100 
--  addStyle ( MESS1, WS_HSCROLL)  -- to MLeText but has problems while working 
-- else                            -- to MLeText but has problems while working 
--  removeStyle (MESS1,WS_VSCROLL) -- to MLeText but has problems while working 
 end if 
 ------ change the size and repaint 
 setRect( WIN2,Center,Center,   nCl1,   nLi,w32True )   -- size janela principal 
 setRect(MESS1,Center,Center,nCl1-15,nLi-55,w32True )   -- size janela de texto 
 setHandler(CLOSE, w32HClick,routine_id("onclick_CLOSE")) 
 
 openDialog(WIN2) 
end procedure 
 
------------------------------------------------------------------------------------------------------------------ 
global function mbx(object ms1) 
	msb(ms1)        -- calcula tamanho, abre e coloca texto no box 
	return 0 
end function