[原创] 将word文档的选中部分拷为幻灯中

cuteword

Sub 拷为幻灯()

 '使用时要选中适量的文字或者图，能读懂同志的还要进一步根据需要进行调整

Dim PPTapp As Object, mySlide As Object
Dim x As Object
    On Error Resume Next
    Application.ScreenUpdating = False
    If Selection.Type <> wdSelectionNormal Then
        Application.StatusBar = "请先选择要导出的内容。仅支持嵌入式图形和文本"
        Application.ScreenUpdating = True
        Selection.CopyAsPicture 'Exit Sub
    End If

    oldPageWidth = Selection.PageSetup.PageWidth
    If oldPageWidth < 600 Then Selection.PageSetup.PageWidth = 600
    selwidth = oldPageWidth - Selection.PageSetup.RightMargin - Selection.PageSetup.LeftMargin
    mm = Selection.Paragraphs.LineSpacing
   
    parawidth = 0
    SelStart = Selection.Range.Start
    selend = Selection.Range.End
     
    For I = 1 To Selection.Range.ComputeStatistics(wdStatisticLines)
        lineStart = Selection.GoTo(What:=wdGoToLine, Which:=wdGoToNext, Count:=1).End
        Selection.MoveLeft
        If parawidth < Selection.Range.Information(wdHorizontalPositionRelativeToPage) Then
            parawidth = Selection.Range.Information(wdHorizontalPositionRelativeToPage)
        End If
        Selection.MoveRight
    Next
    ActiveDocument.Range(SelStart, selend).Select
    Selection.MoveLeft
    heightb = Selection.Range.Information(wdVerticalPositionRelativeToPage)
     ActiveDocument.Range(SelStart, selend).Select
    Selection.MoveDown
    heighte = Selection.Range.Information(wdVerticalPositionRelativeToPage)
    selheight = Abs(heighte - heightb)

    If selheight = 0 Then
        Application.StatusBar = "选择要导出的内太多或者其他问题不能继续进行处理"
        Application.ScreenUpdating = True
        Exit Sub
    End If
    '  PageHeight = CInt(Sqr(selwidth * selheight))
    '根据需要修改
    If parawidth > selwidth Then
        parawidth = selwidth
    End If
    newPageWidth = CInt(Sqr(parawidth * selheight) * 9 / 7) + Selection.PageSetup.RightMargin + Selection.PageSetup.LeftMargin
    'If selwidth < newpagewidth Then newpagewidth = selwidth
    '    If newPageWidth > parawidth * 9 / 5 Then
    '        newPageWidth = parawidth * 9 / 5
    '    End If
    ActiveDocument.Range(SelStart, selend).Select
    Selection.PageSetup.PageWidth = newPageWidth
    If Selection.Range.Start <> Selection.Range.End Then Selection.Copy
    err.Clear
    Set PPTapp = GetObject(, "PowerPoint.Application")
   
    If err.Number > 0 Then
        Set PPTapp = CreateObject("PowerPoint.Application")
        PPTapp.Visible = True
        PPTapp.Presentations.Add
        err.Clear
        If err.Number > 0 Then
            MsgBox "不能打开PPT文件！"
            Selection.PageSetup.PageWidth = oldPageWidth
            Application.ScreenUpdating = True
            Exit Sub
        End If
    End If
    If PPTapp.Presentations.Count = 0 Then PPTapp.Presentations.Add
    err.Clear
    Set mySlide = PPTapp.ActiveWindow.View.Slide
    If err.Number > 0 Or mySlide Is Nothing Then
        PPTapp.ActivePresentation.slides.Add 1, 12
        Set mySlide = PPTapp.ActiveWindow.View.Slide
    End If
    '     Set mySlide = PPTapp.ActivePresentation.Slides.Add(1, 12)
    With mySlide
        err.Clear
        Set x = .Shapes.PasteSpecial(10)
        If err.Number > 0 Or x Is Nothing Then
            Set x = .Shapes.Paste
        End If
        '        PPTapp.ActiveWindow.Selection.SlideRange.Layout = ppLayoutBlank
        pptwidth = PPTapp.ActivePresentation.PageSetup.SlideWidth
        x.Left = CInt((PPTapp.ActivePresentation.PageSetup.SlideWidth) / 16)   '根据需要修改
        x.Top = 150 '根据需要修改
        newwidth = x.Width
        newheight = x.Height
        x.Width = pptwidth - x.Left * 2
        x.Height = CInt(newheight * (x.Width / newwidth))
        If PPTapp.ActivePresentation.PageSetup.Slideheight - 70 < x.Height Then
            x.Height = PPTapp.ActivePresentation.PageSetup.Slideheight - 70
        End If
        x.Left = (pptwidth - x.Width) / 2
    End With
    '进一步修改位置为居中
    x.Top = (PPTapp.ActivePresentation.PageSetup.Slideheight + x.Top - x.Height - CInt((PPTapp.ActivePresentation.PageSetup.Slideheight) / 16)) / 2 '根据需要修改
    Selection.PageSetup.PageWidth = oldPageWidth
    '      PPTapp.Activate
    '      PPTapp.ActiveWindow.Selection.Copy
    PPTapp.Activate
    ' PPTapp.SetFocus
    Set x = Nothing
    Set mySlide = Nothing
    Set PPTapp = Nothing
   
    Application.Activate '注释掉就不回到word了
    '    Selection.Delete
    '    Selection.PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=InLine, DisplayAsIcon:=False
    Application.ScreenUpdating = True

End Sub

[此贴子已经被作者于2007-6-1 10:44:46编辑过]

yuyvtul

有另外一个办法可达到目的：
①将选中内容复制。
②在PPT中插入——对象——Word文档，粘贴。
③调整对象框大小合适，双击对象框外面。

cuteword

程序是思路就是这样的（智能些罢了，处理的情况多些，花了一个晚上功夫），我前些天就是这样干的，现在我改用代码了！

楼上的朋友比较一下，两者的区别！

dsp5000

试试看。。。。。。。。

无限圆满

老师，幻灯片中的文本框可以设置成左靠上一定距离吗，不让它居中。可以随意调整页边距，如何设置呀。