テスト14

'Excel

Public wd As Variant

Sub テスト()

Set wd = CreateObject("Word.Application")
wd.Visible = True
 
Dim wdDoc As Variant
Dim i As Long
Dim FSO As Object
Dim f As Object
Dim P As String
Dim flg As Integer

P = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
flg = 0
'Wordファイルだけ処理
For Each f In FSO.GetFolder(P).Files

    If FSO.GetExtensionName(f.Path) Like "*doc*" And Not (f.Path Like "*$*") Then
    
        Set wdDoc = wd.Documents.Open(ThisWorkbook.Path & "\" & Dir(f.Path))
         
        KanriNo = Sheets("書類チェック").Range("C3")
        Stype = Sheets("書類チェック").Range("C4")
        ShisyaName = Sheets("書類チェック").Range("C5")
        
        '----------------------------------------------------------------
        'ポイントはファイル名は入れない、マクロ名だけ入れる
'        wd.Run "チェックとPDF保存", KanriNo, Stype, ShisyaName
         
Call チェックとPDF保存(KanriNo, Stype, ShisyaName)
        
        '----------------------------------------------------------------
        
        Set wdDoc = Nothing
        flg = 1
    End If

Next f


wd.Visible = False
Set wd = Nothing
Set FSO = Nothing

If flg = 1 Then
    MsgBox "文書のチェックとPDFへの変換が終わりました。", vbInformation
Else
    MsgBox "チェックするWord文書がありませんでした。", vbInformation
End If

End Sub


Sub チェックとPDF保存(KanriNo, Stype, ShisyaName)

Dim myFileName As String
Dim myFilePath As String
Dim myDoc As Variant
Dim intPos As Integer

'------------------------------------------------------------------------
'2行目から管理番号をチェックする
Dim Rng As Variant
Set Rng = wd.ActiveDocument.Range(0, 60)

With Rng.Find

   .Text = KanriNo
   .MatchByte = True
   .MatchCase = True
   
   If .Execute = False Then
       MsgBox "番号が一致しません。", vbInformation
       Set myDoc = Nothing
       End
   End If

End With

Set Rng = Nothing
 
 '3行目から書類の種類を検索する
Set Rng = wd.ActiveDocument.Range(0, 60)
 
With Rng.Find

   .Text = Stype
   .MatchByte = True
   .MatchCase = True
   
   If .Execute = False Then
       MsgBox "書類の種類が一致しません。", vbInformation
       Set myDoc = Nothing
       End
   End If

End With

Set Rng = Nothing
 
'5行目から支社名を検索する
Set Rng = wd.ActiveDocument.Range(0, 60)

With Rng.Find

   .Text = ShisyaName
   .MatchByte = True
   .MatchCase = True
   
   If .Execute = False Then
       MsgBox "支社名が一致しません。", vbInformation
       Set myDoc = Nothing
       End
   End If

End With

Set Rng = Nothing
 
'------------------------------------------------------------------------

Set myDoc = wd.ActiveDocument

'拡張子のない名称を取得
myFileName = myDoc.Name
intPos = InStrRev(myFileName, ".")
myFileName = Left(myFileName, intPos - 1)

'PDFファイルで保存
myFilePath = myDoc.Path  'Wordファイルと同じフォルダ
myDoc.ExportAsFixedFormat _
  OutputFileName:=myFilePath & "\" & myFileName & ".pdf", _
  ExportFormat:=17
  
'「https://tyama-blog.blog.ss-blog.jp/2017-01-18」を参照
'wdExportFormatPDF=17
'------------------------------------------------------------------------
 
wd.ActiveDocument.Close

Set myDoc = Nothing

End Sub