Clickable Chart in excel - vba

I want to create a pie chart with linked sheet but when I am clicking on the graph I am getting some error, "Compile error Argument not optional" on the "WorkSheetFunction.Index" line of the code.
I am beginner in VBA coding.. Please help
this is my code
xl page
ThisWorkbook module
Dim ChartObjectClass As New Class1
Dim ChartObjectClass2 As New Class2
Private Sub Workbook_Open()
Set ChartObjectClass.ChartObject = Worksheets(1).ChartObjects(1).Chart
Set ChartObjectClass2.ChartObject = Worksheets(1).ChartObjects(2).Chart
End Sub
Class module
Option Explicit
Public WithEvents ChartObject As Chart
Private Sub ChartObject_MouseUp(ByVal Button As Long, ByVal Shift As Long, _
ByVal x As Long, ByVal y As Long)
Dim ElementID As Long, Arg1 As Long, Arg2 As Long
Dim myX As Variant, myY As Double
With ActiveChart
.GetChartElement x, y, ElementID, Arg1, Arg2
If ElementID = xlSeries Or ElementID = xlDataLabel Then
If Arg2 > 0 Then
myX=WorksheetFunction.Index(.SeriesCollection(Arg1).XValues.Arg2)
myY=WorksheetFunction.Index(.SeriesCollection(Arg1).Values.Arg2)
MsgBox "Series" & Arg1 & vbCrLf & """" & .SeriesCollection(Arg1)_
.Name & """" & vbCrLf & "Point" & Arg2 & vbCrLf & _
"x= " & myX & vbCrLf & "y= " & myY
Range("A1").Select
On Error Resume Next
Sheets("Series" & myX & "Detail").Select
Range("A1").Select
On Error GoTo 0
End If
End If
End With
End Sub

In your case, Index requires two arguments. The first argument specifies the array of values from which to return a value. The second argument specifies the nth element from the array to return.
myX = WorksheetFunction.Index(.SeriesCollection(Arg1).XValues, Arg2)
myY = WorksheetFunction.Index(.SeriesCollection(Arg1).Values, Arg2)
By the way, you can also dispense with the use of WorksheetFunction.Index...
myX = .SeriesCollection(Arg1).XValues()(Arg2)
myY = .SeriesCollection(Arg1).Values()(Arg2)

Related

Programmatically change all reports

I have a function that logs when users run a report. It is set to run "on open". Is there a way to change the on open for all reports and forms at once?
This code loops through all forms:
Public Sub DoChangeModules()
Dim dstApp As Application
Dim dstDB As Database
Dim AO As Document
Set dstApp = Application
Set dstDB = dstApp.CurrentDb
' iterate forms's modules and insert code
Dim f As Form
Dim M As Module
Debug.Print "Modifying Modules:"
Debug.Print "Forms:"
For Each AO In dstDB.Containers("Forms").Documents
dstApp.DoCmd.OpenForm AO.Name, acViewDesign
Set f = dstApp.Forms(AO.Name)
Set M = f.Module
ProccessModule M
Set f = Nothing
dstApp.DoCmd.Close acForm, AO.Name, acSaveYes
Next AO
End Sub
Public Sub ProccessModule(M As Module)
Dim numLine As Long
Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long
Debug.Print , , M.Name
' insert variable declaration
M.AddFromString "Private testVar As variant ' test addition of module-level variable"
' locate or create Load event procedure
StartLine = 0
StartColumn = 0
EndLine = 0
EndColumn = 0
If Not M.Find(" Form_Open(", StartLine, StartColumn, EndLine, EndColumn) Then
numLine = M.CreateEventProc("Open", "Form")
End If
numLine = M.ProcBodyLine("Form_Open", 0) ' 0 here is vbext_pk_Proc
M.InsertLines numLine + 1, "" & _
" ' Call of global function that logs user" & vbNewLine & _
" doLogUser testVar " & vbNewLine & _
" ' that function called with local module variable "
End Sub

VBA create log file

Hello can you help me please with code in VBA ? I would like create a log file from text in cells ("C2" and "C3 " + date and time ) when I press button "zadat" Thank you
My code for implementation is:
Module 1
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub zadat()
Dim reg, check As String
Dim i, j, done As Integer
reg = Cells(2, 3).Value
check = Cells(4, 3).Value
If check = "True" Then
i = 2
j = 1
done = 0
Do While Sheets("data").Cells(i, j) <> ""
If Sheets("data").Cells(i, j) = reg Then
vytisteno = ZkontrolovatAVytiskoutSoubor()
done = Sheets("data").Cells(i, j + 3)
done = done + 1
Sheets("data").Cells(i, j + 3) = done
Exit Do
End If
i = i + 1
Loop
Else
MsgBox ("Opravit, špatný štítek!!!")
End If
Cells(3, 3) = ""
Cells(3, 3).Select
ActiveWindow.ScrollRow = Cells(1, 1).row
End Sub
Module 2:
Option Explicit
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Function PrintThisDoc(formname As Long, FileName As String)
On Error Resume Next
Dim x As Long
x = ShellExecute(formname, "Print", FileName, 0&, 0&, 3)
End Function
Public Function ZkontrolovatAVytiskoutSoubor() As Boolean
Dim printThis
Dim strDir As String
Dim strFile As String
strDir = "W:\Etikety\Štítky\Krabice\Testy"
strFile = Range("C2").Value & ".lbe"
If Not FileExists(strDir & "\" & strFile) Then
MsgBox "soubor neexistuje!"
ZkontrolovatAVytiskoutSoubor = False
Else
printThis = PrintThisDoc(0, strDir & "\" & strFile)
ZkontrolovatAVytiskoutSoubor = True
End If
End Function
Private Function FileExists(fname) As Boolean
'Returns TRUE if the file exists
Dim x As String
x = Dir(fname)
If x <> "" Then FileExists = True _
Else FileExists = False
End Function
If you don't want to use FSO, there is a simple solution using only VBA statements: Open, Print # and Close:
Sub Log2File(Filename As String, Cell1, Cell2)
Dim f As Integer
f = FreeFile
Open Filename For Append Access Write Lock Write As #f
Print #f, Now, Cell1, Cell2
Close #f
End Sub
I've put the filename and the cells refs as arguments of the sub for re-usability purpose. I also use default (local) formatting, but this can be easily changed.
Note that you don't have to check for existence of the file, it will be created if it doesn't exist.
Try this. Below code will create a new log file every time
Public Function LogDetails()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim logFile As Object
Dim logFilePath As String
Dim logFileName As String
'Replace 'TestLog' with your desired file name
logFileName = "TestLog" & ".txt"
myFilePath = "C:\Users\..\Desktop\" & logFileName 'Modify the path here
If fso.FileExists(myFilePath) Then
Set logFile = fso.OpenTextFile(myFilePath, 8)
Else
' create the file instead
Set logFile = fso.CreateTextFile(myFilePath, True)
End If
logFile.WriteLine "[" & Date & " " & Time & "] " & Worksheet("yoursheetnamehere").Cells(2, 3) & " " & Worksheet("yoursheetnamehere").Cells(3, 3)
logFile.Close ' close the file
End Function

Range.Validation method occure 1004 error

I use VBA to add validation to a cell wich depends from other cell where is another validation. Formula in all this validation has named ranges.
What I tried:
-place values in the cell which this validation depends;
-recalculate book after placing values
-i debug all code and there are no errors in it (error occur only in this code)
Here is a code.
Public Sub MakeValidation(ByVal ValidString As String, ByVal ValidAddress As String, ByVal ValidSheet As String, ByRef WB As Workbook)
Dim n As Long
NewStart:
Err.Clear
n = n + 1
If n = 10 Then Exit Sub
On Error GoTo NewStart
WB.Worksheets(ValidSheet).Range(ValidAddress).Validation.Delete
Debug.Print "'" & Err.Number; "'" & " " & Err.Description
On Error GoTo NewStart
If CheckValidation(ValidAddress, ValidSheet, WB) = True Then
WB.Worksheets(ValidSheet).Range(ValidAddress).Validation.Delete
End If
WB.Worksheets(ValidSheet).Range(ValidAddress).Validation.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=ValidString
End Sub
Have u any ideas why "On error goto NewStart" doesn't work?
And why when i run code by pressing "F5" it doesn't works but when i debug code it works?
Thank's a lot for your answer.
My english is not very good. Sorry for mistakes.
This Resume should be enough to avoid your issue (as explained in comments) :
Public Sub MakeValidation(ByVal ValidString As String, ByVal ValidAddress As String, ByVal ValidSheet As String, ByRef WB As Workbook)
Dim n As Long
NewStart:
Err.Clear
n = n + 1
If n = 10 Then Exit Sub
Resume KeepRunning
KeepRunning:
On Error GoTo NewStart
WB.Worksheets(ValidSheet).Range(ValidAddress).Validation.Delete
Debug.Print "'" & Err.Number; "'" & " " & Err.Description
If CheckValidation(ValidAddress, ValidSheet, WB) = True Then
WB.Worksheets(ValidSheet).Range(ValidAddress).Validation.Delete
End If
WB.Worksheets(ValidSheet).Range(ValidAddress).Validation.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=ValidString
End Sub
I also get rid of the second On Error GoTo NewStart which was useless as you didn't "set off" the previous statement with On Error GoTo 0

Vertical Text on Button control VB

One of my buttons on a form needs to show vertical text like that:
S
T
O
P
I found solutions involving overriding Paint that seems too complicated for such a simple task. I tried this:
Private Sub LabelStopButton()
Dim btTitle As String = "S" & vbCrLf & "T" & vbCrLf & "O" & vbCrLf & "P" & vbCrLf
Me.btnStop.Text = btTitle
End Sub
and also tried replacing vbCrLf with: vbCr, vbLf, Environment.NewLine - to no avail, same result: only the first letter "S" is showing on the button. See image.
Using Visual Studio 2008 (this is an app for an old WinCE 6.0 device).
Any advice?
Thanks!
This is a duplcate of an existing question
See https://stackoverflow.com/a/7661057/2319909
Converted code for reference:
You need to set the button to allow multiple lines. This can be achieved with following P/Invoke code.
Private Const BS_MULTILINE As Integer = &H2000
Private Const GWL_STYLE As Integer = -16
<System.Runtime.InteropServices.DllImport("coredll")> _
Private Shared Function GetWindowLong(hWnd As IntPtr, nIndex As Integer) As Integer
End Function
<System.Runtime.InteropServices.DllImport("coredll")> _
Private Shared Function SetWindowLong(hWnd As IntPtr, nIndex As Integer, dwNewLong As Integer) As Integer
End Function
Public Shared Sub MakeButtonMultiline(b As Button)
Dim hwnd As IntPtr = b.Handle
Dim currentStyle As Integer = GetWindowLong(hwnd, GWL_STYLE)
Dim newStyle As Integer = SetWindowLong(hwnd, GWL_STYLE, currentStyle Or BS_MULTILINE)
End Sub
Use it like this:
MakeButtonMultiline(button1)
I created vertical text on the button with the following codes :
CommandButton1.Caption = "F" & Chr(10) & "I" & Chr(10) & "L" & Chr(10) & "T" & Chr(10) & "E" & Chr(10) & "R" & Chr(10)
Source of userform

VBA: How do I really stop Application.onTime()?

I have already read some questions/threads (e.g. this and this) about how to stop the VBA Application.OnTime procedure, but I just can't get it to stop!
I am using it to pull some data every x seconds. I understand that when I call the OnTime() method I need to pass to it the same time value that was used to schedule the event.
I have also tried to introduce multiple commands (that try to cause an error for example) to stop the execution but it still doesn't work! The program just keeps running... This is how my code looks:
In Worksheet code I have:
Public TimerActive As Boolean
Public tick As String
Public idx As Long
Public counter As Long
Public Sub UpdateOff_Click()
TimerActive = False
tick = "Off"
counter = 1
idx = 1
Call StopTimer(idx, counter, tick, TimerActive)
End ' force quit??
End Sub
Public Sub UpdateOn_Click()
TimerActive = True
tick = "live"
counter = 1
idx = 1
Call StartTimer(idx, counter, tick, TimerActive)
End Sub
and in a separate module I have:
Public fireTime As Date
Sub StartTimer(ByVal idx As Long, ByVal counter As Long, ByVal tick As String, ByVal TimerActive As Boolean)
fireTime = Now + TimeValue("00:00:05")
sMacro = " 'pullData " & idx & " , " & counter & ", " & Chr(34) & tick & Chr(34) & ", " & TimerActive & "'"
Application.OnTime EarliestTime:=fireTime, Procedure:=sMacro, Schedule:=True
End Sub
Sub StopTimer(ByVal idx As Long, ByVal counter As Long, ByVal tick As String, ByVal TimerActive As Boolean)
sMacro = "cause error" ' cause an error (by giving false sub name so program stops?
Application.OnTime EarliestTime:=fireTime, Procedure:=sMacro, Schedule:=False
End
End Sub
Public Sub pullData(ByVal idx As Long, ByVal counter As Long, ByVal tick As String, ByVal TimerActive As Boolean)
DoEvents
If TimerActive = True Then
' pull the data do some stuff, print the data, etc...
idx = idx + 1
counter = counter + 1
tick = tick + " ."
If counter = 6 Then
counter = 1
tick = "live"
End If
Call startTimer(idx, counter, tick, TimerActive)
End If
End Sub
I understand that I may have introduced a few extra measures to stop the execution but none seem to work!
It's because your start & stop routines are referring to different macros. Define sMacro as Public, then it will work
Public sMacro As String
Public fireTime As Date
Sub startTimer(ByVal idx As Long, ByVal counter As Long, ByVal tick As String, ByVal TimerActive As Boolean)
fireTime = Now + TimeValue("00:00:05")
sMacro = " 'pullData " & idx & " , " & counter & ", " & Chr(34) & tick & Chr(34) & ", " & TimerActive & "'"
Application.OnTime EarliestTime:=fireTime, Procedure:=sMacro, Schedule:=True
End Sub
Sub StopTimer(ByVal idx As Long, ByVal counter As Long, ByVal tick As String, ByVal TimerActive As Boolean)
Application.OnTime EarliestTime:=fireTime, Procedure:=sMacro, Schedule:=False
End Sub