That's brilliant, thank you. Is it possible to alternate the text colour? Green for Input and Red for Copy Mode.
That's brilliant, thank you. Is it possible to alternate the text colour? Green for Input and Red for Copy Mode.
This brings up the prompt but cancel doesn't stop the procedure.
Public Sub ClipClear() Call ClipOff MsgBox "Are you sure you wish to clear the data?", vbQuestion + vbYesNo + vbDefaultButton2, "Automatic Clipboard" Sheet10.Range("$C$4") = Null End Sub
Okay, this is the solution.
I'd still like the message to show as green or red as described previously.Public Sub ClipClear()Dim Answer As Integer Answer = MsgBox("Are you sure you wish to clear the data?", vbQuestion + vbYesNo + vbDefaultButton2, "Automatic Clipboard") If Answer = vbYes Then Call ClipOff ' MsgBox "Cleared" Sheet10.Range("C7,C8,C9,C10,C11,C13,C16,C19,E13,G13,I13,E16,G16,I16").ClearContents Sheet10.Range("E7:I7").ClearContents Sheet10.Range("E10:I10").ClearContents Sheet10.Range("E19:I19").ClearContents Sheet10.Range("C22:I22").ClearContents Sheet10.Range("$C$4") = Null Else 'Do nothing End If End Sub
Last edited by MSXL; 09-03-2022 at 10:00 AM.
I think I have figured it out, is this how you would do it?
Public Sub ClipOn() Dim thisAddress As String thisAddress = Split(strAddress, ":")(0) With Sheet10 .IsClipRunning = True ' unprotect and change the color of the "play" button to red (or you may use any color) .Unprotect .Shapes("Status").TextFrame.Characters.Text = "Copy Mode" .Shapes("Status").TextFrame.Characters.Font.Color = vbRed .Shapes("Button 33").TextFrame.Characters.Font.Color = vbRed .Protect If Len(Trim$(.Range(thisAddress).value & "")) Then Call putToClipboard(.Range(thisAddress).value) End If End With End Sub Public Sub ClipOff() With Sheet10 ' unprotect to re-instate the color of "play" button to black .Unprotect .Shapes("Status").TextFrame.Characters.Text = "Input Mode" .Shapes("Status").TextFrame.Characters.Font.Color = RGB(146, 208, 80) .Shapes("Button 33").TextFrame.Characters.Font.Color = vbBlack .IsClipRunning = False .Protect End With End Sub
I'm trying to change the background colour but cannot get the syntax correct.
How do I define the background colour of this textframe please?.Shapes("Status").TextFrame.Fill.BackColor.RGB = RGB(146, 208, 80)
here again your workbook.
Thank you very much, you have been so helpful.
Identical functionality:
Buttons(2).Font.Color = 255 Shapes("Button 33").TextFrame.Characters.Font.Color = vbRed
Thanks snb.
@arnelgp
Ah, some functionality is missing and I had assumed it was there before. The idea behind this worksheet is that pressing play not only displays the last cell selected containing data, it also automatically copies it to the Windows clipboard.
Is that an easy feature to add now that we have start/stop functionality? If so, what additional code is required/where please?
Last edited by MSXL; 09-04-2022 at 05:24 AM.
Is this the best way?
Modify the putToClipboard code:
Public Function putToClipboard(ByVal theValue As Variant) With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") .SetText theValue Sheet10.Range("$C$4") = theValue End With Sheet10.Range("$C$4").Copy End Function
forgot to PutInClipboard:
Public Function putToClipboard(ByVal theValue As Variant) With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") .SetText theValue & "" .PutInClipboard End With Sheet10.Range("$C$4") = theValue End Function
I have just tried using another workbook open at the same time and it's producing errors:
How can this be resolved?Private WithEvents oCbarEvents As CommandBars
Ah, the error message image didn't attach.
lu6uglO.png
It appears to be something to do with any worksheet containing "Private Sub Worksheet_Change(ByVal Target As Range)" as that's when the error occurs, when switching between sheets in another open workbook.
For example:
My workbooks contain a lot of these types of events so I need to know how to avoid this error and have everything continue to work normally.Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Range("C4"), Target) Is Nothing Then If Range("C4").Value = "" Then Application.EnableEvents = False Range("C4").Value = "'Choose" Application.EnableEvents = True End If End If End Sub
You'd better use a Userform.Private Sub Worksheet_Change(ByVal Target As Range) If target.address & target ="$C$4" Then Application.EnableEvents = False target = "Choose" Application.EnableEvents = True End If End Sub
This is rapidly becoming a rather complex issue. Normally a thread composes a singular question. Msxl from here on in, single questions only otherwise start a new thread.
Remember To Do the Following....
Use [Code].... [/Code] tags when posting code to the thread.
Mark your thread as Solved if satisfied by using the Thread Tools options.
If posting the same issue to another forum please show the link
Okay, let's try again. I'm occasionally getting an error with the following:
In Sub ProcessTab, it's specifically this code that throws the error:Option Explicit Public arr As Variant Public strAddress As String Public Sub ProcessTab() Dim i As Integer If Len(strAddress) <> 0 Then For i = 0 To UBound(arr) If arr(i) = Split(strAddress, ":")(0) Then If i = UBound(arr) Then i = 0 Else i = i + 1 End If Exit For End If Next ActiveSheet.Range(arr(i)).Select Else strAddress = arr(0) End If End Sub Public Sub ProcessBkTab() Dim i As Integer If Len(strAddress) <> 0 Then For i = 0 To UBound(arr) If arr(i) = Split(strAddress, ":")(0) Then If i = 0 Then i = UBound(arr) Else i = i - 1 End If Exit For End If Next ActiveSheet.Range(arr(i)).Select Else strAddress = arr(0) End If End Sub
Run-time error '13': Type mismatch
ActiveSheet.Range(arr(i)).SelectRun-time error '9': Subscript out of rangestrAddress = arr(0)
I'm not sure what causes it, except that it's related to pressing TAB.thisAddress = Split(strAddress, ":")(0)
https://drive.google.com/file/d/1yL0...ew?usp=sharing
Last edited by MSXL; 09-08-2022 at 10:18 AM.
http://www.vbaexpress.com/forum/show...l=1#post416601
I've been testing and come across a problem with text being copied to the clipboard being unreadable
Here is the output in Notepad++
q84hbtl.png
In Notepad it shows nothing.
I don't understand. So, I went back to the version that you shared and it's doing the same thing as the Notepad++ screenshot.
Does this happen for anyone else who tries the quoted download? What could be the cause?