View Single Post
 
Old 04-01-2016, 07:49 PM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

A datasource described as:
H:\PWS\Parks\Parks Operations\Sports\Sports15\DATA1.xls
suggests all there was in ws_vh.Range("B4") was ".xls"
That said, I can't see how the path separator (\) after DATA1 could get deleted.

Try:
Code:
Sub Merge2(ByVal i As Long, ByVal ws_vh As Object)
    Dim objWord As Object, oDoc As Object, oDoc2 As Object
    Dim myPath As String, fName As String, StrSrc As String
    Dim itype As String, isubresp As String, StrSQL As String
    Dim ws_th As Worksheet
    Const wdSendtToNewDocument = 0
    Const wdSendToPrinter = 1
    Const wdFormLetters = 0
    Const wdDirectory = 3
    Const wdNotAMergeDocument = -1
    Const wdMergeSubTypeAccess = 1
    Set ws_th = Workbooks("Sports15b.xlsm").Worksheets("TEMP_HOLD")
    itype = Right(ws_th.Range("A" & i + 1), 2)
    isubresp = Left(ws_th.Range("A" & i + 1), 3)
    StrSQL = "SELECT * FROM `CORE$` WHERE [TYPE]='" & itype & "' AND [SIG_CREW]= '" & isubresp & "' ORDER BY [START] ASC, [COMPLEX] ASC, [UNIT] ASC"
    StrSrc = "H:\PWS\Parks\Parks Operations\Sports\Sports15\DATA1\" & ws_vh.Range("B4")
 
    If itype = "DR" Then
        fName = "H:\PWS\Parks\Parks Operations\Sports\Sports15\REPORTS\DR15v1.docx"
    ElseIf itype = "DT" Then
        fName = "H:\PWS\Parks\Parks Operations\Sports\Sports15\REPORTS\DT15v1.docx"
    ElseIf itype = "FR" Then
        fName = "H:\PWS\Parks\Parks Operations\Sports\Sports15\REPORTS\FR15v1.docx"
    ElseIf itype = "FT" Then
        fName = "H:\PWS\Parks\Parks Operations\Sports\Sports15\REPORTS\FT15v1.docx"
    ElseIf itype = "CR" Then
        fName = "H:\PWS\Parks\Parks Operations\Sports\Sports15\REPORTS\CR15v1.docx"
    Else
        fName = "H:\PWS\Parks\Parks Operations\Sports\Sports15\REPORTS\CT15v1.docx"
    End If
 
    MsgBox "Mailmerge Main Document: " & fName
    MsgBox "Data Source: " & StrSrc & vbCr & "Type: " & itype & vbCr & "Sig_Crew: " & isubresp & vbCr & "SQL: " & StrSQL
 
    Set objWord = CreateObject("Word.Application")
    With objWord
        .DisplayAlerts = False
        .Visible = True
        Set oDoc = .Documents.Open(Filename:=fName, ConfirmConversions:=False, _
            ReadOnly:=True, AddToRecentFiles:=False, Visible:=True)
        With oDoc
            With .MailMerge
                .MainDocumentType = wdDirectory
                .Destination = wdSendtToNewDocument
                .SuppressBlankLines = True
                .OpenDataSource _
                Name:=StrSrc, ReadOnly:=True, AddToRecentFiles:=False, LinkToSource:=False, _
                    Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
                    "Data Source=StrSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
                    SQLStatement:=StrSQL, SQLStatement1:="", SubType:=wdMergeSubTypeAccess
                .Execute Pause:=False
            End With
            .Close False
        End With
        .DisplayAlerts = True
    End With
End Sub
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote