help to correct an issue with PDFfile creation in VBScript

[Fraser_Burnett]

Hello All,

I have a piece of VBscript which i was kindly helped to produce by Warship on this site. Everything works perfectly except an issue where the created PDF file which is hyperlinked and saved is being created from the wrong workbook.

I have an "order sheet" workbook which contains the macro and the button to activate, this then takes a cell on this worksheet and opens another workbook "testmcosts" and places this in a new cell - this is then hyperlinked to a created PDF.

The PDF that has been created and hyperlinked (and emailed) is of the "testmcosts" sheet not the "order sheet".

I have tried for days to try and fix this - but being a beginner and trying to achieve this out of normal working hours i am struggling to make this work.

Any assistance would be greatly appreciated.

see script below

Option Explicit
Dim PdfFile As String
Dim ThisWBsheet As Worksheet

Sub test_send_save_cost_hyper()
    Dim wbTarget As Workbook, stWB As String
    Dim shTarget As Worksheet, stSh As String
    Dim stTerm As String, stCost As Single
    Dim fnd As Range, nextRow As Long
    Dim rgHyperLink As String
    
    stWB = "Testmcost.xlsx"
    stSh = "mcosts"
    stTerm = Range("C3")
    stCost = Range("J40")
    
    Set ThisWBsheet = ThisWorkbook.ActiveSheet
    Set wbTarget = Workbooks.Open(ThisWorkbook.Path & "/" & stWB)
    Set shTarget = wbTarget.Sheets(stSh)
    
    Set fnd = shTarget.Rows(1).Find(stTerm, , , xlWhole)
    If Not fnd Is Nothing Then
        nextRow = shTarget.Cells(Rows.Count, fnd.Column).End(xlUp).Row + 1
        With shTarget.Cells(nextRow, fnd.Column)
            .Value = stCost
            .Offset(, -1) = Now
            rgHyperLink = .Address
        End With
        CreatePDF
        ActiveSheet.Hyperlinks.Add Anchor:=Range(rgHyperLink), _
                          Address:=ThisWBsheet.Range("O3") & "/" & PdfFile
        wbTarget.Close True  'close book WITH changes
        emailandsend
    Else
        MsgBox stTerm & " not found"
        wbTarget.Close False  'close book WITHOUT changes
    End If
End Sub

Private Sub CreatePDF()
    ' Define PDF filename
    PdfFile = ThisWBsheet.Range("m5") & "_" & Format(Now(), "ddmmyyyy_hhmm")
    PdfFile = PdfFile & ".pdf"
    
    ' Export activesheet as PDF
    With ActiveSheet
      .ExportAsFixedFormat Type:=xlTypePDF, _
                       Filename:=ThisWBsheet.Range("m3") & "\" & PdfFile, _
                        Quality:=xlQualityStandard, _
           IncludeDocProperties:=True, _
               IgnorePrintAreas:=False, _
               OpenAfterPublish:=False
    End With
    
    With ActiveSheet
      .ExportAsFixedFormat Type:=xlTypePDF, _
                       Filename:=ThisWBsheet.Range("m4") & "\" & PdfFile, _
                        Quality:=xlQualityStandard, _
           IncludeDocProperties:=True, _
               IgnorePrintAreas:=False, _
               OpenAfterPublish:=False
    End With
End Sub

Private Sub emailandsend()
  Dim IsCreated As Boolean
  Dim i As Long
  Dim Title As String
  Dim OutlApp As Object
 
  ' Not sure for what the Title is
  Title = Range("m5") & "_" & Format(Now(), "ddmmyyyy_hhmm")
 
  ' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0
 
  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)
   
    ' Prepare e-mail
    .Subject = Title
    .To = Range("m6")  ' <-- Put email of the recipient here
    .CC = " " ' <-- Put email of 'copy to' recipient here
    .Body = Range("m7")
    .Attachments.Add ThisWBsheet.Range("m3").Value & "\" & PdfFile
   
    ' Try to send
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail was not sent", vbExclamation
    Else
      MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0
   
  End With
 
  ' Quit Outlook if it was created by this code
  If IsCreated Then OutlApp.Quit
 
  ' Release the memory of object variable
  Set OutlApp = Nothing
 
End Sub