I would like a notification to be triggered when part the screen starts to flash. This notification can be a msgbox for now, but I will eventually evolve it into an audible sound.
The purpose of this is we have a dashboard that displays various cells throughout the company. When a cell needs assistance, its spot on the dashboard starts to flash. The cells are displayed in horizontally stackedboxes like this;
Cell 1
Cell 2
Cell 3
Ect...
I would like to build an application that scans the screen, lets say every second, and gets each cells pixel intensity.
The notification will be triggered if/when the cells pixel intensity changes each scan for three consecutive scans in a row (ie. the cell must be flashing).
I am hoping that you guys can help me find a way to scan the screen an return a regions average pixel intensity to which I can then replicate and do the comparison to find out if it is flashing.
Thank you in advance, I am using VB.Net.
I was able to accomplish what I was asking by using this:
Private Sub AvgColors(ByVal InBitmap As Bitmap)
Dim btPixels(InBitmap.Height * InBitmap.Width * 3 - 1) As Byte
Dim hPixels As GCHandle = GCHandle.Alloc(btPixels, GCHandleType.Pinned)
Dim bmp24Bpp As New Bitmap(InBitmap.Width, InBitmap.Height, InBitmap.Width * 3,
Imaging.PixelFormat.Format24bppRgb, hPixels.AddrOfPinnedObject)
Using gr As Graphics = Graphics.FromImage(bmp24Bpp)
gr.DrawImageUnscaledAndClipped(InBitmap, New Rectangle(0, 0,
bmp24Bpp.Width, bmp24Bpp.Height))
End Using
Dim sumRed As Int32
Dim sumGreen As Int32
Dim sumBlue As Int32
For i = 0 To btPixels.Length - 1 Step 3
sumRed += btPixels(i)
sumGreen += btPixels(i + 1)
sumBlue += btPixels(i + 2)
Next
hPixels.Free()
Dim avgRed As Byte = CByte(sumRed / (btPixels.Length / 3))
Dim avgGreen As Byte = CByte(sumGreen / (btPixels.Length / 3))
Dim avgBlue As Byte = CByte(sumBlue / (btPixels.Length / 3))
MsgBox(avgRed & vbCrLf & avgGreen & vbCrLf & avgBlue)
End Sub
Private Function Screenshot() As Bitmap
Dim b As Bitmap = New Bitmap(Screen.PrimaryScreen.Bounds.Width, Screen.PrimaryScreen.Bounds.Height)
Using g As Graphics = Graphics.FromImage(b)
g.CopyFromScreen(0, 0, 0, 0, b.Size, CopyPixelOperation.SourceCopy)
g.Save()
End Using
Return b
End Function
and from here I can just adjust the range of bitmap to what I need, add a timer to tick every second, and keep a variable to compare average RGB's to.
Most of the code found from here:
http://www.vbforums.com/showthread.php?776021-RESOLVED-Getting-Average-RGB-Color-Value-of-Entire-Screen
I'm creating a game, which will store maps on separate files.
This is done in that file using variables as such:
Public X1Y1 = "idle"
Containing the location and pixel information for my screen drawing engine.
To draw each pixel, I need to cycle through all of these variables.
I wanted to do that as shown, but I can't figure out how to refer to the variables in the map file(eg: X1Y1 or X5Y4), using a variable which stores the name of the variable required (pos).
Dim targetmap As SplashMap = New SplashMap()
For rowcount = 0 To targetmap.xRes Step 1
'for each row on the map
For columncount = 0 To targetmap.yRes Step 1
'place the pixel in each column
Dim pos = "X" & rowcount & "Y" & columncount
PlacePixel(pos, targetmap.'var <- problem, vbNull)
'call engine(Pixel Location, Pixel information stored in var, special control instruction (unused))
Next
Next
I am trying to create a row of duplicated objects in PowerPoint, each with a motion path that is slightly shorter than the next, like this:
First Image
I know that you cannot add a path animation from scratch in VBA, so I used VBA to copy and paste an object and its motion path, then edit the motion path.
This is my VBA code:
Sub CopyPastePosition()
' Copy the shape in slide 2 which has a custom motion path aleady
ActivePresentation.Slides(2).Shapes(3).Copy
Dim x As Integer
' For loop - create 5 duplicates
For x = 1 To 5
' Each duplicate is nudged to the left by x*100
With ActivePresentation.Slides(1).Shapes.Paste
.Name = "Smiley"
.Left = x * 100
.Top = 1
End With
' This is where I am unsure - I want the motion path to be longer by x amount each time
ActivePresentation.Slides(1).TimeLine.MainSequence(x).Behaviors(1).MotionEffect.Path = "M 0 0 L 0 x*0.7"
Next x
End Sub
However, the output is like this:
Second Image
Path property for motion path which represents a VML string. The VML string is a collection of coordinates for a Line or Bezier curve (for
powerpoint purposes). The values are fractions of the slide dimensions.
You can generate an incrementing VML path with this function.
Function GetPath(MaxSegments As Integer, Increment As Single)
Dim path As String
Dim i As Integer
path = "M 0 0 "
For i = 1 To MaxSegments
path = path & "L 0 " & CStr(Increment * i) & " "
Next
path = path & " E"
GetPath = path
End Function
Since you are doing copy/paste of a shape with motion path already on it, I would also make this change to ensure we reference the correct motion path upon paste:
With ActivePresentation.Slides(1).TimeLine
.MainSequence(.MainSequence.Count).Behaviors(1).MotionEffect.path = GetPath(x, 0.7)
End With
Yes, I realise that I am trying to insert a variable into a string. yes the correct way of doing this is "M 0 0 L 0 " & (x * 0.7)
Thank you #braX
I am trying to speed up various aspects of my website.
The site is a shopping site various search pages which are slow. There are several potential reasons for this, one being working with images.
The other night I created a function which generates a thumbnail for my Facebook OG tags. The function writes a square image to the server 400px x 400px created by tiling the first few (up to 14) product images generated by a search query.
Running this script in total isolation on a test.aspx file gives me reasonable load time, but nothing I can do can speed it up, even when I don't return anything in the browser, just doing this process is taking about 3 seconds, which obviously expanded across the whole live site slows things down.
The entire code is:
Function mergeImgs(idList, imgList, head, fileName) As String
Try
Dim maxRows = HttpContext.Current.Request.QueryString("r")
Dim imgDim = 400
Dim Image3 As New Bitmap(imgDim, imgDim)
Dim g As Graphics = Graphics.FromImage(Image3)
Dim i = 0
Dim left = 0
Dim rows = 0
For Each item In idList
Dim img = Common.getImageUrl(idList(i), imgList(i), "server", "-tb")
i += 1
If img <> "/Images/awaiting.png" Then
Dim imageData As System.Drawing.Image = System.Drawing.Image.FromFile(img)
Dim aspect As Double = imageData.Width / imageData.Height ' determine aspect and decide how to display image
Dim Image1
Dim fixedHeight = imgDim / maxRows
Dim objGraphic As System.Drawing.Image = System.Drawing.Image.FromFile(img)
Dim aspectRatio = objGraphic.Height / objGraphic.Width
Dim reduction = fixedHeight / objGraphic.Height
Dim newwidth = objGraphic.Width * reduction
Image1 = New Bitmap(objGraphic, objGraphic.Width * reduction, fixedHeight)
g.DrawImage(Image1, New Point(left, fixedHeight * rows))
If left >= imgDim Then
rows += 1
left = 0
ElseIf left < imgDim Then
left += newwidth
ElseIf left < imgDim AndAlso rows = maxRows Then
Exit For
End If
End If
Next
Image3.Save(HttpContext.Current.Server.MapPath("/" & fileName), System.Drawing.Imaging.ImageFormat.Jpeg)
Return rootUrl & fileName
g.Dispose()
g = Nothing
Catch ex As Exception
Return ("<P>" & ex.ToString)
End Try
End Function
There's an external function getImageUrl which is simply a series of logic which writes out a directory structure based on the item ID, this is fast so I doubt holding it up at all.
Variables passed into the function are:
idList = a generic List(of String) ' a list of item IDs
imgList = a generic List(of String) ' a list of image names (image names only stored in DB)
head = the Page.Header ' not actually needed in this prototype, but aimed to allow this to write the OG tag to the Page Header
fileName = simply the name to give the generated image file
I can't help thinking that the section from
Dim imageData As System.Drawing.Image = System.Drawing.Image.FromFile(img)
onwards could potentially be sped up. What this does is work out the aspect ratio of the images loaded, then recalculate the size so they're all the same height so that the tile can be neatly populated in tidy rows.
Dim img = Common.getImageUrl(idList(i), imgList(i), "server", "-tb")
This line loads a thumbnail version ("-tb" in last variable) of the images concerned, so all images being dealt with are approx 50x50px so very small to load and determine the aspect ratios from
There are 4 versions of each image stored on my server, in 4 different sizes for fast display on the website, having messed around with the different images loaded here, it seems to make little difference to the script load time.
Is there anything faster than System.Drawing.Image.FromFile(img) that I can use to load in the images and determine the width and height of it?
There are a couple of other situations on my website where I am required to determine the dimensions of an image and then do something with it and all seem a bit slow.
Any advice most welcome!
Just for info, here's an example of an image generated by the above code
http://www.hgtrs.com/recents.jpg
This is generated from the products returned by this page (which might load slowly!):
http://www.hgtrs.com/search.aspx?Type=recents
I should state the my test.aspx file also includes a call to a database, having tested the query used directly, I get a query time of 0.18 seconds, I dont know how this time expands into a real application. I have optimised this query and the tables (it uses one nested query and a join) as much as I know how.
Is it possible to insert line break in a wrapped cell through VBA code? (similar to doing Alt-Enter when entering data manually)
I have set the cell's wrap text property to True via VBA code, and I am inserting data into it also through VBA code.
Yes. The VBA equivalent of AltEnter is to use a linebreak character:
ActiveCell.Value = "I am a " & Chr(10) & "test"
Note that this automatically sets WrapText to True.
Proof:
Sub test()
Dim c As Range
Set c = ActiveCell
c.WrapText = False
MsgBox "Activcell WrapText is " & c.WrapText
c.Value = "I am a " & Chr(10) & "test"
MsgBox "Activcell WrapText is " & c.WrapText
End Sub
You could also use vbCrLf which corresponds to Chr(13) & Chr(10). As Andy mentions in the comment below, you might be better off using ControlChars.Lf instead though.
Yes there are two ways to add a line feed:
Use the existing constant from VBA (click here for a list of existing vba constants) vbLf in the string you want to add a line feed, as such:
Dim text As String
text = "Hello" & vbLf & "World!"
Worksheets(1).Cells(1, 1) = text
Use the Chr() function and pass the ASCII character 10 in order to add a line feed, as shown bellow:
Dim text As String
text = "Hello" & Chr(10) & "World!"
Worksheets(1).Cells(1, 1) = text
In both cases, you will have the same output in cell (1,1) or A1.
Have a look at these two threads for more information:
What is the difference between a "line feed" and a "carriage return"?
Differences Between vbLf, vbCrLf & vbCr Constants
I know this question is really old, but as I had the same needs, after searching SO and google, I found pieces of answers but nothing usable. So with those pieces and bites I made my solution that I share here.
What I needed
Knowing the column width in pixels
Be able to measure the length of a string in pixels in order to cut it at the dimension of the column
What I found
About the width in pixels of a column, I found this in Excel 2010 DocumentFormat :
To translate the value of width in the file into the column width value at runtime (expressed in terms of pixels), use this calculation:
=Truncate(((256 * {width} + Truncate(128/{Maximum Digit Width}))/256)*{Maximum Digit Width})
Even if it's Excel 2010 format, it's still working in Excel 2016. I'll be able to test it soon against Excel 365.
About the width of a string in pixels, I used the solution proposed by #TravelinGuy in this question, with small corrections for typo and an overflow. By the time I'm writing this the typo is already corrected in his answer, but there is still the overflow problem. Nevertheless I commented his answer so there is everything over there for you to make it works flawlessly.
What I've done
Code three recursive functions working this way :
Function 1 : Guess the approximate place where to cut the sentence so if fits in the column and then call Function 2 and 3 in order to determine the right place. Returns the original string with CR (Chr(10)) characters in appropriate places so each line fits in the column size,
Function 2 : From a guessed place, try to add some more words in the line while this fit in the column size,
Function 3 : The exact opposite of function 2, so it retrieves words to the sentence until it fits in the column size.
Here is the code
Sub SplitLineTest()
Dim TextRange As Range
Set TextRange = FeuilTest.Cells(2, 2)
'Take the text we want to wrap then past it in multi cells
Dim NewText As String
NewText = SetCRtoEOL(TextRange.Value2, TextRange.Font.Name, TextRange.Font.Size, xlWidthToPixs(TextRange.ColumnWidth) - 5) '-5 to take into account 2 white pixels left and right of the text + 1 pixel for the grid
'Copy each of the text lines in an individual cell
Dim ResultArr() As String
ResultArr() = Split(NewText, Chr(10))
TextRange.Offset(2, 0).Resize(UBound(ResultArr) + 1, 1).Value2 = WorksheetFunction.Transpose(ResultArr())
End Sub
Function xlWidthToPixs(ByVal xlWidth As Double) As Long
'Fonction to convert the size of an Excel column width expressed in Excel unit(Range.ColumnWidth) in pixels
'Parameters : - xlWidth : that is the width of the column Excel unit
'Return : - The size of the column in pixels
Dim pxFontWidthMax As Long
'Xl Col sizing is related to workbook default string configuration and depends of the size in pixel from char "0". We need to gather it
With ThisWorkbook.Styles("Normal").Font
pxFontWidthMax = pxGetStringW("0", .Name, .Size) 'Get the size in pixels of the '0' character
End With
'Now, we can make the calculation
xlWidthToPixs = WorksheetFunction.Floor_Precise(((256 * xlWidth + WorksheetFunction.Floor_Precise(128 / pxFontWidthMax)) / 256) * pxFontWidthMax) + 5
End Function
Function SetCRtoEOL(ByVal Original As String, ByVal FontName As String, ByVal FontSize As Variant, ByVal pxAvailW) As String
'Function aiming to make a text fit into a given number of pixels, by putting some CR char between words when needed.
'If some words are too longs to fit in the given width, they won't be cut and will get out of the limits given.
'The function works recursively. Each time it find an End Of Line, it call itself with the remaining text until.
'The recursive process ends whent the text fit in the given space without needing to be truncated anymore
'Parameters : - Original : The text to fit
' - FontName : Name of the font
' - FontSize : Size of the font
' - pxAvailW : Available width in pixels in wich we need to make the text fit
'Return : - The orignal text with CR in place of spaces where the text needs to be cut to fit the width
'If we got a null string, there is nothing to do so we return a null string
If Original = vbNullString Then Exit Function
Dim pxTextW As Long
'If the text fit in, may be it's the original or this is end of recursion. Nothing to do more than returne the text back
pxTextW = pxGetStringW(Original, FontName, FontSize)
If pxTextW < pxAvailW Then
SetCRtoEOL = Original
Exit Function
End If
'The text doesn't fit, we need to find where to cut it
Dim WrapPosition As Long
Dim EstWrapPosition As Long
EstWrapPosition = Len(Original) * pxAvailW / pxTextW 'Estimate the cut position in the string given to a proportion of characters
If pxGetStringW(Left(Original, EstWrapPosition), FontName, FontSize) < pxAvailW Then
'Text to estimated wrap position fits in, we try to see if we can fits some more words
WrapPosition = FindMaxPosition(Original, FontName, FontSize, pxAvailW, EstWrapPosition)
End If
'If WrapPosition = 0, we didn't get a proper place yet, we try to find the previous white space
If WrapPosition = 0 Then
WrapPosition = FindMaxPositionRev(Original, FontName, FontSize, pxAvailW, EstWrapPosition)
End If
'If WrapPosition is still 0, we are facing a too long word for the pxAvailable. We'll cut after this word what ever. (Means we must search for the first white space of the text)
If WrapPosition = 0 Then
WrapPosition = InStr(Original, " ")
End If
If WrapPosition = 0 Then
'Words too long to cut, but nothing more to cut, we return it as is
SetCRtoEOL = Original
Else
'We found a wrap position. We recurse to find the next EOL and construct our response by adding CR in place of the white space
SetCRtoEOL = Left(Original, WrapPosition - 1) & Chr(10) & SetCRtoEOL(Right(Original, Len(Original) - WrapPosition), FontName, FontSize, pxAvailW)
End If
End Function
Function FindMaxPosition(ByVal Text As String, ByVal FontName As String, ByVal FontSize As Variant, ByVal pxAvailW, ByVal WrapPosition As Long) As Long
'Function that finds the maximum number of words fitting in a given space by adding words until it get out of the maximum space
'The function is inteded to work on text with a "guessed" wrap position that fit in the space allowed
'The function is recursive. Each time it guesses a new position and the word still fits in the space, it calls itself with a further WrapPosition
'Parameters : - Text : The text to fit
' - FontName : Name of the font
' - FontSize : Size of the font
' - pxAvailW : Available width in pixels in wich we need to make the text fit
' - WrapPosition : The initial wrap position, positionned someware in the text (WrapPosition < len(Text)) but inside pxAvailW
'Return : - The position were the text must be wraped to put as much words as possible in pxAvailW, but without getting outside of it. If no position can be found, returns 0
Dim NewWrapPosition As Long
Static isNthCall As Boolean
'Find next Whitespace position
NewWrapPosition = InStr(WrapPosition, Text, " ")
If NewWrapPosition = 0 Then Exit Function 'We can't find a wrap position, we return 0
If pxGetStringW(Left(Text, NewWrapPosition - 1), FontName, FontSize) < pxAvailW Then '-1 not to take into account the last white space
'It still fits, we can try on more word
isNthCall = True
FindMaxPosition = FindMaxPosition(Text, FontName, FontSize, pxAvailW, NewWrapPosition + 1)
Else
'It doesnt fit. If it was the first call, we terminate with 0, else we terminate with previous WrapPosition
If isNthCall Then
'Not the first call, we have a position to return
isNthCall = False 'We reset the static to be ready for next call of the function
FindMaxPosition = WrapPosition - 1 'Wrap is at the first letter of the word due to the function call FindMax...(...., NewWrapPosition + 1). The real WrapPosition needs to be minored by 1
Else
'It's the first call, we return 0 | Strictly speaking we can remove this part as FindMaxPosition is already 0, but it make the algo easier to read
FindMaxPosition = 0
End If
End If
End Function
Function FindMaxPositionRev(ByVal Text As String, ByVal FontName As String, ByVal FontSize As Variant, ByVal pxAvailW, ByVal WrapPosition As Long) As Long
'Function working backward of FindMaxPosition. It finds the maximum number of words fitting in a given space by removing words until it fits the given space
'The function is inteded to work on text with a "guessed" wrap position that fit in the space allowed
'The function is recursive. Each time it guesses a new position and the word still doesn't fit in the space, it calls itself with a closer WrapPosition
'Parameters : - Text : The text to fit
' - FontName : Name of the font
' - FontSize : Size of the font
' - pxAvailW : Available width in pixels in wich we need to make the text fit
' - WrapPosition : The initial wrap position, positionned someware in the text (WrapPosition < len(Text)), but outside of pxAvailW
'Return : - The position were the text must be wraped to put as much words as possible in pxAvailW, but without getting outside of it. If no position can be found, returns 0
Dim NewWrapPosition As Long
NewWrapPosition = InStrRev(Text, " ", WrapPosition)
'If we didn't found white space, we are facing a "word" too long to fit pxAvailW, we leave and return 0
If NewWrapPosition = 0 Then Exit Function
If pxGetStringW(Left(Text, NewWrapPosition - 1), FontName, FontSize) >= pxAvailW Then '-1 not to take into account the last white space
'It still doesnt fits, we must try one less word
FindMaxPositionRev = FindMaxPositionRev(Text, FontName, FontSize, pxAvailW, NewWrapPosition - 1)
Else
'It fits, we return the position we found
FindMaxPositionRev = NewWrapPosition
End If
End Function
Known limitations
This code will work as long as the text in the cell has only one font and one font size. Here I assume that the font is not Bold nor Italic, but this can be easily handled by adding few parameters as the function measuring the string length in pixels is already able to do it.
I've made many test and I always got the same result than the autowrap function of Excel worksheet, but it may vary from one Excel version to an other. I assume it works on Excel 2010, and I tested it with success in 2013 and 2016. Fo others I don't know.
If you need to handle cases where fonts type and/or attributs vary inside a given cell, I assume it's possible to achieve it by testing the text in the cell character by character by using the range.caracters property. It should be really slower, but for now, even with texts to split in almost 200 lines, it takes less than one instant so maybe it's viable.
Just do Ctrl + Enter inside the text box