Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Following a plain text Hyperlink from Access 2000

Posted on 2001-08-16
4
Medium Priority
?
376 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 1196 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 Use the Help Bell

Need to boost the visibility of your question for solutions? Use the Experts Exchange Help Bell to confirm priority levels and contact subject-matter experts for question attention.  Check out this how-to article for more information.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft Access is a place to store data within tables and represent this stored data using multiple database objects such as in form of macros, forms, reports, etc. After a MS Access database is created there is need to improve the performance and…
Instead of error trapping or hard-coding for non-updateable fields when using QODBC, let VBA automatically disable them when forms open. This way, users can view but not change the data. Part 1 explained how to use schema tables to do this. Part 2 h…
In Microsoft Access, learn how to “cascade” or have the displayed data of one combo control depend upon what’s entered in another. Base the dependent combo on a query for its row source: Add a reference to the first combo on the form as criteria i…
With Secure Portal Encryption, the recipient is sent a link to their email address directing them to the email laundry delivery page. From there, the recipient will be required to enter a user name and password to enter the page. Once the recipient …
Suggested Courses

972 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