ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Create Hyperlink to URL (https://www.excelbanter.com/excel-programming/436113-create-hyperlink-url.html)

Filips Benoit[_2_]
Create Hyperlink to URL
 
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
Create Hyperlink to URL
 
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

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Filips Benoit" wrote in message ...
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

Filips Benoit[_2_]
Create Hyperlink to URL
 
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"
ActiveSheet.Cells(iLoop + 1, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection,
Address:= _
"mailto:" & MyClient.fields(iLoop)


F


"Ron de Bruin" wrote in message
...
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

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Filips Benoit" wrote in message
...
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
Create Hyperlink to URL
 
For a website you can use this instead of mailto

"http://:" &


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Filips Benoit" wrote in message ...
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"
ActiveSheet.Cells(iLoop + 1, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection,
Address:= _
"mailto:" & MyClient.fields(iLoop)


F


"Ron de Bruin" wrote in message
...
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

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Filips Benoit" wrote in message
...
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

Filips Benoit[_2_]
Create Hyperlink to URL
 
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


"Ron de Bruin" wrote in message
...
For a website you can use this instead of mailto

"http://:" &


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Filips Benoit" wrote in message
...
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"
ActiveSheet.Cells(iLoop + 1, 2).Select
ActiveSheet.Hyperlinks.Add
Anchor:=Selection, Address:= _
"mailto:" & MyClient.fields(iLoop)


F


"Ron de Bruin" wrote in message
...
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

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Filips Benoit" wrote in message
...
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


All times are GMT +1. The time now is 04:41 AM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com