Arrange shape in circle - Microsoft Community

may know how arrange shape nicely vba? intention create shape or wordart vba , automatic arrange it.

i have pre-created 10 wordart , make animation it.

thank help.

sub demo()
    dim arshapes() variant
    dim objrange, objrange2 object
    dim shpno, integer
    dim str string
    dim randno, remain integer

    = 1
    shpno = 0
    
    randno = application.worksheetfunction.randbetween(50, 255)

    set objrange2 = activesheet.shapes.range(array("rectangle 0", "rectangle 1", "rectangle 2", "rectangle 3", "rectangle 4", "rectangle 5", "rectangle 6", "rectangle 7", "rectangle 8", "rectangle 9"))

    remain = randno
    while <= randno
        activesheet.shapes("10-point star 3").textframe.characters.text = remain - 1
        if shpno > 0 or > 1 then
            if objrange2.textframe.characters.font.colorindex = 3 then
                objrange2.textframe.characters.font.colorindex = -1
            end if
        end if
        
        str = "rectangle " & shpno
        arshapes = array(str)
        set objrange = activesheet.shapes.range(arshapes)
        set objrange2 = activesheet.shapes.range(arshapes)

        if objrange.textframe.characters.font.colorindex = 3 then
            objrange.textframe.characters.font.colorindex = -1
        else
            objrange.textframe.characters.font.colorindex = 3
        end if
        
        application.wait (now + 0.000002)
        if remain < 5 then
            application.wait (now + 0.000006)
        end if

        doevents
    
        shpno = shpno + 1
        if shpno > 9 shpno = 0
        = + 1
        remain = remain - 1
    wend

    msgbox activesheet.shapes(str).textframe.characters.text
end sub

your code did not run in new file. try code below in new file.

andreas.

option explicit

sub shapeclock()
  dim ws worksheet
  dim base range, msg range
  dim sh shape
  dim mx double, double
  dim time shape
  dim hourarrow shape, minutearrow shape, secondarrow shape
  dim points, degree double

  set ws = activesheet
  ws.cells.clear
  each sh in ws.shapes
    sh.delete
  next

  set base = activewindow.visiblerange
  set base = base.resize(base.rows.count - 3, base.columns.count - 3).offset(1, 1)
  base
    set sh = ws.shapes.addshape(msoshapedonut, .left, .top, .height, .height)
  end with
 
  set msg = base.rows(0)
  msg.merge
  msg.horizontalalignment = xlcenter

  sh
    .adjustments(1) = 0.005
    mx = .left + .width / 2
    = .top + .height / 2
    set hourarrow = ws.shapes.addshape(msoshaperightarrow, mx, - 50, .width / 4, 100)
    hourarrow.shapestyle = msoshapestylepreset10
    set minutearrow = ws.shapes.addshape(msoshaperightarrow, mx, - 25, .width / 2, 50)
    minutearrow.shapestyle = msoshapestylepreset11
    set secondarrow = ws.shapes.addshape(msoshaperightarrow, mx, - 10, .width / 2, 20)
    secondarrow.shapestyle = msoshapestylepreset8
  end with

  on error goto errorhandler
  application.enablecancelkey = xlerrorhandler
  do
    msg = vba.time$
    degree = hour(now) / 12 * 360 - 90
    points = pointoncircle(sh.width / 8, degree, mx, my)
    hourarrow
      .left = points(0) - .width / 2
      .top = points(1) - .height / 2
      .rotation = degree
    end with
    degree = minute(now) / 60 * 360 - 90
    points = pointoncircle(sh.width / 4, degree, mx, my)
    minutearrow
      .left = points(0) - .width / 2
      .top = points(1) - .height / 2
      .rotation = degree
    end with
    degree = second(now) / 60 * 360 - 90
    points = pointoncircle(sh.width / 4, degree, mx, my)
    secondarrow
      .left = points(0) - .width / 2
      .top = points(1) - .height / 2
      .rotation = degree
    end with
    'give excel time update shapes on screen
    doevents
  loop
errorhandler:
end sub

private function pointoncircle(byval r, byval angle, optional byval x double, optional byval y double) variant
  dim result(0 1)
  result(0) = cos(rad(angle)) * r + x
  result(1) = sin(rad(angle)) * r + y
  pointoncircle = result
end function

private function rad(byval x double) double
  rad = x * atn(1) * 4 / 180
end function

Office / Excel / Microsoft Office Programming