I'm building my first user interface in VBA on Microsoft Access.
I am trying to get the .Left variable to show up in the drop down selection (library?).
The only thing that pops up is LeftPadding, which I'm pretty sure that isn't what I need. Why am I not able to declare the Left position of the rectangles?
Is there another type of variable that I should be using to declare the position of rectangles?
My follow up issue, if I'm doing that correctly, is about a nested If statement. I'm trying to calculate whether a newly visible rectangle's position + its dimensions exceeds the Left position of an already visible rectangle, and if so, position it elsewhere.
Dim ctl As Control
For Each ctl In [Forms]![frmBuilder]
If Left(ctl.Name, 3) = "box" And Box1.Visible = True Then
If ctl.Visible = True Then
NextCaseNum = Int(Right(ctl.Name, (Len(ctl.Name)) - 3) + 1)
NextCasePosition = (ctl.lef + ctl.Width) + 1440 / 60
NextCaseName = "box" & NextCaseNum
Else
CurCaseLeft = ctl.Left
CurCaseWidth = ctl.Width
CurCaseHeight = ctl.Height
With ctl
.Top = UprightBottom - HInch
.Left = NextCasePosition
.Width = WInch
.Height = HInch
.Visible = True
End With
If CurCaseLeft + CurCaseWidth > Upright2.Left Then
With Beam1
.Top = (((5.5 + 6) * 60) + Box1.Top) / 1440
.Left = Upright1.Left
.Height = (5.5 * 60) / 1440
.Width = ((4 * 60) / 1440) + Upright2.Left - Upright1.Left
.Visible = True
End With
End If
I think the problem lies with CurCaseLeft and CurCaseWidth, because I don't know how to define them in the function due to the current box's ctl.Left not showing up.
Do I have to separate the nested If statement in to a different function and call that function from the current function?
Try to be more explicit:
Dim ctl As Control
Dim rct As Rectangle
For Each ctl In [Forms]![frmBuilder]
If Left(ctl.Name, 3) = "box" And Box1.Visible = True Then
If ctl.Visible = True Then
Set rct = ctl
NextCaseNum = Int(Right(rct.Name, (Len(rct.Name)) - 3) + 1)
NextCasePosition = (rct.Left + rct.Width) + 1440 / 60
Related
I'm making a custom winforms button in VB.Net with rounded edges and other features. I create a path using various inputs defined by the user and draw and fill it using pens and brushes.
When I call e.Graphics.FillEllipse(Brush1, Rect1) and e.Graphics.DrawEllips(Pen1, Rect1) it just works fine without any problems, but when I try e.Graphics.FillPath(Brush1, OuterPath) and e.Graphics.DrawPath(Pen1, OuterPath) it doesn't work at all. I get this error:
ArgumentException: The parameter is not valid
I tried giving the right types of each variable used in the process and not letting the compiler decide, creating more variables to calculate and manage the inputs individually to not make all the calculations in the inputs of each function, which makes my work easier honestly, and even using the CType function in the inputs of each function to make sure that the function understands what I want as inputs. But everything failed and I don't know what to do next to fix the issue.
Here is the code:
Private Sub MetaniumButton_Paint(sender As Object, e As System.Windows.Forms.PaintEventArgs) Handles Me.Paint
Dim PathWidth As Integer = Width - BorderSize / 2
Dim PathHeight As Integer = Height - BorderSize / 2
_Roundnes = RoundnesMemory
If PathHeight < Roundenes.Height Then
_Roundnes.Height = PathHeight - 1
End If
If PathWidth < Roundenes.Width Then
_Roundnes.Width = PathWidth - 1
End If
e.Graphics.SmoothingMode = Drawing2D.SmoothingMode.AntiAlias
Dim OuterPath As New GraphicsPath
Dim Rec1 As Rectangle = New Rectangle(CType(BorderSize / 2, Int32), CType(BorderSize / 2, Int32), CType(_Roundnes.Width, Int32), CType(_Roundnes.Height, Int32))
Dim Rec2 As Rectangle = New Rectangle(PathWidth - _Roundnes.Width, BorderSize / 2, _Roundnes.Width, _Roundnes.Height)
Dim Rec3 As Rectangle = New Rectangle(PathWidth - _Roundnes.Width, PathHeight - _Roundnes.Height, _Roundnes.Width, _Roundnes.Height)
Dim Rec4 As Rectangle = New Rectangle(BorderSize / 2, PathHeight - _Roundnes.Height, _Roundnes.Width, _Roundnes.Height)
OuterPath.StartFigure()
OuterPath.AddLine(CInt(_Roundnes.Width / 2 + BorderSize / 2), CInt(BorderSize / 2), CInt(PathWidth - _Roundnes.Width / 2), CInt(BorderSize / 2))
OuterPath.AddArc(Rec1, 180.0, 90.0) ' Here is the problem and it could probably in any AddArc Function i used
OuterPath.AddLine(PathWidth, CInt(_Roundnes.Height / 2 + BorderSize / 2), PathWidth, CInt(PathHeight - _Roundnes.Height / 2))
OuterPath.AddArc(Rec2, -90, 90)
OuterPath.AddLine(CInt(_Roundnes.Width / 2 + BorderSize / 2), PathHeight, CInt(PathWidth - _Roundnes.Width / 2), PathHeight)
OuterPath.AddArc(Rec3, 0, 90)
OuterPath.AddLine(CInt(BorderSize / 2), CInt(_Roundnes.Height / 2), CInt(BorderSize / 2), CInt(PathHeight - _Roundnes.Height / 2))
OuterPath.AddArc(Rec4, 90, 90)
OuterPath.CloseFigure()
e.Graphics.FillPath(Brush1, OuterPath)
e.Graphics.DrawPath(Pen1, OuterPath)
Dim LabelCount As Integer = 0
For Each l As Label In Controls
LabelCount += 1
Next
Dim TextPlace As New Label With {.Name = "TextLabel",
.Text = Text,
.AutoEllipsis = True,
.Size = New Size(Width -
Margin.Left + Margin.Right + 2 * _Roundnes.Width) / 2, Height - (Margin.Top + Margin.Bottom + 2 * _Roundnes.Height) / 2),
.TextAlign = _TextAlign,
.ForeColor = _FontColor,
.BackColor = _MetaniumBackColor,
.Location = New Point((Width - .Width) / 2, (Height - .Height) / 2)}
AddHandler TextPlace.TextChanged, AddressOf MetaniumButton_TextChanged
AddHandler Me.TextChanged, AddressOf MetaniumButton_TextChanged
Controls.Add(TextPlace)
T += 1
If LabelCount <= 0 Then
0: For Each l As Label In Controls
If l.Name = "TextLabel" Then
l.Text = Text
l.AutoEllipsis = True
l.Size = New Size(Width - (Margin.Left + Margin.Right + 2 * _Roundnes.Width) / 2, Height - (Margin.Top + Margin.Bottom + 2 * _Roundnes.Height) / 2)
l.TextAlign = _TextAlign
l.ForeColor = _FontColor
l.BackColor = _MetaniumBackColor
l.Location = New Point((Width - l.Width) / 2, (Height - l.Height) / 2)
End If
Next
ElseIf LabelCount = 1 Then
For Each l As Label In Controls
If l.Name <> "TextLabel" Then
Controls.Remove(l)
Else
GoTo 1
End If
1: GoTo 0
Next
Else
End If
End Sub
When I track down the bug it seems the problem is in the AddArc() function, and I really don't know why it doesn't work. Any help appreciated.
BTW, I use VB.Net Express 2010 with .Net Framework 4.8.
PS: you can post an answer using either VB.Net or C# I can translate the code from both of them.
I solved My problem, and the answer was to initialize the value or Roundnes to (1,1) at least because my code creates the arcs of the edges using Roundnes to know how wide and long the curving edge
so the solution is to add this line of code before the code responsible for creating the arc.
If _Roundnes = New Size(0, 0) Then _Roundnes = New Size(1, 1)
And that's pretty much it! Thank you for helping me out!
My program constantly updates a shape's position, based on another manipulable shape. Without DoEvents, GotoSlide, .AddShape, or increasing slideshowwindow, the screen will not refresh, and will only show the end result of the shape's position. I can't use DoEvents because it slows down too much when the mouse is moved, and I can't use GotoSlide, .AddShape, or similar methods because they don't allow the user to click in the PowerPoint (will either ignore or crash the program).
Please note, the workarounds here How to refresh the active Slide in a slide show? cause the problems I noted above (.AddShape, GotoSlide, and increasing slideshowwindow all crash the program if the mouse clicks)
I have experimented with GetQueueStaus and GetInputState as a means to filter out certain events from DoEvents, but neither seem to apply. And using them to only DoEvents when necessary obviously isn't an option because it will always be necessary when the shape is moving, and the movement will always slow down based on mouse movement during DoEvents.
Finally, I have also experimented with charts because they are the only shape in PowerPoint that has .refresh functionality, but I both was unable to get this to work, and decided that it wasn't worth the time because the shape of the chart will always be restricted to a rectangle (too limited for what I want my program to do).
Here is my code: (I am currently using GotoSlide method)
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Sub Aloop()
Dim Q As Shape
Dim B As Shape
Dim TotalTime As Long
Dim StartTime As Long
Dim TimerTextRange As TextRange
Dim A As Shape
Const PI = 3.14159265359
Set A = ActivePresentation.Slides(1).Shapes("A")
Set SldOne = ActivePresentation.Slides(1)
Set Q = ActivePresentation.Slides(1).Shapes("Q")
Set B = ActivePresentation.Slides(1).Shapes("B")
Set TimerTextRange = ActivePresentation.Slides(1).Shapes("TimerTextRange") _
.TextFrame.TextRange
TotalTime = 0
StartTime = Timer
With TimerTextRange
.Text = Int(TotalTime + (Timer - StartTime))
End With
Do While TimerTextRange.Text < 10
With TimerTextRange
.Text = Int(TotalTime + (Timer - StartTime))
End With
If Q.Left < A.Left Then
Q.Left = Q.Left + 1
ElseIf Q.Left > A.Left Then
Q.Left = Q.Left - 1
Else
End If
If Q.Top < A.Top Then
Q.Top = Q.Top + 1
ElseIf Q.Top > A.Top Then
Q.Top = Q.Top - 1
Else
End If
If GetAsyncKeyState(vbKeyD) Then
A.Left = A.Left + 4
Else
End If
If GetAsyncKeyState(vbKeyW) Then
A.Top = A.Top - 4
Else
End If
If GetAsyncKeyState(vbKeyS) Then
A.Top = A.Top + 4
Else
End If
If GetAsyncKeyState(vbKeyA) Then
A.Left = A.Left - 4
Else
End If
With Q
If (-A.Top + (.Top + .Width / 2)) > 0 Then
.Rotation = ((Atn(((A.Left + A.Width / 2) - ((.Left + .Width / 2))) / (-(A.Top + A.Height / 2) + ((.Top + .Width / 2))))) * 180 / PI)
ElseIf (-A.Top + (.Top + .Width / 2)) < 0 Then
.Rotation = ((Atn(((A.Left + A.Width / 2) - ((.Left + .Width / 2))) / (-(A.Top + A.Height / 2) + ((.Top + .Width / 2))))) * 180 / PI) + 180
Else
End If
End With
ActivePresentation.SlideShowWindow.View.GotoSlide (1)
Loop
End Sub
The code makes shape Q follow shape A around the screen, and the user can control shape a with W A S D keyboard inputs.
!!Be careful not to click the slide while the code is running, or the program will crash!!
i'm trying to fit the user form to screen on diifernet screens.
the userform was first managed in my work screen and i fit it to my screen but when i'm trying the userform on other screens part of it vanished.
i can't put the whole code in here but i will put just the sub that suppose to fit to screen:
Private Sub UserForm_Initialize()
Dim w As Long, h As Long
Application.Visible = False
With Me
rMaxHeight = Application.Height
rMaxWidth = Application.Width
If .Height > Application.Height - 10 Then
rNormalHeight = rMaxHeight * 0.85
Else
rNormalHeight = Me.Height
End If
If .Width > Application.Width - 10 Then
rNormalWidth = rMaxWidth * 0.85
Else
rNormalWidth = Me.Width
End If
.StartUpPosition = 1
.Left = 0
.Top = 0
FitSize
...
Private Sub FitSize()
Dim h, w
Dim c As Control
Dim PHeight, PWidth As Double
PHeight = rNormalHeight / Me.Height
PWidth = rNormalWidth / Me.Width
h = 0: w = 0
If PHeight = 1 And PWidth = 1 Then Exit Sub
For Each c In Me.Controls
If c.Visible Then
If c.Top + c.Height > h Then h = (c.Top + c.Height) ' * PHeight
If c.Left + c.Width > w Then w = (c.Left + c.Width) ' * PWidth
If Not TypeName(c) = "Image" Or TypeName(c) = "ListBox" Then c.FontSize = c.FontSize * ((PHeight + PWidth) / 2)
End If
Next c
If h > 0 And w > 0 Then
With Me
.Width = w + 40
.Height = h + 40
End With
End If
End Sub
hope you could help me with that
Thank you all
sefi
You can either Re-position every single control in the UserForm with VBA or simply enable ScrollBars for the UserForm object so they can access all the elements with a bit of scrolling.
Change the ScrollBars property of the UserForm to like 3 - fmScrollBarsBoth as the default is 0 - fmScrollBarsNone
Then you need to figure out how tall and wide it needs to be:
ScrollHeight
ScrollWidth
Hello and thank for everyone that tried to help me.
I found the solution to this problem by fitting the controls to the proportion of the screen copared with the original form.
At first step you need to calculate the proportion:
Dim PHeight, PWidth As Double
'define form size compared with the original size of the form
rMaxHeight = Application.Height
rMaxWidth = Application.Width
If Me.Height > Application.Height Then
rNormalHeight = rMaxHeight * 0.85
Else
rNormalHeight = Me.Height
End If
If Me.Width > Application.Width Then
rNormalWidth = rMaxWidth * 0.85
Else
rNormalWidth = Me.Width
End If
'normal is the size needed in normal mode before the form get to maximize mode
'we want to calculate the needed divided to the orignal
PHeight = rNormalHeight / Me.Height
PWidth = rNormalWidth / Me.Width
now we call fitsize()
Private Sub FitSize()
Dim h, w
Dim c As Control
h = 0: w = 0
If PHeight = 1 And PWidth = 1 Then Exit Sub ' if the it is the original size of the form- don't bother...
'loop on the form controls
For Each c In Me.Controls
If c.Visible Then ' just visible controls
c.Top = c.Top * PHeight ' fit to proportion of the screen compared with the original form
c.Height = c.Height * PHeight
If c.Top + c.Height > h Then h = c.Top + c.Height ' collect the height needed from the controls
c.Left = c.Left * PWidth ' fit to proportion of the screen compared with the original form
c.Width = c.Width * PWidth
If c.Left + c.Width > w Then w = c.Left + c.Width ' collect the height needed from the controls
'fit the font for the text controls
If Not TypeName(c) = "Image" Or TypeName(c) = "ListBox" Then c.FontSize = c.FontSize * ((PHeight + PWidth) / 2)
End If
Next c
'define the size needed form the specific screen
If h > 0 And w > 0 Then
With Me
.Width = w + 40
.Height = h + 40
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
End With
End If
End Sub
this code will define the size needed in each screen by the proportion that calculated in the needed value divded to the original value.
Try it and tell me if it works.
thank you all
sefi
I am currently programming a sheet which visualizes data sets in graphs. Because the user of this sheet will not need all the graphs, I would like to let them choose the ones needed through a UserForm. Since the amount of data sets is variable, the UserForm will have the same amount of checkboxes as there are datasets.
The Userform code is as follows.
Private Sub UserForm_Initialize()
Dim chkBoxA As MSForms.CheckBox
Dim chkBoxB As MSForms.CheckBox
Dim lblBox As MSForms.Label
Dim cnt As Control
Amount = Sheet4.Range("C4").Value 'Amount of datasets
For i = 1 To Amount
Set lblBox = Me.Controls.Add("Forms.label.1", "Label" & i)
lblBox.Caption = "Set" & i
lblBox.Left = 5
lblBox.Top = 8 + ((i - 1) * 40)
Set chkBoxA = Me.Controls.Add("Forms.CheckBox.1", "A" & i)
chkBoxA.Caption = "Graph a"
chkBoxA.Left = 55
chkBoxA.Top = 5 + ((i - 1) * 40)
Set chkBoxB = Me.Controls.Add("Forms.CheckBox.1", "B" & i)
chkBoxB.Caption = "Graph b"
chkBoxB.Left = 55
chkBoxB.Top = 20 + ((i - 1) * 40)
Next
CommandButton1.Left = 20
CommandButton1.Top = 40 + ((Amount - 1) * 40)
CommandButton1.TabIndex = Amount * 3 + 1
Me.Height = 220
Me.ScrollBars = fmScrollBarsVertical
Me.ScrollWidth = Me.InsideWidth * 9
For Each cnt In Me.Controls
If cnt.Top + cnt.Height > Me.ScrollHeight Then
Me.ScrollHeight = cnt.Top + cnt.Height + 5
End If
Next
End Sub
When the UserForm is filled in (graphs are chosen by clicking on the options), the user will press CommandButton1. An event should then be run to show the correct graph, but for the simplicity I am first testing if a MsgBox will show up. Unfortunately the MsgBox does not show up.
Private Sub CommandButton1_Click()
'Will fix this with a loop
If A1 = True Then
MsgBox ("TestA1")
End If
If B1 = True then
MsgBox ("TestB1")
End If
If A2 = True then
MsgBox ("TestA2")
End If
Unload Me
End Sub
I am stuck on this part. The checkboxes do show up on the UserForm and they are clickable, but the commandbutton only shuts down the sub (Unload Me). I would like to see the MsgBox show up when I select the corresponding option and click the commandbutton. Any help on getting this to work is appreciated!
You are referencing 'A1' in the sub, but that variable does not exitst at compile time, because you add them dynamically. What you need to do is loop the controls, to check the names. Best practice is to put the checkboxes in a frame, to be able to group them.
Add a frame to the userform and name it 'checkboxframe'
And then instead of:
For i = 1 To Amount
Set lblBox = Me.Controls.Add("Forms.label.1", "Label" & i)
lblBox.Caption = "Set" & i
lblBox.Left = 5
lblBox.Top = 8 + ((i - 1) * 40)
Set chkBoxA = Me.Controls.Add("Forms.CheckBox.1", "A" & i)
chkBoxA.Caption = "Graph a"
chkBoxA.Left = 55
chkBoxA.Top = 5 + ((i - 1) * 40)
Set chkBoxB = Me.Controls.Add("Forms.CheckBox.1", "B" & i)
chkBoxB.Caption = "Graph b"
chkBoxB.Left = 55
chkBoxB.Top = 20 + ((i - 1) * 40)
Next
you would need to do:
With Me.checkboxframe
For i = 1 To Amount
Set lblBox = .Controls.Add("Forms.label.1", "Label" & i)
lblBox.Caption = "Set" & i
lblBox.Left = 5
lblBox.Top = 8 + ((i - 1) * 40)
Set chkBoxA = .Controls.Add("Forms.CheckBox.1", "A" & i)
chkBoxA.Caption = "Graph a"
chkBoxA.Left = 55
chkBoxA.Top = 5 + ((i - 1) * 40)
Set chkBoxB = .Controls.Add("Forms.CheckBox.1", "B" & i)
chkBoxB.Caption = "Graph b"
chkBoxB.Left = 55
chkBoxB.Top = 20 + ((i - 1) * 40)
Next
End With
And to add the checkboxes to the frame, use something like:
For Each ctr In UserForm1.frame("checkboxframe").Controls
If TypeName(ctr) = "CheckBox" Then
If ctr.Value = True Then
'do something usefull here
msgbox ctr.name
End If
End If
Next ctr
The reason nothing appears is because there is no object "A1" manually defined as a variable.
To get the value of the box you Dynamically named "A1" you would have to refer to it as such:
If Me.Controls.Item("A1").Value = True then
Hope this helps!
NET developers.
I'm trying to put 20 labels on a form and place them line by line (I do this by the .Top method). I am sure there is a way I can program declaring and formatting by looping through more general code 20 times.
The below is what I've done for the first label.
Thanks in advance for help!
Dim Label1 As New Label
Me.Controls.Add(Label1)
For m = 1 To OutlookManager3.GlobalVariables.SelectedAppointmentsNo
With Label1
.Width = 512
.Height = 18
.Top = subject.Top + subject.Height + m * 6 + (m - 1) * 18 + (m - 1) * 6
.Left = 12
.Text = "label" & m
End With
Next
You should place this as the first line inside your loop:
Dim Label1 As New Label
And this as the last line insde your loop:
Me.Controls.Add(Label1)
Example 1
For m = 1 To OutlookManager3.GlobalVariables.SelectedAppointmentsNo
Dim Label1 As New Label
With Label1
.Width = 512
.Height = 18
.Top = subject.Top + subject.Height + m * 6 + (m - 1) * 18 + (m - 1) * 6
.Left = 12
.Text = "label" & m
End With
Me.Controls.Add(Label1)
Next
Example 2
For m = 1 To OutlookManager3.GlobalVariables.SelectedAppointmentsNo
Me.Controls.Add(New Label() With {.Width = 512, .Height = 18, .Top = (subject.Top + subject.Height + m * 6 + (m - 1) * 18 + (m - 1) * 6), .Left = 12, .Text = ("label" & m)})
Next
you can use your code by place declare statement inside loop
For m = 1 To OutlookManager3.GlobalVariables.SelectedAppointmentsNo
Dim Label1 As New Label
With Label1
.Width = 512
.Height = 18
.Top = subject.Top + subject.Height + m * 6 + (m - 1) * 18 + (m - 1) * 6
.Left = 12
.Text = "label" & m
End With
Me.Controls.Add(Label1)
Next
or use panel just like this but you have to place declare statement inside loop
or should make label array for future reference by
Dim label(yoursize) As Label
For m = 1 To OutlookManager3.GlobalVariables.SelectedAppointmentsNo
label(m) = new label
label(m).ID="future referece id"
With Label1
.Width = 512
.Height = 18
.Top = subject.Top + subject.Height + m * 6 + (m - 1) * 18 + (m - 1) * 6
.Left = 12
.Text = "label" & m
End With
by this you can use that next time
Me.Controls.Add(Label1)
Next