Passing between modules

Hi,

I am struggling with passing file paths between modules. Basically I have an excel sheet that creates a word doc and saves it in a folder on your desktop. (see below)

'=============================================================================
'- COPY/PASTE EXCEL RANGE AS PICTURE INTO WORD
'- Brian Baulsom November 2008
'=============================================================================
Public WordDoc As Object
Public WordApp As Object

Sub PASTE_PICTURE()
    '------------------------------------------------------------------------
    '- COPY EXCEL RANGE
    Set xBook = activeworkbook
    Set iSh = Sheets("INPUT")
    iSh.Range("A1:Y48").CopyPicture Appearance:=xlScreen, Format:=xlPicture


    '------------------------------------------------------------------------
    '- OPEN WORD
    Set WordApp = CreateObject("Word.Application")
    '-----------------------------------------------------------------------
    '- PASTE PICTURE
    With WordApp
        Set WordDoc = .Documents.Add
            With WordDoc
                .PageSetup.Orientation = 1
            End With
        .Visible = True
        .Selection.Paste
        .Selection.TypeParagraph
        .ActiveWindow.ActivePane.Zooms(3).Percentage = 100
    End With
    
    x = MsgBox("Would you like to print the change request?", vbQuestion + vbYesNo, "PRINT CHANGE REQUEST")

        If x = vbYes Then
            WordDoc.PrintOut
            GoTo Cleanup
        Else
            GoTo Cleanup
        End If
    '-----------------------------------------------------------------------
Cleanup:
    Deskstr = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
          & Application.PathSeparator & "STAFF CHANGES BACKUP"
    
    If Dir(Deskstr, vbDirectory) = "" Then MkDir Deskstr

SaveStr = Deskstr & Application.PathSeparator & "CHANGE REQUEST" _
        & " - " _
        & iSh.Range("Q4") _
        & " - " _
        & Format(Now, "dd-mm-yy - hh.mm")
        
WordDoc.SaveAs Filename:=SaveStr & ".doc"

If Err.Number = 5356 Then
    GoTo Ehandle
Else
WordDoc.Close False
WordApp.Quit
   Set WordDoc = Nothing
   Set WordApp = Nothing
    
iSh.Select
xBook.SaveAs Filename:=SaveStr & ".xls", FileFormat:=56
End If
Exit Sub

Ehandle:

    WordDoc.Close False
    Set WordDoc = Nothing

iSh.Select

End Sub
'=============================================================================

There are 3 problems that kind of interlink...

Firstly a word doc is created as I said, sometimes it seems to try and make the word doc twice which creates an error because there is file with that name already open, I don't want this second file to be made in the first place and i'm also not sure how to make an error handler that will close and not save the second word doc if the second one is created.

The next stage is that a ping tests the connection to the mail server.

If there is no connection a msgbox displays detailing what to do and I then want it to reopen the word document and display the print option again.

If there is connectivity with the mail server I want it to run the email routine. The problem I have with this is that I need the file path of the word doc to attach it to the email.

Also I need to attach thisworkbook (which failed as another programme was using it "the macro I'm guessing") This workbook is saved in the same folder as the word doc.

Here is my ping code and email code below that.

Sub ping()
  
   Dim nRes
   Dim x
      
   With CreateObject("WScript.Shell")
        nRes = .Run("%comspec% /c ping.exe -n " & 1 & " -w " & 250 _
          & " 192.168.0.5 | find ""TTL="" > nul 2>&1", 0, True)
   End With
   
   If nRes <> 0 Then
   MsgBox ("Unable to connect to the mail server." & vbNewLine & vbNewLine _
        & "Please print off the word document if you haven't already done so " & vbNewLine _
        & "and give it the Authorisor. The file can be found in a folder " & vbNewLine _
        & "called 'STAFF CHANGES BACKUP' on your desktop. Alternative email " & vbNewLine _
        & "both the excel file and word document relating to this request to " & vbNewLine _
        & "the Authorisor")
        
     x = MsgBox("Would you like to print the change request?", vbQuestion + vbYesNo, "PRINT CHANGE REQUEST")

        If x = vbYes Then
            WordDoc.PrintOut
            Exit Sub
        Else
            Exit Sub
        End If
   Else
   Call Emailer.EMAILLIST
   End If
   
End Sub

Public xBook As Workbook
Public iSh As Worksheet


Sub EMAILLIST()

    Dim cell As Object
    Dim NR As Long
    Dim tagerror As String
    Dim Email_Send_To, Email_Send_From, Email_Subject, Email_Body As String
    Dim strUserEmail As String
    Dim strFirstClassPassword As String
    Dim errPar As String
    Dim iMsg As Object
    Dim iConfig As Object
    Dim sConfig As Variant
    Dim Row As Integer
    Dim Atc As String
    
    
    Set xBook = activeworkbook
    Set iSh = xBook.Sheets("INPUT")
    
        
    strUserEmail = iSh.Range("MMAIL")
    strFirstClassPassword = ""

    Set iMsg = CreateObject("CDO.Message")
    Set iConfig = CreateObject("CDO.Configuration")
    iConfig.Load -1
    Set sConfig = iConfig.Fields
        
        With sConfig
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "192.168.0.5" 'Name or IP of remote SMTP server
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25  'Server Port
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = strUserEmail
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strFirstClassPassword
            .Update
        End With
     
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
   

 '-----------------------------------------------------------------------------

    Email_Send_To = iSh.Range("AMAIL")
    Email_Send_From = iSh.Range("MMAIL")
    Email_Subject = "CHANGE REQUEST"
    Email_Body = "Dear " & iSh.Range("ANAME") & "," & vbNewLine & vbNewLine _
                & "Please complete this change request which was submitted by " & iSh.Range("MNAME") _
                & " on the " & Format(Now, "dd/mm/yyyy") & ". To complete this request please download the " _
                & "attached files to your desktop. If you only have a word document, please print this off, " _
                & "sign it and return it to HR. If there is also an excel sheet, once you have downloaded it, " _
                & "open it and check the details. If you give permission for this change request, click the " _
                & "'Authorise' button. If you get a message saying unable to connect, then you must print off " _
                & "the word document and submit it to HR." & vbNewLine & vbNewLine _
                & "Any queries should be directed to your segment's HR team who will be happy to help." _
                & vbNewLine & vbNewLine _
                & "Kind regards," & vbNewLine & vbNewLine _
                & "HR"
                
    

'-----------------------------------------------------------------------------
         

    With iMsg
        Set .Configuration = iConfig
    End With
    
            iMsg.To = Email_Send_To
            iMsg.From = Email_Send_From
            iMsg.Subject = Email_Subject
            iMsg.Textbody = Email_Body
                If iSh.Range("PDESC") = "" Then
                    GoTo NAtt
                Else
                    iMsg.AddAttachment iSh.Range("PDESC")
                End If
NAtt:       iMsg.AddAttachment ThisWorkbook.FullName
            iMsg.AddAttachment Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 3) & "doc"
            iMsg.Send
    
    Exit Sub

On Error GoTo tagerror


clean_up:
    With Application
       .EnableEvents = True
       .ScreenUpdating = True
    End With
 

    
tagerror:
    MsgBox "Error: (" & Err.Number & ") " & Err.Description & " at " & Err.Source, vbCritical
    Resume clean_up

    
End Sub