お世話になります
Option Compare Database
Option Explicit
' Wordオブジェクト
Private WithEvents WordApp As Word.Application
' Word.Documentオブジェクト
Private WordDoc As Word.Document
'------------------------------------------------------------------------------
' クラス初期化時処理
'------------------------------------------------------------------------------
Private Sub Class_Initialize()
'word起動
Set WordApp = CreateObject("Word.application")
End Sub
'------------------------------------------------------------------------------
' Word・保存前イベント処理
'------------------------------------------------------------------------------
Private Sub WordApp_DocumentBeforeSave(ByVal Doc As Word.Document, SaveAsUI As Boolean, Cancel As Boolean)
Dim strPath As String
'テキスト1の値をファイル名の先頭に付加
strPath = Application.CurrentProject.Path & "\" & Me.テキスト1.Value & ".docx"
'自分で新しいファイル名でDialogを呼出す
With WordApp.Dialogs(wdDialogFileSaveAs)
.Name = strPath
.Show
End With
'通常のDialogの非表示
Cancel = True
End Sub
''------------------------------------------------------------------------------
'' Word・終了前イベント処理 ★
''------------------------------------------------------------------------------
'Private Sub WordApp_DocumentBeforeClose(ByVal Doc As Word.Document, Cancel As Boolean)
' ActiveDocument.PrintPreview
'End Sub
'------------------------------------------------------------------------------
' Word・終了イベント処理
'------------------------------------------------------------------------------
Private Sub WordApp_Quit()
'Wordオブジェクト解放
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
'******************************************************************************
' Word文書オープン処理
'******************************************************************************
' 関数名 : WordOpen()
' 引数 : P_strFileName 'Word文書ファイル名
' : P_blnVisible '初期表示フラグ
'******************************************************************************
Public Sub WordOpen(ByVal P_strFileName As String, ByVal P_blnVisible As Boolean)
On Error GoTo Err_WordOpen
'word起動
If WordApp Is Nothing Then
Call Class_Initialize
End If
'ワードファイルを読み込み、文章を編集する状態にする
Set WordDoc = WordApp.Documents.Open(P_strFileName) '編集モードで開く
If P_blnVisible = True Then
'Word文書表示処理
Call WordDisplay
End If
Exit_WordOpen:
Exit Sub
Err_WordOpen:
MsgBox Err.Description
Resume Exit_WordOpen
End Sub
'******************************************************************************
' Word文書表示処理
'******************************************************************************
' 関数名 : WordDisplay()
'******************************************************************************
Public Sub WordDisplay()
On Error GoTo Err_WordDisplay
WordApp.Visible = True
WordApp.Activate
Exit_WordDisplay:
Exit Sub
Err_WordDisplay:
MsgBox Err.Description
Resume Exit_WordDisplay
End Sub
'******************************************************************************
' Word文書クローズ処理
'******************************************************************************
' 関数名 : WordClose()
'******************************************************************************
Public Sub WordClose()
On Error GoTo Err_WordClose
'word閉じる
If Not WordDoc Is Nothing Then
'ドキュメントをSAVE無しで閉じる
WordDoc.Close False
Set WordDoc = Nothing
'Wordを閉じる
WordApp.Quit
Set WordApp = Nothing
End If
Exit_WordClose:
Exit Sub
Err_WordClose:
MsgBox Err.Description
Resume Exit_WordClose
End Sub
'******************************************************************************
' Word文書文字列置換処理
'******************************************************************************
' 関数名 : WordReplace()
' 引数 : P_vaKey() '差替KEY文字列の配列
' : P_vaVal() '差替文字列の配列
' : P_blnCrLfLeftAlign '左揃えフラグ
'******************************************************************************
Public Sub WordReplace(P_vaKey() As Variant, P_vaVal() As Variant, P_blnCrLfLeftAlign As Boolean)
On Error GoTo Err_WordReplace
Dim i As Integer
For i = 0 To UBound(P_vaKey)
If InStr(P_vaVal(i), vbCrLf) = 0 Or P_blnCrLfLeftAlign = False Then
'置換文字列に改行コードが無い場合、または左揃えフラグがOFF
'文字を検索、置換する
With WordDoc.Content.Find
.Text = P_vaKey(i)
.Forward = True
.Replacement.Text = Replace(CStr(P_vaVal(i)), vbCrLf, vbCr)
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With
Else
With WordApp.Selection.Find
.Text = P_vaKey(i)
.Execute
End With
'文字を検索、置換する
With WordDoc.Content.Find
.Text = P_vaKey(i)
.Forward = True
.Replacement.Text = ""
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With
Dim arr() As String
arr = Split(P_vaVal(i), vbCrLf)
'改行で分解した文字列をカーソル位置から順次出力
Dim ix As Integer
For ix = 0 To UBound(arr)
If ix > 0 Then
'2個目以降は改行出力
WordApp.Selection.TypeText vbCr
End If
WordApp.Selection.TypeText arr(ix)
Next ix
End If
Next i
Exit_WordReplace:
Exit Sub
Err_WordReplace:
MsgBox Err.Description
Resume Exit_WordReplace
End Sub
ですが、よろしくお願いします
