URL Autodetection.

[FyRe]

I was wondering if there is a clean way to do AutoDetectURL.  I've looked over the net for a long time.  I only found a few samples and I created a very messy AutoDetection.

This is when the form loads: Form_Load()

Code Select Expand

   '// auto detect urls
    With rtbChat
        lngEventMask = SendMessage(.HWnd, EM_GETEVENTMASK, 0, ByVal CLng(0))
        If lngEventMask Xor ENM_LINK Then
            lngEventMask = lngEventMask Or ENM_LINK
        End If
        lngWin32apiResultCode = SendMessage(.HWnd, EM_SETEVENTMASK, 0, ByVal CLng(lngEventMask))
        lngWin32apiResultCode = SendMessage(.HWnd, EM_AUTOURLDETECT, CLng(1), ByVal CLng(0))
    End With
    With rtbWhisper
        lngEventMask = SendMessage(.HWnd, EM_GETEVENTMASK, 0, ByVal CLng(0))
        If lngEventMask Xor ENM_LINK Then
            lngEventMask = lngEventMask Or ENM_LINK
        End If
        lngWin32apiResultCode = SendMessage(.HWnd, EM_SETEVENTMASK, 0, ByVal CLng(lngEventMask))
        lngWin32apiResultCode = SendMessage(.HWnd, EM_AUTOURLDETECT, CLng(1), ByVal CLng(0))
    End With
    glngOriginalhWnd = Me.HWnd
    glnglpOriginalWndProc = SetWindowLong(glngOriginalhWnd, GWL_WNDPROC, AddressOf RichTextBoxSubProc)
This is in the Declares mod.

Code Select Expand

'AutoDetectURL
Public Const GWL_WNDPROC = (-4)
Public Const WM_USER = &H400
Public Const WM_NOTIFY = &H4E
Public Const WM_LBUTTONDOWN = &H201
Public Const EM_GETEVENTMASK = WM_USER + 59
Public Const EM_GETTEXTRANGE = WM_USER + 75
Public Const EM_AUTOURLDETECT = (WM_USER + 91)
Public Const EM_SETEVENTMASK = WM_USER + 69
Public Const EN_LINK = &H70B
Public Const ENM_LINK = &H4000000
Public Const SW_SHOWNORMAL = 1

Type tagNMHDR
    hwndFrom As Long
    idFrom   As Long
    code     As Long
End Type

Type CHARRANGE
    cpMin As Long
    cpMax As Long
End Type

Type ENLINK
    nmhdr  As tagNMHDR
    msg    As Long
    wParam As Long
    lParam As Long
    chrg   As CHARRANGE
End Type

Type TEXTRANGE
    chrg      As CHARRANGE
    lpstrText As Long
End Type

Public glnglpOriginalWndProc As Long
Public glngOriginalhWnd As Long
Public Function RichTextBoxSubProc(ByVal HWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim udtNMHDR               As tagNMHDR
    Dim udtENLINK              As ENLINK
    Dim udtTEXTRANGE           As TEXTRANGE
    Dim strBuffer              As String * 128
    Dim strOperation           As String
    Dim strFileName            As String
    Dim strDefaultDirectory    As String
    Dim lngHInstanceExecutable As Long
    Dim lngWin32apiResultCode  As Long

    If uMsg = WM_NOTIFY Then
        RtlMoveMemory udtNMHDR, ByVal lParam, Len(udtNMHDR)
        If udtNMHDR.hwndFrom = frmMain.rtbChat.HWnd And udtNMHDR.code = EN_LINK Then
            RtlMoveMemory udtENLINK, ByVal lParam, Len(udtENLINK)
            If udtENLINK.msg = WM_LBUTTONDOWN Then
                strBuffer = ""
                With udtTEXTRANGE
                    .chrg.cpMin = udtENLINK.chrg.cpMin
                    .chrg.cpMax = udtENLINK.chrg.cpMax
                    .lpstrText = StrPtr(strBuffer)
                End With
                With frmMain.rtbChat
                    lngWin32apiResultCode = SendMessage(.HWnd, EM_GETTEXTRANGE, 0, udtTEXTRANGE)
                End With
                RtlMoveMemory ByVal strBuffer, ByVal udtTEXTRANGE.lpstrText, Len(strBuffer)
                strOperation = "open"
                strFileName = strBuffer
                lngHInstanceExecutable = ShellExecute(frmMain.HWnd, strOperation, strFileName, vbNullString, strDefaultDirectory, SW_SHOWNORMAL)
            End If
        ElseIf udtNMHDR.hwndFrom = frmMain.rtbWhisper.HWnd And udtNMHDR.code = EN_LINK Then
        RtlMoveMemory udtENLINK, ByVal lParam, Len(udtENLINK)
        If udtENLINK.msg = WM_LBUTTONDOWN Then
            strBuffer = ""
            With udtTEXTRANGE
                .chrg.cpMin = udtENLINK.chrg.cpMin
                .chrg.cpMax = udtENLINK.chrg.cpMax
                .lpstrText = StrPtr(strBuffer)
            End With
            With frmMain.rtbWhisper
                lngWin32apiResultCode = SendMessage(.HWnd, EM_GETTEXTRANGE, 0, udtTEXTRANGE)
            End With
            RtlMoveMemory ByVal strBuffer, ByVal udtTEXTRANGE.lpstrText, Len(strBuffer)
            strOperation = "open"
            strFileName = strBuffer
            lngHInstanceExecutable = ShellExecute(frmMain.HWnd, strOperation, strFileName, vbNullString, strDefaultDirectory, SW_SHOWNORMAL)
        End If
    End If
End If
RichTextBoxSubProc = CallWindowProc(glnglpOriginalWndProc, HWnd, uMsg, wParam, lParam)
End Function
When the Program closes:

Code Select Expand

   'Autodetecturl Unload
    Dim lngWin32apiResultCode As Long
    lngWin32apiResultCode = SetWindowLong(glngOriginalhWnd, GWL_WNDPROC, glnglpOriginalWndProc)

Sorry, for such a big message.  I know this code is messy and bad coding.  I'm just asking for suggestions and anything simpler

Thanks.

[JaMi]

how do you declare your SetWindowLong ?

[Spht]

how do you declare your SetWindowLong ?

That's a standard Win32 API function.

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

[Camel]

if you ever need to look up an api call, you can use the "api text viewer" that comes with visual studio
if you have just vb and not vs, you can usually find it as the first or second result on www.google.com

[FyRe]

Code Select Expand

Public Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal HWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal HWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Sorry, thought I added everything.

[haZe]

There is a much smaller and simplified version at
http://pscode.com/vb/scripts/ShowCodeAsText.asp?txtCodeId=36414&lngWId=1