Adding/combining cell text to a web address and displaying as a hyperlink

[Rybo1967]

Good Morning,

I am new to programming and looking to make this code below even more user friendly. Right now the user has to double click on the cell to get the VBA to take the cell information and plug it into the URL based on criteria in the code. Is there a way to have the VBA run through and set them up as visible hyperlinks within the worksheet at that point rather than waiting for a double click? The reason I would like to do this is because I believe that opens up the option form me to save this as an .html file which would allow more people access to tracking of orders.

Any help is appreciated!

I am new to thins so I hope I explained that well enough. See the code below.



Option Explicit

Enum W32_Window_State
Show_Normal = 1
Show_Minimized = 2
Show_Maximized = 3
Show_Min_No_Active = 7
Show_Default = 10
End Enum

Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long

Dim trackingno As String
Dim URL As String
Dim C As Long
Dim R As Long
Dim carrier As String
Dim IsHyperlink As Boolean
Dim i As Long


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

C = ActiveCell.Column
R = ActiveCell.Row

If C = 10 Then

Range("J" & R).Select

' checks to see if cell contains hyperlink
i = Target.Hyperlinks.Count
If i > 0 Then
IsHyperlink = True
Else
IsHyperlink = False
End If
'MsgBox (IsHyperlink)
'Exit Sub
If IsHyperlink = True Then
Exit Sub
End If

URL = ""
trackingno = ActiveCell.Value
carrier = Sheet1.Cells(R, "I").Value

'UPS Tracking
If (Mid(trackingno, 1, 8) = "1Z" And Mid(carrier, 1, 3) = "UPS") Then
URL = "http://wwwapps.ups.com/WebTracking/track?track=yes&trackNums=" & trackingno
End If

'Standard Forwarding Tracking
If Mid(carrier, 1, 3) = "STD" Then
trackingno = Replace(trackingno, "-", "")
URL = "https://www.standardforwarding.com/faces/home?Adf-Window-Id=w4&traceType=pronumber&_afrWindowMode=2&proNumbers=1073553740%0A&_afrLoop=446694512598319&_afrRedirect=446694640636659#%40%3FAdf-Window-Id%3Dw4%26traceType%3Dpronumber%26proNumbers%3D" & trackingno & "%250A%26_afrWindowMode%3D2%26_afrRedirect%3D446694640636659%26_afrLoop%3D446694512598319%26_adf.ctrl-state%3Dg7ow31yzx_95"
End If

'Con-Way Tracking
If Mid(carrier, 1, 3) = "CON" Then
URL = "http://www.con-way.com/webapp/manifestrpts_p_app/shipmentTracking.do?PRO=" & trackingno & "&imageField.x=7&imageField.y=3"
End If

'Dohrn Tracking
If Mid(carrier, 1, 5) = "DOHRN" Then
URL = "http://www.dohrn.com/scripts/cgiip.exe/boldetail.htm?wbtn=PRO&wpro1=" & trackingno & "&seskey=&nav=&language=ENGLISH"
End If

'Fedex Ground Tracking (Like UPS)
If (Mid(carrier, 1, 19) = "FED EXPRESS GROUND" Or Mid(carrier, 1, 19) = "FED EX GROUND") Then
URL = "https://www.fedex.com/apps/fedextrack/?action=track&trackingnumber=" & trackingno & "&cntry_code=us"
End If

'Fedex Freight Tracking
If (Mid(carrier, 1, 19) = "FED EX FREIGHT" Or Mid(carrier, 1, 19) = "FED EX FRT" Or Mid(carrier, 1, 19) = "FED EX FREIGHT") Then
trackingno = Replace(trackingno, "-", "")
URL = "https://www.fedex.com/apps/fedextrack/?action=track&trackingnumber=" & trackingno & "&cntry_code=us"
End If

'Lakeville Motor Exrpess Tracking
If (Mid(carrier, 1, 3) = "LME" Or Mid(carrier, 1, 4) = "LAKE") Then
URL = "http://www.lme4me.com/PrintPro.html?OpenAgent&" & trackingno & "*2*09/04/15*3*FAR87058204*4*3583561*5*2*6*4197.0*7*CEDAR_FALLS,_IA*8*LAKEVILLE,_MN*9**10*09/08/15*11*STP-SAINT_PAUL"
End If

'Estes Tracking (Only Goes To The Estes Web Site - Must Copy And Paste The Tracking Number)
If Mid(carrier, 1, 5) = "ESTES" Then
URL = "https://www.estes-express.com/WebApp/ShipmentTracking/"
End If

'USF HOlland Tracking (Only Goes To The Estes Web Site - Must Copy And Paste The Tracking Number)
If (Mid(carrier, 1, 3) = "USF" Or Mid(carrier, 1, 3) = "HOL") Then
URL = "http://public.hollandregional.com/shipmentStatus"
End If

'Old Dominion Freight Line Tracking
If Mid(carrier, 1, 3) = "OLD" Then
URL = "http://www.odfl.com/Trace/standardResult.faces?pro=" & trackingno & ""
End If

'Dayton Freight Line Tracking
If Mid(carrier, 1, 6) = "DAYTON" Then
URL = "https://www.daytonfreight.com/Tracking/TrackingDetail.aspx?proNum=" & trackingno & ""
End If

'SAIA Tracking
If Mid(carrier, 1, 4) = "SAIA" Then
URL = "http://www.saia.com/Tracing/AjaxProstatusByPro.aspx?m=2&UID=&PWD=&SID=BCJZW76265689&PRONum1=" & trackingno & ""
End If

'N & M Transfer Tracking
If (Mid(carrier, 1, 3) = "N &" Or Mid(carrier, 1, 3) = "N&M") Then
URL = "https://www.nmtransfer.com/quickTrack?qtProNumber=104424678&qtPickupNumber=&qtInterlineProNumber=" & trackingno & ""
End If

'R & L Carriers Tracking (Only Goes To The Estes Web Site - Must Copy And Paste The Tracking Number)
If (Mid(carrier, 1, 3) = "R &" Or Mid(carrier, 1, 3) = "R&L") Then
URL = "http://www2.rlcarriers.com/freight/shipping/shipment-tracing"
End If

'YRC Yellow Roadway (Only Goes To The Roadway/Yellow Web Site - Must Copy And Paste The Tracking Number)
If (Mid(carrier, 1, 4) = "RDWY" Or Mid(carrier, 1, 3) = "YRC") Then
URL = "https://my.yrc.com/dynamic/national/servlet?CONTROLLER=com.rdwy.ec.rextracking.http.controller.DisplayPublicTrackingController&DESTINATION=/rextracking/quickTrakRequest.jsp"
End If

If URL <> "" Then
Selection.Style = "Hyperlink"
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=URL
Call OpenURL(URL, 1)
Range("K" & R).Select
End If
End If

End Sub

Function OpenURL(URL As String, WindowState As W32_Window_State) As Boolean

' Opens passed URL with default application, or Error Code (<32) upon error

Dim lngHWnd As Long
Dim lngReturn As Long

lngReturn = ShellExecute(lngHWnd, "open", URL, vbNullString, vbNullString, WindowState)

OpenURL = (lngReturn > 32)
End Function