Attribute VB_Name = "XlsRead"
' ##############################################################
' #                     GLOBAL VARIABLES                       #
' ##############################################################

' mpath - this is where your excel files are located
' by default - should be the worpapers directory in
' the current folder
Global mpath As String

' Excel variables
Global xlApp As Object
Global xlWB As Object

' Word variables
Global ths As String

' ##############################################################
' #                         SUBROUTINES                        #
' ##############################################################

' this subroutine will copy the range from the excel sheet sheetName and paste it as a
' table at bookmark bm in the current word document
Public Sub copyRangeAndPaste(ByVal sheetName As String, ByVal range As String, ByVal bm As String)

       
    Dim r
    Dim clip As DataObject ' object used for cleaning clipboard
    
    ' initialize clip to an empty string
    Set clip = New DataObject
    clip.SetText ""
       
    ' copy the range into r
    Set r = xlWB.Sheets.Item(sheetName).range(range)
  
    Dim bmRange   As range
    
  
    ' activate the currently used word doc
    Word.Documents.Item(ths).Activate
    
    If ActiveDocument.Bookmarks.Exists(bm) And Not r Is Nothing Then
        r.Copy ' copy stuff from r into clipboard
            
        'copy the contents of bm to bmrange
        Set bmRange = ActiveDocument.Bookmarks(bm).range
            
        'pase clipboard into bmrange (overwriting other crap and deleting bookmark)
        bmRange.Paste
                    
        ' add new bookmark named same as bm, and containing bm's range
        ActiveDocument.Bookmarks.Add name:=bm, range:=bmRange
        
        'clear out clipboard
        clip.PutInClipboard
    End If
    
      
End Sub

' ##############################################################

Public Function Initialize(ByVal filename As String)
     
     ' default path for workpapers
    mpath = ThisDocument.Path & "\workpapers\"
       
    ' keep track of this document so we can go back
    ths = ActiveDocument.name
    
    'open excell instance
    Set xlApp = CreateObject("Excel.Application")
    
    ' display a notice to the user so he waits
    ' patiently and doesn't cry that program froze
    DgDialog.longWaitNotice
    
    
    ' hide excel window
    xlApp.Visible = False
    xlApp.ScreenUpdating = False
    
    
    ' -----------------------------------------------
    '   uncomment for debuging to see excel actions:
    ' -----------------------------------------------
            'xlApp.Visible = True
            'xlApp.ScreenUpdating = True
    ' -----------------------------------------------
    
    
    arfile = ChooseFile(xlApp, filename)
    
     'boolean variable for filecheck
    Dim ar As Boolean
       
    'check if the chosen file exists
    ar = Check(arfile)
        
    ' if the file does not exist, bail out
    If ar = False Then noFileError (arfile)
    
    Set xlWB = xlApp.Workbooks.Open(arfile)
    
    Initialize = arfile
    

End Function

' ##############################################################

' Ask the user to choose if they want to choose file manually, or use the file called
' fname licated in the same folder as the active document
Private Function ChooseFile(ByRef xlApp As Object, ByVal fname As String)

   
    dachoice = MsgBox("Do you want use the following file?" & vbCrLf & vbCrLf & _
        mpath & fname & vbCrLf & vbCrLf & _
        "If you choose No, you will be prompted to choose a file manually", vbYesNo, "Custom Worpaper Filenames")
    
        Dim File As String
        
    If (dachoice = vbNo) Then
        
        xlApp.Visible = True
                
        File = xlApp.GetOpenFilename("Excel files (*.xl*),*.xl*", _
        1, "Please choose your file", False)
                        
    Else
        File = XlsRead.mpath & fname
    End If
    
    ChooseFile = File

End Function

' ##############################################################


' checks if the file exists
Private Function Check(ByVal name As String) As Boolean
    
    Dim fso
    Dim File As String
    
    File = name
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(File) Then Check = False Else Check = True

End Function

' ##############################################################

' No File Error - displays the message and closes all XLS objects
Private Sub noFileError(ByVal arfile As String)

    Dim text As String
     
    text = "Unable to Complete this Task. Following Files Were Not Found:" & vbCrLf & vbCrLf
    text = text & arfile & vbCrLf
    text = text & vbCrLf & "The task was aborted prematurely and no changes were" & _
        vbCrLf & "made to this document." & vbCrLf & _
        vbCrLf & "Please make sure you specified a correct existing file" & _
        vbCrLf & " and try again"
                
    MsgBox text, vbCritical
    
    KillXLS

End Sub


' ##############################################################

' Displays error about using wrong workbook and then closes out Excel
Private Sub worksheetError()

    MsgBox "Wrong File or Worksheet Not Found" & vbCrLf & _
            vbCrLf & "Plese make sure that: " & vbCrLf & _
            vbCrLf & "1. You are using correct XLS file" & _
            vbCrLf & "2. You have Reading permissions for that file" & _
            vbCrLf & "3. You can open the file normally in Excel" & _
            vbCrLf & "4. No workseets are missing in your file" & _
            vbCrLf & vbCrLf & "Recovery Tip:" & vbCrLf & _
            vbCrLf & "Close all Excel windows and try again", vbCritical
            
    KillXLS

End Sub

' ##############################################################

Sub KillXLS()

    If Not xlWB Is Nothing Then xlWB.Close 'False ' close the workbook without saving
    
    If Not xlApp Is Nothing Then
        xlApp.Visible = True
        xlApp.ScreenUpdating = True
        xlApp.Quit ' close the Excel application
    End If
    
    Set xlWB = Nothing
    Set xlApp = Nothing

End Sub

' ##############################################################
' ##############################################################
' ##############################################################


' the folowing function will open up sample.xls and copy the range
' A1:E10 from Worksheet 1 into the bookmark first_table in the active
' Word documnent. If the bookmark doesn't exist nothing will happen.
' User will be asked if the worksheet is in the same directory as the
' word document, or if they want to choose it manually.
Sub example()


    On Error GoTo Wrong_Doc                
        
    arfile = Initialize("sample.xls")
    
    copyRangeAndPaste "Worksheet 1", "A1:E10", "first_table"
      

Wrong_Doc:
    worksheetError
End

End Sub