Floating Command button

P

Probyn

Is there a way to make a command button stay in place in Excel sheet
as I scroll around. I would like to achieve this without using the menu
bar or placing the button above a a Freeze Pane.

Thanks
 
A

Ardus Petus

This will move the commandbutton with activecell

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Me.CommandButton1
.Top = ActiveCell.Top
.Left = ActiveCell.Left + 2 * ActiveCell.Width
End With
End Sub

HTH
 
P

Probyn

Thanks Ardus.

This routine move the command button to 2 place of the selected cell.
Is there a way to keep the Command Button in place as I scroll around
the sheel.

Thanks.
 
P

Probyn

Looking at your code It would seems that if code the Command button to
move opposited to and in response to the sheet scrolling that should
work. Any idea how to write the code to respond to the scrolling
event. Thanks
 
D

Dave Peterson

I don't think you'll find a scrolling event.
Looking at your code It would seems that if code the Command button to
move opposited to and in response to the sheet scrolling that should
work. Any idea how to write the code to respond to the scrolling
event. Thanks
Click to expand...
 
M

Miyahn

Is there a way to make a command button stay in place in Excel sheet
as I scroll around. I would like to achieve this without using the menu
bar or placing the button above a a Freeze Pane.
Click to expand...

The following is an example.
If you are using Excel2003, you will receive an alert when opening the book.
To avoid this alert, you must change security setting by ORK.

Option Explicit
Sub Auto_Close()
On Error Resume Next
Worksheets(1).DHTMLEdit1.DOM.Script.StopTimer
On Error GoTo 0
End Sub
Sub Auto_Open()
SetTimer
End Sub
'
Private Sub SetTimer()
Dim aObject As Object, Found As Boolean
With Worksheets(1)
For Each aObject In .OLEObjects
If aObject.Name = "DHTMLEdit1" Then Found = True
Next aObject
If Not Found Then
On Error Resume Next
.OLEObjects.Add "DHTMLEdit.DHTMLEdit.1"
On Error GoTo 0
End If
If .Buttons.Count = 0 Then .Buttons.Add 0, 0, 75, 25
End With
Application.OnTime Now + TimeValue("00:00:01"), "StartTimer"
End Sub
'
Private Sub StartTimer()
Dim Src(20) As String
Src(0) = "<script Language = VBS>"
Src(1) = "Dim tId, Target, PX, PY"
Src(2) = "Sub MoveTimer()"
Src(3) = " On Error Resume Next"
Src(4) = " With Target.Parent.Application"
Src(5) = " P = Target.Parent.Columns(.ActiveWindow.ScrollColumn).Left"
Src(6) = " If P <> PX Then Target.Left = P: PX = P"
Src(7) = " P = Target.Parent.Rows(.ActiveWindow.ScrollRow).Top"
Src(8) = " If P <> PY Then Target.Top = P: PY = P"
Src(9) = " End With"
Src(10) = " On Error GoTo 0"
Src(11) = "End Sub"
Src(12) = "Sub StartTimer(Arg)"
Src(13) = " Set Target = Arg: If tId <> 0 Then StopTimer"
Src(14) = " tId = Window.setInterval(""MoveTimer"", 100)"
Src(15) = "End Sub"
Src(16) = "Sub StopTimer()"
Src(17) = " Set Target = Nothing: Window.clearInterval tId"
Src(18) = " tId = 0"
Src(19) = "End Sub"
Src(20) = "</script>"
With Worksheets(1).DHTMLEdit1
.Width = 0: .Height = 0: .BrowseMode = True
.DocumentHTML = Join(Src, vbCrLf)
Do While .Busy: DoEvents: Loop
.DOM.Script.StartTimer Worksheets(1).Buttons(1)
End With
End Sub
 
P

Probyn

Arigato-gozaimasu Miyahn-san.

I find that this code generates the command button but how do I attach
my macro to this button and how do I make more than one button.

Regards
 
M

Miyahn

I find that this code generates the command button but how do I attach
my macro to this button and how do I make more than one button.
Click to expand...

My example is for demonstration, so create a DHTMLEdit object and
one command button object dynamicaly.
You can add these objects by manual operation.
If the book already has these objects, necessary code is,

Option Explicit
Sub Auto_Close()
Worksheets(1).DHTMLEdit1.DOM.Script.StopTimer
End Sub
'
Sub Auto_Open()
Dim Src(20) As String
Src(0) = "<script Language = VBS>"
Src(1) = "Dim tId, Target, PX, PY"
Src(2) = "Sub MoveTimer()"
Src(3) = " On Error Resume Next"
Src(4) = " With Target.Parent.Application"
Src(5) = " P = Target.Parent.Columns(.ActiveWindow.ScrollColumn).Left"
Src(6) = " If P <> PX Then Target.Left = P: PX = P"
Src(7) = " P = Target.Parent.Rows(.ActiveWindow.ScrollRow).Top"
Src(8) = " If P <> PY Then Target.Top = P: PY = P"
Src(9) = " End With"
Src(10) = " On Error GoTo 0"
Src(11) = "End Sub"
Src(12) = "Sub StartTimer(Arg)"
Src(13) = " Set Target = Arg: If tId <> 0 Then StopTimer"
Src(14) = " tId = Window.setInterval(""MoveTimer"", 100)"
Src(15) = "End Sub"
Src(16) = "Sub StopTimer()"
Src(17) = " Set Target = Nothing: Window.clearInterval tId"
Src(18) = " tId = 0"
Src(19) = "End Sub"
Src(20) = "</script>"
With Worksheets(1).DHTMLEdit1
.DocumentHTML = Join(Src, vbCrLf)
Do While .Busy: DoEvents: Loop
.DOM.Script.StartTimer Worksheets(1).Buttons(1)
End With
End Sub

To attach your macro to the button, right click the button -> [Attach Macro]
(I am not sure expression of menu item in english version.)

For more than one button, modify DHTMLEdit1.DocumentHTML's script to
Accept collection of objects
Set appropriate position for each object
and pass buttons collection to the script.
 
P

Probyn

Thanks again Miyahn,

I did not use Scripting language before so this is a little difficult
for me. Your first set of codes I attached to the work sheet and it
created the command button dynamically. However when I right-clicked
the 'Assigned Macro' option was not selectable. Your second set of
codes I do not understand if should be in the worksheet, a module or
attached to the command button. Also, how does the code reference the
command button? Let's assume I have two command buttons name
TestButton1 and TestButton2 in TestWorksheet1 please demonstrate the
code for this.

Much thanks.




I find that this code generates the command button but how do I attach
my macro to this button and how do I make more than one button.
Click to expand...

My example is for demonstration, so create a DHTMLEdit object and
one command button object dynamicaly.
You can add these objects by manual operation.
If the book already has these objects, necessary code is,

Option Explicit
Sub Auto_Close()
Worksheets(1).DHTMLEdit1.DOM.Script.StopTimer
End Sub
'
Sub Auto_Open()
Dim Src(20) As String
Src(0) = "<script Language = VBS>"
Src(1) = "Dim tId, Target, PX, PY"
Src(2) = "Sub MoveTimer()"
Src(3) = " On Error Resume Next"
Src(4) = " With Target.Parent.Application"
Src(5) = " P = Target.Parent.Columns(.ActiveWindow.ScrollColumn).Left"
Src(6) = " If P <> PX Then Target.Left = P: PX = P"
Src(7) = " P = Target.Parent.Rows(.ActiveWindow.ScrollRow).Top"
Src(8) = " If P <> PY Then Target.Top = P: PY = P"
Src(9) = " End With"
Src(10) = " On Error GoTo 0"
Src(11) = "End Sub"
Src(12) = "Sub StartTimer(Arg)"
Src(13) = " Set Target = Arg: If tId <> 0 Then StopTimer"
Src(14) = " tId = Window.setInterval(""MoveTimer"", 100)"
Src(15) = "End Sub"
Src(16) = "Sub StopTimer()"
Src(17) = " Set Target = Nothing: Window.clearInterval tId"
Src(18) = " tId = 0"
Src(19) = "End Sub"
Src(20) = "</script>"
With Worksheets(1).DHTMLEdit1
.DocumentHTML = Join(Src, vbCrLf)
Do While .Busy: DoEvents: Loop
.DOM.Script.StartTimer Worksheets(1).Buttons(1)
End With
End Sub

To attach your macro to the button, right click the button -> [Attach Macro]
(I am not sure expression of menu item in english version.)

For more than one button, modify DHTMLEdit1.DocumentHTML's script to
Accept collection of objects
Set appropriate position for each object
and pass buttons collection to the script.
Click to expand...
 
M

Miyahn

Thanks again Miyahn,

I did not use Scripting language before so this is a little difficult
for me. Your first set of codes I attached to the work sheet and it
created the command button dynamically. However when I right-clicked
the 'Assigned Macro' option was not selectable.
Click to expand...

VBS is very similar to VBA.
Right-click on the point where mouse pointer changes to cross-arrows.
Your second set of
codes I do not understand if should be in the worksheet, a module or
attached to the command button.
Click to expand...

Paste into the standard module.
Also, how does the code reference the command button?
Click to expand...

This line
.DOM.Script.StartTimer Worksheets(1).Buttons(1)
Click to expand...
is passing the button object as a parameter to the script.

--
Miyahn (Masataka Miyashita) JPN
Microsoft MVP for Microsoft Office - Excel(Jan 2006 - Dec 2006)
https://mvp.support.microsoft.com/profile=e971f039-a892-426c-9544-83d372c269b4
If you can read Japanese,
Miyahn's Archive: http://homepage2.nifty.com/miyahn/
 
P

Probyn

Miyahn thanks for your time. I am now able to assign a macro to the
automatically generated button. I am unable to work with the manual
code. Would you please add the code to your program below to make say
4 command buttons. This migh help me to understand the code a little
more. Thanks.


Option Explicit
Sub Auto_Close()
On Error Resume Next
Worksheets(1).DHTMLEdit1.DOM.Script.StopTimer
On Error GoTo 0
End Sub
Sub Auto_Open()
SetTimer
End Sub
'
Private Sub SetTimer()
Dim aObject As Object, Found As Boolean
With Worksheets(1)
For Each aObject In .OLEObjects
If aObject.Name = "DHTMLEdit1" Then Found = True
Next aObject
If Not Found Then
On Error Resume Next
.OLEObjects.Add "DHTMLEdit.DHTMLEdit.1"
On Error GoTo 0
End If
If .Buttons.Count = 0 Then .Buttons.Add 0, 0, 75, 25
End With
Application.OnTime Now + TimeValue("00:00:01"), "StartTimer"
End Sub
'
Private Sub StartTimer()
Dim Src(20) As String
Src(0) = "<script Language = VBS>"
Src(1) = "Dim tId, Target, PX, PY"
Src(2) = "Sub MoveTimer()"
Src(3) = " On Error Resume Next"
Src(4) = " With Target.Parent.Application"
Src(5) = " P =
Target.Parent.Columns(.ActiveWindow.ScrollColumn).Left"
Src(6) = " If P <> PX Then Target.Left = P: PX = P"
Src(7) = " P = Target.Parent.Rows(.ActiveWindow.ScrollRow).Top"
Src(8) = " If P <> PY Then Target.Top = P: PY = P"
Src(9) = " End With"
Src(10) = " On Error GoTo 0"
Src(11) = "End Sub"
Src(12) = "Sub StartTimer(Arg)"
Src(13) = " Set Target = Arg: If tId <> 0 Then StopTimer"
Src(14) = " tId = Window.setInterval(""MoveTimer"", 100)"
Src(15) = "End Sub"
Src(16) = "Sub StopTimer()"
Src(17) = " Set Target = Nothing: Window.clearInterval tId"
Src(18) = " tId = 0"
Src(19) = "End Sub"
Src(20) = "</script>"
With Worksheets(1).DHTMLEdit1
.Width = 0: .Height = 0: .BrowseMode = True
.DocumentHTML = Join(Src, vbCrLf)
Do While .Busy: DoEvents: Loop
.DOM.Script.StartTimer Worksheets(1).Buttons(1)
End With
End Sub
 
M

Miyahn

Miyahn thanks for your time. I am now able to assign a macro to the
automatically generated button. I am unable to work with the manual
code.
Click to expand...

Do you mean that you can use only the macro created by 'Macro Recording'?

Well, the update version is here.

Option Explicit
Const MaxN = 4, HGap = 100, VOfs = 50, BW = 75, BH = 25
Const BCap = "TestButton", ModuleName = "Module1"
Sub Auto_Close()
On Error Resume Next
Worksheets(1).DHTMLEdit1.DOM.Script.StopTimer
On Error GoTo 0
End Sub
Sub Auto_Open()
SetTimer
End Sub
Private Sub SetTimer()
Dim aObject As Object, Found As Boolean, I As Long
With Worksheets(1)
For Each aObject In .OLEObjects
If aObject.Name = "DHTMLEdit1" Then Found = True
Next aObject
If Not Found Then
On Error Resume Next
.OLEObjects.Add "DHTMLEdit.DHTMLEdit.1"
On Error GoTo 0
End If
If .Buttons.Count = 0 Then
For I = 1 To MaxN
.Buttons.Add(HGap * I, VOfs, BW, BH).Caption = BCap & CStr(I)
Next
End If
End With
Application.OnTime Now + TimeValue("00:00:01"), "StartTimer"
End Sub
Private Sub StartTimer()
Dim Buf As String
With Application.VBE.ActiveVBProject.VBComponents(ModuleName).Codemodule
Buf = .Lines(1, .CountOfLines)
End With
With CreateObject("VBScript.RegExp")
.Pattern = "' <script language=vbs>\r\n([\s\S]+)' </script>"
Buf = .Execute(Buf)(0)
End With
Buf = Replace(Buf, "HGap", CStr(HGap)): Buf = Replace(Buf, "VOfs", CStr(VOfs))
With Worksheets(1).DHTMLEdit1
.Width = 0: .Height = 0: .BrowseMode = True
.DocumentHTML = Replace(Buf, "'", "")
Do While .Busy: DoEvents: Loop
.DOM.Script.StartTimer Worksheets(1).Buttons
End With
End Sub
' <script language=vbs>
' Dim tId, cTarget, PX, PY
' Sub MoveTimer()
' Dim P, IsScrolled, I
' On Error Resume Next
' With cTarget.Parent.Application
' P = cTarget.Parent.Columns(.ActiveWindow.ScrollColumn).Left
' IsScrolled = (P <> PX): PX = P
' P = cTarget.Parent.Rows(.ActiveWindow.ScrollRow).Top
' IsScrolled = IsScrolled Or (P <> PY): PY = P
' End With
' If IsScrolled = False Then Exit Sub
' For I = 1 To cTarget.Count
' cTarget(I).Left = PX + HGap * I
' cTarget(I).Top = PY + VOfs
' Next
' On Error GoTo 0
' End Sub
' Sub StartTimer(Arg)
' Set cTarget = Arg: If tId <> 0 Then StopTimer
' tId = Window.setInterval("MoveTimer", 100)
' End Sub
' Sub StopTimer()
' Set cTarget = Nothing: Window.clearInterval tId: tId = 0
' End Sub
' </script>
 
P

Probyn

Thanks again Miyahn. There is one problem with the new code. I get the
following error when I run the program:

Run-time error '1004'
Progrmmatic access to Visual Basic Project is not trusted.

The error is associated with the following line

With
Application.VBE.ActiveVBProject.VBComponents(ModuleName).Codemodules.

Also, does changing MaxN only determine the number of buttons.


in message news:[email protected]

Do you mean that you can use only the macro created by 'Macro Recording'?
Click to expand...

When I tried to use the manual code you sent (that is the code that
does not dynamically create the command button). I created two command
buttons using the Control Tool Box. I named the controls, Button1 and
Commandbutton1. But I could not figure out how to connect the code and
those command buttons and so the float did not work.

Thanks again.




Well, the update version is here.

Option Explicit
Const MaxN = 4, HGap = 100, VOfs = 50, BW = 75, BH = 25
Const BCap = "TestButton", ModuleName = "Module1"
Sub Auto_Close()
On Error Resume Next
Worksheets(1).DHTMLEdit1.DOM.Script.StopTimer
On Error GoTo 0
End Sub
Sub Auto_Open()
SetTimer
End Sub
Private Sub SetTimer()
Dim aObject As Object, Found As Boolean, I As Long
With Worksheets(1)
For Each aObject In .OLEObjects
If aObject.Name = "DHTMLEdit1" Then Found = True
Next aObject
If Not Found Then
On Error Resume Next
.OLEObjects.Add "DHTMLEdit.DHTMLEdit.1"
On Error GoTo 0
End If
If .Buttons.Count = 0 Then
For I = 1 To MaxN
.Buttons.Add(HGap * I, VOfs, BW, BH).Caption = BCap & CStr(I)
Next
End If
End With
Application.OnTime Now + TimeValue("00:00:01"), "StartTimer"
End Sub
Private Sub StartTimer()
Dim Buf As String
With Application.VBE.ActiveVBProject.VBComponents(ModuleName).Codemodule
Buf = .Lines(1, .CountOfLines)
End With
With CreateObject("VBScript.RegExp")
.Pattern = "' <script language=vbs>\r\n([\s\S]+)' </script>"
Buf = .Execute(Buf)(0)
End With
Buf = Replace(Buf, "HGap", CStr(HGap)): Buf = Replace(Buf, "VOfs", CStr(VOfs))
With Worksheets(1).DHTMLEdit1
.Width = 0: .Height = 0: .BrowseMode = True
.DocumentHTML = Replace(Buf, "'", "")
Do While .Busy: DoEvents: Loop
.DOM.Script.StartTimer Worksheets(1).Buttons
End With
End Sub
' <script language=vbs>
' Dim tId, cTarget, PX, PY
' Sub MoveTimer()
' Dim P, IsScrolled, I
' On Error Resume Next
' With cTarget.Parent.Application
' P = cTarget.Parent.Columns(.ActiveWindow.ScrollColumn).Left
' IsScrolled = (P <> PX): PX = P
' P = cTarget.Parent.Rows(.ActiveWindow.ScrollRow).Top
' IsScrolled = IsScrolled Or (P <> PY): PY = P
' End With
' If IsScrolled = False Then Exit Sub
' For I = 1 To cTarget.Count
' cTarget(I).Left = PX + HGap * I
' cTarget(I).Top = PY + VOfs
' Next
' On Error GoTo 0
' End Sub
' Sub StartTimer(Arg)
' Set cTarget = Arg: If tId <> 0 Then StopTimer
' tId = Window.setInterval("MoveTimer", 100)
' End Sub
' Sub StopTimer()
' Set cTarget = Nothing: Window.clearInterval tId: tId = 0
' End Sub
' </script>
Click to expand...
 
P

Probyn

Arigato-gozaimasu Miyahn-san.

It is now working fine. I will now experiment with some parameter
modify different settings.

Thank you.
 
Top