• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Compile a custom figure into one shape in powerpoint (using VBA)

M

marcvanderpeet12

Member
I have code that creates a map of the US in powerpoint.

Code: 
Sub ArrayLoop(array1, array2, amountOfLine)


Dim i AsLongFor i =0To amountOfLineWith ActivePresentation.Slides(1).Shapes.AddLine(BeginX:=array1(i), BeginY:=array2(i), EndX:=array1(i +1), EndY:=array2(i +1)).Line.DashStyle = msoLineDashDotDot.ForeColor.RGB = RGB(50,0,128)EndWithNextEndSub


Sub TestArrayLoop()

Dim USA1, USA2Dim amount AsInteger

USA1 = Array(316.0954,321.021,332.9831,337.205,337.205,346.4698,351.3953,354.9135,361.9501,367.5793,370.394,371.8012,374.6158,376.7268,375.3195,376.7268,383.0596,385.1706,378.8377,376.0232,378.1341,378.8377,368.9866,364.061,366.172,371.0976,373.9122,382.356,388.6888,393.6144,397.1327,394.318,393.6144, _
384.4669,384.4669,376.7268,374.6158,369.6902,368.2829,366.172,366.172,361.9501,358.4318,354.9135,350.6917,347.8771,347.8771,347.8771,347.1734,346.4698,350.6917,343.6551,345.0624,342.2478,339.4332,337.9087,330.8721,317.5027,314.6881,312.5772,310.4662,316.0954,319.6137,323.132,325.2429,327.3539,328.7612,335.7977,339.4332,337.205,338.7296,335.7977,331.5757,330.1685,325.9465,324.5393,322.4283,319.6137,318.2064,315.3918,313.9845,309.7626,306.2443,306.2443,311.1698,311.8735,308.3553,306.2443,303.4297,302.0224,297.0969,290.0603,285.8384,279.5055,280.2092,280.9128,278.8019,275.2836,267.5435,264.0252,265.4325,260.5069,254.8777,247.1376,242.212,237.2865,223.917,220.3988,214.7696,211.2513,206.9121,206.9121,214.0659,219.6951,227.4353,232.3609,231.6572,233.7682,239.3974,247.1376,247.8412,309.0589,316.0954)

USA2 = Array(247.1064,248.5467,254.3079,263.6699,267.9909,265.1102,260.7893,260.0691,258.6288,251.4273,252.1475,259.349,257.1885,257.9087,260.0691,262.9498,257.9087,255.028,254.3079,249.987,247.8265,244.9459,247.1064,251.4273,246.3862,243.5056,240.625,241.3451,240.625,237.0242,234.1435,226.942,223.3412,218.3002,215.4195,200.2962,206.7776,208.218,206.7776,206.7776,196.5754,195.8553,190.8142,191.5343,190.094,190.8142,194.415,198.1357,206.0575,208.9381,217.58,224.0613,234.8637,237.0242,235.5839,222.621,221.9009,213.9792,213.9792,207.4978,205.3373,187.9335,184.3327,182.1723,182.1723,174.9708,169.2095,167.7692, _
164.8886,158.4072,154.0862,150.4854,149.7653,156.9669,163.4483,155.5265,152.6459,156.2467,152.6459,147.6049,141.1235,133.9219,144.0041,147.6049,151.9258,156.2467,159.8475,158.4072,158.4072,162.0079,160.5676,160.5676,157.687,159.1273,161.2878,165.6087,164.8886,160.5676,162.0079,159.1273,156.2467,154.8064,151.9258,149.7653,151.2056,145.4444,151.9258,155.5265,154.0862,150.4854,149.0452,200.2962,203.897,201.0164,215.4195,219.0203,224.7815,229.1024,237.0242,242.0653,245.6661,245.6661,247.1064)


amount = UBound(USA1)- LBound(USA2)+1
amount = amount -2
ArrayLoop USA1, USA2, amount
EndSub

This all works fine but the thing is that now I cant select the whole figure. So im looking for a way so I merge in it a figure which I can drag around the screen. In the attached zip file you find an example of what I am looking for in the second sheet.
 

Attachments

  • sample.zip
    32.3 KB · Views: 4
Try this code:

Code: 
Sub TestArrayLoop()

Dim USA1, USA2
Dim amount As Integer

USA1 = Array(316.0954, 321.021, 332.9831, 337.205, 337.205, 346.4698, 351.3953, 354.9135, 361.9501, 367.5793, 370.394, 371.8012, 374.6158, 376.7268, 375.3195, 376.7268, 383.0596, 385.1706, 378.8377, 376.0232, 378.1341, 378.8377, 368.9866, 364.061, 366.172, 371.0976, 373.9122, 382.356, 388.6888, 393.6144, 397.1327, 394.318, 393.6144, _
384.4669, 384.4669, 376.7268, 374.6158, 369.6902, 368.2829, 366.172, 366.172, 361.9501, 358.4318, 354.9135, 350.6917, 347.8771, 347.8771, 347.8771, 347.1734, 346.4698, 350.6917, 343.6551, 345.0624, 342.2478, 339.4332, 337.9087, 330.8721, 317.5027, 314.6881, 312.5772, 310.4662, 316.0954, 319.6137, 323.132, 325.2429, 327.3539, 328.7612, 335.7977, 339.4332, 337.205, 338.7296, 335.7977, 331.5757, 330.1685, 325.9465, 324.5393, 322.4283, 319.6137, 318.2064, 315.3918, 313.9845, 309.7626, 306.2443, 306.2443, 311.1698, 311.8735, 308.3553, 306.2443, 303.4297, 302.0224, 297.0969, 290.0603, 285.8384, 279.5055, 280.2092, 280.9128, 278.8019, 275.2836, 267.5435, 264.0252, 265.4325, 260.5069, 254.8777, 247.1376, 242.212, 237.2865, 223.917, 220.3988, 214.7696, 211.2513, 206.9121, 206.9121, 214.0659, 219.6951, 227.4353, 232.3609, 231.6572, 233.7682, 239.3974, 247.1376, 247.8412, 309.0589, 316.0954)

USA2 = Array(247.1064, 248.5467, 254.3079, 263.6699, 267.9909, 265.1102, 260.7893, 260.0691, 258.6288, 251.4273, 252.1475, 259.349, 257.1885, 257.9087, 260.0691, 262.9498, 257.9087, 255.028, 254.3079, 249.987, 247.8265, 244.9459, 247.1064, 251.4273, 246.3862, 243.5056, 240.625, 241.3451, 240.625, 237.0242, 234.1435, 226.942, 223.3412, 218.3002, 215.4195, 200.2962, 206.7776, 208.218, 206.7776, 206.7776, 196.5754, 195.8553, 190.8142, 191.5343, 190.094, 190.8142, 194.415, 198.1357, 206.0575, 208.9381, 217.58, 224.0613, 234.8637, 237.0242, 235.5839, 222.621, 221.9009, 213.9792, 213.9792, 207.4978, 205.3373, 187.9335, 184.3327, 182.1723, 182.1723, 174.9708, 169.2095, 167.7692, _
164.8886, 158.4072, 154.0862, 150.4854, 149.7653, 156.9669, 163.4483, 155.5265, 152.6459, 156.2467, 152.6459, 147.6049, 141.1235, 133.9219, 144.0041, 147.6049, 151.9258, 156.2467, 159.8475, 158.4072, 158.4072, 162.0079, 160.5676, 160.5676, 157.687, 159.1273, 161.2878, 165.6087, 164.8886, 160.5676, 162.0079, 159.1273, 156.2467, 154.8064, 151.9258, 149.7653, 151.2056, 145.4444, 151.9258, 155.5265, 154.0862, 150.4854, 149.0452, 200.2962, 203.897, 201.0164, 215.4195, 219.0203, 224.7815, 229.1024, 237.0242, 242.0653, 245.6661, 245.6661, 247.1064)


amount = UBound(USA1) - LBound(USA2) + 1
amount = amount - 2
ArrayLoop USA1, USA2, amount
End Sub

Sub ArrayLoop(array1, array2, amountOfLine)


Dim i As Long
Dim triArray() As Single
ReDim triArray(1 To UBound(array1, 1), 1 To 2)

For i = 1 To UBound(array1, 1)
  triArray(i, 1) = array1(i)
  triArray(i, 2) = array2(i)
Next i

Set myDocument = ActivePresentation.Slides(1)

ActivePresentation.Slides(1).Shapes.AddPolyline SafeArrayOfPoints:=triArray
End Sub
 
here goes

Code: 
Sub ArrayLoop(array1, array2, amountOfLine)


Dim i As Long
Dim triArray() As Single
ReDim triArray(1 To UBound(array1, 1), 1 To 2)

For i = 1 To UBound(array1, 1)
  triArray(i, 1) = array1(i)
  triArray(i, 2) = array2(i)
Next i

Set myDocument = ActivePresentation.Slides(1)

With ActivePresentation.Slides(1)
  .Shapes.AddPolyline SafeArrayOfPoints:=triArray
  .Shapes(1).Fill.ForeColor.RGB = RGB(255, 0, 0) 'R, G, B
End With

End Sub
 
You must log in or register to reply here.
Back
Top