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*