Макрос: Конверт оле объектов (вопрос по перемещению объектов)

[Sanchos]

Вот написал..., а как заставить ставить объект после вставки на место вырезанного Оле объекта, а то они все в центр листа складываются?

Sub convertOLEtoShape()
    Dim s As Shape, t As Shape, r As New ShapeRange, l As Layer, c As Long
    Set r = ActiveSelectionRange: Set l = ActiveLayer: c = 0
    For Each s In r
        If s.Type = cdrOLEObjectShape Then
        s.Cut
        l.PasteSpecial "Metafile", False, False
        c = c + 1
        End If
    Next s
    MsgBox CStr(c) & " OLEobject convert"
End Sub

Надо наверно запомнить местоположение старого, а к новому применить Move. Вот тока как? Может быть глупый вопрос но помогите пожалуйста.

 

[wOxxOm]

Ответ: Макрос: Конверт оле объектов (вопрос по перемещению объектов)

Sub convertOLEtoShape()
    Dim s As Shape, t As Shape, r As New ShapeRange, l As Layer, c As Long

    dim x#,y#

    Set r = ActiveSelectionRange: Set l = ActiveLayer: c = 0
    For Each s In r
        If s.Type = cdrOLEObjectShape Then
            x=s.positionX:y=s.positionY
            s.Cut
            l.PasteSpecial "Metafile", False, False
            activeshape.setposition x,y
            c = c + 1
        End If
    Next s
    MsgBox CStr(c) & " OLEobject convert"
End Sub

 

[Sanchos]

Ответ: Макрос: Конверт оле объектов (вопрос по перемещению объектов)

Вот как в этом:

Sub convertOLEtoShape2()
    Dim p As Page, oldP As Page, shapes As New ShapeRange
    Set shapes = ActiveSelectionRange: Set oldP = ActivePage
    'boostStart "Convert OLE to Shape"
    If shapes.Count = 0 Then
      For Each p In ActiveDocument.Pages
         p.Activate: convertOLE2 p.FindShapes(, cdrOLEObjectShape)
      Next p
      oldP.Activate
    Else
        convertOLE2 shapes
        shapes.CreateSelection
    End If
    'boostFinish endUndoGroup:=True
    MsgBox "OLEobject convert"
End Sub


Private Sub convertOLE2(ByRef scope As ShapeRange)
    Dim sh As Shape, fc As FountainColor, l As Layer, x#, y#
    On Error Resume Next
    For Each sh In scope
sh.PowerClip.shapes.All
        If sh.Type = cdrGroupShape Then
            convertOLE2 sh.shapes.FindShapes(, cdrOLEObjectShape)
        Else
            With sh
            If s.Type = cdrOLEObjectShape Then
                Set l = ActiveLayer
                x = sh.PositionX: y = sh.PositionY: sh.Cut
                l.PasteSpecial "Metafile", False, False
                ActiveShape.SetPosition x, y
            End If
            End With
        End If
    Next
End Sub

сделать штоб не конвертил в поверклипах, но предупреждал что есть поверклип с ОЛЕ объектом?

 

[wOxxOm]

Ответ: Макрос: Конверт оле объектов (вопрос по перемещению объектов)

В х3 findshapes не должен находить в клипах, это было в 11, 12

 

[Sanchos]

Ответ: Макрос: Конверт оле объектов (вопрос по перемещению объектов)

В ХЗ находит... чё делать?

 

[wOxxOm]

Ответ: Макрос: Конверт оле объектов (вопрос по перемещению объектов)

Не использовать findshapes, и делать обычный перебор с проверкой на тип оле и групп

 

[Sanchos]

Ответ: Макрос: Конверт оле объектов (вопрос по перемещению объектов)

Во, работат.
Надеемся что никто не догадается засунуть ОЛЕ в поверклип

Sub convertOLEtoShape2()
    Dim p As Page, oldP As Page, shapes As New ShapeRange
    Set shapes = ActiveSelectionRange: Set oldP = ActivePage
    'boostStart "Convert OLE to Shape"
    If shapes.Count = 0 Then
      For Each p In ActiveDocument.Pages
         p.Activate: convertOLE2 p.FindShapes(, cdrOLEObjectShape)
      Next p
      oldP.Activate
    Else
        convertOLE2 shapes
        ActiveDocument.ClearSelection
    End If
    'boostFinish endUndoGroup:=True
    MsgBox "OLEobject convert"
End Sub

Private Sub convertOLE2(ByRef scope As ShapeRange)
    Dim sh As Shape, fc As FountainColor, l As Layer, x#, y#
    For Each sh In scope
        If sh.Type = cdrGroupShape Then
            If sh.shapes.Type = cdrOLEObjectShape Then
            convertOLE2 sh.shapes
            End If
        Else
            With sh
            If sh.Type = cdrOLEObjectShape Then
                Set l = ActiveLayer
                x = sh.PositionX: y = sh.PositionY: sh.Cut
                l.PasteSpecial "Metafile", False, False
                ActiveShape.SetPosition x, y
            End If
            End With
        End If
    Next
End Sub