Announcement

Collapse
No announcement yet.

Excel VBA API - Absolute Hyperlink extraction issues

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Excel VBA API - Absolute Hyperlink extraction issues

    Basically when I run my macro the Variable "URL" comes up with this address:
    ../DWF/HHY-049-01 (Topographical Survey).dwf

    Rather than this (which is whats in the hyperlink)

    File:///\\Yorkshire2\global\t -technical\sites\012\DWF\HHY-049-01 (Topographical Survey).dwf

    Any Ideas or help to make every link extract the full filepath would be greately appreciated.

    Thanks
    Dave



    My Code is below
    Code:



    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

    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

    Option Explicit
    Option Compare Text
    Dim PrintURL As String
    Dim URL As String
    Dim hlnk As Hyperlink
    Dim Printer As String
    Dim PaperSizeA4 As String
    Dim PaperSizeA3 As String
    Dim PaperSizeA2 As String
    Dim PaperSizeA1 As String
    Dim PaperSizeA0 As String
    Dim OldPrinter As String
    Dim msg As String
    Dim SelRange As Range
    Dim Addr As String
    Dim sMyDefPrinter As String
    Dim myRegKey As String
    Dim myValue As String
    Dim myAnswer As Integer
    Dim strProgram As String

    Private Sub UserForm_Initialize()

    PaperSizeA4 = "\\yorkshire2\KONICA MINOLTA C350 PCL5c"
    PaperSizeA3 = "\\yorkshire2\KONICA MINOLTA C350 PCL5c A3"
    PaperSizeA2 = "\\yorkshire2\OCE TDS300 A2"
    PaperSizeA1 = "\\yorkshire2\OCE TDS300 A1"
    PaperSizeA0 = "\\yorkshire2\OCE TDS300"

    End Sub

    ' ############################ START OF PRINTING SCRIPTS ################## ###############

    Private Sub OKButton_Click()
    Dim Papersizes As String
    Dim cell As Range

    Addr = RefEdit1.Value
    myRegKey = "HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows\Device"
    sMyDefPrinter = RegKeyRead(myRegKey)
    ' ##### OPENS ADOBE READER 8.0
    'strProgram = "C:\Program Files\Adobe\Reader 8.0\Reader\Acrord32.exe"
    'Call ShellExecute(vbNull, vbNull, strProgram, vbNull, vbNull, vbNull)
    ' ##### DWF Viewer
    'strProgram = "C:\Program Files\Autodesk\Autodesk DWF Viewer\DWFViewer.exe"
    'Call ShellExecute(vbNull, vbNull, strProgram, vbNull, vbNull, vbNull)

    For Each hlnk In Range(Addr).Hyperlinks

    If hlnk.Range.Offset(0, 1).Text = "A4" Then

    URL = hlnk.Address
    Printer = GetPrinterKey(PaperSizeA4)
    RegKeySave myRegKey, Printer

    Call ShellExecute(0&, "print", URL, vbNullString, vbNullString, vbNormalFocus)
    End If

    ' Next

    ' Sleep (10000)

    'For Each hlnk In Range(Addr).Hyperlinks
    If hlnk.Range.Offset(0, 1).Text = "A3" Then

    URL = hlnk.Address
    Printer = GetPrinterKey(PaperSizeA3)
    RegKeySave myRegKey, Printer

    Call ShellExecute(0&, "print", URL, vbNullString, vbNullString, vbNormalFocus)
    End If
    'Next

    ' Sleep (10000)

    'For Each hlnk In Range(Addr).Hyperlinks

    If hlnk.Range.Offset(0, 1).Text = "A2" Then

    URL = hlnk.Address
    Printer = GetPrinterKey(PaperSizeA2)
    RegKeySave myRegKey, Printer

    Call ShellExecute(0&, "print", URL, vbNullString, vbNullString, vbNormalFocus)
    End If

    ' Next

    ' Sleep (10000)

    'For Each hlnk In Range(Addr).Hyperlinks

    If hlnk.Range.Offset(0, 1).Text = "A1" Then

    URL = hlnk.Address
    Printer = GetPrinterKey(PaperSizeA1)
    RegKeySave myRegKey, Printer

    Call ShellExecute(0&, "print", URL, vbNullString, vbNullString, vbNormalFocus)
    End If

    ' Next

    ' Sleep (12000)

    ' For Each hlnk In Range(Addr).Hyperlinks

    If hlnk.Range.Offset(0, 1).Text = "A0" Then

    URL = hlnk.Address
    Printer = GetPrinterKey(PaperSizeA0)
    RegKeySave myRegKey, Printer

    Call ShellExecute(0&, "print", URL, vbNullString, vbNullString, vbNormalFocus)
    End If


    Sleep (5000)
    Next
    RegKeySave myRegKey, sMyDefPrinter

    Unload UserForm1

    End Sub
Working...
X