文字和嵌入式图形混排“串”无变形粘贴到PPT

chuhaiou

谢谢分享，收藏备用

莫悠悠

csnAlex 发表于 2007-5-20 16:56
按照3楼方式一中的意思，在WORD里运行宏COPY2PPT，会自动把你选择的一行（目前只支持一行）文本或嵌入式图形 ...

要是能实现多行该多好啊

leikaiyi123

csnAlex 发表于 2007-5-20 16:56
按照3楼方式一中的意思，在WORD里运行宏COPY2PPT，会自动把你选择的一行（目前只支持一行）文本或嵌入式图 ...

经测试，发现4楼的代码仍有两个问题：
1、前面有首行缩进，粘贴后的图片左边仍有一段空白
2、最好将2、4楼综合一下，有打开的ppt就粘贴到打开的ppt中，若没有则新建一个ppt
修改如下，请指正：Sub Copy2PPT() '嵌入图形复制发送到ppt
    Dim pptApp As Object, ptPre As Object, mySlide As Object
    Dim x As Object

    On Error Resume Next

    If Selection.Type <> wdSelectionNormal Then
        MsgBox "请先选择要导出的内容。仅支持嵌入式图形和文本。"
        Exit Sub
    End If

    oldPageWidth = Selection.PageSetup.PageWidth

    sj = Selection.ParagraphFormat.FirstLineIndent '首行缩进
    Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)

    Selection.EndKey Unit:=wdLine    '光标移到末尾
    rightPos = Selection.Information(wdHorizontalPositionRelativeToPage)    '获得光标的LEFT位置
    newPageWidth = rightPos + Selection.PageSetup.RightMargin + 2    '+右页边距

    Selection.PageSetup.PageWidth = newPageWidth    '改变页宽
    Application.ScreenRefresh    '刷新屏幕

    Selection.Paragraphs(1).Range.Select  '选中该段
    Selection.Copy

    Err.Clear
    Set pptApp = GetObject(, "PowerPoint.Application")    '获取打开的ppt

    If Err.Number > 0 Then  '若没有打开ppt(出错信息＞0)
        'MsgBox "没有打开的PPT文件。"
        'Selection.PageSetup.PageWidth = oldPageWidth    '出错恢复原页宽
        'Exit Sub
        Set pptApp = CreateObject("PowerPoint.Application") '则新建一个ppt
        Set ptPre = pptApp.Presentations.Add
        Set mySlide = ptPre.Slides.Add(1, 12)
        pptApp.Visible = msoTrue
    End If
    Set mySlide = pptApp.ActiveWindow.View.Slide

    With mySlide
        Set x = .Shapes.PasteSpecial(2)    '非格式粘贴
        x.Left = 100: x.Top = 100
    End With

    Selection.PageSetup.PageWidth = oldPageWidth '恢复原页宽
    Selection.ParagraphFormat.FirstLineIndent = sj '恢复原缩进值

    pptApp.Activate
    Set x = Nothing
    Set pptApp = Nothing
    Set ptPre = Nothing
    Set mySlide = Nothing
End Sub

leikaiyi123

csnAlex 发表于 2007-5-20 16:56
按照3楼方式一中的意思，在WORD里运行宏COPY2PPT，会自动把你选择的一行（目前只支持一行）文本或嵌入式图 ...

3、此种方法对公式编辑器插入的公式有效，但对域生成的公式，如{EQ\F(a+b,a-b)}，若此行只有域生成的公式，无效，若域生成的公式后面还有汉字，又有效，不知道是怎么回事？

leikaiyi123

经测试，还有一种较好的方法，就是不用改页宽，在word中选择性粘贴为图片后，再利用裁剪的方法得到图片，再粘贴到ppt中，或在ppt中选择性粘贴为图片后，再裁剪都可以做到。 x1 = Selection.Information(wdHorizontalPositionRelativeToPage)  '57
x2 = ActiveDocument.Range(Selection.End, Selection.End).Information(wdHorizontalPositionRelativeToPage)    '取得结束位置的左侧位置
myshp.PictureFormat.CropRight = myshp.Width - (x2 - x1)    '裁剪