VBA Code to change pattern fill colours [SOLVED]

Todbury · Mar 21, 2014

Hi there I'm trying to write some code that will will a shape (rectangle) of set size with various patterns such as msoPatternHorizontalBrick. Everything there is ok but it keeps using white as the foreground and blue as the background. How do I force it so that the foreground is blue and the background is black.

iferror · Mar 21, 2014

Hi Tod,
please post the code you've been dealing with so far

Todbury · Mar 21, 2014

Hi there here goes with inserting the code, apologies if I mess it up. I've copied this code from someone on the web, it's not perfect for what I want but it's a damn good start.

Code:

Sub WreckTangles()
Application.ScreenUpdating = False
Dim xRow&, dblHeight#, dblWidth#, strText$, shp As Shape, ws As Worksheet
Set ws = ActiveSheet
For xRow = 1 To 100
dblHeight = Cells(xRow, 1).Value
dblWidth = Cells(xRow, 2).Value
strText = Cells(xRow, 3).Value
With ws.Cells(xRow, 3)
Set shp = ws.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=.Left, Top:=.Top, Width:=dblWidth, Height:=dblHeight)
    shp.Fill.Patterned msoPatternHorizontalBrick
              
End With
shp.TextEffect.Text = strText
Next xRow
Set ws = Nothing
Application.ScreenUpdating = True
End Sub

iferror · Mar 21, 2014

The "Macro Recorder" is your best friend

Say that you run your code once so that the shapes get created, then start recording a macro and select one shape, edit the patterns colors and then stop recording, this is the code you'll get

Code:

Sub test()
  ActiveSheet.Shapes.Range(Array("Rectangle 8")).Select
  With Selection.ShapeRange.Fill
  .Visible = msoTrue
  .ForeColor.RGB = RGB(255, 0, 0)
  .BackColor.RGB = RGB(255, 255, 255)
  .Patterned msoPatternHorizontalBrick
  End With
  With Selection.ShapeRange.Fill
  .Visible = msoTrue
  .ForeColor.RGB = RGB(255, 0, 0)
  .BackColor.RGB = RGB(255, 255, 0)
  .Patterned msoPatternHorizontalBrick
  End With
End Sub

Consider that recorded macro are the further thing you can nget from a wellwritten and performing macro...but definitelly a good starting point!!

All you need here is
.ForeColor.RGB = RGB(255, 0, 0)
.BackColor.RGB = RGB(255, 255, 0)

and you'll get this

Code:

Sub WreckTangles()
Application.ScreenUpdating = False
Dim xRow&, dblHeight#, dblWidth#, strText$, shp As Shape, ws As Worksheet
Set ws = ActiveSheet
For xRow = 1 To 100
dblHeight = Cells(xRow, 1).Value
dblWidth = Cells(xRow, 2).Value
strText = Cells(xRow, 3).Value
With ws.Cells(xRow, 3)
Set shp = ws.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=.Left, Top:=.Top, Width:=dblWidth, Height:=dblHeight)
    shp.Fill.Patterned msoPatternHorizontalBrick
   shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
   shp.Fill.BackColor.RGB = RGB(255, 255, 0)

             
End With
shp.TextEffect.Text = strText
Next xRow
Set ws = Nothing
Application.ScreenUpdating = True
End Sub

upps... just notice that you wanted blue and black while i used yellow and red.... well you know how to play with this now, don't you??

Todbury · Mar 21, 2014

thanks will go and have a play

Todbury · Mar 24, 2014

ok another request for this topic. I've managed to get rectangles of different pattern fill with help. Now I want to shake this up big time, but again need help. I want to have a column of different pattern fills with regard to inputs from the user. I'd like to have an input sheet with x and y for column width and height and then a number that refers to a different pattern fill. If column C = 1 then the pattern must be blue bricks on a black background that is x wide and y height. then on to the next row down if C = 2 then the pattern must be yellow bricks on red background. I can work the colour and pattern fill type. But i'm having trouble fixing the pattern to the individual row size of the x and y, when I run the code above it does the same fill to all rows.

thanks in advance

iferror · Mar 24, 2014

Assuming that you now moved the text to column D this is my 2cents-not-tested macro

Code:

Sub WreckTangles()
Application.ScreenUpdating = False
Dim xRow&, dblHeight#, dblWidth#, strText$, shp As Shape, ws As Worksheet
Set ws = ActiveSheet
For xRow = 1 To 100
dblHeight = Cells(xRow, 1).Value
dblWidth = Cells(xRow, 2).Value
strText = Cells(xRow, 4).Value
With ws.Cells(xRow, 4)
Set shp = ws.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=.Left, Top:=.Top, Width:=dblWidth, Height:=dblHeight)
    shp.Fill.Patterned msoPatternHorizontalBrick
    if Cells(xRow, 3).Value=1 then
       ' black and blue
    else
      'red and yellow
      shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
      shp.Fill.BackColor.RGB = RGB(255, 255, 0)
   endif       
End With
shp.TextEffect.Text = strText
Next xRow
Set ws = Nothing
Application.ScreenUpdating = True
End Sub

Alternativelly, should you need more than one option, i'd use the case clause

Code:

Sub WreckTangles()
Application.ScreenUpdating = False
Dim xRow&, icolor&, dblHeight#, dblWidth#, strText$, shp As Shape, ws As Worksheet
Set ws = ActiveSheet
For xRow = 1 To 100
dblHeight = Cells(xRow, 1).Value
dblWidth = Cells(xRow, 2).Value
icolor = Cells(xRow, 3).Value
strText = Cells(xRow, 4).Value
With ws.Cells(xRow, 4)
Set shp = ws.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=.Left, Top:=.Top, Width:=dblWidth, Height:=dblHeight)
    shp.Fill.Patterned msoPatternHorizontalBrick
    Select Case icolor
       Case 1
            'fore and back color for C=1
       Case 2
            'fore and back color for C=2   
       Case 3
            'fore and back color for C=3
       '...and so on, i think you see where i am going now ;)
   End Select
End With
shp.TextEffect.Text = strText
Next xRow
Set ws = Nothing
Application.ScreenUpdating = True
End Sub

Todbury · Mar 24, 2014

Hi iferror,

thanks again for your excellent reply I like the case one, never knew that existed, I love trying new things and making the old grey matter work (even if it's not always mine

). I have one more request and then I think I'm there to go ahead and start my project. The above just changes the colours to msoPatternHorizontalBrick, by moving the mso part into the case section I can now change the pattern. My question is can I create new fill pattens?. If not how do I add a texture fill of my choice?.

cheers

iferror · Mar 24, 2014

Have a look at this:

http://office.microsoft.com/en-us/e...r-shape-effect-HA010355845.aspx#_Toc258910684

http://office.microsoft.com/en-us/excel-help/add-a-picture-fill-to-a-shape-HA102528342.aspx

Todbury · Mar 24, 2014

iferror if your still out there today. I've done the import of images I can scale and offset using columns. But I need to reference the heights of these boxes from an origin rather than per cell. Is that possible for instance I need to have rectangle from a zero point down to 50mm then the next rectangle needs to go from 50mm down to 75mm, hope this makes sense

thanks again

iferror · Mar 24, 2014

Dimensions in vba are given in Points. To convert points to lenght you can use this
1 point = 1/72 inches
1 point = .35 millimetre

The macro as it is uses cell as reference
Set shp = ws.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=.Left, Top:=.Top, Width:=dblWidth, Height:=dblHeight)

you can easily switch to worksheet reference, just remove the reference to the cell

AS IS:

Code:

With ws.Cells(xRow, 4)
Set shp = ws.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=.Left, Top:=.Top, Width:=dblWidth, Height:=dblHeight)
shp.Fill.Patterned msoPatternHorizontalBrick
End With

TO START PLAYING WITH

:

Code:

'With ws.Cells(xRow, 4)
Set shp = ws.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=xRow*10, Top:=xRow*20, Width:=dblWidth, Height:=dblHeight)
shp.Fill.Patterned msoPatternHorizontalBrick
'End With

Todbury · Mar 25, 2014

Hi again just a note to say big thanks

this now works great

Code:

Sub WreckTangles3()

ActiveSheet.DrawingObjects.Select
    Selection.Delete
Application.ScreenUpdating = False

Dim xRow&, icolor&, dblHeight#, dblWidth#, strText$, shp As Shape, ws As Worksheet, xscale#, yscale#, xtop#

Set ws = ActiveSheet


For xRow = 2 To 100

dblHeight = Cells(xRow, 1).Value
dblWidth = Cells(xRow, 2).Value
icolor = Cells(xRow, 3).Value
xtop = Cells(xRow, 4).Value
xscale = Cells(xRow, 5).Value
yscale = Cells(xRow, 6).Value

Set shp = ws.Shapes.AddShape(Type:=msoShapeRectangle, Left:=300, Top:=xtop, Width:=dblWidth, Height:=dblHeight)
  
    Select Case icolor
       Case 1
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\Marl.png"
            shp.Fill.TextureHorizontalScale = xscale
            shp.Fill.TextureVerticalScale = xscale
            shp.Line.Visible = msoFalse
          
      Case 2
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\Shale.png"
            shp.Fill.TextureHorizontalScale = xscale
            shp.Fill.TextureVerticalScale = xscale
            shp.Line.Visible = msoFalse
      
      Case 3
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\Dolomite.png"
            shp.Fill.TextureHorizontalScale = xscale
            shp.Fill.TextureVerticalScale = xscale
            shp.Line.Visible = msoFalse
          
      Case 4
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\Anhydrite.png"
            shp.Fill.TextureHorizontalScale = xscale
            shp.Fill.TextureVerticalScale = xscale
            shp.Line.Visible = msoFalse
          
      Case 5
          
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\limestone.png"
            shp.Fill.TextureHorizontalScale = xscale
            shp.Fill.TextureAlignment = msoTextureTopLeft
            shp.Line.Visible = msoFalse
  
    Case 6
          
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\sandstone.png"
            shp.Fill.TextureHorizontalScale = xscale
            shp.Fill.TextureVerticalScale = xscale
            shp.Line.Visible = msoFalse
  
  End Select
  

Next xRow
  
    Set ws = Nothing

Application.ScreenUpdating = True

End Sub

it now gives me this

iferror · Mar 25, 2014

Glad to hear that

Please ninjas, edit the thread title to [SOLVED^2]

SirJB7 · Mar 25, 2014

@iferror
Hi!
I'm sorry to tell you that the Ninja team doesn't perform anymore that task. That's due to two facts: the 1st is that it didn't prove to be accurate; the 2nd that with the new forums (we're at Q3 of its roll out and nothing yet) it'd be easily and automatically (ha!); the 3rd one is that Chandoo is very behind on payments so we neither receive any more the 5 bucks for each solved post nor the 15 for those reopened. Surely the checks are in the mail (internal joke).
Regards!

Todbury · Apr 7, 2014

SirJB7 said:
@iferror
Hi!
I'm sorry to tell you that the Ninja team doesn't perform anymore that task. That's due to two facts: the 1st is that it didn't prove to be accurate; the 2nd that with the new forums (we're at Q3 of its roll out and nothing yet) it'd be easily and automatically (ha!); the 3rd one is that Chandoo is very behind on payments so we neither receive any more the 5 bucks for each solved post nor the 15 for those reopened. Surely the checks are in the mail (internal joke).
Regards!

Todbury · Apr 7, 2014

Drat pressed the wrong button. I have a problem, my code is really slow, can it be speeded up and how do delete just my rectangles rather than all objects on the sheet?. Here's my code so far

Code:

Sub Lithology()

Dim xRow&, icolorp&, dblHeightp#, dblWidthp#, icolora&, dblHeighta#, dblWidtha#, strText$, shp As Shape, ws As Worksheet, xscalep#, yscalep#, xtopp#, xscalea#, yscalea#, xtopa

'Application.ScreenUpdating = False

Sheets("Sheet1").Select


Set ws = ActiveSheet

For xRow = 2 To 100

dblHeightp = Cells(xRow, 1).Value
dblWidthp = Cells(xRow, 2).Value
icolorp = Cells(xRow, 3).Value
xtopp = Cells(xRow, 4).Value
xscalep = Cells(xRow, 5).Value
yscalep = Cells(xRow, 6).Value
dblHeighta = Cells(xRow, 23).Value
dblWidtha = Cells(xRow, 24).Value
icolora = Cells(xRow, 25).Value
xtopa = Cells(xRow, 26).Value
xscalea = Cells(xRow, 27).Value
yscalea = Cells(xRow, 28).Value

Set shp = ws.Shapes.AddShape(Type:=msoShapeRectangle, Left:=10, Top:=xtopp, Width:=dblWidthp, Height:=dblHeightp)
  
    Select Case icolorp
       Case 1
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\Marl.png"
            shp.Fill.TextureHorizontalScale = xscalep
            shp.Fill.TextureVerticalScale = xscalep
            shp.Line.Visible = msoFalse
          
      Case 2
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\Shale.png"
            shp.Fill.TextureHorizontalScale = xscalep
            shp.Fill.TextureVerticalScale = xscalep
            shp.Line.Visible = msoFalse
      
      Case 3
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\Dolomite.png"
            shp.Fill.TextureHorizontalScale = xscalep
            shp.Fill.TextureVerticalScale = xscalep
            shp.Line.Visible = msoFalse
          
      Case 4
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\Anhydrite.png"
            shp.Fill.TextureHorizontalScale = xscalep
            shp.Fill.TextureVerticalScale = xscalep
            shp.Line.Visible = msoFalse
          
      Case 5
          
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\limestone.png"
            shp.Fill.TextureHorizontalScale = xscalep
            shp.Fill.TextureVerticalScale = xscalep
            shp.Line.Visible = msoFalse
  
    Case 6
          
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\sandstone.png"
            shp.Fill.TextureHorizontalScale = xscalep
            shp.Fill.TextureVerticalScale = xscalep
            shp.Line.Visible = msoFalse
  
  End Select
  
Set shp = ws.Shapes.AddShape(Type:=msoShapeRectangle, Left:=100, Top:=xtopa, Width:=dblWidtha, Height:=dblHeighta)
  
    Select Case icolora
       Case 1
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\Marl.png"
            shp.Fill.TextureHorizontalScale = xscalea
            shp.Fill.TextureVerticalScale = xscalea
            shp.Line.Visible = msoFalse
          
      Case 2
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\Shale.png"
            shp.Fill.TextureHorizontalScale = xscalea
            shp.Fill.TextureVerticalScale = xscalea
            shp.Line.Visible = msoFalse
      
      Case 3
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\Dolomite.png"
            shp.Fill.TextureHorizontalScale = xscalea
            shp.Fill.TextureVerticalScale = xscalea
            shp.Line.Visible = msoFalse
          
      Case 4
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\Anhydrite.png"
            shp.Fill.TextureHorizontalScale = xscalea
            shp.Fill.TextureVerticalScale = xscalea
            shp.Line.Visible = msoFalse
          
      Case 5
          
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\limestone.png"
            shp.Fill.TextureHorizontalScale = xscalea
            shp.Fill.TextureVerticalScale = xscalea
            shp.Line.Visible = msoFalse
  
    Case 6
          
            shp.Fill.UserPicture "C:\Users\bedfx0\Documents\sandstone.png"
            shp.Fill.TextureHorizontalScale = xscalea
            shp.Fill.TextureVerticalScale = xscalea
            shp.Line.Visible = msoFalse
  
  End Select
  
Next xRow
  
    Set ws = Nothing

'Application.ScreenUpdating = True

End Sub

this code draws to columns of different rocks depending upon the input from the Tops sheet

iferror · Apr 8, 2014

Not sure i can be of any help here, never had the chance to add 200 image files in an excel file

but, does it get any better if you de-comment the ScreenUpdating?

how do delete just my rectangles rather than all objects on the sheet?

This is quite easy, name the shapes in a way you can recognize i.e.

shp.Name = 'Lithology_a_' & xRow

and

shp.Name = 'Lithology_p_' & xRow

VBA Code to change pattern fill colours [SOLVED]

Todbury

New Member

iferror

Member

Todbury

New Member

iferror

Member

Todbury

New Member

Todbury

New Member

iferror

Member

Todbury

New Member

iferror

Member

Todbury

New Member

iferror

Member

Todbury

New Member

Attachments

iferror

Member

SirJB7

Excel Rōnin

Todbury

New Member

Todbury

New Member

iferror

Member