在任何 PowerPoint 上运行 VBA 以更改 LanguageID

Question

我正在尝试创建一个带有按钮的工具栏，该按钮会将 PowerPoint 文档中所有形状和文本框的 LanguageID 更改为 EnglishUS。这是为了解决一个问题，即如果有人使用另一种语言（在本例中为法语）对文档进行拼写检查，该语言会嵌入到 .ppt 文件本身中。当另一个用户尝试使用另一种语言（例如英语）对同一区域进行拼写检查时，拼写检查器建议的单词是原始语言。例如，它试图将“指定”一词更正为“指定”，一个法语单词。根据我的阅读，解决此语言问题的唯一方法是使用 VBscript，而在 Powerpoint 中运行 VBscript 而无需将其嵌入 .ppt 并每次都加载该文件的唯一方法是创建一个加载项使用工具栏按钮运行宏，也使用 VBS。下面是我从各种来源获取的代码，当我尝试将它放在一起时，它不起作用（尽管它确实编译了）。如果有人可以看一下，我敢肯定它是一个简单的语法错误或类似的东西，这将是一个巨大的帮助。提前致谢！！

顺便说一句，如果有人知道在 PPT 中运行宏而无需每次都打开某个 PPT 的更简单方法，我很乐意。

现在，脚本：

Sub Auto_Open() 
    Dim oToolbar As CommandBar 
     Dim oButton As CommandBarButton 
     Dim MyToolbar As String 

     ''# Give the toolbar a name 
     MyToolbar = "Fix Language" 

     On Error Resume Next    
     ''# so that it doesn't stop on the next line if the toolbar's already there 

     ''# Create the toolbar; PowerPoint will error if it already exists 
     Set oToolbar = CommandBars.Add(Name:=MyToolbar, _ 
         Position:=msoBarFloating, Temporary:=True) 
     If Err.Number <> 0 Then   
           ''# The toolbar's already there, so we have nothing to do 
           Exit Sub 
     End If 

     On Error GoTo ErrorHandler 

     ''# Now add a button to the new toolbar 
     Set oButton = oToolbar.Controls.Add(Type:=msoControlButton) 

     ''# And set some of the button's properties 
     With oButton 
          .DescriptionText = "Fix Language for Spell Check"    
           ''# Tooltip text when mouse if placed over button 
          .Caption = "Click to Run Script"     
          ''# Text if Text in Icon is chosen 
          .OnAction = "Button1"   
           ''# Runs the Sub Button1() code when clicked 
          .Style = msoButtonIcon     
           ''# Button displays as icon, not text or both 
          .FaceId = 59        

     End With 

     ''# Repeat the above for as many more buttons as you need to add 
     ''# Be sure to change the .OnAction property at least for each new button 

     ''# You can set the toolbar position and visibility here if you like 
     ''# By default, it'll be visible when created 
     oToolbar.Top = 150 
     oToolbar.Left = 150 
     oToolbar.Visible = True 

 NormalExit: 
     Exit Sub   ''# so it doesn't go on to run the errorhandler code 

 ErrorHandler: 
      ''# Just in case there is an error 
      MsgBox Err.Number & vbCrLf & Err.Description 
      Resume NormalExit: 
 End Sub 

 Sub Button1() 
 ''#         This is the code to replace the LanguageID throughout the ppt 
  Option Explicit    
  Public Sub ChangeSpellCheckingLanguage()    
  Dim j As Integer, k As Integer, scount As Integer, fcount As Integer  
  scount = ActivePresentation.Slides.Count  
  For j = 1 To scount  
  fcount = ActivePresentation.Slides(j).Shapes.Count  
  For k = 1 To fcount  
  If ActivePresentation.Slides(j).Shapes(k).HasTextFrame Then  
  ActivePresentation.Slides(j).Shapes(k) _  
  .TextFrame.TextRange.LanguageID = msoLanguageIDEnglishUS  
  End If  
  Next k  
  Next j  
  End Sub 

  End Sub

Answer 1

如果还不清楚，答案是很明显的。

如您所见，sub Button1() 封装了另一个子组件。因此，我建议您删除调用ChangeSpellingCheckingLanguage 和最后一个End sub，然后您的代码将工作。

Answer 2

这可能是一个非常晚的答案，但我刚刚使用 VBScript（可以在 powerpoint 之外运行）解决了这个问题。编写的脚本会将给定目录（和子目录）中每个 powerpoint 文件的语言更改为英语。这是脚本：

Option Explicit

'microsoft office constants
Const msoTrue = -1
Const msoFalse = 0
Const msoLanguageIDEnglishUS = 1033
Const msoGroup = 6

'starting folder (current folder)
Const START_FOLDER = ".\"
'valid powerpoint file extensions
Dim FILE_EXTENSIONS : FILE_EXTENSIONS = Array("pptx", "pptm", "ppt", "potx", "potm", "pot")
'desired language for all Text
Dim DESIRED_LANGUAGE : DESIRED_LANGUAGE = msoLanguageIDEnglishUS

'VBScript file system objects for starting folder
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objStartingFolder : Set objStartingFolder = objFSO.GetFolder(START_FOLDER)

IterateContainingItems objStartingFolder

'recursive subroutine to iterate each file in specified folder and all subfolders
Sub IterateContainingItems(objCurrentFolder)
    Dim colFiles : Set colFiles = objCurrentFolder.Files
    Dim objCurrentFile
    For Each objCurrentFile in colFiles
        ReportInfo(objCurrentFile)
    Next
    Dim colFolders : Set colFolders = objCurrentFolder.SubFolders
    Dim objNextFolder
    For Each objNextFolder in colFolders
        IterateContainingItems objNextFolder
    Next
End Sub

'subroutine executed for every file iterated by IterateContainingItems subroutine
Sub ReportInfo(objCurrentFile)
    Dim strPathToFile
    strPathToFile = objFSO.GetAbsolutePathName(objCurrentFile.Path)

    If isPowerpointFile(strPathToFile) Then
        Dim objPowerpointApp, objPresentations, objPresentation, objSlides, intSlideCount

        set objPowerpointApp = CreateObject("Powerpoint.Application")
        set objPresentations = objPowerpointApp.Presentations
        Set objPresentation = objPresentations.Open(strPathToFile, msoFalse, msoFalse, msoFalse)
        Set objSlides = objPresentation.Slides
        intSlideCount = objSlides.Count

        ResetLanguage objPresentation

        objPresentation.Save
        objPresentation.Close
        objPowerpointApp.Quit
    End If
End Sub

'check if given filepath specifies a powerpoint file as described by the "constant" extension array
Function isPowerpointFile(strFilePath)
    Dim strExtension, found, i
    strExtension = objFSO.GetExtensionName(strFilePath)
    found = false
    for i = 0 to ubound(FILE_EXTENSIONS)
        if FILE_EXTENSIONS(i) = strExtension then    
            found = true
            exit for
        end if
    next
    isPowerpointFile = found
End Function

'finds every shape in the entire document and attempts to reset its LanguageID
Sub ResetLanguage(objCurrentPresentation)
    Dim objShape

    'change shapes from presentation-wide masters
    If objCurrentPresentation.HasHandoutMaster Then
        For Each objShape in objCurrentPresentation.HandoutMaster.Shapes
            ChangeLanguage objShape
        Next
    End If
    If objCurrentPresentation.HasNotesMaster Then
        For Each objShape in objCurrentPresentation.NotesMaster.Shapes
            ChangeLanguage objShape
        Next
    End If
    If objCurrentPresentation.HasTitleMaster = msoTrue Then
        For Each objShape in objCurrentPresentation.TitleMaster.Shapes
            ChangeLanguage objShape
        Next
    End If
    'change shapes from each design's master
    Dim tempDesign
    For Each tempDesign in objCurrentPresentation.Designs
        For Each objShape in tempDesign.SlideMaster.Shapes
            ChangeLanguage objShape
        Next
    Next
    'change shapes from each slide
    Dim tempSlide
    For Each tempSlide in objCurrentPresentation.Slides
        For Each objShape in tempSlide.Shapes
            ChangeLanguage objShape
        Next
        If tempSlide.hasNotesPage Then
            For Each objShape in tempSlide.NotesPage.Shapes
                ChangeLanguage objShape
            Next
        End If
    Next
End Sub

'if the given shape contains a text element, it checks and corrects the LanguageID
'if the given shape is a group, it iterates through each element in the group
Sub ChangeLanguage(objShape)
    If objShape.Type = msoGroup Then
        Dim objShapeGroup : Set objShapeGroup = objShape.GroupItems
        Dim objShapeChild
        For Each objShapeChild in objShapeGroup
            ChangeLanguage objShapeChild
        Next
    Else
        If objShape.HasTextFrame Then
            Dim intOrigLanguage : intOrigLanguage = objShape.TextFrame.TextRange.LanguageID
            If Not intOrigLanguage = DESIRED_LANGUAGE Then
                If objShape.TextFrame.TextRange.Length = 0 Then
                    objShape.TextFrame.TextRange.Text = "[PLACEHOLDER_TEXT_TO_DELETE]"
                End If
                objShape.TextFrame.TextRange.LanguageID = DESIRED_LANGUAGE
                If objShape.TextFrame.TextRange.Text = "[PLACEHOLDER_TEXT_TO_DELETE]" Then
                    objShape.TextFrame.TextRange.Text = ""
                End If
            End If
        End If
    End If
End Sub

要运行它，只需将代码复制并粘贴到文本编辑器中，然后将其作为“script_name.vbs”保存在您的 powerpoint 文件所在的目录中。双击脚本并等待运行它。

Answer 3

要在每次打开 PowerPoint 时加载宏，您需要创建一个 PowerPoint 插件。 Microsoft 为Office XP 提供了分步指南。对于 Office 2007 及更高版本，AFAIK 将执行以下步骤：

• 将文件另存为 *.ppam 到它建议的目录 (%APPDATA%\Microsoft\AddIns)
• 打开设置（点击左上角的office按钮，选择“PowerPoint选项”），选择“加载项”页面，在“管理”后面的下拉菜单中选择“PowerPoint加载项”，单击“开始”按钮。将打开一个对话框。选择“添加新”会弹出一个文件选择器对话框。您应该可以在那里选择文件。

您也可以使用Office Custom UI Editor 来创建功能区。

但是，我已经为当前版本的 PowerPoint 创建了这样的语言修复程序插件，并且我已将其免费下载供个人使用：PowerPoint Language Fixer by Jan Schejbal