Edit: I updated version 2. Now It's monochrome. I tried to fix it by making sure to call CreateCOmpatibleBitmap with the window's DC rather than the memdc (as written), but it is still wrong :(
Below are 3 different simplified versions of functions I have written. Version 1 works perfectly (but has flicker, obviously), version 2 does nothing, and version 3 fills the entire form with black. What is wrong with version 2? Scalemode is set to vbPixels.
Version 1:
Private Sub Form_Paint()
Me.Cls
DrawStuff Me.hDc
End Sub
Version 2 (new):
Private Sub Form_Paint()
Me.Cls
If m_HDCmem = 0 then
m_HDC = GetDC(hwnd)
m_HDCmem = CreateCompatibleDC(m_HDC)
m_HBitmap = CreateCompatibleBitmap(m_HDC, Me.ScaleWidth, Me.ScaleHeight)
ReleaseDC Null, m_HDC
SelectObject m_HDCmem, m_HBitmap
End If
DrawStuff m_HDCmem
Debug.Print BitBlt(Me.hDc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, m_HDCmem, 0, 0, SRCCOPY) 'During testing, this printed "1"
Me.Refresh
End Sub
Version 3:
Private Sub Form_Paint()
Me.Cls
If m_HDC = 0 Then m_HDC = CreateCompatibleDC(Me.hDc)
DrawStuff m_HDC
BitBlt(Me.hDc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, m_HDC, 0, 0, BLACKNESS) 'During testing, this printed "1"
Me.Refresh
End Sub
Note: I stuck the code below in my resize function immediately before the call to paint. It did not help, but I'm pretty sure I should leave it there:
If m_HDC <> 0 Then DeleteDC m_HDC
m_HDC = 0
in Version 2 & 3 your call to CreateCompatibleDC() builds a monochrome drawing surface that is 1 pixel by 1 pixel. You need to call CreateCompatibleBitmap() somewhere in there.
see here
Related
I got my project 95% done but a small issue remains. My code, run from a user form, opens a PDF document with its first line, identifies its window in the second and moves and resizes that window in the third.
ActiveWorkbook.FollowHyperlink Mail(0) & Mail(Me.Tag)
Wnd = FindWindow(vbNullString, AcrobatWindowID(Mail(Me.Tag)))
SetWindowPos Wnd, HWND_TOP, 1950, 10, 1100, 1300, SWP_NOACTIVATE
At the end of this operation the user form is dimmed out. The focus seems to remain with the PDF. That doesn't really matter because the form is fully developed and I can click on it or the PDF to activate either, just the way I wanted.
Nevertheless I tried to give the focus to the form and then to a particular control. I succeeded in finding the Excel window but failed to set the focus on the form, not to mention the control. In fact, I don't know how to check if I succeeded in setting the focus on the Excel window. I used this code in my attempt of whose syntax I'm not sure.
Public Const SWP_NOMOVE = &H2 ' ignore cx and cy
Public Const SWP_NOSIZE = &H1 ' ignore X and Y
SetWindowPos Wnd, HWND_TOP, 0, 0, 0, 0, (SWP_NOMOVE + SWP_NOSIZE)
Anyway, the form remains dimmed out. Does anyone have advice for me?
In order to obtain the form handler, you should proceed in this way:
Use API GetActiveWindow and create a Private variable on top of the form code module (in the declarations area):
Option Explicit
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private frmHwnd as LongPtr
Insert the next code line in the UserForm_Initialize event:
frmHwnd = GetActiveWindow
VBA noob here.
I am developing a workbook which makes use of an external dll from my client.
In a sheet I have a button that, when pressed, starts a routine which makes a shape orange, then calls the API and finally makes the shape black.
Misteriously, it works only 'few times'.
The following code resides in a sub within a module:
Dim shapeToFlash As String
shapeToFlash = "SHAPE " & sheetName
Worksheets("GTE HOME").Shapes(shapeToFlash).Fill.ForeColor.SchemeColor = 53
Worksheets("HOME").Shapes(shapeToFlash).Fill.ForeColor.SchemeColor = 53
// API CALL (kind of long operation ~ 3/4 seconds)
Worksheets("GTE HOME").Shapes(shapeToFlash).Fill.ForeColor.SchemeColor = 0
Worksheets("HOME").Shapes(shapeToFlash).Fill.ForeColor.SchemeColor = 0
I cannot share details about the API. I simply declare with the traditional sintax:
#If Win64 Then
Private Declare PtrSafe Function IMB_set_value _
Lib "path/API.dll" () As Long
#Else
Private Declare Function IMB_set_value _
Lib "path/API.dll" () As Long
and works perfectly.
The problem is that the first SchemeColor (to 53) does not work meaning that the API is called and the second SchemeColor too (the shape turns black). Just to test, I tried to comment the second SchemeColor (to 0) and I noticed that in this case the shape turns orange AFTER the API is called! That suggested me Excel create a sort of priority queue of the commands to be executed and that the API call is performed before the first SchemeColor: that clearly messes with my flow. Is there a way to force Excel to execute immediately an operation? Is there another reason for the fail?
P.S.: I have executed the first SchemeColor lines of code separately and works nicely so I suppose the code is correct.
P.P.S.: I have also tried using RGB instead of SchemeColor, with the same result.
Try this
Sub InitiateLongRunningOperation()
Dim Argument as String
HighlightShape
Argument = "Argument Value"
Application.OnTime Now, "'LongRunningOperation """ & Argument & """'"
End Sub
Sub HighlightShape()
Worksheets(1).Shapes(1).Fill.ForeColor.SchemeColor = 53
End Sub
Sub LongRunningOperation(AnArgument As String)
Debug.Print AnArgument
' Replace the line below with your API call
Application.Wait Now + TimeValue("0:00:03")
Application.OnTime Now, "ResetShape"
End Sub
Sub ResetShape()
Worksheets(1).Shapes(1).Fill.ForeColor.SchemeColor = 0
End Sub
It works with Application.OnTime to start the chain of events without waiting for all of it to end before updating.
I have changed some of your code to make it easier to reproduce, but I think you will be able to follow it quite easy.
I'm a student and I have to learn a lot of stuff/questions, so I came up with an idea and I don't know how to realize it.
So all I am asking is for someone kind to show me how I can program Excel to specifically shade the selected cell with a certain color with a press of a button, as the title suggests.
I want to get in a special mode, where:
I can move around the cells with the arrow keys
by pressing 1 or 2 or 3 or 4, then the selected cell gets shaded with a specific color. (each number for a different color)
The question is, how do I do it? Is something like that possible at all in Excel? I have some background with code, but not even close to a professional. I just did VB Stuff for my GCE A Levels in Computing.
Macros are also possible as I can see but really don't know how to use them.
So here I am, asking this question, hoping someone kind will maybe see it as a challenge and help me realize it. I would invest the time to learn how to do this myself, but with the free time I have now, something like that would take months, just because I'm thorough and I want to learn from the absolute basics.
To enter this special mode you can run a macro to assign new purposes to those keys.
In a module in the VBE Editor, you can add:
Sub EnterSpecialMode()
Call Application.OnKey("1", "color1")
Call Application.OnKey("2", "color2")
Call Application.OnKey("3", "color3")
Call Application.OnKey("4", "color4")
End Sub
Sub ExitSpecialMode()
Call Application.OnKey("1")
Call Application.OnKey("2")
Call Application.OnKey("3")
Call Application.OnKey("4")
End Sub
Sub color1()
Selection.Interior.Color = RGB(255, 0, 0)
End Sub
Sub color2()
Selection.Interior.Color = RGB(0, 255, 0)
End Sub
Sub color3()
Selection.Interior.Color = RGB(0, 0, 255)
End Sub
Sub color4()
Selection.Interior.Color = RGB(255, 255, 0)
End Sub
Self-explanatory, but to enter the special mode you have to run the EnterSpecialMode. And to exit run the ExitSpecialMode sub
I have a Microsoft Form 2.0 Frame Control with three option buttons. The name of the Frame Control is Side, three option button captions are X, O, and Random with names xOption, oOption, and randomSide respectively.
The code runs fine, except upon startup, if I open Excel and run the program immediately, it will give me an Error 91, note that one of the options (X, O, or Random) is already selected. In order to get rid of this error, I need to explicitly select another option, then the error goes away. I don't know why this happens. Here is the sub for the Frame Control
Public Sub Side_Click()
sideLetter = Side.ActiveControl.Caption
If StrComp(sideLetter, "Random") = 0 Then
Randomize
tempRand = Int((Rnd() * 2 + 1))
If tempRand = 1 Then
sideLetter = "X"
Else
sideLetter = "O"
End If
End If
End Sub
The Line sideLetter = Side.ActiveControl.Caption Is the one causing the issue. I have not explicitly declared Side as a frame control in case that's some helpful information because I'm thinking that the object is already declared just by making the Frame Control. Thanks in advance!
You need to check that Side.ActiveControl is actually an object, before you read it's Caption:
Public Sub Side_Click()
If Not Side.ActiveControl Is Nothing Then
sideLetter = Side.ActiveControl.Caption
If StrComp(sideLetter, "Random") = 0 Then
Randomize
tempRand = Int((Rnd() * 2 + 1))
If tempRand = 1 Then
sideLetter = "X"
Else
sideLetter = "O"
End If
End If
End If
End Sub
I have a program that runs a scoretable front screen. I want to have a running ad loop of videos that pop up based on a timer. I created a separate form to play the video and am using a timer to open the form and play one video, then I am incrementing a global variable, closing the form, then waiting for the timer to reopen the form. When the timer tries to reopen the form, it is giving me a thread error. I am somewhat new to this level of coding and am confused about why this error is occuring and how to fix it. I read up on the topic and think I generally understand the problem, but can't seem to find the proper code to get it to work. Here is the code (global variable of VAds) I have used the invoke procedure to fix this problem with a picture box, but cant figure out the same thing for the video. Thanks in advance.
Private Sub PlayAdVideos(sender As Object, e As EventArgs) Handles VideoAds.Click
On Error Resume Next
If Application.OpenForms().OfType(Of frmAds).Any Then
frmVideoAds.Close()
Play_Ads.Text = "Start Video Advertisement Loop"
Exit Sub
Else
Play_Ads.Text = "Close Video Advertisement Loop"
Dim Sz As Integer
If ScreenNo.Text = "" Then
Sz = 1
Else
Sz = ScreenNo.Text
End If
Dim screen As Screen
screen = Screen.AllScreens(Sz)
frmVideoAds.StartPosition = FormStartPosition.Manual
frmVideoAds.Location = screen.Bounds.Location + New Point(0, 0)
frmVideoAds.WindowState = FormWindowState.Maximized
frmVideoAds.FormBorderStyle = FormBorderStyle.None
frmVideoAds.TopMost = True
frmVideoAds.BackColor = Color.Black
frmVideoAds.Show()
End If
For Each foundFile As String In My.Computer.FileSystem.GetFiles("C:\CCHS\VideoAds\")
VideoAdList.Items.Add(foundFile)
Next
If VideoAdList.Items.Count = 0 Then
Exit Sub
End If
Dim TMR2 As New System.Timers.Timer()
VideoAdNum = VideoAdList.Items.Count - 1
TMR2.Interval = 10000 'miliseconds
TMR2.Enabled = True
TMR2.Start()
AddHandler TMR2.Elapsed, AddressOf OnTimedEvent
End Sub
Public Sub OnTimedEvent(ByVal sender As Object, ByVal e As ElapsedEventArgs)
If frmVideoAds.InvokeRequired Then
If VAds = VideoAdNum Then
VAds = 0
Else
VAds = VAds + 1
End If
frmVideoAds.Invoke(Sub() frmVideoAds.Show())
Else
If VAds = VideoAdNum Then
VAds = 0
Else
VAds = VAds + 1
End If
frmVideoAds.Show()
End If
End Sub
System.Timers.Timer elapsed events will generally always be fired on a thread other than the UI thread.
Which means you'll have to call the frmVideoAds.Invoke every time you call frmVideoAds.Show() in that method.
Your else statement should just need to have the invoke added, which would make both execution paths the same so you could update the whole thing.
Public Sub OnTimedEvent(ByVal sender As Object, ByVal e As ElapsedEventArgs)
If VAds = VideoAdNum Then
VAds = 0
Else
VAds = VAds + 1
End If
frmVideoAds.Invoke(Sub() frmVideoAds.Show())
End Sub
This will generally work, but in some cases , ActiveX in particular, the System.Timers is required to be in a Single Threaded Apartment (STA). It defaults to a Multi threaded apartment (MTA). To force it into a STA mode simply add
TMR2.SynchronizingObject = Me
just before your TM2.Start().