Tweet
Hi all
I needed the functionality, so I wrote this.
Please comment and suggest corrections, before it goes to the source code Forum.
I would really like suggestions on how to implement cut'n paste from MS word.
It's only tested on Windows 98 SE. DK.
--
Best Regards
Peter Scheutz
------------------
[This message has been edited by Peter Scheutz (edited November 29, 2000).]
I needed the functionality, so I wrote this.
Please comment and suggest corrections, before it goes to the source code Forum.
I would really like suggestions on how to implement cut'n paste from MS word.
It's only tested on Windows 98 SE. DK.
--
Best Regards
Peter Scheutz
Code:
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' RichEdit DDT Hyperlink sample, showing how to create a ' Richedit Control with Hyperlink functionality. ' ' By Peter Scheutz, released As Public Domain - November 28, 2000 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' HOWTO: ' Compile, execute, select some text, click "Make Hyperlink", ' enter link Text, press [ok], move mouse over link. ' Link text could be: [url="http://www.powerbasic.com"]www.powerbasic.com[/url] or [url="http://www.powerbasic.com"]http://www.powerbasic.com[/url] ' or mailto:[email protected] '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' REQUIRES: ' Rich Edit control 2 or later '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' TODO: ' 1) Make it possible To paste rtf From MS Word And Preserve the ' hyperlinks. I hope that someone in the PB forum can help with that. ' ' 2) Add "richEd_Hyperlink_RemoveLink" function. ' 3) Add "richEd_Hyperlink_CleanUpLinks" function, to use when ' text is changed by copy and paste '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' CODE BASED ON: ' "Small RichEdit sample", ' By Borje Hagsten, released As Public Domain - April 24, 2000 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' EXTERNAL RESCOURCES: ' The method was taken from: ' [url="http://www.wdj.com/archive/1108/feature.html"]http://www.wdj.com/archive/1108/feature.html[/url] ' '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ #Compile Exe #Dim All #Include "WIN32API.INC" 'Some include files #Include "COMMCTRL.INC" #Include "RICHEDIT.INC" Global hRichEd As Long Type charformat2a cbSize As Long dwMask As Dword dwEffects As Dword yHeight As Long yOffset As Long crTextColor As Dword bCharSet As Byte bPitchAndFamily As Byte szFaceName As Asciiz * %LF_FACESIZE wpad2 As Integer wWeight As Word sSpacing As Integer crBackColor As Dword lcid As Long dwReserved As Dword sStyle As Integer wKerning As Word bUnderlineType As Byte bAnimation As Byte bRevAuthor As Byte bReserved1 As Byte End Type Type ENLINK nmhdr As NMHDR msg As Dword wParam As Long lParam As Long chrg As CHARRANGE End Type %ID_RICHEDIT = 500 '%IDSTYLECOMBO = 501 %IDURLLABEL = 502 '%EM_AUTOURLDETECT = ( %WM_USER + 91 ) %CFM_LINK = &H20 '/* Exchange hyperlink extension */ %CFM_LCID = &H2000000 %CFE_LINK = &H20 %EN_LINK = &H70b %ENM_LINK = &H4000000 Global hEdit As Long Declare CallBack Function DlgCallback() '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ Global richEd_Hyperlink_Hyperlinks() As String Global richEd_Hyperlink_HyperlinksCount As Long Function richEd_Hyperlink_GetFreeID() As Long Incr richEd_Hyperlink_HyperlinksCount ReDim Preserve richEd_Hyperlink_Hyperlinks(1 To richEd_Hyperlink_HyperlinksCount) Function= richEd_Hyperlink_HyperlinksCount End Function Function richEd_Hyperlink_GetHyperLink(ID As Long) As String If ID>0 And ID<=richEd_Hyperlink_HyperlinksCount Then _ Function= richEd_Hyperlink_Hyperlinks(ID) End Function Function richEd_Hyperlink_SetLink( ByVal ID As Long ) As Long Local cf As charformat2a cf.cbSize = Len( cf ) 'Length of structure cf.dwMask = %CFM_LCID Or %CFM_LINK 'Set mask to link and id only cf.dwEffects = %CFE_LINK cf.lcid = ID Call SendMessage( hEdit, %EM_SETCHARFORMAT, %SCF_SELECTION, VarPtr( cf )) Function=%True End Function Function richEd_Hyperlink_AddLink() As Long Local ID As Long Local url As String ID=richEd_Hyperlink_GetFreeID() If ID>0 Then url = InputBox$(" Type the link text") If Len(url)>2 Then ' do a check for a valid Url here? richEd_Hyperlink_Hyperlinks(ID)=url Call richEd_Hyperlink_SetLink(ID) Function=%True End If End If End Function Function richEd_Hyperlink_UrlClicked(ByVal ID As Long) As Long Call ShellExecute(%NULL,"open",richEd_Hyperlink_GetHyperLink( ID ),"","",%SW_SHOW) End Function Function richEd_Hyperlink_HandleURL(ByVal hWnd As Long, lpLink As ENLINK) As Long Local linkCf2 As charformat2a Local chrg As CHARRANGE Call SendMessage(hEdit,%EM_HIDESELECTION,%True,0) ' cache current selection Call SendMessage(hEdit,%EM_EXGETSEL,0,VarPtr(chrg)) Call SendMessage( hEdit, %EM_EXSETSEL, 0, VarPtr( lpLink.chrg )) linkCf2.cbSize = Len( linkCf2 ) 'Length of structure linkCf2.lcid = 0 Call SendMessage( hEdit, %EM_GETCHARFORMAT, %True, VarPtr( linkCf2 )) ' restore old selection Call SendMessage(hEdit,%EM_EXSETSEL,0,VarPtr(chrg)) Call SendMessage(hEdit,%EM_HIDESELECTION,%False,0) Select Case lpLink.msg Case %WM_LBUTTONDOWN Call richEd_Hyperlink_UrlClicked(linkCf2.lcid) Function=%True : Exit Function Case %WM_LBUTTONDBLCLK, %WM_LBUTTONUP ' Swallow these button events Function=%True : Exit Function Case %WM_MOUSEMOVE Control Set Text hWnd, %IDURLLABEL, richEd_Hyperlink_GetHyperLink( linkCf2.lcid ) Function=%True : Exit Function End Select Function=%False End Function '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ Function PbMain Local hDlg As Long, rText As String 'hRichEd = LoadLibrary("RICHED32.DLL") hRichEd = LoadLibrary( "Riched20.DLL" ) Call InitCommonControls Dialog New 0, "DDT RichEdit Hyperlinks demo",,, 320, 138, %WS_THICKFRAME Or %WS_CAPTION Or %WS_SYSMENU Or %WS_MAXIMIZEBOX To hDlg Control Add Button, hDlg, %IDOK, "&Make Hyperlink", 140, 6, 70, 14 Control Add Label, hDlg, %IDURLLABEL, "Empty", 2, 2, 100, 14 Control Add "RichEdit20A", hDlg, %ID_RICHEDIT, "", 6, 6, 126, 110, _ %WS_CHILD Or %WS_VISIBLE Or %ES_MULTILINE Or %WS_VSCROLL _ Or %ES_AUTOVSCROLL Or %ES_WANTRETURN Or _ %ES_NOHIDESEL, %WS_EX_CLIENTEDGE 'Call RichEdCallback Control Handle hDlg, %ID_RICHEDIT To hEdit ' Call SendMessage( hEdit, %EM_AUTOURLDETECT, %True, 0 ) Call SendMessage( hEdit, %EM_SETEVENTMASK, 0, %ENM_LINK ) rText = Repeat$( 30, "Compile, execute, select some text, click 'Make Hyperlink' " ) 'Create and set some text Call SendMessage( hEdit, %WM_SETTEXT, 0, StrPtr( rText )) SetFocus hEdit Dialog Show Modal hDlg Call DlgCallback End Function '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' Main callback procedure for all controls '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ CallBack Function DlgCallback() Local hiLparam As Integer Local loLparam As Integer Local enlink As ENLINK Local enlinkPtr As ENLINK Ptr 'cache these and avoid sign loss if sending them to subs later on. hiLparam = HiWrd( CbLparam ) loLparam = LoWrd( CbLparam ) Select Case CbMsg Case %WM_NOTIFY ' get a Pointer to the ENLINK structure enlinkPtr = CbLparam enlink = @enlinkPtr ' MSDN states that it's better to use enlink.nmhdr.idFrom than Wparam for ID detection. If enlink.nmhdr.code = %EN_LINK And enlink.nmhdr.idFrom = %ID_RICHEDIT Then Call SetWindowLong(CbHndl,%DWL_MSGRESULT, richEd_Hyperlink_HandleURL(CbHndl,enlink)) Function=%True ': Exit Function End If Function=%False ': Exit Function Case %WM_COMMAND Select Case CbCtl Case %IDOK Call richEd_Hyperlink_AddLink() 'The sub will prompt for link text End Select Case %WM_SIZE MoveWindow GetDlgItem( CbHndl, %ID_RICHEDIT ), 4, 40, loLparam - 8, hiLparam - 50, - 1 End Select End Function
[This message has been edited by Peter Scheutz (edited November 29, 2000).]
Comment