-
If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.
How to zoom on charts using VBA
- Thread starter Rasm
- Start date
ohhh boy - lots of read flag - I did read Jon's article on MouseDown and the problems he is having. I do have MouseUp & MouseDown working (I used some code that Andrew P had posted to add Textboxes when you click a specific datapoint) - This works by placing the chart events in a class module.
I also found a thread using Application.CommandBars("Zoom Tools") - but that I cannot get to work.
I will mess around some more - but this may be over my head.
Anyway - I am going to give it a try - I will post code (if I make any progress) - Sounds like there is interest. Good thing my wife is a very forgiving person - hehehe
I also found a thread using Application.CommandBars("Zoom Tools") - but that I cannot get to work.
I will mess around some more - but this may be over my head.
Anyway - I am going to give it a try - I will post code (if I make any progress) - Sounds like there is interest. Good thing my wife is a very forgiving person - hehehe
Upvote
0
Excel Facts
Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Ok – Had a look at the Chart Events – OMG – This article made me think twice http://www.cpearson.com/excel/Events.aspx - Then I came down to earth.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com
fficeffice" /><o
></o>
So I decided to write a Zoom program without the use of Chart Events. Guess showing my real color – my apologies to the professionals. But this actually works quite well.
I have focused on XYscatter charts as both axes are numeric. However I would be very interested in anybody wanting to add to the code to include Line charts or any other improvements.
I show codes for two programs below
1) The Chart Zoomer program --- It is an Add-in – so save as XLAM file(optional)
2) Chartmaker – this program simply allow you to create 3 charts by a single click. So if you want to develop using your own charts – go for it.
The Chart Zoomer program works as follows (Click Tab ‘Add-Ins’ in Excel then <LOAD Zoomer>).
a) Click on a chart to Activate it.
b) 'Set Area' -- pressing this adds a textbox into the chart (width = ½ chart, Height=3/4 chart). Simply move and resize the textbox to select the area of the chart to be Zoomed.
c) 'Zoom in' - The chart is now zoomed to match your select.
d) <ZOOM Original>- 'Zoom Original' -- The charts is Zoomed Out to be like it existed before we started.
Note: The Zoomer program saves the original settings of the chart in the sheets(“Chart_size_Original”) – Make sure that SheetName exists – it can be blank – but name must exists. The sheet is emptied when you initialize Excel. But will track of any charts manipulated as long as you don’t shut down Excel – so you can always set focus to a chart and then Zoom Out to its original axes.
<o></o>
If you use the ChartMaker program (option2 above) for development – then it contains two macros or run the userform:
1) Creates charts from Arrays – all data is included.
2) Deletes all charts on active sheet.
<o></o>
So here is where I struggle (well big struggles – LOL):
a) How to show the Add-in tab in Excel if a Chart has focus (embedded into a worksheet – rather than a chart tab).
b) Having trouble getting the Xaxis coordinates just right – I compute what each pixel = on each of the axis (assuming that the .left/.width/.... properties are expressed in pixels) – But is doing this wrong – just off by 5% relative or so.
c) How to rescale none numeric axes – rescale is wrong word – I simply want to drop stuff in beginning and stuff in the end – But how is that done if scales are none numeric.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com
fficeffice" /><o></o>So I decided to write a Zoom program without the use of Chart Events. Guess showing my real color – my apologies to the professionals. But this actually works quite well.
I have focused on XYscatter charts as both axes are numeric. However I would be very interested in anybody wanting to add to the code to include Line charts or any other improvements.
I show codes for two programs below
1) The Chart Zoomer program --- It is an Add-in – so save as XLAM file(optional)
2) Chartmaker – this program simply allow you to create 3 charts by a single click. So if you want to develop using your own charts – go for it.
The Chart Zoomer program works as follows (Click Tab ‘Add-Ins’ in Excel then <LOAD Zoomer>).
a) Click on a chart to Activate it.
b) 'Set Area' -- pressing this adds a textbox into the chart (width = ½ chart, Height=3/4 chart). Simply move and resize the textbox to select the area of the chart to be Zoomed.
c) 'Zoom in' - The chart is now zoomed to match your select.
d) <ZOOM Original>- 'Zoom Original' -- The charts is Zoomed Out to be like it existed before we started.
Note: The Zoomer program saves the original settings of the chart in the sheets(“Chart_size_Original”) – Make sure that SheetName exists – it can be blank – but name must exists. The sheet is emptied when you initialize Excel. But will track of any charts manipulated as long as you don’t shut down Excel – so you can always set focus to a chart and then Zoom Out to its original axes.
<o
></o>If you use the ChartMaker program (option2 above) for development – then it contains two macros or run the userform:
1) Creates charts from Arrays – all data is included.
2) Deletes all charts on active sheet.
<o
></o>So here is where I struggle (well big struggles – LOL):
a) How to show the Add-in tab in Excel if a Chart has focus (embedded into a worksheet – rather than a chart tab).
b) Having trouble getting the Xaxis coordinates just right – I compute what each pixel = on each of the axis (assuming that the .left/.width/.... properties are expressed in pixels) – But is doing this wrong – just off by 5% relative or so.
c) How to rescale none numeric axes – rescale is wrong word – I simply want to drop stuff in beginning and stuff in the end – But how is that done if scales are none numeric.
Last edited by a moderator:
Upvote
0
THIS IS A CORRECTION - SORRY FOR POSTING BAD CODE EARLIER. Hope I did not waste your time.
I have tested the code extensively - I moved code around - deleted comments and so fourth - then posted - did not check it properly
Ok – Had a look at the Chart Events – OMG – This article made me think twice http://www.cpearson.com/excel/Events.aspx - Then I came down to earth.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o> </o>
So I decided to write a Zoom program without the use of Chart Events. Guess showing my real color – my apologies to the professionals. But this actually works quite well.<o></o>
I have focused on XYscatter charts as both axes are numeric. However I would be very interested in anybody wanting to add to the code to include Line charts or any other improvements.<o></o>
I show codes for two programs below<o></o>
1) The Chart Zoomer program --- It is an Add-in – so save as XLAM file(optional)<o></o>
2) Chartmaker – this program simply allow you to create 3 charts by a single click. So if you want to develop using your own charts – go for it.<o></o>
The Chart Zoomer program works as follows (Click Tab ‘Add-Ins’ in Excel then <Load Zoomer>).<o></o>
a) Click on a chart to Activate it.<o></o>
b) ‘Set Area’ - pressing this adds a textbox into the chart (width = ½ chart, Height=3/4 chart). Simply move and resize the textbox to select the area of the chart to be Zoomed.<o></o>
c) ‘Zoom In’ - The chart is now zoomed to match your select.<o></o>
d) ‘Zoom Original’ - The charts is Zoomed Out to be like it existed before we started.<o></o>
Note: The XLAM program saves the original settings of the chart in the sheets(“Chart_size_Original”) – Make sure that SheetName exists – it can be blank – but name must exists. The sheet is emptied when you initialize Excel. But will keep track of any charts manipulated as long as you don’t shut down Excel – so you can always set focus to a chart and then Zoom Out to its original axes.<o></o>
<o> </o>
If you use the ChartMaker program (option2 above) for development – then it contains two macros or just run the userform:<o></o>
1) Creates charts from Arrays – all data is included.<o></o>
2) Deletes all charts on active sheet.<o></o>
<o> </o>
So here is where I struggle (well big struggles – LOL):<o></o>
a) How to show the Add-in tab in Excel if a Chart has focus (embedded into a worksheet – rather than a chart tab).<o></o>
b) Having trouble getting the Xaxis coordinates just right – I compute what each pixel = on each of the axis (assuming that the .left/.width/.... properties are expressed in pixels) – But is doing this wrong – just off by 5% relative or so.<o></o>
c) How to rescale none numeric axes – rescale is wrong word – I simply want to drop stuff in beginning and stuff in the end – But how is that done if scales are none numeric.<o></o>
d) How to adjust for secondary axes.<o></o>
Zoom tool - ThisWorkBook
Zoom Tool - Useform Nmae - FormZoom
Zoom Tool - Module1
Zoom Tool - Module Name - mUI
ChartMaker - optional
Shhet1
ChartMaker - Userform name- FormMakeCharts
ChartMaker - Module1
I have tested the code extensively - I moved code around - deleted comments and so fourth - then posted - did not check it properly
Ok – Had a look at the Chart Events – OMG – This article made me think twice http://www.cpearson.com/excel/Events.aspx - Then I came down to earth.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com
fficeffice" /><o></o><o
> </o>So I decided to write a Zoom program without the use of Chart Events. Guess showing my real color – my apologies to the professionals. But this actually works quite well.<o
></o>I have focused on XYscatter charts as both axes are numeric. However I would be very interested in anybody wanting to add to the code to include Line charts or any other improvements.<o
></o>I show codes for two programs below<o
></o>1) The Chart Zoomer program --- It is an Add-in – so save as XLAM file(optional)<o
></o>2) Chartmaker – this program simply allow you to create 3 charts by a single click. So if you want to develop using your own charts – go for it.<o
></o>The Chart Zoomer program works as follows (Click Tab ‘Add-Ins’ in Excel then <Load Zoomer>).<o
></o>a) Click on a chart to Activate it.<o
></o>b) ‘Set Area’ - pressing this adds a textbox into the chart (width = ½ chart, Height=3/4 chart). Simply move and resize the textbox to select the area of the chart to be Zoomed.<o
></o>c) ‘Zoom In’ - The chart is now zoomed to match your select.<o
></o>d) ‘Zoom Original’ - The charts is Zoomed Out to be like it existed before we started.<o
></o>Note: The XLAM program saves the original settings of the chart in the sheets(“Chart_size_Original”) – Make sure that SheetName exists – it can be blank – but name must exists. The sheet is emptied when you initialize Excel. But will keep track of any charts manipulated as long as you don’t shut down Excel – so you can always set focus to a chart and then Zoom Out to its original axes.<o
></o><o
> </o>If you use the ChartMaker program (option2 above) for development – then it contains two macros or just run the userform:<o
></o>1) Creates charts from Arrays – all data is included.<o
></o>2) Deletes all charts on active sheet.<o
></o><o
> </o>So here is where I struggle (well big struggles – LOL):<o
></o>a) How to show the Add-in tab in Excel if a Chart has focus (embedded into a worksheet – rather than a chart tab).<o
></o>b) Having trouble getting the Xaxis coordinates just right – I compute what each pixel = on each of the axis (assuming that the .left/.width/.... properties are expressed in pixels) – But is doing this wrong – just off by 5% relative or so.<o
></o>c) How to rescale none numeric axes – rescale is wrong word – I simply want to drop stuff in beginning and stuff in the end – But how is that done if scales are none numeric.<o
></o>d) How to adjust for secondary axes.<o
></o>Zoom tool - ThisWorkBook
Code:
Option Explicit
Private Sub Workbook_Open()
On Error Resume Next
Dim LastRow As Long
Dim i As Long
With ThisWorkbook.Sheets("Chart_size_Original")
.UsedRange.ClearContents
.Cells(1, 1) = "WorkBookName"
.Cells(1, 2) = "SheetName"
.Cells(1, 3) = "ChartName"
.Cells(1, 4) = "X_Type"
.Cells(1, 5) = "X_Min_primary"
.Cells(1, 6) = "X_Max_primary"
.Cells(1, 7) = "X_Min_Secondary"
.Cells(1, 8) = "X_Max_Secondary"
.Cells(1, 9) = "Y_Type"
.Cells(1, 10) = "Y_Min_primary"
.Cells(1, 11) = "Y_Max_primary"
.Cells(1, 12) = "Y_Min_Secondary"
.Cells(1, 13) = "Y_Max_Secondary"
End With
Dim ctrl As CommandBarControl
Set ctrl = Application.CommandBars.FindControl(Tag:="Zoom Tool")
If Not ctrl Is Nothing Then CleanUp
Create_Menu
End SubZoom Tool - Useform Nmae - FormZoom
Code:
Option Explicit
Option Compare Text
Private Sub CmdSetZoomArea_Click()
Call SetZoomArea
End Sub
Private Sub CmdZoomIn_Click()
Call ZoomIn
End Sub
Private Sub CmdZoomOut_Click()
Call ZoomOut
End SubZoom Tool - Module1
Code:
Option Explicit
Option Compare Text
Dim i As Long, ii As Long
Dim Astr As String, AAstr As String, AAAstr As String
Dim Asingle As Single, AAsingle As Single, AAAsingle As Single, AAAAsingle As Single
Dim strMsg As String
Dim intMsgType As Integer
Dim intResponse As Integer
Dim LeftBox, TopBox, HeightBox, WidthBox As Single
Dim PlotAreaLeft As Single, PlotAreatop As Single, PlotAreaHeight As Single, PlotAreaWidth As Single
Public ZoomTop As Single, ZoomLeft As Single, ZoomHeight As Single, ZoomWidth As Single
Public XaxisMin As Variant, XaxisMax As Variant, YaxisMin As Variant, YaxisMax As Variant
Public Status As String
Private Sub ChkIfChartExists(Status)
On Error Resume Next
Err.Clear
Astr = ActiveChart.Name
If Err.Number <> 0 Then
Status = "No Charts"
MsgBox "You need to Activate the chart to be manipulated"
Exit Sub
End If
Status = "Ok"
Err.Clear
End Sub
Public Sub SaveChartsMinMax()
Dim LastRow As Long
Dim NotExist As Boolean
Dim Aint As Integer
Dim Along As Long
Dim Xvlue() As Variant
Dim WrkBookName As String
Dim ActiveShtName As String
Dim ActChartName As String
Dim Xmin As Single
Dim Xmax As Single
Dim Ymin As Single
Dim Ymax As Single
Dim Xtype As String
Dim Ytype As String
On Error Resume Next
Err.Clear
WrkBookName = ActiveWorkbook.Name
ActiveShtName = ActiveSheet.Name
ActChartName = ActiveChart.Name
Aint = InStr(1, ActChartName, ActiveShtName)
If Aint > 0 Then ActChartName = Right(ActChartName, Len(ActChartName) - Len(ActiveShtName) - 1)
With ActiveChart
Xmin = .Axes(xlValue).MinimumScale
If Err.Number <> 0 Then MsgBox "ok what now"
Xmax = .Axes(xlValue).MaximumScale
If Err.Number <> 0 Then MsgBox "ok what now"
Xtype = "Number"
Ymin = .Axes(xlCategory).MinimumScale
If Err.Number <> 0 Then
Err.Clear
Xvlue = .SeriesCollection(1).XValues
If Err.Number <> 0 Then MsgBox "ok what now"
Ytype = "String"
Else
Ymax = .Axes(xlCategory).MaximumScale
End If
End With
With ThisWorkbook.Sheets("Chart_size_Original").UsedRange
LastRow = .Rows(.Rows.Count).Row
End With
With ThisWorkbook.Sheets("Chart_size_Original")
'see if settings already recorded
NotExist = True
For i = 2 To LastRow
If .Cells(i, 2) = ActiveShtName And .Cells(i, 1) = WrkBookName Then
Aint = InStr(1, ActChartName, .Cells(i, 3))
If Aint > 0 Then NotExist = False
End If
Next i
If NotExist Then
.Cells(i, 1) = WrkBookName
.Cells(i, 2) = ActiveShtName
.Cells(i, 3) = ActChartName
.Cells(i, 4) = Xtype
.Cells(i, 5) = Xmin
.Cells(i, 6) = Xmax
.Cells(i, 7) = "Xmin_Not Implemented"
.Cells(i, 8) = "Xmax_Not Implemented"
.Cells(i, 9) = Ytype
If Ytype = "String" Then
.Cells(i, 10) = UBound(Xvlue) & " Values"
For ii = 1 To UBound(Xvlue)
.Cells(i, ii + 10) = Xvlue(ii)
Next ii
Else
.Cells(i, 10) = Ymin
.Cells(i, 11) = Ymax
.Cells(i, 12) = "Ymin_Not Implemented"
.Cells(i, 13) = "Ymax_Not Implemented"
End If
End If
End With
End Sub
Public Sub SetZoomArea()
Call ChkIfChartExists(Status)
If Status = "No Charts" Then Exit Sub
Call CheckIfXYtype(Status)
If Status <> "XYscatter Type" Then
strMsg = "The 'Zoomer' program is been developed for XYscatter type plots." & vbCrLf & "Not the type selected." & vbCrLf & "Do you wish to continue (may not work)"
intMsgType = vbExclamation + vbYesNo
intResponse = MsgBox(strMsg, intMsgType, ".ChartType property not tested")
If intResponse <> 6 Then Exit Sub
End If
Call SaveChartsMinMax
With ActiveChart
For i = 1 To .Shapes.Count
If .Shapes(i).Name = "X_ZoomArea_X" Then .Shapes(i).Delete
Next i
Err.Clear
LeftBox = (.PlotArea.InsideWidth / 4) + .PlotArea.InsideLeft
TopBox = (.PlotArea.InsideHeight / 4) + .PlotArea.Top
HeightBox = .PlotArea.InsideHeight / 4 * 3
WidthBox = .PlotArea.InsideWidth / 2
.Shapes.AddTextbox(msoTextOrientationHorizontal, LeftBox, TopBox, WidthBox, HeightBox).Name = "X_ZoomArea_X"
.Shapes("X_ZoomArea_X").TextEffect.Alignment = msoTextEffectAlignmentCentered
.Shapes("X_ZoomArea_X").Select
Astr = "Area to be zoomed." & vbCrLf
Astr = Astr & "Adjust size to suit." & vbCrLf
Astr = Astr & "After press <Zoom In>"
Selection.Characters.Text = Astr
With Selection.Characters.Font
.Name = "Arial"
.FontStyle = "Bold"
Select Case WidthBox * HeightBox
Case Is >= 80000
.Size = 36
Case Is >= 40000
.Size = 24
Case Is >= 20000
.Size = 18
Case Is >= 15000
.Size = 16
Case Is >= 10000
.Size = 12
Case Else
.Size = 8
End Select
.Strikethrough = False
.Superscript = True
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1 'xlAutomatic
End With
End With
End Sub
Public Sub ZoomIn()
Call ChkIfChartExists(Status)
If Status = "No Charts" Then Exit Sub
Err.Clear
If ActiveChart.Shapes.Count <= 0 Then
MsgBox "You need to 'Set Area' first"
Status = "No Textbox"
Exit Sub
End If
Status = ""
For i = ActiveChart.Shapes.Count To 1 Step -1
If ActiveChart.Shapes(i).Name = "X_ZoomArea_X" Then Status = "Found Box"
Next i
If Status <> "Found Box" Then
MsgBox "You need to 'Set Area' first"
Status = "No Textbox"
Exit Sub
End If
Dim YaxisLabelWidth As Single
Dim XaxisLabelHeight As Single
Dim Xtype As String
Dim PlotWidthDiff As Single
Dim PlotHeightDiff As Single
Dim Xvlue() As Variant
Dim YnewMax As Single, YnewMin As Single, XnewMax As Single, XnewMin As Single
Dim XaxisCurrentMin As Single
Dim XaxisCurrentMax As Single
With ActiveChart
For i = .Shapes.Count To 1 Step -1
If .Shapes(i).Name = "X_ZoomArea_X" Then
ZoomTop = .Shapes(i).Top
ZoomLeft = .Shapes(i).Left
ZoomHeight = .Shapes(i).Height
ZoomWidth = .Shapes(i).Width
.Shapes(i).Delete
End If
Next i
PlotAreaLeft = .PlotArea.Left 'InsideLeft
PlotAreaHeight = .PlotArea.Height 'InsideHeight
PlotAreaWidth = .PlotArea.Width 'InsideWidth
PlotAreatop = .PlotArea.Top 'InsideTop
End With
With ActiveChart
If .HasAxis(xlValue, xlSecondary) Then 'this is a problem to be solved
MsgBox "Secondary 'xlValue' axis not implemented." & vbCrLf & "Make sure program behaves as expected."
End If
If .HasAxis(xlCategory, xlSecondary) Then 'this is a problem to be solved
MsgBox "Secondary 'xlCategory' axis not implemented." & vbCrLf & "Make sure program behaves as expected."
End If
On Error Resume Next
Err.Clear
XaxisCurrentMin = .Axes(xlCategory).MinimumScale
If Err.Number <> 0 Then
Xtype = "string"
'Err.Clear
'Xvlue = .SeriesCollection(1).Values
'If Err.Number <> 0 Then Stop
'XaxisCurrentMin = Xvlue(1)
'XaxisCurrentMax = Xvlue(UBound(Xvlue))
Else
XaxisCurrentMax = .Axes(xlCategory).MaximumScale
End If
End With
YaxisMin = ActiveChart.Axes(xlValue).MinimumScale
YaxisMax = ActiveChart.Axes(xlValue).MaximumScale
XaxisMin = ActiveChart.Axes(xlCategory).MinimumScale
XaxisMax = ActiveChart.Axes(xlCategory).MaximumScale
YaxisLabelWidth = ActiveChart.PlotArea.InsideLeft - ActiveChart.PlotArea.Left
XaxisLabelHeight = ActiveChart.PlotArea.Top + ActiveChart.PlotArea.Height - (ActiveChart.PlotArea.Top + ActiveChart.PlotArea.InsideHeight)
'Works - do not touch
YnewMax = YaxisMax - (ZoomTop - ActiveChart.PlotArea.InsideTop) * ((YaxisMax - YaxisMin) / ActiveChart.PlotArea.InsideHeight)
'Works do not touch
YnewMin = YnewMax - (ZoomHeight * (YaxisMax - YaxisMin) / ActiveChart.PlotArea.InsideHeight)
XnewMin = XaxisMin + (ZoomLeft - ActiveChart.PlotArea.Left) * ((XaxisMax - XaxisMin) / (ActiveChart.PlotArea.InsideWidth + (YaxisLabelWidth * 2)))
If ActiveChart.HasAxis(xlValue, xlSecondary) Then
YnewMax = YaxisMax - (ZoomTop - ActiveChart.PlotArea.InsideTop) _
* ((YaxisMax - YaxisMin) / (ActiveChart.PlotArea.InsideHeight + YaxisLabelWidth))
Else
XnewMax = XnewMin + (ZoomWidth * ((XaxisMax - XaxisMin) / (ActiveChart.PlotArea.InsideWidth)))
End If
ActiveChart.Axes(xlValue).MinimumScale = YnewMin 'Format(minimumX, "#####.##")
ActiveChart.Axes(xlValue).MaximumScale = YnewMax 'Format(maximumX, "#####.##")
If Xtype = "string" Then
MsgBox "Only XYscatter types supported - Xaxis will not be rescaled"
Else
ActiveChart.Axes(xlCategory).MinimumScale = XnewMin ' Format(minimumX, "#####.##")
ActiveChart.Axes(xlCategory).MaximumScale = XnewMax 'Format(maximumX, "#####.##")
End If
End Sub
Public Sub ZoomOut()
Call ChkIfChartExists(Status)
If Status = "No Charts" Then Exit Sub
Dim LastRow As Long
Dim Aint As Integer
Dim WrkBookName As String
Dim ActiveShtName As String
Dim ActChartName As String
Dim Xmin As Single
Dim Xmax As Single
Dim Ymin As Single
Dim Ymax As Single
On Error Resume Next
Err.Clear
WrkBookName = ActiveWorkbook.Name
If Err.Number <> 0 Then MsgBox "Weird"
ActiveShtName = ActiveSheet.Name
If Err.Number <> 0 Then MsgBox "Weird"
ActChartName = ActiveChart.Name
If Err.Number <> 0 Then MsgBox "Weird"
Aint = InStr(1, ActChartName, ActiveShtName)
If Aint > 0 Then
ActChartName = Right(ActChartName, Len(ActChartName) - Len(ActiveShtName) - 1)
End If
With ThisWorkbook.Sheets("Chart_size_Original").UsedRange
LastRow = .Rows(.Rows.Count).Row
End With
With ThisWorkbook.Sheets("Chart_size_Original")
For i = 2 To LastRow
If .Cells(i, 2) = ActiveShtName And .Cells(i, 1) = WrkBookName Then
Aint = InStr(1, ActChartName, .Cells(i, 3))
If Aint > 0 Then
If .Cells(i, 4) = "String" Then Stop 'Never seen this before
If .Cells(i, 9) = "String" Then
ActiveChart.Axes(xlValue).MinimumScale = .Cells(i, 5)
ActiveChart.Axes(xlValue).MaximumScale = .Cells(i, 6)
'ActiveChart.Axes(xlCategory).MinimumScale = 9
'ActiveChart.Axes(xlCategory).MaximumScale = 14
Else
ActiveChart.Axes(xlValue).MinimumScale = .Cells(i, 5)
ActiveChart.Axes(xlValue).MaximumScale = .Cells(i, 6)
ActiveChart.Axes(xlCategory).MinimumScale = .Cells(i, 10)
ActiveChart.Axes(xlCategory).MaximumScale = .Cells(i, 11)
End If
End If
End If
Next i
End With
End Sub
Private Sub CheckIfXYtype(Status)
Select Case ActiveChart.ChartType
Case -4169, -4151, 72, 73, 74, 75
Status = "XYscatter Type"
Case Else
Status = "Not XYscatter Type"
End Select
End SubZoom Tool - Module Name - mUI
Code:
Option Explicit
Option Compare Text
Sub Create_Menu()
Dim cmdbr As CommandBar, cbc As CommandBarControl, cbcNew As CommandBarControl
Dim cbcOpt As CommandBarControl
Set cmdbr = Application.CommandBars("Worksheet Menu Bar")
Set cbc = cmdbr.Controls.Add(Type:=msoControlPopup, temporary:=True)
With cbc
.Caption = "&Zoom Tool"
.Visible = True
.Tag = "Zoom Tool"
.TooltipText = "Zoom your Excel charts"
.Move before:=cmdbr.Controls.Count - 1
End With
Set cbcNew = CreateControl(cbc, "&Open Zoomer", "Load Zoomer", msoControlButton, , "LoadFormZoom")
Set cbcNew = CreateControl(cbc, "&Close Zoomer", "Unload Zoomer", msoControlButton, , "UnLoadFormZoom")
End Sub
Sub CleanUp()
Dim cbc As CommandBarControl
On Error Resume Next
Set cbc = Application.CommandBars("Worksheet Menu Bar").Controls("Zoom Tool")
If Not cbc Is Nothing Then
Do
cbc.Delete
Set cbc = Nothing
Set cbc = Application.CommandBars("Worksheet Menu Bar").Controls("Zoom Tool")
Loop Until cbc Is Nothing
End If
Set cbc = Application.CommandBars("Cell").Controls("&Open Zoomer")
Do While Not cbc Is Nothing
cbc.Delete
Set cbc = Nothing
Set cbc = Application.CommandBars("Cell").Controls("&Open Zoomer")
Loop
Set cbc = Application.CommandBars("Cell").Controls("&Close Zoomer")
Do While Not cbc Is Nothing
cbc.Delete
Set cbc = Nothing
Set cbc = Application.CommandBars("Cell").Controls("&Close Zoomer")
Loop
End Sub
Function CreateControl(container As Variant, strCap As String, strTip As String, lngType As MsoControlType, Optional tagLine, Optional Macro) As CommandBarControl
Dim ctrl
Set ctrl = container.Controls.Add(lngType)
With ctrl
.Caption = strCap
.TooltipText = strTip
If Not IsMissing(tagLine) Then .Tag = tagLine
If Not IsMissing(Macro) Then .OnAction = Macro
End With
Set CreateControl = ctrl
End Function
Private Sub LoadFormZoom()
Load FormZoom
FormZoom.Show vbModeless
End Sub
Private Sub UnLoadFormZoom()
Unload FormZoom
End SubChartMaker - optional
Shhet1
Code:
Option Explicit
Option Compare Text
Private Sub CommandButton1_Click()
Load FormMakeCharts
FormMakeCharts.Show vbModeless
End SubChartMaker - Userform name- FormMakeCharts
Code:
Option Explicit
Option Compare Text
Dim Astr As String
Dim Along As Long
Dim i As Long
Dim Asingle As Single, AAsingle As Single, AAAsingle As Single, AAAAsingle As Single
Private Sub MakeNewCharts_Click()
Call AddHistochart
End Sub
Private Sub CmdClearCharts_Click()
Dim NumCharts As Long
NumCharts = ActiveSheet.ChartObjects.Count
If NumCharts > 0 Then
For i = NumCharts To 1 Step -1
ActiveSheet.ChartObjects(i).Delete
Next i
End If
End SubChartMaker - Module1
Code:
Option Explicit
Option Compare Text
Dim i As Long, ii As Long
Dim Astr As String
Dim Asingle As Single, AAsingle As Single, AAAsingle As Single, AAAAsingle As Single
Public Sub AddHistochart()
Dim NumCharts As Long
Dim YPlotValues() As Variant
Dim XPlotValues() As Single
Dim i As Long, ii As Long
Dim frequency() As Long 'As Variant
Dim binlabel() As Single 'As Variant
Dim binsize As Single 'As Variant
Dim minimumX As Single
Dim maximumX As Single
Dim NumBins As Long
Dim Along As Long, AAlong As Long
Dim NumParameters As Long
Dim HighFrequency As Long
Dim Asingle As Single
Dim Avar As Variant
Dim MeanVal() As Single
Dim CounterVal() As Long
Dim WrkBookName As String
Dim ActiveShtName As String
Dim ActChartName As String
Dim Aint As Integer
Application.StatusBar = "Making Histogram"
NumBins = 11
NumParameters = 1
ReDim frequency(1 To NumBins)
ReDim binlabel(1 To NumBins)
Call GetArrayValue(YPlotValues, XPlotValues, minimumX, maximumX)
binsize = (maximumX - minimumX) / NumBins
For i = 1 To NumBins
binlabel(i) = Format(minimumX + 0.5 * binsize + (i - 1) * binsize, "####0.00")
Next i
HighFrequency = 0
For i = 1 To NumBins - 1
For ii = 1 To UBound(YPlotValues)
If YPlotValues(ii) >= binlabel(i) - 0.5 * binsize And YPlotValues(ii) < binlabel(i + 1) - 0.5 * binsize Then
frequency(i) = frequency(i) + 1
If frequency(i) > HighFrequency Then HighFrequency = frequency(i)
End If
Next ii
Next i
'******* last bin
For i = 1 To UBound(YPlotValues)
If YPlotValues(i) >= binlabel(NumBins) - 0.5 * binsize And YPlotValues(i) < maximumX Then
frequency(NumBins) = frequency(NumBins) + 1
If frequency(NumBins) > HighFrequency Then HighFrequency = frequency(i)
End If
Next i
NumCharts = ActiveSheet.ChartObjects.Count
If NumCharts > 0 Then
For i = NumCharts To 1 Step -1
ActiveSheet.ChartObjects(i).Delete
Next i
End If
Along = 1
ReDim MeanVal(1 To HighFrequency)
ReDim CounterVal(1 To HighFrequency)
Along = UBound(YPlotValues)
Asingle = 0
AAlong = 0
For i = 1 To UBound(YPlotValues)
Asingle = Asingle + YPlotValues(i)
AAlong = AAlong + 1
Next i
Asingle = Asingle / AAlong
For i = 1 To HighFrequency
CounterVal(i) = i '- 1
MeanVal(i) = Asingle
Next i
StartMakingCharts:
ActiveSheet.ChartObjects.Add Left:=50, Top:=50, Width:=600, Height:=300
NumCharts = ActiveSheet.ChartObjects.Count
If NumCharts = 2 Then
ActiveSheet.ChartObjects(NumCharts).Left = ActiveSheet.ChartObjects(NumCharts - 1).Left
ActiveSheet.ChartObjects(NumCharts).Top = ActiveSheet.ChartObjects(NumCharts - 1).Top + ActiveSheet.ChartObjects(NumCharts - 1).Height + 20
ActiveSheet.ChartObjects(NumCharts).Height = ActiveSheet.ChartObjects(NumCharts - 1).Height
ActiveSheet.ChartObjects(NumCharts).Width = ActiveSheet.ChartObjects(NumCharts - 1).Width
End If
If NumCharts = 3 Then
ActiveSheet.ChartObjects(NumCharts).Left = ActiveSheet.ChartObjects(1).Left + ActiveSheet.ChartObjects(1).Width + 20
ActiveSheet.ChartObjects(NumCharts).Top = ActiveSheet.ChartObjects(1).Top
ActiveSheet.ChartObjects(NumCharts).Height = ActiveSheet.ChartObjects(1).Height
ActiveSheet.ChartObjects(NumCharts).Width = ActiveSheet.ChartObjects(1).Width
End If
'NumCharts = ActiveSheet.ChartObjects.Count
ActiveSheet.ChartObjects(NumCharts).Activate
Dim Achart As ChartObject
Set Achart = ActiveSheet.ChartObjects(NumCharts)
With Achart.Chart 'Set chart properties
Select Case NumCharts
Case 1
.ChartType = xlColumnClustered
'.ChartType = xlLineMarkers
Case 2
.ChartType = xlXYScatterSmoothNoMarkers
'.ChartType = xlLine
Case 3
.ChartType = xlXYScatter
'.ChartType = xlLineMarkers
Case Else
MsgBox "Not implemented"
End Select
.SeriesCollection.NewSeries
.HasLegend = False
.Axes(xlCategory).MajorTickMark = xlTickMarkOutside
.Axes(xlValue).MajorTickMark = xlTickMarkOutside 'xlTickMarkNone
If NumCharts = 3 Then
.Axes(xlValue).MinimumScale = Format(minimumX, "#####.##")
.Axes(xlValue).MaximumScale = Format(maximumX, "#####.##")
.Axes(xlCategory).MinimumScale = Format(minimumX, "#####.##")
.Axes(xlCategory).MaximumScale = Format(maximumX, "#####.##")
.SeriesCollection(NumParameters).Values = Array(XPlotValues)
.SeriesCollection(NumParameters).XValues = Array(YPlotValues)
.Axes(xlCategory).HasTitle = True
.Axes(xlCategory).AxisTitle.Characters.Text = "Reference data"
.Axes(xlValue).HasTitle = True
.Axes(xlValue).AxisTitle.Characters.Text = "Predicted values"
End If
If NumCharts = 1 Or NumCharts = 2 Then
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScale = HighFrequency + 1
.SeriesCollection(NumParameters).Values = Array(frequency)
.SeriesCollection(NumParameters).XValues = Array(binlabel)
.Axes(xlCategory).HasTitle = True
.Axes(xlCategory).AxisTitle.Characters.Text = "Predictions"
.Axes(xlValue).HasTitle = True
.Axes(xlValue).AxisTitle.Characters.Text = "Frequency"
End If
If NumCharts = 2 Then
.SeriesCollection.NewSeries
.SeriesCollection(NumParameters + 1).Values = Array(frequency)
.SeriesCollection(NumParameters + 1).XValues = Array(binlabel)
.SeriesCollection(NumParameters + 1).Smooth = True
'.SeriesCollection.NewSeries 'Fonny series
'.SeriesCollection(NumParameters + 2).Values = Array(CounterVal)
'.SeriesCollection(NumParameters + 2).XValues = Array(MeanVal) ' creates bars
'.SeriesCollection(NumParameters + 2).Smooth = True
'.HasAxis(xlValue, xlSecondary) = True
'.SeriesCollection(NumParameters + 2).AxisGroup = 2
.Axes(xlCategory).MinimumScale = Format(minimumX, "#####.##")
.Axes(xlCategory).MaximumScale = Format(maximumX, "#####.##")
GoTo dasjdhjahda
.HasAxis(xlCategory, xlSecondary) = True
.Axes(xlCategory, xlSecondary).HasTitle = True
.Axes(xlCategory, xlSecondary).AxisTitle.Caption = "This is it" '.Characters.Text = "2nd axis"
With .Axes(xlValue, xlSecondary)
.MinimumScale = 0
.MaximumScale = 25
.MinorUnitIsAuto = True
.MajorUnit = 5
.Crosses = xlCustom
.CrossesAt = 0
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
dasjdhjahda:
'Selection.TickLabels.NumberFormat = "0"
ActiveChart.Axes(xlValue).Select
End If
WrkBookName = ActiveWorkbook.Name
ActiveShtName = ActiveSheet.Name
ActChartName = ActiveChart.Name
Aint = InStr(1, ActChartName, ActiveShtName)
If Aint > 0 Then
ActChartName = Right(ActChartName, Len(ActChartName) - Len(ActiveShtName) - 1)
End If
.HasTitle = True
.ChartTitle.Text = WrkBookName & "--" & ActiveShtName & "--" & ActChartName 'Adds header for entire chart
End With
'ActiveChart.Select
Set Achart = Nothing
If NumCharts < 3 Then GoTo StartMakingCharts
Application.StatusBar = "Completed ---- Making Histogram/Curve Histogram - Start new Task"
End Sub
Private Sub GetArrayValue(YPlotValues, XPlotValues, minimumX, maximumX)
Dim NumObvs As Long
NumObvs = 177
minimumX = 9.1
maximumX = 14
ReDim YPlotValues(1 To NumObvs)
ReDim XPlotValues(1 To NumObvs)
YPlotValues(1) = 10.496: XPlotValues(1) = 10.4
YPlotValues(2) = 10.3: XPlotValues(2) = 10.2
YPlotValues(3) = 10.469: XPlotValues(3) = 10.6
YPlotValues(4) = 10.381: XPlotValues(4) = 10.4
YPlotValues(5) = 10.148: XPlotValues(5) = 10.1
YPlotValues(6) = 10.306: XPlotValues(6) = 10.6
YPlotValues(7) = 10.457: XPlotValues(7) = 10.5
YPlotValues(8) = 9.893: XPlotValues(8) = 9.9
YPlotValues(9) = 9.881: XPlotValues(9) = 9.7
YPlotValues(10) = 9.44: XPlotValues(10) = 10
YPlotValues(11) = 9.276: XPlotValues(11) = 9.3
YPlotValues(12) = 9.162: XPlotValues(12) = 9.2
YPlotValues(13) = 9.721: XPlotValues(13) = 9.6
YPlotValues(14) = 9.61: XPlotValues(14) = 9.6
YPlotValues(15) = 9.804: XPlotValues(15) = 9.7
YPlotValues(16) = 9.794: XPlotValues(16) = 9.93
YPlotValues(17) = 10.27: XPlotValues(17) = 10.21
YPlotValues(18) = 10.416: XPlotValues(18) = 10.38
YPlotValues(19) = 10.571: XPlotValues(19) = 10.62
YPlotValues(20) = 10.793: XPlotValues(20) = 11
YPlotValues(21) = 11.061: XPlotValues(21) = 11
YPlotValues(22) = 11.28: XPlotValues(22) = 11.25
YPlotValues(23) = 11.472: XPlotValues(23) = 11.41
YPlotValues(24) = 11.527: XPlotValues(24) = 11.58
YPlotValues(25) = 11.809: XPlotValues(25) = 11.82
YPlotValues(26) = 11.962: XPlotValues(26) = 11.9
YPlotValues(27) = 12.141: XPlotValues(27) = 12.11
YPlotValues(28) = 12.328: XPlotValues(28) = 12.28
YPlotValues(29) = 12.49: XPlotValues(29) = 12.45
YPlotValues(30) = 12.677: XPlotValues(30) = 12.58
YPlotValues(31) = 12.871: XPlotValues(31) = 12.92
YPlotValues(32) = 12.951: XPlotValues(32) = 12.97
YPlotValues(33) = 13.15: XPlotValues(33) = 13.11
YPlotValues(34) = 13.305: XPlotValues(34) = 13.28
YPlotValues(35) = 13.272: XPlotValues(35) = 13.26
YPlotValues(36) = 13.168: XPlotValues(36) = 13.14
YPlotValues(37) = 13.457: XPlotValues(37) = 13.44
YPlotValues(38) = 13.411: XPlotValues(38) = 1344
YPlotValues(39) = 13.613: XPlotValues(39) = 13.62
YPlotValues(40) = 13.651: XPlotValues(40) = 13.62
YPlotValues(41) = 13.91: XPlotValues(41) = 13.82
YPlotValues(42) = 11.053: XPlotValues(42) = 11.12
YPlotValues(43) = 11.176: XPlotValues(43) = 11.32
YPlotValues(44) = 11.153: XPlotValues(44) = 11.22
YPlotValues(45) = 11.902: XPlotValues(45) = 11.72
YPlotValues(46) = 11.111: XPlotValues(46) = 11.02
YPlotValues(47) = 11.316: XPlotValues(47) = 11.42
YPlotValues(48) = 11.839: XPlotValues(48) = 11.62
YPlotValues(49) = 11.633: XPlotValues(49) = 11.562
YPlotValues(50) = 11.752: XPlotValues(50) = 11.862
YPlotValues(51) = 11.709: XPlotValues(51) = 11.762
YPlotValues(52) = 11.868: XPlotValues(52) = 11.762
YPlotValues(53) = 12.061: XPlotValues(53) = 12.062
YPlotValues(54) = 12.223: XPlotValues(54) = 12.262
YPlotValues(55) = 12.164: XPlotValues(55) = 12.162
YPlotValues(56) = 12.308: XPlotValues(56) = 12.462
YPlotValues(57) = 12.541: XPlotValues(57) = 12.62
YPlotValues(58) = 12.389: XPlotValues(58) = 12.562
YPlotValues(59) = 12.697: XPlotValues(59) = 12.62
YPlotValues(60) = 12.722: XPlotValues(60) = 12.62
YPlotValues(61) = 12.458: XPlotValues(61) = 12.562
YPlotValues(62) = 12.888: XPlotValues(62) = 12.62
YPlotValues(63) = 12.999: XPlotValues(63) = 12.92
YPlotValues(64) = 12.072: XPlotValues(64) = 12.22
YPlotValues(65) = 12.953: XPlotValues(65) = 12.62
YPlotValues(66) = 11.03: XPlotValues(66) = 11.12
YPlotValues(67) = 11.192: XPlotValues(67) = 11.32
YPlotValues(68) = 11.086: XPlotValues(68) = 11.6
YPlotValues(69) = 11.197: XPlotValues(69) = 11.42
YPlotValues(70) = 11.236: XPlotValues(70) = 11.62
YPlotValues(71) = 11.324: XPlotValues(71) = 11.362
YPlotValues(72) = 11.696: XPlotValues(72) = 11.62
YPlotValues(73) = 11.732: XPlotValues(73) = 11.562
YPlotValues(74) = 11.943: XPlotValues(74) = 11.862
YPlotValues(75) = 12.113: XPlotValues(75) = 12.362
YPlotValues(76) = 12.17: XPlotValues(76) = 12.162
YPlotValues(77) = 12.475: XPlotValues(77) = 12.462
YPlotValues(78) = 12.349: XPlotValues(78) = 12.262
YPlotValues(79) = 13.006: XPlotValues(79) = 13.22
YPlotValues(80) = 12.688: XPlotValues(80) = 12.62
YPlotValues(81) = 12.655: XPlotValues(81) = 12.62
YPlotValues(82) = 12.869: XPlotValues(82) = 12.72
YPlotValues(83) = 13.098: XPlotValues(83) = 13.12
YPlotValues(84) = 13.127: XPlotValues(84) = 13.22
YPlotValues(85) = 13.146: XPlotValues(85) = 13.12
YPlotValues(86) = 13.493: XPlotValues(86) = 13.42
YPlotValues(87) = 13.746: XPlotValues(87) = 13.62
YPlotValues(88) = 13.729: XPlotValues(88) = 13.62
YPlotValues(89) = 13.833: XPlotValues(89) = 13.92
YPlotValues(90) = 14.026: XPlotValues(90) = 14.02
YPlotValues(91) = 13.958: XPlotValues(91) = 13.62
YPlotValues(92) = 11.208: XPlotValues(92) = 11.32
YPlotValues(93) = 11.098: XPlotValues(93) = 11.22
YPlotValues(94) = 11.4: XPlotValues(94) = 11.52
YPlotValues(95) = 11.221: XPlotValues(95) = 11.32
YPlotValues(96) = 11.22: XPlotValues(96) = 11.02
YPlotValues(97) = 11.191: XPlotValues(97) = 11.02
YPlotValues(98) = 10.946: XPlotValues(98) = 10.72
YPlotValues(99) = 11.353: XPlotValues(99) = 11.42
YPlotValues(100) = 11.274: XPlotValues(100) = 11.32
YPlotValues(101) = 11.361: XPlotValues(101) = 11.32
YPlotValues(102) = 11.173: XPlotValues(102) = 11.22
YPlotValues(103) = 11.034: XPlotValues(103) = 11.12
YPlotValues(104) = 10.986: XPlotValues(104) = 10.02
YPlotValues(105) = 11.025: XPlotValues(105) = 11.02
YPlotValues(106) = 10.88: XPlotValues(106) = 10.72
YPlotValues(107) = 10.862: XPlotValues(107) = 10.72
YPlotValues(108) = 10.852: XPlotValues(108) = 10.72
YPlotValues(109) = 11.185: XPlotValues(109) = 11.32
YPlotValues(110) = 10.71: XPlotValues(110) = 10.42
YPlotValues(111) = 10.83: XPlotValues(111) = 10.72
YPlotValues(112) = 10.961: XPlotValues(112) = 10.92
YPlotValues(113) = 10.71: XPlotValues(113) = 10.52
YPlotValues(114) = 10.895: XPlotValues(114) = 10.72
YPlotValues(115) = 10.66: XPlotValues(115) = 10.62
YPlotValues(116) = 10.712: XPlotValues(116) = 10.72
YPlotValues(117) = 10.86: XPlotValues(117) = 10.52
YPlotValues(118) = 10.777: XPlotValues(118) = 10.72
YPlotValues(119) = 10.779: XPlotValues(119) = 10.72
YPlotValues(120) = 10.596: XPlotValues(120) = 10.52
YPlotValues(121) = 10.754: XPlotValues(121) = 10.92
YPlotValues(122) = 10.488: XPlotValues(122) = 10.42
YPlotValues(123) = 10.829: XPlotValues(123) = 10.72
YPlotValues(124) = 10.667: XPlotValues(124) = 10.62
YPlotValues(125) = 10.527: XPlotValues(125) = 10.52
YPlotValues(126) = 10.378: XPlotValues(126) = 10.32
YPlotValues(127) = 10.188: XPlotValues(127) = 10.22
YPlotValues(128) = 10.566: XPlotValues(128) = 10.42
YPlotValues(129) = 10.468: XPlotValues(129) = 10.32
YPlotValues(130) = 10.488: XPlotValues(130) = 10.32
YPlotValues(131) = 10.389: XPlotValues(131) = 10.22
YPlotValues(132) = 10.188: XPlotValues(132) = 10.12
YPlotValues(133) = 10.29: XPlotValues(133) = 10.32
YPlotValues(134) = 10.313: XPlotValues(134) = 10.32
YPlotValues(135) = 10.289: XPlotValues(135) = 10.22
YPlotValues(136) = 10.214: XPlotValues(136) = 10.22
YPlotValues(137) = 10.194: XPlotValues(137) = 10.12
YPlotValues(138) = 10.126: XPlotValues(138) = 10.12
YPlotValues(139) = 10.125: XPlotValues(139) = 10.12
YPlotValues(140) = 10.071: XPlotValues(140) = 10.02
YPlotValues(141) = 10.248: XPlotValues(141) = 10.32
YPlotValues(142) = 10.157: XPlotValues(142) = 10.22
YPlotValues(143) = 10.242: XPlotValues(143) = 10.32
YPlotValues(144) = 10.128: XPlotValues(144) = 10.12
YPlotValues(145) = 10.028: XPlotValues(145) = 10.02
YPlotValues(146) = 10.304: XPlotValues(146) = 10.32
YPlotValues(147) = 10.092: XPlotValues(147) = 10.02
YPlotValues(148) = 10.038: XPlotValues(148) = 10.12
YPlotValues(149) = 9.995: XPlotValues(149) = 9.62
YPlotValues(150) = 10.132: XPlotValues(150) = 10.32
YPlotValues(151) = 10.131: XPlotValues(151) = 10.22
YPlotValues(152) = 9.857: XPlotValues(152) = 9.62
YPlotValues(153) = 10.22: XPlotValues(153) = 10.42
YPlotValues(154) = 9.977: XPlotValues(154) = 9.92
YPlotValues(155) = 10.135: XPlotValues(155) = 10.62
YPlotValues(156) = 10.181: XPlotValues(156) = 10.32
YPlotValues(157) = 10.042: XPlotValues(157) = 10.02
YPlotValues(158) = 9.988: XPlotValues(158) = 10.02
YPlotValues(159) = 10.151: XPlotValues(159) = 10.12
YPlotValues(160) = 10.108: XPlotValues(160) = 10.22
YPlotValues(161) = 10.16: XPlotValues(161) = 10.02
YPlotValues(162) = 10.088: XPlotValues(162) = 10.12
YPlotValues(163) = 10.224: XPlotValues(163) = 10.12
YPlotValues(164) = 10.078: XPlotValues(164) = 10.02
YPlotValues(165) = 10.05: XPlotValues(165) = 10.02
YPlotValues(166) = 9.901: XPlotValues(166) = 10.02
YPlotValues(167) = 9.915: XPlotValues(167) = 10.12
YPlotValues(168) = 9.988: XPlotValues(168) = 9.829
YPlotValues(169) = 9.999: XPlotValues(169) = 9.72
YPlotValues(170) = 10.005: XPlotValues(170) = 10.02
YPlotValues(171) = 9.962: XPlotValues(171) = 9.62
YPlotValues(172) = 9.971: XPlotValues(172) = 10.02
YPlotValues(173) = 10.075: XPlotValues(173) = 10.12
YPlotValues(174) = 9.989: XPlotValues(174) = 10.02
YPlotValues(175) = 10.015: XPlotValues(175) = 10.12
YPlotValues(176) = 10.086: XPlotValues(176) = 10.9
YPlotValues(177) = 10.172: XPlotValues(177) = 10.32
End Sub
Upvote
0
Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- Windows
I've been working on this over the weekend and after some painstaking debugging work here is what I 've come up with.
Workbook demo.
The code uses Windows GDI functions to do the zooming. After enabling the zooming , the chart is zoomed-in by simply moving the mouse over the chart area and goes back to its initial zoom when the mouse is moved away.
One known limitation to this API aproach is the gradual blurring of the image as you zoom-in. The greater the zoom the worst the image but all in all I think it is not that bad.
Here is the code for the record: (In a Standard Module)
Workbook demo.
The code uses Windows GDI functions to do the zooming. After enabling the zooming , the chart is zoomed-in by simply moving the mouse over the chart area and goes back to its initial zoom when the mouse is moved away.
One known limitation to this API aproach is the gradual blurring of the image as you zoom-in. The greater the zoom the worst the image but all in all I think it is not that bad.
Here is the code for the record: (In a Standard Module)
Code:
'/Jaafar Tribak.
'/This code uses GDI functions
'/to zoom worksheet embeeded charts.
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type Rect
left As Long
top As Long
right As Long
bottom As Long
End Type
Private Type COLORADJUSTMENT
caSize As Integer
caFlags As Integer
caIlluminantIndex As Integer
caRedGamma As Integer
caGreenGamma As Integer
caBlueGamma As Integer
caReferenceBlack As Integer
caReferenceWhite As Integer
caContrast As Integer
caBrightness As Integer
caColorfulness As Integer
caRedGreenTint As Integer
End Type
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" _
(ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function GetColorAdjustment Lib "gdi32" _
(ByVal hdc As Long, lpca As COLORADJUSTMENT) As Long
Private Declare Function SetColorAdjustment Lib "gdi32" _
(ByVal hdc As Long, lpca As COLORADJUSTMENT) As Long
Private Declare Function GetStretchBltMode Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, _
ByVal dwRop As Long) As Long
Private Declare Function InvalidateRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long
Private Declare Function RedrawWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal lprcUpdate As Long, _
ByVal hrgnUpdate As Long, _
ByVal fuRedraw As Long) As Long
Private Declare Function SetRect Lib "user32.dll" _
(ByRef lpRect As Rect, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32.dll" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function GetCurrentProcessId Lib _
"kernel32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal hwnd As Long, ByRef lpdwProcessId As Long) As Long
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long
Private Declare Function PtInRect Lib "user32" _
(lpRect As Rect, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private Const SRCCOPY As Long = &HCC0020
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const PointsPerInch As Long = 72
Private Const RDW_INVALIDATE As Long = &H1
Private Const RDW_ALLCHILDREN As Long = &H80
Private Const HALFTONE As Long = 4
Private tInitRect As Rect
Private lMemoryDC As Long
Private lDC As Long
Private i As Long
Private lRgn As Long
Private lInitScrRow As Long
Private lInitScrCol As Long
Private bInside As Boolean
Private bEnableZooming As Boolean
Private oChart As ChartObject
'/Public Procedures...
Public Sub EnableZooming()
Call ZoomChart(Sheets("Test").ChartObjects(1))
End Sub
Public Sub DisableZooming()
bEnableZooming = False
InvalidateRect 0, 0, 0
ReleaseDC lDC, 0
DeleteDC lMemoryDC
If Not oChart Is Nothing Then
oChart.OnAction = ""
End If
End Sub
'/Private Procedures...
Private Sub ZoomChart(ByVal Chart As ChartObject, Optional ByVal Zoom As Long)
Dim CA As COLORADJUSTMENT
Dim tpt1 As POINTAPI
Dim tpt2 As POINTAPI
Dim lBmp As Long
If bEnableZooming Then _
MsgBox "Zoomed already enabled": Exit Sub
lInitScrRow = Application.ActiveWindow.ScrollRow
lInitScrCol = Application.ActiveWindow.ScrollColumn
bEnableZooming = True
i = 0
Set oChart = Chart
oChart.OnAction = "DummyMacro"
With tInitRect
tInitRect = GetChartRect(Chart)
.left = tInitRect.left - 4
.top = .top - 4
.right = .right + 2
.bottom = .bottom + 2
End With
With tInitRect
lDC = GetDC(0)
lMemoryDC = CreateCompatibleDC(lDC)
lBmp = CreateCompatibleBitmap _
(lDC, .right - .left, .bottom - .top)
DeleteObject SelectObject(lMemoryDC, lBmp)
BitBlt lMemoryDC, 0, 0, .right - .left, .bottom - .top, _
lDC, .left, .top, SRCCOPY
tpt1.x = .left
tpt1.y = .top
tpt2.x = .right
tpt2.y = .bottom
lRgn = CreateRectRgn(tpt1.x, tpt1.y, tpt2.x, tpt2.y)
End With
GetColorAdjustment lDC, CA
CA.caSize = Len(CA)
'CA.caBrightness = -100
CA.caColorfulness = 100
If GetStretchBltMode(lDC) <> HALFTONE Then
SetStretchBltMode lDC, HALFTONE
End If
SetColorAdjustment lDC, CA
Call StartZooming(Zoom)
End Sub
Private Sub StartZooming(Optional ByVal Zoom As Long)
Dim tZoomedRect As Rect
Dim tLeftRgn As Rect
Dim tTopRgn As Rect
Dim tRightRgn As Rect
Dim tBottomRgn As Rect
Dim tCurPos As POINTAPI
Dim h As Long
Dim lActiveProcessID As Long
Dim lRgn1 As Long
Dim lRgn2 As Long
Dim lRgn3 As Long
Dim lRgn4 As Long
Dim bZoomingIN As Boolean
On Error Resume Next
Do
GetCursorPos tCurPos
Call GetWindowThreadProcessId _
(WindowFromPoint(tCurPos.x, tCurPos.y), lActiveProcessID)
If lActiveProcessID <> GetCurrentProcessId Then
bZoomingIN = False
GoTo MaxZoomReached
End If
If Not ActiveSheet Is oChart.Parent Then
bZoomingIN = False
GoTo MaxZoomReached
End If
If Application.ActiveWindow.ScrollColumn <> lInitScrCol _
Or Application.ActiveWindow.ScrollRow <> lInitScrRow Then
bZoomingIN = False
InvalidateRect 0, 0, 0
lInitScrCol = ActiveWindow.ScrollColumn
lInitScrRow = ActiveWindow.ScrollRow
With tInitRect
tInitRect = GetChartRect(oChart)
.left = tInitRect.left - 4
.top = .top - 4
.right = .right + 2
.bottom = .bottom + 2
End With
bZoomingIN = False
GoTo MaxZoomReached
End If
Zoom = oChart.Parent.OLEObjects("cbZoomFactor").Object.Value - 100
Sleep 10
If CBool(PtInRect(tInitRect, tCurPos.x, tCurPos.y)) Then
If i >= Zoom Then GoTo MaxZoomReached
bZoomingIN = True
With tInitRect
StretchBlt _
lDC, .left - i, _
.top - i, _
(.right - .left) + (i * 2), (.bottom - .top) + (i * 2), _
lMemoryDC, 0, 0, (.right - .left), _
(.bottom - .top), SRCCOPY
SetRect tZoomedRect, .left - Zoom, .top - Zoom, _
.right + Zoom, .bottom + Zoom
End With
ElseIf Not CBool(PtInRect(tZoomedRect, tCurPos.x, tCurPos.y)) Then
i = 0
If bZoomingIN Then
bZoomingIN = False
Do
StretchBlt _
lDC, tZoomedRect.left + h, _
tZoomedRect.top + h, _
(tZoomedRect.right - tZoomedRect.left) - ((h) * 2), _
(tZoomedRect.bottom - tZoomedRect.top) - ((h) * 2), _
lMemoryDC, 0, 0, (tInitRect.right - tInitRect.left), _
(tInitRect.bottom - tInitRect.top), SRCCOPY
With tLeftRgn
.left = tZoomedRect.left + h
.top = tZoomedRect.top + h + 2
.right = tZoomedRect.right - h
.bottom = tZoomedRect.top + h - 2
lRgn1 = CreateRectRgn _
(.left, .top, .right, .bottom)
End With
With tTopRgn
.left = tZoomedRect.left + h
.top = tZoomedRect.bottom - h - 2
.right = tZoomedRect.right - h
.bottom = tZoomedRect.bottom - h + 2
lRgn2 = CreateRectRgn _
(.left, .top, .right, .bottom)
End With
With tRightRgn
.left = tZoomedRect.left + h - 2
.top = tZoomedRect.top + h
.right = tZoomedRect.left + h + 2
.bottom = tZoomedRect.bottom - h
lRgn3 = CreateRectRgn _
(.left, .top, .right, .bottom)
End With
With tBottomRgn
.left = tZoomedRect.right - h - 2
.top = tZoomedRect.top + h
.right = tZoomedRect.right - h + 2
.bottom = tZoomedRect.bottom - h
lRgn4 = CreateRectRgn _
(.left, .top, .right, .bottom)
End With
RedrawWindow 0, 0, lRgn1, RDW_INVALIDATE + RDW_ALLCHILDREN
RedrawWindow 0, 0, lRgn2, RDW_INVALIDATE + RDW_ALLCHILDREN
RedrawWindow 0, 0, lRgn3, RDW_INVALIDATE + RDW_ALLCHILDREN
RedrawWindow 0, 0, lRgn4, RDW_INVALIDATE + RDW_ALLCHILDREN
DoEvents
h = h + 1
If bEnableZooming = False Then bZoomingIN = True: Exit Sub
Loop Until h > Zoom
RedrawWindow 0, 0, lRgn, RDW_INVALIDATE + RDW_ALLCHILDREN
Call StartZooming(Zoom)
End If
End If
i = i + 1
ReleaseDC lDC, 0
MaxZoomReached:
DoEvents
Loop Until bEnableZooming = False
ReleaseDC lDC, 0
End Sub
Private Function ScreenDPI(bVert As Boolean) As Long
Static lDPI(1), lDC
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / PointsPerInch
End Function
Private Function GetChartRect(ByVal Chart As ChartObject) As Rect
Dim tpt1 As POINTAPI
Dim tpt2 As POINTAPI
Dim OWnd As Window
On Error Resume Next
Set OWnd = Chart.Parent.Parent.Windows(1)
With Chart
GetChartRect.left = _
PTtoPX((.left) * OWnd.Zoom / 100, 0) _
+ OWnd.PointsToScreenPixelsX(0)
GetChartRect.top = _
PTtoPX((.top) * OWnd.Zoom / 100, 1) _
+ OWnd.PointsToScreenPixelsY(0)
GetChartRect.right = _
PTtoPX((.Width) * OWnd.Zoom / 100, 0) _
+ GetChartRect.left
GetChartRect.bottom = _
PTtoPX((.Height) * OWnd.Zoom / 100, 1) _
+ GetChartRect.top
End With
End Function
Private Sub DummyMacro()
End Sub
Upvote
0
Jaafar
I luv the routine - I can definitely use this. Cool - thanks a bunch.
Having said that - My original request was how to Zoom in on a specific area of the chart - But I guess that was not clear - so say in you example where the Y value is >100 and <300 and the X axis is >5 and < 10 - so only that region of area of the chart is shown. In other words I want an chart where the Axes are changed and only the corresponding values are displayed.
PS Your comment about religion is so true.
I luv the routine - I can definitely use this. Cool - thanks a bunch.
Having said that - My original request was how to Zoom in on a specific area of the chart - But I guess that was not clear - so say in you example where the Y value is >100 and <300 and the X axis is >5 and < 10 - so only that region of area of the chart is shown. In other words I want an chart where the Axes are changed and only the corresponding values are displayed.
PS Your comment about religion is so true.
Upvote
0
Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- Windows
Rasm.
My bad. Your original request was in fact clear. I just didn't read it properly. I see what you mean.I like the idea to be able to zoom parts of the chart using the mouse.I'll take another look and if anything comes up i'll post back.
Upvote
0
AlphaFrog
MrExcel MVP
- Joined
- Sep 2, 2009
- Messages
- 16,561
If you're not married to the draw a box type of zoom, perhaps a a user form with slider controls would suit your needs.
Blow is very simple code (for illustration purposes) for a userform with two scroll bar slider controls to zoom and scroll the X axis. The user form also has two command buttons, and two labels irrelevant to the code. Again, it's proof-of-concept type code rather than a bullet-proof-ready-for-public-use application.
User Form name:
FormZoomChart
Scroll bar 1: Sets the "zoom" of scaling on the X axis
scrZoomX
Scroll bar 2: Sets the left-right display range of the x-axis once the zoom is increased greater than 100%
scrRangeX
Command Button 1: Resets the two scroll bars and the chart
cmbResetChart
Command Button 2: Closes the user form and resets the Chart on close.
cmbClose
There is no error trapping in the code. It assumes you have an XY Scatter chart selected when you initialize the user form. It's expecting a chart with values on the x axis and not a categorical x-axis.
I'm sure you could add many other features like two additional scroll bars for the Y axis, the ability to scroll a category-type x-axis instead of a values-type x-axis, etc.
Blow is very simple code (for illustration purposes) for a userform with two scroll bar slider controls to zoom and scroll the X axis. The user form also has two command buttons, and two labels irrelevant to the code. Again, it's proof-of-concept type code rather than a bullet-proof-ready-for-public-use application.
User Form name:
FormZoomChart
Scroll bar 1: Sets the "zoom" of scaling on the X axis
scrZoomX
Scroll bar 2: Sets the left-right display range of the x-axis once the zoom is increased greater than 100%
scrRangeX
Command Button 1: Resets the two scroll bars and the chart
cmbResetChart
Command Button 2: Closes the user form and resets the Chart on close.
cmbClose
Code:
Public MajUnit As Variant, MajTickCount As Long
Public MaxScale As Variant, MinScale As Variant
Public ScaleRange As Variant
Private Sub UserForm_Initialize()
With ActiveChart.Axes(xlCategory)
' Original settings
MaxScale = .MaximumScale
MinScale = .MinimumScale
ScaleRange = .MaximumScale - .MinimumScale
MajUnit = .MajorUnit
MajTickCount = ScaleRange / MajUnit
' Zoom X scroll bar
scrZoomX.Max = MajTickCount
scrZoomX.Min = 1
scrZoomX.SmallChange = 1
scrZoomX.LargeChange = 1
scrZoomX.Value = 1
' Range X scroll bar
scrRangeX.Max = MajTickCount
scrRangeX.Min = MajTickCount
scrRangeX.SmallChange = 1
scrRangeX.LargeChange = 1
scrRangeX.Value = MajTickCount
End With
End Sub
Private Sub scrRangeX_Change()
With ActiveChart.Axes(xlCategory)
.MinimumScale = MinScale + (MajUnit * (MajTickCount - scrRangeX.Value))
.MaximumScale = .MinimumScale + (MajUnit * (MajTickCount - scrZoomX.Value + 1))
End With
End Sub
Private Sub scrZoomX_Change()
With ActiveChart.Axes(xlCategory)
.MaximumScaleIsAuto = False
.MaximumScale = .MinimumScale + (MajUnit * (MajTickCount - scrZoomX.Value + 1))
scrRangeX.Max = MajTickCount - scrZoomX.Value + 1
End With
End Sub
Private Sub cmbClose_Click()
cmbResetChart_Click
Unload FormZoomChart
End Sub
Private Sub cmbResetChart_Click()
With ActiveChart.Axes(xlCategory)
.MaximumScale = MaxScale
.MinimumScale = MinScale
.MajorUnit = MajUnit
End With
scrZoomX.Value = 1
scrRangeX.Value = MajTickCount
End SubThere is no error trapping in the code. It assumes you have an XY Scatter chart selected when you initialize the user form. It's expecting a chart with values on the x axis and not a categorical x-axis.
I'm sure you could add many other features like two additional scroll bars for the Y axis, the ability to scroll a category-type x-axis instead of a values-type x-axis, etc.
Upvote
0
Similar threads
- Question
