Create Hyperlink to URL

[Filips Benoit]

Hey,

While inporting data from access into a excelsheet i want the URL-field to
became a hyperlinkfield so the user can click on it to go to the webpage

strange: when i doubleclick on the url it becomes a hyperlink !!!

Thanks,

Filip

Public Sub ExposantGegevensOphalenMetID(ByVal KlantID As Long, strMode As
String)

Dim MyConnection As String
Dim MySQL As String
Dim MyDatabaseFilePathAndName As String
Dim MyClient As Object
Dim iActiveRow As Long
Dim iLoop As Long
Dim strDataSource As String
Dim strEmail As String

'Create connection string
strDataSource = Sheets("datasource").Cells(1, 1).Value
MyConnection = "Provider=Microsoft.Jet.OLEDB.4.0;"
MyConnection = MyConnection & "Data Source=" & strDataSource & ";"

' Create MySQL string
MySQL = "SELECT Deelnemers.* FROM Deelnemers WHERE
(((Deelnemers.DeelnemerID)=" & KlantID & "));"

' Open the database and copy the data
On Error GoTo SomeThingWrong
Set MyClient = CreateObject("adodb.recordset")
MyClient.Open MySQL, MyConnection, 0, 1, 1

If Not MyClient.EOF Then
Select Case strMode
Case "input"
iActiveRow = ActiveCell.Row
If Not IsNull(MyClient.fields(3)) Then
ActiveSheet.Cells(iActiveRow, 12) = MyClient.fields(3)
Case "detailsheet"
Sheets("Detail_Exposant").Activate
For iLoop = 0 To MyClient.fields.Count - 1
ActiveSheet.Cells(iLoop + 1, 1) =
MyClient.fields(iLoop).Name
If Not IsNull(MyClient.fields(iLoop)) Then
Select Case MyClient.fields(iLoop).Name
Case "Email"
ActiveSheet.Cells(iLoop + 1, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection,
Address:= _
"mailto:" & MyClient.fields(iLoop)
Case "URL"
ActiveSheet.Cells(iLoop + 1, 2) = "http://" &
MyClient.fields(iLoop) & "/"
Case Else
ActiveSheet.Cells(iLoop + 1, 2) =
MyClient.fields(iLoop)
End Select
End If
Next iLoop
Sheets("aankopen").Activate
End Select
Else
MsgBox "Exposant niet gevonden !" & vbCrLf & "Waarschijnlijk foutief
ID !", vbCritical
End If

MyClient.Close
Set MyClient = Nothing
Exit Sub

SomeThingWrong:
If MyClient.State = xlOpen Then
MyClient.Close
Set MyClient = Nothing
End If
If Err.Number = -2147467259 Then
MsgBox "Database '3_PRODUCTEURS DE VIN.mdb' niet gevonden !" &
Chr$(13) & "Dus geen gegevenoverdracht."
Else
MsgBox Err.Number & " " & Err.Description, vbCritical
End If
End Sub

 

[Ron de Bruin]

Hi Filips

Add code to the macro to change the cell or cells to a hyperlink
If you tell me the range I post a example

 

[Filips Benoit]

Ron,

The range ( 1 cell ) is in the code = ActiveSheet.Cells(iLoop + 1, 2)

remark:
in the code below ( 1 mail) the code to create an hyperlink for email works
ok

Case "Email"

F

 

[Ron de Bruin]

For a website you can use this instead of mailto

"http://:" &

 

[Filips Benoit]

The cell only becomes a hyperlink ( bleu and handcursor) after doubleclick
on the cell and reselecting the cell.
It's not a hyperlink directly like in the case of the emailcell above it.

F