Re: Глюк VBA с overprint. Нужна помощь

Написал wOxxOm в 23/11/2009 12:18:26

что-то вспоминаю.
по всей видимости правильно делает только перевод в картинку средствами интерфейса Convert to Bitmap с включенной опцией "overprint black" (как ни странно, но это включает не только оверпринт черного но и все остальные). Потом уже это дело надо делать правой кнопкой и SaveAs (чтобы не было дополнительного пересчета пикселей). Этот процесс можно автоматизировать, разместив нижеследующий код в обычном VBA-модуле (Project->Module).

А!!! нужно будет предварительно настроить диалог преобразования в битмап, выделив любой объект, вызвав Convert to Bitmap, настроить как надо, и НАЖАТЬ ОК!!!

вот это в само начале "модуля"

Declare Function GetForegroundWindow& Lib "user32" ()
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd&, ByVal Msg&, ByVal wParam&, ByVal lParam&) As Long
Private Declare Function SetTimer& Lib "user32" (ByVal hWnd&, ByVal nID&, ByVal uElapse&, ByVal lpFunc&)
Private Declare Function KillTimer& Lib "user32" (ByVal hWnd&, ByVal uID&)
Private hTimer&

'а это где угодно ниже.

Sub ConvertToBitmapOVP()
   Dim p0 As Page, sel0 As ShapeRange, p As Page, t0!, err$
   On Error Resume Next
   Set p0 = ActivePage
   Set sel0 = ActiveSelectionRange
   ActiveDocument.BeginCommandGroup "tif export with overprints"
   For Each p In ActiveDocument.Pages
      p.Activate
      p.Shapes.All.CreateSelection
      If ActiveSelectionRange.Count > 0 Then
         hTimer = SetTimer(0, 1, 100, AddressOf timerSendEnter)
         t0 = Timer
         FrameWork.Automation.Invoke "c44919b9-e389-4c0d-8a54-8e6e3fcfade3"
         Do
            DoEvents
            If ActiveShape.Type = cdrBitmapShape Then
               With ActiveShape.Bitmap
                  ActiveDocument.ExportBitmap _
                     ("d:\" & ActiveDocument.Name & " #" & p.Index & IIf(left$(p.Name, 5) <> "Page " And left$(p.Name, 9) <> "Страница ", Trim$(p.Name), "" ) & ".tif", _
                     cdrTIFF, cdrSelection, cdrCMYKColorImage, .SizeWidth, .SizeHeight, .ResolutionX, .ResolutionY, cdrNoAntiAliasing, _
                     Transparent:=False, UseColorProfile:=True, Compression:=cdrCompressionLZW).Finish
                  Exit Do
               End With
            End If
            If Timer - t0 > 60! Then '1 minute
               err = err & p.Index & " "
               Exit Do
            End If
         Loop
      End If
   Next
   ActiveDocument.EndCommandGroup
   ActiveDocument.unDo
   p0.Activate
   sel0.CreateSelection
   If Len(err) Then MsgBox err, vbExclamation, "Error pages"
End Sub

Sub timerSendEnter(ByVal hWnd&, ByVal uMsg&, ByVal idEvent&, ByVal dwTime&)
   KillTimer 0, hTimer
   SendMessage GetForegroundWindow(), &H111, 1, 0
End Sub

p.s. чертов ббкод вставлял смайлы в код,