Merge a custom figure in powerpoint - vba

I have custom that creates of map of the US in powerpoint.
Sub ArrayLoop(array1, array2, amountOfLine)
Dim i As Long
For i = 0 To amountOfLine
With 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)
End With
Next
End Sub
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
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.
Any thoughts on how I can do this? Preferably in VBA


Your main issue is that you are adding many individual lines. For the code to work the way you envision, you somehow have to add your shape as a single line. To do this, change your sub from this:
Sub ArrayLoop(array1, array2, amountOfLine)
Dim i As Long
For i = 0 To amountOfLine
With 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)
End With
Next
End Sub
to this:
Sub ArrayLoop(array1, array2)
'you will need a single array of points for the call.
'whether you want to pass in 2 arrays and then merge them
'or pass in a single merged array is up to you
With ActivePresentation.Slides(1).Shapes.AddPolyline(<an array of points>).Line
.DashStyle = msoLineDashDotDot
.ForeColor.RGB = RGB(50, 0, 128)
End With
End Sub
You will need to tweak your array of points to get this to work.

Related

How to pass string user input (RGB) to VBA

I have a userform with RGB values to be assigned to shapes that will be later created by the macro:
Private Sub UserForm_Initialize()
With lstChosenColor
lstChosenColor.AddItem "RGB(0, 0, 0)"
lstChosenColor.AddItem "100, 100, 100" 'different from the above to show one alternative of my trials
End With
End Sub
However I do not know how to insert the selected value into the macro itself. I tried in many ways:
Dim lstChosenColor As String 'somewhere else i saw it as Long, tried but without success
' Dim ChosenColor As String
' ChosenColor = lstChosenColor 'I tried this one, too
If lstChosenColor = False Then
MsgBox "No Color Selected"
Else: New_Shape.Fill.ForeColor.RGB = lstChosenColor.Selected 'I tried also 'New_Shape.Fill.ForeColor.RGB = lstChosenColor and 'New_Shape.Fill.ForeColor.RGB = RGB(lstChosenColor)
End If
Set New_Shape = myDocument.Shapes.AddShape(Type:=msoShapeOval, Left:=Shp_Cntr - ((Shp.Width + 2) / 2), Top:=Shp_Mid - ((Shp.Width + 2) / 2), Width:=Shp.Width, Height:=Shp.Width)
' New_Shape.Fill.ForeColor.RGB = RGB(lstChosenColor) 'I commented this as it is part of a repeating block for a various number of shapes and I thought I could assign the RGB value above
Could anyone please advise?

If you use (eg) "100, 100, 100" as the value you can do something like:
Dim v, arr
v = lstChosenColor.Value 'get selected value
arr = Split(Replace(v, " ", ""), ",") 'remove any spaces and split to array
'assign each array element as an argument to RGB()
New_Shape.Fill.ForeColor.RGB = RGB(CLng(arr(0)), CLng(arr(1)), CLng(arr(2)))

ms-access shorten vba code

I'm using the following code alot in my project:
txtVoornaam.Locked = False
txtVoornaam.BorderStyle = 4
txtVoornaam.BorderColor = RGB(255, 165, 0
txtAchternaam.Locked = False
txtAchternaam.BorderStyle = 4
txtAchternaam.BorderColor = RGB(255, 165, 0)
txtAfdeling.Locked = False
txtAfdeling.BorderStyle = 4
txtAfdeling.BorderColor = RGB(255, 165, 0)
I wonder if there is a way to not display this in my code or shorten this. The code gets very long if i use this a few times..

Whenever you need to repeat a set of instructions, instead of copy+pasta'ing code your first reaction should be to ask yourself "how can I avoid copying this chunk over and over?" - and the solution is pretty much always to extract a method and parameterize it.
So you take one of the repeated chunks:
txtAchternaam.Locked = False
txtAchternaam.BorderStyle = 4
txtAchternaam.BorderColor = RGB(255, 165, 0)
and then copy it one last time in a new scope:
Private Sub RenameMe()
txtAchternaam.Locked = False
txtAchternaam.BorderStyle = 4
txtAchternaam.BorderColor = RGB(255, 165, 0)
End Sub
Then you extract the parameters:
Private Sub RenameMe(ByVal target As Control)
target.Locked = False
target.BorderStyle = 4
target.BorderColor = RGB(255, 165, 0)
End Sub
Then you replace the repeated chunks with calls to that new procedure:
RenameMe txtVoornaam
RenameMe txtAchternaam
RenameMe txtAfdeling
Or if that's still tedious you can iterate controls and call that procedure in the loop body - whatever works best for you.
And if you need more flexibility, extract more parameters and make them Optional as needed:
Private Sub RenameMe(ByVal target As Control, Optional ByVal lockCtrl As Boolean = False, Optional ByVal brdrStyle As Long = 4, Optional ByVal brdrColor As Long = 42495)
target.Locked = lockCtrl
target.BorderStyle = brdrStyle
target.BorderColor = brdrColor
End Sub
Now the hard part is to give RenameMe a meaningful name that properly conveys what's going on here. I'd suggest FormatControl or something along these lines.

An option if you have several controls that you are creating through a form would be to do the following:
Dim names() As String
names = Split("txtVoornaam,txtAchternaam,txtAfdeling", ",")
Dim ctrl As Variant
Dim ctrlName As Variant
For Each ctrl In Me.Controls
For Each ctrlName In names
If StrComp(ctrlName, ctrl.Name) = 0 Then
ctrl.Locked = False
ctrl.BorderStyle = 4
ctrl.BorderColor = RGB(255, 165, 0)
End If
Next ctrlName
Next ctrl
This code iterates through each of the control names that fit your list.
However, this is much less efficient than Mat's Mug's answer because you are iterating through the entire list of controls in your form, but it does showcase how you might take a list of static names and iterate through them and a collection.
If you wanted to change all the text controls this would be the way to do it; simply remove the ctrlName check.
As Parfait has correctly pointed out, you could shorten the code to the following if you are confident in your control names:
Dim names() As String
names = Split("txtVoornaam,txtAchternaam,txtAfdeling", ",")
Dim ctrlName As Variant
For Each ctrlName In names
With Me.Controls(ctrlName)
.Locked = False
.BorderStyle = 4
.BorderColor = RGB(255, 165, 0)
End With
Next ctrlName

function Lockdown(strControl)
with me(strControl)
.locked = false
.borderstyle = 4
.bordercolor = RGB(255,165,0)
end with
use me or forms!formname depending on where you're calling from

if your controls are the same, obviously put them in a single sub/function that you can call from anywhere. i would not try to lock or change the format of textboxes, instead just enable/disable, and it will handle the format for you:
textbox.enabled = true/false
if you are doing this on multiple forms and really want a single sub/function to control enabling/disabling the textboxes on each form, then there are various ways of doing that as well, solution will depend on your needs, but certainly doable and some have already commented above.
for example, you can use the "tag" property of the textboxes to flag the textboxes on that form that you want to enable/disable. you can then have a single sub/function that would take in the form as reference, and then you can read the "tag" property of all textboxes on that form and if they are the ones you flagged, you would proceed to enable/disable them

Change Border Color of a Range Without Changing the Linestyle/Weight

I have a nicely formatted range of cells with different border line weights (some of them are medium thickness and some of them are thin, in no particular pattern). I want to run a macro that changes the color of the borders to grey, but every time I do it, it changes all of the border weights to xlThin automatically. I want to keep the original line thickness so I don't have to go through and change the respective ones back to xlMedium, which would be tedious.
Can someone help me out? Is this possible?
The code I currently have is simple, and it changes the color correctly. It just also changes the line weight automatically, even though I don't specify the weight or linestyle at all:
Range("NamedRange").Borders.Color = RGB(150, 150, 150)

This, on my Excel 2016, will only change the color of the cell border, without changing the size:
Sub changeColorOnly()
Dim rng As Range, cel As Range
Set rng = Range("C6:C9")
For Each cel In rng
cel.Borders.Color = RGB(150, 150, 150)
Next cel
End Sub
Does it still change the size for you?
Edit: Hm, I suspect there's something else going on in your code, as I can recolor a named range without it affecting the borders. However, just because I was already working on another alternative, you could also use these subs (and tweak as necessary)
Dim brdrTop, brdrLeft, brdrRight, brdrBtm, brdrInside
Sub changeColor()
saveBorderSize Range("myNamedRange")
Range("MyNamedRange").Borders.Color = RGB(150, 150, 150)
resetBorderSize Range("myNamedRange")
End Sub
Private Sub saveBorderSize(cel As Range)
brdrTop = cel.Borders(xlEdgeTop).Weight
brdrLeft = cel.Borders(xlEdgeLeft).Weight
brdrRight = cel.Borders(xlEdgeRight).Weight
brdrBtm = cel.Borders(xlEdgeBottom).Weight
brdrInside = cel.Borders(xlInsideHorizontal).Weight
End Sub
Private Sub resetBorderSize(cel As Range)
cel.Borders(xlEdgeTop).Weight = brdrTop
cel.Borders(xlEdgeLeft).Weight = brdrLeft
cel.Borders(xlEdgeRight).Weight = brdrRight
cel.Borders(xlEdgeBottom).Weight = brdrBtm
cel.Borders(xlInsideHorizontal).Weight = brdrInside
End Sub

Try .Borders.Color = RGB(216,216,216)
I ran the below script to try to identify the closest color to normal gridlines. My eyes are not great so check it out yourself to find the best color. BTW I agree it makes no sense that MS overrides the border color defying reason. Angry employees and too much bureaucracy - that's my theory.
Sub borcol()
Dim i As Integer
For i = 1 To 250
ActiveCell.Borders.Color = RGB(i, i, i)
ActiveCell.Offset(1, 0).Select
Next i
End Sub

To change the cell border color in a loop, using the enum value for each border makes it easy to loop through them.
This code will change the border color of the selected cell.
If there's no line the MsgBox will indicate its value.
Sub CellBorderColour()
Dim MyBorder(5 To 12) As String
Dim i As Integer
MyBorder(5) = "xlDiagonalDown"
MyBorder(6) = "xlDiagonalUp"
MyBorder(7) = "xlEdgeLeft"
MyBorder(8) = "xlEdgeTop"
MyBorder(9) = "xlEdgeBottom"
MyBorder(10) = "xlEdgeRight"
MyBorder(11) = "xlInsideVertical"
MyBorder(12) = "xlInsideHorizontal"
For i = 5 To 12
With Selection.Borders(i)
If .LineStyle > 0 Then
.Color = RGB(100, 100, 100)
Else
MsgBox ("Borders(" & MyBorder(i) & ").LineStyle is: " & .LineStyle)
End If
End With
Next i
End Sub

Flag a line chart series if it is over another series

I have 2 sheets with about 10-20 graphs per sheet. every graph is of the same format witht the same series names. one series is called "forecast spendings" and the other is called "spendings should-be." I need to flag the chart when the forecast spendings line goes over the spendings shout-be line. I was thinking making a red dot on the given point(s).
I tried using a bunch of tricks with conditional foratting by making other data tables and manipulating the values but with no success.
VBA will probably be the solution. I've never used VBA on charts though so im not sure how to procede. I've been doing sone research but i dont know how to modify codes in accordance to my needs due to my inexperience with charts.
I think comparind an array of the 2 series would be the answer. this would then have to loop for each chart and then loof for each sheet.
I found this code that seems useable to me but i dont understant what is being referenced. I'm guessing this is assuming that htere is only one chart wiht one serie:
Dim chartIterator As Integer, pointIterator As Integer, _
seriesArray() As Variant
For chartIterator = 1 To ActiveSheet.ChartObjects.Count
seriesArray = ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _
chart.SeriesCollection(1).Values
For pointIterator = 1 To UBound(seriesArray)
If seriesArray(pointIterator) >= 0 Then
ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _
chart.SeriesCollection(1).Points(pointIterator).Interior.Color = _
RGB(146, 208, 80)
Else
ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _
chart.SeriesCollection(1).Points(pointIterator).Interior.Color = _
RGB(255, 0, 0)
End If
Next pointIterator
Next chartIterator
Please explain your answer so i can understand it and repeat it.
Thank you in advance for your time!

This seemed to work fine for me.
Sub tester()
Dim co As ChartObject
For Each co In ActiveSheet.ChartObjects
CheckChart co.Chart
Next co
End Sub
Sub CheckChart(cht As Chart)
Dim s As Series, sForecast As Series, sShould As Series
Dim i As Long
'see if we can find the required series on this chart
For Each s In cht.SeriesCollection
Debug.Print s.Name
If s.Name = "forecast spendings" Then Set sForecast = s
If s.Name = "spendings should-be" Then Set sShould = s
Next s
'series located?
If sShould Is Nothing Or sForecast Is Nothing Then
MsgBox "required series not found!"
Else
'found the series, so compare the point values
'assumes same # of points in both lines
' and same start/end
For i = 1 To sShould.Points.Count
If sForecast.Values(i) > sShould.Values(i) Then
'label point
With sForecast.Points(i)
.HasDataLabel = True
.DataLabel.Position = xlLabelPositionAbove
.DataLabel.Text = "!!!"
.DataLabel.Characters.Font.Color = vbRed
End With
End If
Next i
End If
End Sub

Excel 2010 VBA - Storing decimal in array and using to chart percentage of stored value

SO Community,
I'm looking to automate some of the metrics that are used at my work using VBA. I am currently trying to read through an array that I have my ticketing raw data stored in and then either store the value as a decimal or percentage. After this is stored in the array, I am attempting to create or update a chart series with the array and display this value as a percent. I suspect that I'm just missing some syntax for this, but I have checked SO, MSDN and Excel help and have had no luck. I have attached the relevant code below:
FUNCTION
Function calcTopApplications(iArray As Variant)
Dim m_counter As Long, r_counter As Long, placeholder As Double
Dim fNav_counter As Long, pmoNav_counter As Long, rmgr_counter As Long, wlm_counter As Long, total_counter As Long
ReDim tkt_month_arr(12), tkt_fnav_arr(12)
For m_counter = 1 To 12
fNav_counter = 0
pmoNav_counter = 0
rmgr_counter = 0
wlm_counter = 0
total_counter = 0
For r_counter = 2 To UBound(iArray, 1)
If iArray(r_counter, 1) <> iArray(r_counter - 1, 1) Then
If CDate(iArray(r_counter, 5)) >= DateAdd("m", -m_counter, DateSerial(Year(Date), Month(Date), 1)) Then
If CDate(iArray(r_counter, 5)) < DateAdd("m", (1 - m_counter), DateSerial(Year(Date), Month(Date), 1)) Then
total_counter = total_counter + 1
If StrConv(iArray(r_counter, 7), vbLowerCase) = "franchise navigator" Then
fNav_counter = fNav_counter + 1
End If
End If
End If
End If
Next r_counter
placeholder = FormatNumber(fNav_counter / total_counter, 2)
tkt_month_arr(12 - (m_counter - 1)) = CLng(DateAdd("m", -m_counter, DateSerial(Year(Date), Month(Date), 1)))
tkt_fnav_arr(12 - (m_counter - 1)) = placeholder
Next m_counter
End Function
SUBROUTINE
If Me.ChartObjects("Top 4 Applications Ticket Volume") Is Nothing Then
On Error GoTo 0
With Me.Shapes.AddChart
.Left = Me.Range("A16").Left
.Top = Me.Range("A16").Top
.Width = Me.Range("A16:S16").Width
.Height = Me.Range("A16:A30").Height
.Select
End With
With ActiveChart
.ChartType = xlLine
.ChartStyle = 42
.HasDataTable = True
.HasTitle = True
.Parent.Name = "Top 4 Applications Ticket Volume"
.ChartTitle.Caption = "Open/Close Ticket Volume by Month (Top 4 Applications)"
.Axes(xlCategory).TickLabels.NumberFormat = "mmm yyyy"
End With
With ActiveChart.SeriesCollection
.NewSeries
.Item(1).Name = "Franchise Navigator"
.Item(1).XValues = tkt_month_arr
.Item(1).Values = tkt_fnav_arr
End With
Else
With Me.ChartObjects("Top 4 Applications Ticket Volume")
.Select
End With
With ActiveChart.SeriesCollection
.Item(1).XValues = tkt_month_arr
.Item(1).Values = tkt_fnav_arr
End With
End If
This gives me the values for the percentage but does not behave on the chart as a percentage (have the % symbol).

When you create a chart "normally" and add a data table, all you have to do is format the source cells, and the table follows. But the method you use means you don't have "source cells"; and as far as I was able to tell, Microsoft doesn't provide a method to modify the formatting of the data table when it's generated with your method.
An "ugly workaround" is to create a hidden sheet, put the data there, and format it correctly. Point to this data when you create the data table, and the formatting will be correct.
It would be nice if Microsoft provided the flexibility you are asking for... sigh