1

Тема: Помогите пожалуйста, удаление рисунков

Есть текст в рисунке - очень нужно избавиться от рамки А4 технической, помогите пожалуйста - файлов много страниц море.
Нашел макрос по удалению рисунков но валит соответственно и текст. Помогите пожалуйста

Post's attachments

бжд на печать.doc 492.5 Кб, 3 скачиваний с 2017-04-30 

You don't have the permssions to download the attachments of this post.

2

Re: Помогите пожалуйста, удаление рисунков

вроде получилось, хотя и кривовато

3

Re: Помогите пожалуйста, удаление рисунков

Поздновато увидел

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

4

Re: Помогите пожалуйста, удаление рисунков

Sub ShapesTextOMFG()
Dim oShape As Shape
Dim oDoc As Document
Dim oStartPage As Range
Dim oEndPage As Range
    Set oDoc = ActiveDocument
    i = 0
For Each oShape In oDoc.Shapes
    'For i = 1 To oShape.GroupItems.Count
    '    Shapes = oShape.GroupItems(i).AlternativeText
    '    If Not Shapes = "" Then MsgBox Shapes
    'Next i
    sText = oShape.GroupItems(1).AlternativeText
    If Not sText = "" Then
        oShape.Delete
        i = i + 1
        Set oStartPage = ActiveDocument.Range.GoTo(wdGoToPage, wdGoToAbsolute, i)
        Set oEndPage = ActiveDocument.Range.GoTo(wdGoToPage, wdGoToAbsolute, i)
        oDoc.Range(oStartPage.Start, oEndPage.End).Select
        Selection.Range = sText
    End If
    If sText = "" Then oShape.Delete
Next oShape
If oDoc.Shapes.Count > 0 Then Call CheckoDoc
Call ClearMe("^0013")
Call ClearMe("^0032")
End Sub
Private Sub CheckoDoc()
Dim oDoc As Document
Dim oShape As Shape
Set oDoc = ActiveDocument
iCount = oDoc.Shapes.Count
Do While iCount > 0
For Each oShape In oDoc.Shapes
    oShape.Select
    oShape.LockAspectRatio = msoFalse
    oShape.Delete
Next oShape
iCount = oDoc.Shapes.Count
Loop
End Sub
Private Sub ClearMe(ByVal sText As String)
Select Case sText
Case "^0013": sRepl = Chr(13)
Case "^0032": sRepl = Chr(32)
End Select
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Execute FindText:="[" & sText & "]{2;}", MatchWildcards:=True, Forward:=True, Wrap:=wdFindContinue, ReplaceWith:=sRepl, Replace:=wdReplaceAll
End With
End Sub

Весёлый объект

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

5

Re: Помогите пожалуйста, удаление рисунков

оказывается, что мой пример не прицепился

Post's attachments

w0501.zip 110.89 Кб, 1 скачиваний с 2017-05-02 

You don't have the permssions to download the attachments of this post.

6

Re: Помогите пожалуйста, удаление рисунков

Так в итоге то - как удалять рамку автоматизированно ?

7

Re: Помогите пожалуйста, удаление рисунков

вы не откликнулись на выложенный пример --устроил ли он вас

8

Re: Помогите пожалуйста, удаление рисунков

Да устроил, извините что не сразу написал.

9

Re: Помогите пожалуйста, удаление рисунков

проверю еще раз, добъю комментарии
к вечеру выложу

10

Re: Помогите пожалуйста, удаление рисунков

спс