Solved

Following a plain text Hyperlink from Access 2000

Posted on 2001-08-16
4
319 Views
Last Modified: 2012-08-13
I have a form with two controls

btnFollowHyperlink

and a bound textbox
CompanyWebsite

When I click on btnFollowHyperlink I want to launch Internet Explorer and make it go to the website stored as plaintext in CompanyWebsite.

And no I do not want to use the native access hyperlink datatype :-)


The code I have is as follows.  It seems that this used to work on Windows98 and Access2000, but now doesnt work under Windows2000 Pro.  Any ideas?


Private Sub btnFollowHyperlink_Click()

    On Error GoTo bfhErr:

    Dim stDocName As String

    stDocName = Forms!Contacts!CompanyWebsite

    Dim ctl As CommandButton
    Set ctl = Me!btnFollowHyperlink
    With ctl
        Application.FollowHyperlink stDocName, , True
    End With


    DoCmd.Maximize

    Exit Sub

bfhErr:
    Select Case Err.Number
        Case 5:
            MsgBox "There is no internet connection", vbInformation, "Please connect to the internet and try again."
            Resume Next
        Case 6:
            MsgBox "The page could not be found online.  Please check the address.", vbInformation, "Page not found."
            Resume Next

        Case Else:
            MsgBox "Problem Number " & CStr(Err.Number) & " - " & Err.Description
            Exit Sub
    End Select

    Exit Sub




0
Comment
Question by:mmerlin
  • 2
4 Comments
 
LVL 1

Author Comment

by:mmerlin
ID: 6391855
the link might also be a mailto:mm@ecoms.com kind of link which should activate the default email client
0
 
LVL 12

Expert Comment

by:Paurths
ID: 6391994
hi mmerlin,

here is an example of starting internet explorer, or the default email editor, depending on   stDocName


Dim retvar
Dim IEPath As String
Dim stDocName As String

'this is your field from your table, placed in a variable
stDocName = "your@email.com"
stDocName = "www.experts-exchange.com"

If InStr(stDocName, "@") Then

    DoCmd.SendObject acSendNoObject, , acFormatRTF, stDocName, , , , , True
   
Else

    IEPath = fReturnRegKeyValue(HKEY_CLASSES_ROOT, "Applications\iexplore.exe\shell\open\command", "")
    IEPath = Left(IEPath, Len(IEPath) - 2)
    retvar = Shell(IEPath & " " & stDocName, vbMaximizedFocus)
   
End If
End Sub




u will need to paste this into a new module:


Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006

Private Const STANDARD_RIGHTS_READ = &H20000
Private Const KEY_QUERY_VALUE = &H1&
Private Const KEY_ENUMERATE_SUB_KEYS = &H8&
Private Const KEY_NOTIFY = &H10&
Private Const SYNCHRONIZE = &H100000
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
                        KEY_QUERY_VALUE Or _
                        KEY_ENUMERATE_SUB_KEYS Or _
                        KEY_NOTIFY) And _
                        (Not SYNCHRONIZE))
Private Const MAXLEN = 256
Private Const ERROR_SUCCESS = &H0&

Const REG_NONE = 0
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_DWORD_LITTLE_ENDIAN = 4
Const REG_DWORD_BIG_ENDIAN = 5
Const REG_LINK = 6
Const REG_MULTI_SZ = 7
Const REG_RESOURCE_LIST = 8

Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Declare Function apiRegOpenKeyEx Lib "advapi32.dll" _
        Alias "RegOpenKeyExA" (ByVal hKey As Long, _
        ByVal lpSubKey As String, ByVal ulOptions As Long, _
        ByVal samDesired As Long, ByRef phkResult As Long) _
        As Long

Private Declare Function apiRegCloseKey Lib "advapi32.dll" _
        Alias "RegCloseKey" (ByVal hKey As Long) As Long

Private Declare Function apiRegQueryValueEx Lib "advapi32.dll" _
        Alias "RegQueryValueExA" (ByVal hKey As Long, _
        ByVal lpValueName As String, ByVal lpReserved As Long, _
        ByRef lpType As Long, lpData As Any, _
        ByRef lpcbData As Long) As Long

Private Declare Function apiRegQueryInfoKey Lib "advapi32.dll" _
        Alias "RegQueryInfoKeyA" (ByVal hKey As Long, _
        ByVal lpClass As String, ByRef lpcbClass As Long, _
        ByVal lpReserved As Long, ByRef lpcSubKeys As Long, _
        ByRef lpcbMaxSubKeyLen As Long, _
        ByRef lpcbMaxClassLen As Long, _
        ByRef lpcValues As Long, _
        ByRef lpcbMaxValueNameLen As Long, _
        ByRef lpcbMaxValueLen As Long, _
        ByRef lpcbSecurityDescriptor As Long, _
        ByRef lpftLastWriteTime As FILETIME) As Long

Function fReturnRegKeyValue(ByVal lngKeyToGet As Long, _
                            ByVal strKeyName As String, _
                            ByVal strValueName As String) _
                            As String
Dim lnghKey As Long
Dim strClassName As String
Dim lngClassLen As Long
Dim lngReserved As Long
Dim lngSubKeys As Long
Dim lngMaxSubKeyLen As Long
Dim lngMaxClassLen As Long
Dim lngValues As Long
Dim lngMaxValueNameLen As Long
Dim lngMaxValueLen As Long
Dim lngSecurity As Long
Dim ftLastWrite As FILETIME
Dim lngType As Long
Dim lngData As Long
Dim lngTmp As Long
Dim strRet As String
Dim varRet As Variant
Dim lngRet As Long
   
    On Error GoTo fReturnRegKeyValue_Err
       
    'Open the key first
    lngTmp = apiRegOpenKeyEx(lngKeyToGet, _
                strKeyName, 0&, KEY_READ, lnghKey)

    'Are we ok?
    If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise _
                                lngTmp + vbObjectError

    lngReserved = 0&
    strClassName = String$(MAXLEN, 0):  lngClassLen = MAXLEN

    'Get boundary values
    lngTmp = apiRegQueryInfoKey(lnghKey, strClassName, _
        lngClassLen, lngReserved, lngSubKeys, lngMaxSubKeyLen, _
        lngMaxClassLen, lngValues, lngMaxValueNameLen, _
        lngMaxValueLen, lngSecurity, ftLastWrite)

    'How we doin?
    If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise _
                                lngTmp + vbObjectError
   
    'Now grab the value for the key
    strRet = String$(MAXLEN - 1, 0)
    lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, ByVal strRet, lngData)
    Select Case lngType
      Case REG_SZ
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, ByVal strRet, lngData)
        varRet = Left(strRet, lngData - 1)
      Case REG_DWORD
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, lngRet, lngData)
        varRet = lngRet
      Case REG_BINARY
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, ByVal strRet, lngData)
        varRet = Left(strRet, lngData)
    End Select
   
    'All quiet on the western front?
    If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise _
                                lngTmp + vbObjectError

fReturnRegKeyValue_Exit:
    fReturnRegKeyValue = varRet
    lngTmp = apiRegCloseKey(lnghKey)
    Exit Function
fReturnRegKeyValue_Err:
    varRet = "Error: Key or Value Not Found."
    Resume fReturnRegKeyValue_Exit
End Function


hope this helps,
Ricky


0
 
LVL 12

Accepted Solution

by:
Paurths earned 299 total points
ID: 6392016
just to add,

the usual path of ie is c:\Program Files\internet explorer\iexplore.exe

tho i have never seen iexplore in another folder, it might just happen.
But u can try this code, so u dont need to read the registry:


Dim retvar
Dim stDocName As String

'this is your field from your table, placed in a variable
stDocName = "your@email.com"
stDocName = "www.experts-exchange.com"

If InStr(stDocName, "@") Then

   DoCmd.SendObject acSendNoObject, , acFormatRTF, stDocName, , , , , True
   
Else

   retvar = Shell("c:\Program Files\internet explorer\iexplore.exe " & stDocName, vbMaximizedFocus)
'mind, the space between <...iexplore.exe>   and  <" & stDo..> has to be there !
   
End If



cheers
Ricky
0
 
LVL 6

Expert Comment

by:devtha
ID: 6392646
MM

   Dim ctl As CommandButton
   Set ctl = Me!btnFollowHyperlink
   With ctl
       Application.FollowHyperlink Me!Text0, , True
   End With



the textbox here is text0 and this works
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

In the article entitled Working with Objects – Part 1 (http://www.experts-exchange.com/Microsoft/Development/MS_Access/A_4942-Working-with-Objects-Part-1.html), you learned the basics of working with objects, properties, methods, and events. In Work…
Introduction When developing Access applications, often we need to know whether an object exists.  This article presents a quick and reliable routine to determine if an object exists without that object being opened. If you wanted to inspect/ite…
Familiarize people with the process of retrieving data from SQL Server using an Access pass-thru query. Microsoft Access is a very powerful client/server development tool. One of the ways that you can retrieve data from a SQL Server is by using a pa…
Learn how to number pages in an Access report over each group. Activate two pass printing by referencing the pages property: Add code to the Page Footers OnFormat event to capture the pages as there occur for each group. Use the pages property to …

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now