PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

Hyperlink control?

https://www.purebasic.fr/english/viewtopic.php?t=4511

Page 1 of 2

Posted: Wed Sep 04, 2002 1:37 pm
by BackupUser
Restored from previous forum. Originally posted by Justin.

I would like to emulate an hyperlink control. I'm thinking to create a new window class, with the hand cursor and the text color that changes and underlines when the mouse is over, detect the mouse click and launch the URL.

Has anyone tried this?, is there a better way?

PD: I want to do it without the QHTM dll i found in the phorum.

Posted: Wed Sep 04, 2002 2:16 pm
by BackupUser
Restored from previous forum. Originally posted by traumatic.

afaik Danilo is working on something like that. Danilo?

Posted: Wed Sep 04, 2002 2:27 pm
by BackupUser
Restored from previous forum. Originally posted by PB.

> afaik Danilo is working on something like that. Danilo?

Yep, Danilo is working on a hyperlink library. I've seen a beta-test
version, and it's cool. Shouldn't be too far away from release.


PB - Registered PureBasic Coder

Posted: Wed Sep 04, 2002 3:15 pm
by BackupUser
Restored from previous forum. Originally posted by Justin.

Great,
Danilo do you have an aprox date for the release?, weeks, months..?

Posted: Wed Sep 04, 2002 11:57 pm
by BackupUser
Restored from previous forum. Originally posted by Justin.

Here is my lame attempt to emulate an hyperlink control, no colors and always underlined. Probably there are easier ways to accomplish the same effect.

I hope Danilo's lib come soon.

;Hyperlink lame test
#IDC_HAND=32649

Procedure windowproc(hwnd,msg,wParam,lParam)
Shared hyp,hparent
ret=#PB_ProcessPureBasicEvents
Select msg
Case #WM_LBUTTONDOWN
If hwnd=hyp
shellexecute_(hparent,"open","http:\\http://www.purebasic.com","","",#SW_SHOWNORMAL)
EndIf
ret=0
EndSelect
ProcedureReturn ret
EndProcedure

wc.WNDCLASS

classname.s="PB_hypclass_001"

hparent=OpenWindow(1,100,100,500,100,#PB_Window_SystemMenu,"Hyperlink Test")
CreateGadgetList(hparent)

wc\style=#CS_HREDRAW|#CS_VREDRAW
wc\lpfnWndProc=getwindowlong_(hparent,#GWL_WNDPROC)
wc\cbClsExtra=0
wc\cbWndExtra=0
wc\hInstance=GetModuleHandle_(0)
wc\hIcon=#null
wc\hCursor=LoadCursor_(#NULL,#IDC_HAND)
wc\hbrBackground=#COLOR_WINDOW
wc\lpszMenuName=#null
wc\lpszClassName=@classname

registerclass_(@wc)

hyp=createwindowex_(0,"PB_hypclass_001","",#WS_CHILD|#WS_VISIBLE,10,10,100,20,hparent,#null,getmodulehandle_(0),0)
CreateGadgetList(hyp)

htext=TextGadget(2,0,0,100,20,"Visit PureBasic",#PB_Text_Center)

hf=createfont_(15,0,0,0,0,0,#true,0,0,0,0,0,0,"Verdana")

sendmessage_(htext,#WM_SETFONT,hf,#true)

SetWindowCallback(@windowproc())

Repeat
Until WaitWindowEvent()=#PB_Event_CloseWindow

Posted: Thu Sep 05, 2002 6:35 am
by BackupUser
Restored from previous forum. Originally posted by Danilo.

month. at least 2.

The Hyperlink is only a little piece in a big Toolbox
for Windows programming.
I have to add more new Gadgets, skinned Gadgets (Colored and Transparent),
much faster SkinWin (with SkinMaker) and much more other stuff (secret :)).

But this time i cant give out all the stuff
for free, so the big Toolbox will become shareware.
Its really much work to write all this stuff and
the user can save all this time later.
So it should be OK to make it shareware, i think. (other opinions?)

There will be a light version available which has
some of the cool stuff for free (without restrictions)
and the Hyperlink Gadget should be in the free version...

I´ll do the main work in 3 weeks, when i have 4 weeks
holiday. I´ll see how complete it is after the holidays... :)

cya,
...Danilo

(registered PureBasic user)

Posted: Thu Sep 05, 2002 6:51 am
by BackupUser
Restored from previous forum. Originally posted by PB.

> Its really much work to write all this stuff and
> the user can save all this time later.
> So it should be OK to make it shareware, i think. (other opinions?)

I think Shareware is okay -- just don't make it too expensive! :)

My next version of vis2pure is really advanced compared to all the
earlier versions, so I have to make it Shareware too because it's
a hell of a lot of work and features for it. It won't be crippled
or anything -- the user doesn't have to pay the fee if they don't
feel honest, but unless they do they'll have the inconvenience of
tweaking small things here and there to make it a bit more readable.

It'll only be US $5.00 anyway which is cheap enough, I think.


PB - Registered PureBasic Coder

Posted: Thu Sep 05, 2002 7:56 am
by BackupUser
Restored from previous forum. Originally posted by Danilo.

> Here is my lame attempt to emulate an hyperlink control

Try this, looks a little bit better:

Code: Select all

;---------------------normalcursor = LoadCursor_(0,#IDC_ARROW)
mousecursor  = LoadCursor_(0, 32649) ; #IDC_HAND
 
 
Procedure windowproc(hwnd,msg,wParam,lParam)
Shared htext,hparent, hfnormal, hfmouse, highlighted, normalcursor, mousecursor
returnvalue = #PB_ProcessPureBasicEvents
Select msg
   Case #WM_LBUTTONDOWN
        If ChildWindowFromPoint_(hparent,lParam & $FFFF,lParam >> 16) = htext
           ;Beep_(800,100)
           shellexecute_(hparent,"open","http:\\[url]http://www.purebasic.com[/url]","","",#SW_SHOWNORMAL)
           returnvalue = 0
        EndIf
   Case #WM_MOUSEMOVE
        If ChildWindowFromPoint_(hparent,lParam & $FFFF,lParam >> 16) = htext
           SetCursor_(mousecursor)
           If highlighted = 0
              sendmessage_(htext,#WM_SETFONT,hfmouse,#true)
              highlighted = 1
              returnvalue = 0
           EndIf
        Else
           If highlighted = 1
              sendmessage_(htext,#WM_SETFONT,hfnormal,#true)
              SetCursor_(normalcursor)
              highlighted = 0
              returnvalue = 0
           EndIf
        EndIf
EndSelect 
ProcedureReturn returnvalue 
EndProcedure
 
 
hparent=OpenWindow(1,100,100,500,100,#PB_Window_SystemMenu,"Hyperlink Test")
CreateGadgetList(hparent)
htext=TextGadget(2,10,10,100,15,"Visit PureBasic",#PB_Text_Center) 
 
; prepare TextGadget
hfnormal = createfont_(15,0,0,0,  0,0,#true,0,0,0,0,0,0,"Verdana")
hfmouse  = createfont_(15,0,0,0,700,0,#true,0,0,0,0,0,0,"Verdana")
sendmessage_(htext,#WM_SETFONT,hfnormal,#true)
SetClassLong_(htext,#GCL_HCURSOR,0)
 
 
SetWindowCallback(@windowproc())
 
Repeat
Until WaitWindowEvent()=#PB_Event_CloseWindow
;---------------------
Should be enough for a quick workaround, not ??

cya,
...Danilo

(registered PureBasic user)

Posted: Thu Sep 05, 2002 8:08 am
by BackupUser
Restored from previous forum. Originally posted by Rings.

:) very good example Danilo.thx to share with us.

Its a long way to the top if you wanna .....CodeGuru

Posted: Fri Sep 06, 2002 6:52 pm
by BackupUser
Restored from previous forum. Originally posted by Justin.

The setcursor doc says something about setting the class to null if you change the cursor, i don't know..

http://msdn.microsoft.com/library/defau ... cursor.asp

also i think you can't load the hand cursor in W95.

I did this workaround that uses a listview, there is a style that does the job of changing the cursor and coloring the text.

The only problem is that the text is highlited for a short time, maybe it can be fixed?

I had to create the control because i could't make a borderless listicon gadget, it can be done?

;Hyperlink test2
#LVS_EX_ONECLICKACTIVATE=64
#LVM_SETEXTENDEDLISTVIEWSTYLE=#LVM_FIRST+54
#LVN_ITEMACTIVATE=#LVN_FIRST-14

Structure lvst
mask.l
iItem.l
iSubItem.l
state.l
stateMask.l
pszText.s
cchTextMax.l
iImage.l
lParam.l
iIndent.l
EndStructure
LVITEM.lvst

Procedure listproc(hwnd,msg,wparam,lparam)
ret=#PB_ProcessPureBasicEvents
Select msg

Case #WM_NOTIFY
*ptr.NMHDR=lparam
If *ptr\code=#LVN_ITEMACTIVATE ;click
Activategadget(1)
shellexecute_(hwnd,"open","http:\\http://www.purebasic.com","","",#SW_SHOWNORMAL)
ret=0
EndIf

EndSelect
ProcedureReturn ret
EndProcedure

hwnd=OpenWindow(0,10,10,300,200,#PB_Window_SystemMenu,"Hyperlink Test")
CreateGadgetList(hwnd)

hl=CreateWindowEx_(0,"SysListView32","",#WS_CHILD|#WS_VISIBLE|#LVS_LIST,10,10,100,20,hwnd,0,GetModuleHandle_(0),0)

hf=createfont_(15,0,0,0,0,0,#true,0,0,0,0,0,0,"Verdana")

sendmessage_(hl,#WM_SETFONT,hf,#true)
sendmessage_(hl,#LVM_SETEXTENDEDLISTVIEWSTYLE,-1,#LVS_EX_ONECLICKACTIVATE)
sendmessage_(hl,#LVM_SETBKCOLOR,0,#CLR_NONE)
sendmessage_(hl,#LVM_SETTEXTBKCOLOR,0,#CLR_NONE)

LVITEM\mask=#LVIF_TEXT
LVITEM\iItem=0
LVITEM\pszText="VisitPureBasic"
sendmessage_(hl,#LVM_INSERTITEM,0,@LVITEM)

ButtonGadget(1,230,175,60,20,"Cancel")

SetWindowCallback(@listproc())

Repeat
eventid=WaitWindowEvent()
If eventid=#PB_EventGadget
If EventGadgetID()=1 : End : EndIf
EndIf
Until eventid=#PB_Event_CloseWindow

Posted: Fri Sep 06, 2002 7:32 pm
by BackupUser
Restored from previous forum. Originally posted by Justin.

I found a fix, now the effect is quite convincing.

Does anyone know how to launch a new instance of the default browser?, shellexecute uses the existing one if any.

;Hyperlink test3
#LVS_EX_ONECLICKACTIVATE=64
#LVM_SETEXTENDEDLISTVIEWSTYLE=#LVM_FIRST+54
#LVN_ITEMACTIVATE=#LVN_FIRST-14

Structure NMLISTVIEW
hdr.NMHDR
iItem.l
iSubItem.l
uNewState.l
uOldState.l
uChanged.l
ptAction.POINT
lParam.l
EndStructure

Structure lvst
mask.l
iItem.l
iSubItem.l
state.l
stateMask.l
pszText.s
cchTextMax.l
iImage.l
lParam.l
iIndent.l
EndStructure
LVITEM.lvst

Procedure listproc(hwnd,msg,wparam,lparam)
ret=#PB_ProcessPureBasicEvents
Select msg

Case #WM_NOTIFY
*ptr2.NMLISTVIEW=lparam
If *ptr2\hdr\code=#LVN_ITEMCHANGING
ret=#true
EndIf

*ptr.NMHDR=lparam
If *ptr\code=#LVN_ITEMACTIVATE ;click
shellexecute_(hwnd,"open","http:\\http://www.purebasic.com","","",#SW_SHOWNORMAL)
ret=0
EndIf

EndSelect
ProcedureReturn ret
EndProcedure

hwnd=OpenWindow(0,10,10,300,200,#PB_Window_SystemMenu,"Hyperlink Test")
CreateGadgetList(hwnd)

hl=CreateWindowEx_(0,"SysListView32","",#WS_CHILD|#WS_VISIBLE|#LVS_LIST,10,10,100,20,hwnd,0,GetModuleHandle_(0),0)

hf=createfont_(15,0,0,0,0,0,#true,0,0,0,0,0,0,"Verdana")

sendmessage_(hl,#WM_SETFONT,hf,#true)
sendmessage_(hl,#LVM_SETEXTENDEDLISTVIEWSTYLE,-1,#LVS_EX_ONECLICKACTIVATE)
sendmessage_(hl,#LVM_SETBKCOLOR,0,#CLR_NONE)
sendmessage_(hl,#LVM_SETTEXTBKCOLOR,0,#CLR_NONE)

LVITEM\mask=#LVIF_TEXT
LVITEM\iItem=0
LVITEM\pszText="VisitPureBasic"
sendmessage_(hl,#LVM_INSERTITEM,0,@LVITEM)

ButtonGadget(1,230,175,60,20,"Cancel")

SetWindowCallback(@listproc())

Repeat
eventid=WaitWindowEvent()
If eventid=#PB_EventGadget
If EventGadgetID()=1 : End : EndIf
EndIf
Until eventid=#PB_Event_CloseWindow

Posted: Fri Sep 06, 2002 9:02 pm
by BackupUser
Restored from previous forum. Originally posted by Danilo.

> The setcursor doc says something about setting the class to null
> if you change the cursor, i don't know..

I know and i did it: SetClassLong_(htext,#GCL_HCURSOR,0)

> also i think you can't load the hand cursor in W95.

Well, the hand-cursor was your thing... (remember?)

cya,
...Danilo

(registered PureBasic user)

Posted: Fri Sep 06, 2002 9:43 pm
by BackupUser
Restored from previous forum. Originally posted by Justin.
I know and i did it: SetClassLong_(htext,#GCL_HCURSOR,0)
sorry, i did not see it.
Well, the hand-cursor was your thing... (remember?)
right, so i had to look for a solution.

also i looked for another workaround because your code makes an api call for every mouse move event on the main window and is permanently trying to set the cursor when it's moving over the link.

Posted: Sat Sep 07, 2002 4:30 am
by BackupUser
Restored from previous forum. Originally posted by Danilo.

> also i looked for another workaround because your code makes an api call
> for every mouse move event on the main window and is permanently trying
> to set the cursor when it's moving over the link.

Yes, this was a workaround because SetClassLong_() didnt
work with the handle of the Link Window ( hText ).
It works fine when you take the handle of the owner
Window, hParent.

So it should look more like this for the cursor part:

Code: Select all

;Hyperlink lame testnormalcursor = LoadCursor_(0,#IDC_ARROW)
mousecursor  = LoadCursor_(0,#IDC_CROSS) ; 32649) ; #IDC_HAND
 
 
Procedure windowproc(hwnd,msg,wParam,lParam)
Shared htext,hparent, hfnormal, hfmouse, highlighted, normalcursor, mousecursor
returnvalue = #PB_ProcessPureBasicEvents
Select msg
   Case #WM_LBUTTONDOWN
        If ChildWindowFromPoint_(hparent,lParam & $FFFF,lParam >> 16) = htext
           ;Beep_(800,100)
           shellexecute_(hparent,"open","http:\\[url]http://www.purebasic.com[/url]","","",#SW_SHOWNORMAL)
           returnvalue = 0
        EndIf
   Case #WM_MOUSEMOVE
        If ChildWindowFromPoint_(hparent,lParam & $FFFF,lParam >> 16) = htext
           ;SetCursor_(mousecursor)
           If highlighted = 0
              SetClassLong_(hparent, #GCL_HCURSOR, mousecursor)

              sendmessage_(htext,#WM_SETFONT,hfmouse,#true)
              highlighted = 1
              returnvalue = 0
           EndIf
        Else
           If highlighted = 1
              sendmessage_(htext,#WM_SETFONT,hfnormal,#true)
              SetClassLong_(hparent, #GCL_HCURSOR, normalcursor)
              ;SetCursor_(normalcursor)
              highlighted = 0
              returnvalue = 0
           EndIf
        EndIf
EndSelect 
ProcedureReturn returnvalue 
EndProcedure
 
 
hparent=OpenWindow(1,100,100,500,100,#PB_Window_SystemMenu,"Hyperlink Test")
CreateGadgetList(hparent)
htext=TextGadget(2,10,10,100,15,"Visit PureBasic",#PB_Text_Center) 
 
; prepare TextGadget
hfnormal = createfont_(15,0,0,0,  0,0,#true,0,0,0,0,0,0,"Verdana")
hfmouse  = createfont_(15,0,0,0,700,0,#true,0,0,0,0,0,0,"Verdana")
sendmessage_(htext,#WM_SETFONT,hfnormal,#true)
;SetClassLong_(htext,#GCL_HCURSOR,0)
 
 
SetWindowCallback(@windowproc())
 
Repeat
Until WaitWindowEvent()=#PB_Event_CloseWindow
Anyway... you found another workaround for you now...

cya,
...Danilo

(registered PureBasic user)

Posted: Sat Sep 07, 2002 11:36 am
by BackupUser
Restored from previous forum. Originally posted by Justin.

Looks better to me, it's a pity that we can't load a custom hand cursor from inside the PB exe.

If someone is interested this is what i do to launch a new instance of the browser, first looks for IE, then Netscape, if they are not found uses shellexecute.

I had to call the winexc api, for some reason runprogram does not work.

;Launch browser
#HKEY_LOCAL_MACHINE=2147483650
iepath.s=Space(255)
iepathsize.l=255

nspath.s=Space(255)
nspathsize.l=255

url.s="http:\\http://www.purebasic.com"

RegQueryValue_(#HKEY_LOCAL_MACHINE,"SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\IEXPLORE.EXE",@iepath,@iepathsize)
RegQueryValue_(#HKEY_LOCAL_MACHINE,"SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\Netscape.exe",@nspath,@nspathsize)

If iepath""
WinExec_(iepath + " " + url,#SW_SHOWNORMAL)
Else
If nspath""
WinExec_(nspath + " " + url,#SW_SHOWNORMAL)
Else
shellexecute_(0,"open",url,"","",#SW_SHOWNORMAL)
EndIf
EndIf
All times are UTC+01:00
Page 1 of 2

Powered by phpBB® Forum Software © phpBB Limited