I'm trying to create a teleprompter by using Word VBA and Userform. I made it by dragging a Userform's label to the top every xxx millisecond to give the text scrolling effect.
My problem is the blinking screen as probably the code runs much faster than the graphic update.
Is there a way out to prevent the blinking screen?
EDIT:
Below is the code
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Dim i As Double
Dim dblScrollHeight As Double
Dim sglPause As Single, sglStart As Single
Dim dblEndPos As Double
If KeyAscii = 32 Then bolScroll = Not bolScroll
If bolScroll = True Then
dblEndPos = 50
dblScrollHeight = 0.1
sglPause = 0.0005 'Alter this number to adjust scroll speed.
i = dblCurrTop
Do
sglStart = Timer 'Set Start time.
Do
DoEvents
Loop Until Timer - sglStart > sglPause
i = i - dblScrollHeight
dblCurrTop = i
'Application.ScreenUpdating = False
Me.lblPrompter.Top = dblCurrTop
'Application.ScreenUpdating = True
If i + Me.lblPrompter.Height <= dblEndPos Then bolScroll = False
Loop Until bolScroll = False
End If
End Sub
Related
I'm trying to make a toggle button on a command bar but I'm coming across two problems 1) It keeps performing 'removebleed' rather than toggling between the two. 2) it doesn't show the button being toggled. First I've attached the menu button code then after the code for the button. Many thanks for any help, Jay
Set ToggleButton = oToolbar.Controls.Add(Type:=msoControlButton)
With ToggleButton
.DescriptionText = "Switch bleed on or off"
.Caption = "Bleed on/off"
.OnAction = "ToggleButton"
.Style = msoButtonCaption
End With
Sub ToggleButton()
Static Toggle As Boolean
If Toggle = True Then
With Application.CommandBars.ActionControl
.State = Not .State
End With
Toggle = False ' changes the variable so next time it unpresses the button and runs the other macro
AddBleed
Else
RemoveBleed
End If
End Sub
Sub AddBleed()
Dim WidthBleed As String
Dim HeightBleed As String
WidthBleed = 0.125 * 72
HeightBleed = 0.25 * 72
SWidth = ActivePresentation.PageSetup.SlideWidth
SHeight = ActivePresentation.PageSetup.SlideHeight
With Application.ActivePresentation.PageSetup
.SlideWidth = SWidth + WidthBleed
.SlideHeight = SHeight + HeightBleed
End With
End Sub
Sub RemoveBleed()
Dim WidthBleed As String
Dim HeightBleed As String
Dim SWidth As String
Dim SHeight As String
WidthBleed = 0.125 * 72
HeightBleed = 0.25 * 72
SWidth = ActivePresentation.PageSetup.SlideWidth
SHeight = ActivePresentation.PageSetup.SlideHeight
With Application.ActivePresentation.PageSetup
.SlideWidth = SWidth - WidthBleed
.SlideHeight = SHeight - HeightBleed
End With
End Sub
I needed to add the Toggle True to the 'Else' side
Sub ToggleButton()
Static Toggle As Boolean
If Toggle = True Then
With Application.CommandBars.ActionControl
.State = Not .State
End With
Toggle = False ' changes the variable so next time it unpresses the button and runs the other macro
RemoveBleed
Else
With Application.CommandBars.ActionControl 'unpresses the button
.State = Not .State
End With
Toggle = True 'changes the variable so next time it operates the other macro
AddBleed
End If
End Sub
I created a line graph in Visual Basic to show how many calories the user eats per day. However, my user requires me to include a scroll bar to scroll back and forward along the x-axis to view more days.
Unfortunately, I have never done anything like this before, and after looking through Stack Overflow and Googling, I cannot see any examples of anyone doing so.
Here is a screenshot of my graph so far:
And here is the code:
Cursor.Current = Cursors.WaitCursor
CalorieChartView = True
BurntChartView = False
NetChartView = False
Dim Series As Series = CalorieChart.Series(0)
'keeps track of if the chart is empty, starting as true
Dim empty As Boolean = True
'Clears the chart
Series.Points.Clear()
'Draws the chart in dark red
Series.Color = Color.DarkRed
'The legend text is changed
Series.LegendText = "Calories Consumed"
'For each of the past 8 days, a point is plotted with how many calories were eaten in that day
For i = -7 To 0
Series.Points.Add(User.GetCaloriesEaten(User.Username, Date.Now.AddDays(i)))
Series.Points(7 + i).AxisLabel = Date.Now.AddDays(i).ToString("dd/MM/yyyy")
'If any of the points are not 0
If User.GetCaloriesEaten(User.Username, Date.Now.AddDays(i)) <> 0 Then
'the chart is not empty
empty = False
End If
Next
HandleEmpty(empty)
Cursor.Current = Cursors.Default
I would appreciate any help.
If I understand your question you want to add a horizontal scroll bar to your graph. I have made some modification and new code to your code as for mock data purpose. Please refer the below code. You can get the idea by running this code separately.
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim blockSize As Integer = 10
Cursor.Current = Cursors.WaitCursor
CalorieChartView = True
BurntChartView = False
NetChartView = False
CalorieChart.Series.Clear()
Dim series = CalorieChart.Series.Add("My Series")
series.ChartType = SeriesChartType.Line
series.XValueType = ChartValueType.Int32
'keeps track of if the chart is empty, starting as true
Dim empty As Boolean = True
'Clears the chart
series.Points.Clear()
'Draws the chart in dark red
series.Color = Color.DarkRed
'The legend text is changed
series.LegendText = "Calories Consumed"
'For each of the past 8 days, a point is plotted with how many calories were eaten in that day
Dim sizeOfDayToDisplay As Int16 = 0
For i = 0 To 100
'Series.Points.Add(User.GetCaloriesEaten(User.Username, Date.Now.AddDays(i)))
'Series.Points(7 + i).AxisLabel = Date.Now.AddDays(i).ToString("dd/MM/yyyy")
''If any of the points are not 0
'If User.GetCaloriesEaten(User.Username, Date.Now.AddDays(i)) <> 0 Then
' 'the chart is not empty
' empty = False
'End If
' just for testing purpose.
series.Points.Add(getRandumNumber())
series.Points(i).AxisLabel = Date.Now.AddDays(i).ToString("dd/MM/yyyy")
' series.Points.AddXY(i, Date.Now.AddDays(i).ToString("dd/MM/yyyy"))
sizeOfDayToDisplay += 1
Next
'most new code added is below here
Dim chartArea = CalorieChart.ChartAreas(Series.ChartArea)
chartArea.AxisX.Minimum = 0
chartArea.AxisX.Maximum = sizeOfDayToDisplay
chartArea.CursorX.AutoScroll = True
chartArea.AxisX.ScaleView.Zoomable = True
chartArea.AxisX.ScaleView.SizeType = DateTimeIntervalType.Number
Dim position As Integer = 0
Dim size As Integer = blockSize
chartArea.AxisX.ScaleView.Zoom(position, size)
chartArea.AxisX.ScrollBar.ButtonStyle = ScrollBarButtonStyles.SmallScroll
chartArea.AxisX.ScaleView.SmallScrollSize = blockSize
'HandleEmpty(empty)
'Cursor.Current = Cursors.Default
End Sub
Public Function getRandumNumber() As Int16
Return CInt(Math.Floor((3500 - 1000 + 1) * Rnd())) + 1000
End Function
Based on this: How to scroll MS Chart along x-axis in vb.net, you can use:
Chart1.Series("LoadCell").Points.AddY(receivedData)
Chart1.ResetAutoValues()
If Chart1.Series("LoadCell").Points.Count >= 100 Then
Chart1.Series("LoadCell").Points.RemoveAt(0)
End If
It Auto scales the y axis as well as limiting the x axis to 100 by
removing the first entry when the entries exeed 100.
Is there a way to change the index value of a ActiveX Button that inserted onto a spreadsheet. I currently have four buttons and two are hidden and two are visible. I would like to re-order the them to not have a large gap between objects. I have some VBA code that runs when the document is opened to ensure that they are the right size and location. Because it loops through the OLEObjects Collection; it will not matter what order they are in on the spreadsheet they will always appear with a gap because of the index value in the OLE Object collection. Below is the code:
Private Sub Workbook_Open()
Application.ErrorCheckingOptions.EvaluateToError = False
ActiveWorkbook.Worksheets("SITE").Activate
Dim button As OLEObject
Dim name As String, top As Integer
top = 15
For Each button In ActiveWorkbook.Worksheets("SITE").OLEObjects
Debug.Print button.name & " " & button.ZOrder
name = button.name
If button.OLEType = xlButtonOnly And InStr(name, "btn") = 1 Then
With button
.Height = 21.75
.Width = 174.75
.Left = 1114.5
.top = top
End With
top = top + 30
End If
Next button
End Sub
If you give them proper names with an integer code in it reflecting their intended position (e.g.: "btn...01", "btn...02",...) then you could try this code (sorry for not being able to format it as code by now):
Private Sub Workbook_Open()
Application.ErrorCheckingOptions.EvaluateToError = False
ActiveWorkbook.Worksheets("SITE").Activate
Dim button As OLEObject
Dim name As String
Dim btnRnk As Long
For Each button In ActiveWorkbook.Worksheets("SITE").OLEObjects
name = button.name
If button.OLEType = xlButtonOnly And InStr(name, "btn") = 1 Then
btnRnk = CLng(Right(name,2))
With button
.Height = 21.75
.Width = 174.75
.Left = 1114.5
.top = 15 + (btnRank - 1) * 30
End With
End If
Next button
End Sub
I coded a function in VBA for Excel to assign a letter and color code to the font of the cell, depending of 2 differents values.
Basically, the function has 2 parameters for the compared values and the cell that will contains the letter and color. I use the webdings font, so the letter will look like a symbol.
I know this could be done with conditionnal format but this function will be call in my workbook lots of time, insides multiples sheets, I found out it would be easier to maintain over time with a VBA function and put everything at the same place.
PROBLEM : The use of "currentCell.Font.Color" is slowing down Excel terrably. Even if I initialized the constant color when the workbook open, used some optimization tricks I found on the web, etc.
Do you know why the change of font color is slowing down Excel so much ?
Regards,
Const DefUnderBudget = 0.95
Const DefOverBudget = 1.05
Const FavMoyen = 0.98
Const DefMoyen = 1.02
Const FavOverBudget = 1.05
Const FavUnderBudget = 0.95
Const SMALL = "="
Const BIG = "n"
Global RED As Long
Global BLUE As Long
Global YELLOW As Long
Sub InitColors()
RED = RGB(218, 150, 148)
BLUE = RGB(149, 179, 215)
YELLOW = RGB(243, 202, 38)
End Sub
Function setPerformanceIndicator(actualVal As Double, compVal As Double, currentCell As Range) As String
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
If actualVal < compVal * DefUnderBudget Then
currentCell.Font.Color = RED
setPerformanceIndicator = BIG
ElseIf actualVal < compVal * FavMoyen Then
currentCell.Font.Color = YELLOW
setPerformanceIndicator = SMALL
ElseIf actualVal > compVal * FavOverBudget Then
currentCell.Font.Color = BLUE
setPerformanceIndicator = BIG
Else
setPerformanceIndicator = vbNullString
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Function
Technically, Windows is probably having to refresh the screen multiple times.
Before multiple calls, run
Application.ScreenUpdating = False
Afterwards, run
Application.ScreenUpdating = True
I'm very new to programming and vb.net, trying to self teach more so as a hobby, as I have an idea for a program that I would find useful, but I am having trouble getting past this issue and I believe it is to do with the timer.
I have a form of size.(600,600) with one button of size.(450,150) that is set location(100,50) on the form. When clicked I want to move down it's own height, then add a new button in it's place. The code included below works as desired for the first two clicks, but on the third click the button keeps moving and the autoscroll bar extends. I initially thought it was the autoscroll function or the location property, but realised that as the button keeps moving, the timer hasn't stopped. I am aware that the code is probably very clunky in terms of achieving the outcome, and that there are a few lines/variables that are currently skipped over by the compiler (these are from older attempts to figure this out).
I have looked around and can't find the cause of my problem. Any help would be greatly appreciated. Apologies if the code block looks messy - first go.
Public Class frmOpenScreen
Dim intWButtons, intCreateButtonY, intCreateButtonX 'intTimerTick As Integer
Dim arrWNames() As String
Dim ctrlWButtons As Control
Dim blnAddingW As Boolean
Private Sub btnCreateW_Click(sender As System.Object, e As System.EventArgs) Handles btnCreateW.Click
'Creates new Button details including handler
Dim strWName, strWShort As String
Dim intCreateButtonY2 As Integer
Static intNumW As Integer
Dim B As New Button
strWName = InputBox("Please enter the name name of the button you are creating. Please ensure the spelling is correct.", "Create W")
If strWName = "" Then
MsgBox("Nothing Entered.")
Exit Sub
End If
strWShort = strWName.Replace(" ", "")
B.Text = strWName
B.Width = 400
B.Height = 150
B.Font = New System.Drawing.Font("Arial Narrow", 21.75)
B.AutoSizeMode = Windows.Forms.AutoSizeMode.GrowAndShrink
B.Anchor = AnchorStyles.Top
B.Margin = New Windows.Forms.Padding(0, 0, 0, 0)
'Updates Crucial Data (w name array, number of w buttons inc Create New)
If intNumW = 0 Then
ReDim arrWNames(0)
Else
intNumW = UBound(arrWNames) + 1
ReDim Preserve arrWNames(intNumW)
End If
arrWNames(intNumW) = strWShort
intNumW = intNumW + 1
intWButtons = WButtonCount(intWButtons) + 1
'updates form with new button and rearranges existing buttons
intCreateButtonY = btnCreateW.Location.Y
intCreateButtonX = btnCreateW.Location.X
‘intTimerTick = 0
tmrButtonMove.Enabled = True
‘Do While intTimerTick < 16
‘ 'blank to do nothing
‘Loop
'btnCreateW.Location = New Point(intCreateButtonX, intCreateButtonY + 150)
B.Location = New Point(intCreateButtonX, intCreateButtonY)
Me.Controls.Add(B)
B.Name = "btn" & strWShort
intCreateButtonY2 = btnCreateW.Location.Y
If intCreateButtonY2 > Me.Location.Y Then
Me.AutoScroll = False
Me.AutoScroll = True
Else
Me.AutoScroll = False
End If
'MsgBox(intCreateButtonY)
End Sub
Function WButtonCount(ByRef buttoncount As Integer) As Integer
buttoncount = intWButtons
If buttoncount = 0 Then
Return 1
End If
Return buttoncount
End Function
Public Sub tmrButtonMove_Tick(sender As System.Object, e As System.EventArgs) Handles tmrButtonMove.Tick
Dim intTimerTick As Integer
If intTimerTick > 14 Then
intTimerTick = 0
End If
If btnCreateW.Location.Y <= intCreateButtonY + 150 Then
btnCreateW.Top = btnCreateW.Top + 10
End If
intTimerTick += 1
If intTimerTick = 15 Then
tmrButtonMove.Enabled = False
End If
End Sub
End Class
So my current understanding is that the tick event handler should be increasing the timertick variable every time it fires, and that once it has hits 15 it should diable the timer and stop the button moving, but it is not doing so.
Thanks in advance.
IntTimerTick is initialized to 0 at the beginning of every Tick event. This won't happen if you declare it to be static:
Static Dim intTimerTick As Integer