これは既に公開されているいくつかの問題と類似しています。私は他の質問に答えを適用する方法を知らないので、私は具体的な助けが必要です。VBA Wordリモートサーバーマシンが存在しないか、利用できません。
基本的に、私はMSWordのを参照するAccessでコードを書いている、と私は、コードを複数回実行した場合、それがリモートサーバーマシンが
を存在しないか、使用できる状態ではありませんメッセージで失敗を開始ここで
はコードです:
Private Sub CreateWordMergeDoc_Click()
On Error GoTo Err_CreateWordMergeDoc_Click
Dim strSQL, strChurch, strDistLang, strFind, strReplace As String
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim wrdMergeDoc As Word.Document
Dim strFilepath As String
strFilepath = "O:\Church Phone List"
'Require choice for church and district
If IsNull(Me![ChurchCombo]) = True Then
MsgBox "Select church", , "Church Phone List"
Me.ChurchCombo.SetFocus
GoTo CloseSub
End If
strChurch = Me![ChurchCombo]
strDistLang = Me![DistrictChoiceCombo]
If strDistLang = "" Then
MsgBox "Select District", , "Church Phone List"
Me.DistrictChoiceCombo.SetFocus
GoTo CloseSub
Else
strDistLang = IIf(Me![DistrictChoiceCombo] = "", "Church", Me![DistrictChoiceCombo])
End If
'Create SQL string from present church/district information
strSQL = "SELECT Churches.* " & vbCrLf & _
"FROM Churches " & vbCrLf & _
"WHERE (((Churches.Church)='" & strChurch & "') AND ((Churches.[District/Language])Like'" & strDistLang & "')) " & vbCrLf & _
"ORDER BY Churches.NAME;"
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open(strFilepath & "\Phone Merge Document.docx")
With wrdDoc
With .ActiveWindow
'Open the header/footer and add the church (and district if appropriate)
.ActivePane.View.SeekView = WdSeekView.wdSeekCurrentPageHeader
.Selection.EndKey Unit:=wdLine
.Selection.TypeText Text:=strChurch & IIf(strDistLang <> "Church", " (" & strDistLang & ")", "")
'Close header/footer
.ActivePane.View.SeekView = WdSeekView.wdSeekMainDocument
End With
With .MailMerge
.MainDocumentType = wdCatalog
.OpenDataSource NAME:= _
GetNamePath _
, ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:= _
"DSN=MS Access Database;DBQ=" & strFilepath & "2017\Phone List 2017.mdb;DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;" _
, SQLStatement:=strSQL, SubType:= _
wdMergeSubTypeOther
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
.Close SaveChanges:=wdDoNotSaveChanges
End With
With wrdApp
.Selection.WholeStory
With .Selection.ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
End With
.Selection.ParagraphFormat.TabStops.ClearAll
.ActiveDocument.DefaultTabStop = InchesToPoints(0.5)
'Add a tab stop
.Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.1), _
Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
'Replace (C) and (¢) with [C] and [c] since auto replace for (c) may be enabled
.Selection.Find.Replacement.ClearFormatting
With .Selection.Find
.Text = "(C)"
.Replacement.Text = "[C]"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Selection.Find.Execute Replace:=wdReplaceAll
With .Selection.Find
.Text = "(¢)"
.Replacement.Text = "[c]"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Selection.Find.Execute Replace:=wdReplaceAll
'Lock document so track changes stays on
.ActiveDocument.Protect Password:="onebody1", NoReset:=False, Type:= _
wdAllowOnlyRevisions, UseIRM:=False, EnforceStyleLock:=False
.ChangeFileOpenDirectory _
strFilepath & "\Track-Change Documents\"
End With
strFind = "/"
strReplace = " "
strDistLang = Replace(strDistLang, strFind, strReplace)
wrdApp.ActiveDocument.SaveAs2 FileName:=strChurch & IIf(strDistLang <> "Church", " - " & strDistLang, ""), FileFormat _
:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
wrdApp.ActiveDocument.Activate
'quit the word application:
wrdApp.Quit
MsgBox "Completed", , "Church Phone List"
CloseSub:
'Clear the object variables:
Set wrdDoc = Nothing
Set wrdApp = Nothing
Exit_CreateWordMergeDoc_Click:
Set wrdDoc = Nothing
Set wrdApp = Nothing
Exit Sub
Err_CreateWordMergeDoc_Click:
MsgBox Err.Description
Resume Exit_CreateWordMergeDoc_Click
End Sub
誰かがエラーメートルに関しては、コードのクリーンアップに役立つことができれば、私は非常に感謝するだろうエッセージ。
これはうまくいきました。私のテストは限られていましたが、これ以上のエラーメッセージはありませんでした。私はあなたの援助に非常に感謝しています! – KLJKevin