Question

我正在尝试创建一个带有按钮的工具栏，该按钮可将PowerPoint文档中所有形状和文本框的LanguageID更改为EnglishUS。这是为了解决一个问题，即如果某人使用其他语言（在本例中为法语）拼写检查文档，则该语言将嵌入到.ppt文件本身中。当另一个用户尝试使用其他语言（例如英语）拼写检查同一区域时，拼写检查者建议使用原始语言。例如，它试图将'specified'一词改为'specificie'，一个法语单词。根据我的阅读，解决这个语言问题的唯一方法是使用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 AddIn。 Microsoft已为Office XP提供了分步指南。对于Office 2007及更高版本的AFAIK，以下步骤将执行此操作：

将文件另存为* .ppam到其建议的目录（%APPDATA%\Microsoft\AddIns）
打开设置（单击左上角的办公室按钮并选择“PowerPoint选项”），选择“加载项”页面，在“管理”后面的下拉列表中选择“PowerPoint加载项”，单击“开始”按钮。将打开一个对话框选择“添加新”将显示文件选择器对话框。您应该可以在那里选择文件。

您还可以使用Office Custom UI Editor创建色带。

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

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

3 个答案: