[dba-Tech] would an array be best for this?

John Bartow john at winhaven.net
Wed Feb 9 00:34:31 CST 2005


I'm working with PowerPoint VBA here but it is really a simple VBA problem.
I think that I'm PP'd out. I have the code all working fine. (It basically
loops through an entire presentation and converts all colors over to
grayscale.)  This is for a client's printing job. The printer would like it
to all be grayscale except the slides that need to be printed in color. The
machine they use charges by grayscale page or color page. So if any pixel of
color is accidentally left on the slide the page gets charged at the color
rate. Anyway...
 
My problem is that I need to have a method which allows the user to enter
which pages shouldn't be converted to grayscale and then prevent my little
routine here from messing with those slides. There is one small section in
the PP-VBA module below, enclosed in
'--------------------------------------------- where you will be able to see
what I mean. I have eliminated one slide from being processed by the
statement: "If objSlide.SlideNumber <> 9 Then"
I should be able to gather the dozen or so slides that shouldn't be
processed by using an array and looping through it, instr() or something but
I am in total brain block and haven't any idea how to do this.
 
My mouse's batteries are dying on me so I will have to place it in the
cradle and give up for now but maybe one of you VBA gurus can help me out
with some advice for tomorrow morning's PP session.

John B.
 
 
'*begin code*
 
'Code by: WinHaven LLC   Last update: 02-08-05
 
Option Explicit
Public intCountObjects As Integer 'running count of objects
 
Sub ProcessShapes()
Dim objSlide As Slide
Dim objShape As Shape
Dim i As Integer
Dim intUseGray As Integer
Dim lngNewRGB As Long
 
For Each objSlide In ActivePresentation.Slides
    intCountObjects = intCountObjects + 1 'running count of objects
 
'---------------------------------------------------------------------------
---------------
    'need to have input box with array or some other method of
    'preventing a list of slides from be converted to gray
    If objSlide.SlideNumber <> 9 Then
 
'---------------------------------------------------------------------------
---------------
    For Each objShape In objSlide.Shapes
        intCountObjects = intCountObjects + 1 'running count of objects
        If objShape.Type = msoGroup Then
            For i = 1 To objShape.GroupItems.count
                intCountObjects = intCountObjects + 1 'running count of
objects
                Call ChangeToGray(objShape.GroupItems(i))
            Next i
        Else
            Call ChangeToGray(objShape)
        End If
    Next objShape
    End If
Next objSlide
MsgBox intCountObjects 'running count of objects
End Sub
 
Function CalcGray(lngRGB As Long) As Long
'find rgb values divide by three to get a gray tone value to return
 
Dim lngRed As Long
Dim lngGreen As Long
Dim lngBlue As Long
Dim lngGray As Long
Dim intGray As Integer
 
    lngRed = lngRGB Mod 256
    lngGreen = lngRGB \ 256 Mod 256
    lngBlue = lngRGB \ 65536 Mod 256
    lngGray = (lngRed + lngGreen + lngBlue)
    If lngGray <> 0 Then
        lngGray = (lngGray / 3)
    End If
 
intGray = CInt(lngGray)
 
CalcGray = RGB(intGray, intGray, intGray)
 
End Function
 
Function ChangeToGray(objShape As Shape)
    Dim lngNewRGB As Long
    Dim i As Integer
    Dim oTxtRng As TextRange
    On Error Resume Next
    If objShape.HasTextFrame Then
        'change text objects
        If objShape.TextFrame.HasText Then
            Set oTxtRng = objShape.TextFrame.TextRange
            For i = 1 To oTxtRng.Runs.count
                intCountObjects = intCountObjects + 1 'running count of
objects
                With oTxtRng.Runs(i).Font.Color
                        lngNewRGB = CalcGray(.RGB)
                        .RGB = lngNewRGB
                End With
            Next i
        End If
    End If
    If objShape.Fill.Visible Then
        'forecolor fill
        lngNewRGB = CalcGray(objShape.Fill.ForeColor.RGB)
        objShape.Fill.ForeColor.RGB = lngNewRGB
        'backcolor fill
        lngNewRGB = CalcGray(objShape.Fill.BackColor.RGB)
        objShape.Fill.BackColor.RGB = lngNewRGB
    End If
    If objShape.Line.Visible Then
        'line color
        lngNewRGB = CalcGray(objShape.Line.ForeColor.RGB)
        objShape.Line.ForeColor.RGB = lngNewRGB
    End If
    'picture color
    objShape.PictureFormat.ColorType = msoPictureGrayscale
End Function
 
 
'*End Code*



More information about the dba-Tech mailing list