LoginSignup
2
2

More than 5 years have passed since last update.

VBA Powerpointの参照設定をイミディエイトに出力する Wordはファイルに出力する Powerpoint And WinWord Export Reference Settings

Posted at

Outlook Publisherはこの機能がないらしい

PowerpointとPublisherは似ているのですが、ここが全く違います。

必ず下記の参照設定が必要です

Microsoft Visual Basic for Applications Extensibility X.X
現在は5.3のようです。
これをしないと動きません。
またWordは
Microsoft Scripting Runtimeも参照設定しています。
Wordで使っているのはダブルクォーテーションで包み、コンマまたは改行を付加する関数です。
https://qiita.com/Q11Q/items/0c956f9bbdb7efee56f0

Powerpoint

Sub ExoirtPowerpointaRefsettings()
'Powerpointの参照設定を出力する
Dim pp As PowerPoint.Presentation: Set pp = ActivePresentation
Dim VP As VBProject
Dim ref As Reference, refs As References
Set VP = Application.VBE.ActiveVBProject
Set refs = VP.References
For Each ref In refs
Debug.Print ref.Name
Next
End Sub

Word

Sub ExportWordVBARefs()
'FilesystemObjectは参照設定
'出力先は
Const ExportFileFullPath = "D:\wdList.txt"
Dim wd As Word.Document: Set wd = ThisDocument
Dim refs As VBIDE.References, ref As VBIDE.Reference
Dim Ts As TextStream, FSO As New Scripting.FileSystemObject
Set Ts = FSO.OpenTextFile(ExportFileFullPath, ForAppending, True)
Set refs = Application.VBE.ActiveVBProject.References
For Each ref In refs
On Error Resume Next
If ref.IsBroken = False Then
Ts.Write RpDqtc(ref.Name) & RpDqtc(ref.Major) & RpDqtc(ref.Minor) & RpDqtc(ref.Description) & RpDqtc(ref.FullPath) & RpDqtc(ref.GUID) & RpDqR(ref.Type)
Else
Ts.Write RpDqtc(ref.Name) & RpDqtc("Broken") & "" & "" & vbCrLf
End If
If Err.Number <> 0 Then Debug.Print ref.Name, Err.Number, Err.Description: Err.Clear
Next
Ts.Close
End Sub

Function RpDqtc(varString) ' As String
' String Return With DoubleQuotation Such As
' Dog => "Dog" ,
' wRapping with DoubleQuoTation
'RpDqtc=chr(34) & varString & chr(34) & ","
On Error Resume Next
If TypeName(varString) = "Date" Then
RpDqtc = Chr(34) & CDate(varString) & Chr(34) & Chr(44)
Else
RpDqtc = Chr(34) & CStr(varString) & Chr(34) & Chr(44)
End If
Exit Function
On Error GoTo 0
If Err.Number <> 0 Then
Err.Clear
RpDqtc = Chr(34) & Chr(34) & Chr(44)
Exit Function
End If
End Function
Function RpDqR(varString) ' As String
' String Return With DoubleQuotation Such As
' Dog => "Dog" & VbCrLf
' wRapping with DoubleQuoTation
On Error Resume Next
If TypeName(varString) = "Date" Then
RpDqR = Chr(34) & CDate(varString) & Chr(34) & vbCrLf
Else
RpDqR = Chr(34) & CStr(varString) & Chr(34) & vbCrLf
End If
Exit Function
On Error GoTo 0
 If Err.Number <> 0 Then
 'Wscript.Echo Err.Number, Err.Description
  Err.Clear
  RpDqR = Chr(34) & Chr(34) & vbCrLf: Exit Function
  End If
End Function
2
2
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
2
2