I have a lot of pictures (about 10.000) and would need to paint with Pink on every pixel that is white.
I found multiple threads on getting the color of a pixel, but they require me to go over every pixel of every image and verify if it is white. On the other hand in python it can be done extremely quickly with numpy.
Is there a way to select only the white pixels quickly and paint over them in vb.net? maybe using gr.ExcludeClip() or something like that?
any help appreciated.
UPDATE with the current code
Dim im As Image = Image.FromFile(imagepath & "\" & imagename)
Dim palette = im.Palette
Dim c As Color = Color.FromArgb(R, G, B)
Dim mapWhite = New Imaging.ColorMap() With {
.OldColor = Color.White,
.NewColor = c
}
For i As Integer = 0 To palette.Entries.Length - 1
If palette.Entries(i) = mapWhite.OldColor Then
palette.Entries(i) = mapWhite.NewColor
End If
Next
im.Palette = palette
Background: I am the developer of IguanaTex, a Powerpoint add-in to include LaTeX displays in Powerpoint. IguanaTex can generate vector graphics displays (Powerpoint Shapes, typically Freeforms) by inserting EMF files into a slide, ungrouping them, and doing some clean up (removing extra shapes, further ungrouping, removing lines, ...). These EMF files are typically generated using an external engine (Tex2img) either from LaTeX or from a PDF file that a user wants to convert into an editable shape (not really related to LaTeX, but the whole code base is there to offer that feature, so I put it in).
Issue: I have recently noticed sporadic issues when programmatically ungrouping EMF files, while ungrouping the same file via the GUI does not lead to errors. I have confirmed this occurs on two Windows 10 machines running either Office 2010, Office 2016, or Office 365.
Let's say we insert this EMF file and obtain the following Picture object in Powerpoint:
Inserting the same file using IguanaTex's VBA code leads to the following distorted output, where the "a" and "s" letters are vertically elongated:
The VBA code essentially:
Adds the EMF file as a shape using the Shapes.AddPicture method
Ungroups the shape using the Shape.Ungroup method into a ShapeRange (equivalent to Ungrouping an inserted EMF file in the GUI)
Cleans up by doing one more Ungroup, removing the extra shapes (in our case 1 Autoshape and 1 Rectangle), selecting the group (or Freeform if there is only one) that's at the top, removing the remaining Rectangle, and setting each shape's Outline to be invisible.
Running the code in Debug mode, I could pinpoint the distortion occurring at the first Shape.Ungroup step, which should again in theory be equivalent to doing Shift+Ctrl+G in the GUI (and pressing Yes, as the GUI asks for confirmation when ungrouping EMF files). Note that the distortion still happens when I step over the Ungrouping line.
What is particularly frustrating with this bug, is that if I place in a macro essentially the exact same VBA code that handles Steps 2 and 3 above (everything except inserting the file), then stops the add-in code after the file insertion in Step 1 and run the rest using the macro, that usually doesn't lead to any distortion. I say usually, because this bug is not 100% reproducible: it will sometimes occur, and sometimes it won't. The most reliable way that I found to reproduce it has been to insert the EMF file linked above.
So there doesn't seem to be a particular issue with the code itself, but with the way Powerpoint runs it. Could there be some race condition? Note that I have also noticed that IguanaTex sometimes raises an error in random locations when grouping/ungrouping shapes, and re-running generally solves the issue, which could also point at some race condition. That however seems unlikely here because the distortion issue still occurs when stepping over the code in debug mode.
My questions are thus: does anyone have a clue what is going on, and how can I fix this?
Below is the macro mentioned earlier:
Public Sub Emftoshape()
Dim ConvertLines As Boolean
ConvertLines = False
Dim Sel As Selection
Set Sel = Application.ActiveWindow.Selection
' Get current slide, it will be used to group ranges
Dim sld As Slide
Dim SlideIndex As Long
SlideIndex = ActiveWindow.View.Slide.SlideIndex
Set sld = ActivePresentation.Slides(SlideIndex)
Dim shp As Shape
Set shp = Sel.ShapeRange(1)
' Convert EMF image to object
Dim Shr As ShapeRange
Set Shr = shp.Ungroup
Set Shr = Shr.Ungroup
' Clean up
Shr.Item(1).Delete
Shr.Item(2).Delete
Dim newShape As Shape
If Shr(3).GroupItems.count > 2 Then
Set newShape = Shr(3)
Else ' only a single freeform, so not a group
Set newShape = Shr(3).GroupItems(2)
End If
Shr(3).GroupItems(1).Delete
If newShape.Type = msoGroup Then
Dim arr_group() As Variant
arr_group = GetAllShapesInGroup(newShape)
Call FullyUngroupShape(newShape)
Set newShape = sld.Shapes.Range(arr_group).Group
Dim emf_arr() As Variant ' gather all shapes to be regrouped later on
j_emf = 0
Dim delete_arr() As Variant ' gather all shapes to be deleted later on
j_delete = 0
Dim s As Shape
For Each s In newShape.GroupItems
j_emf = j_emf + 1
ReDim Preserve emf_arr(1 To j_emf)
If s.Type = msoLine Then
If ConvertLines And (s.Height > 0 Or s.Width > 0) Then
emf_arr(j_emf) = LineToFreeform(s).name
j_delete = j_delete + 1
ReDim Preserve delete_arr(1 To j_delete)
delete_arr(j_delete) = s.name
Else
emf_arr(j_emf) = s.name
End If
Else
emf_arr(j_emf) = s.name
If s.Fill.Visible = msoTrue Then
s.Line.Visible = msoFalse
Else
s.Line.Visible = msoTrue
End If
End If
Next
newShape.Ungroup
If j_delete > 0 Then
sld.Shapes.Range(delete_arr).Delete
End If
Set newShape = sld.Shapes.Range(emf_arr).Group
Else
If newShape.Type = msoLine Then
newShapeName = LineToFreeform(newShape).name
newShape.Delete
Set newShape = sld.Shapes(newShapeName)
Else
newShape.Line.Visible = msoFalse
End If
End If
newShape.LockAspectRatio = msoTrue
End Sub
Private Sub FullyUngroupShape(newShape As Shape)
Dim Shr As ShapeRange
Dim s As Shape
If newShape.Type = msoGroup Then
Set Shr = newShape.Ungroup
For i = 1 To Shr.count
Set s = Shr.Item(i)
If s.Type = msoGroup Then
Call FullyUngroupShape(s)
End If
Next
End If
End Sub
Private Function GetAllShapesInGroup(newShape As Shape) As Variant
Dim arr() As Variant
Dim j As Long
Dim s As Shape
For Each s In newShape.GroupItems
j = j + 1
ReDim Preserve arr(1 To j)
arr(j) = s.name
Next
GetAllShapesInGroup = arr
End Function
Private Function LineToFreeform(s As Shape) As Shape
t = s.Line.Weight
Dim ApplyTransform As Boolean
ApplyTransform = True
Dim bHflip As Boolean
Dim bVflip As Boolean
Dim nBegin As Long
Dim nEnd As Long
Dim aC(1 To 4, 1 To 2) As Double
With s
aC(1, 1) = .Left: aC(1, 2) = .Top
aC(2, 1) = .Left + .Width: aC(2, 2) = .Top
aC(3, 1) = .Left: aC(3, 2) = .Top + .Height
aC(4, 1) = .Left + .Width: aC(4, 2) = .Top + .Height
bHflip = .HorizontalFlip
bVflip = .VerticalFlip
End With
If bHflip = bVflip Then
If bVflip = False Then
' down to right -- South-East
nBegin = 1: nEnd = 4
Else
' up to left -- North-West
nBegin = 4: nEnd = 1
End If
ElseIf bHflip = False Then
' up to right -- North-East
nBegin = 3: nEnd = 2
Else
' down to left -- South-West
nBegin = 2: nEnd = 3
End If
xs = aC(nBegin, 1)
ys = aC(nBegin, 2)
xe = aC(nEnd, 1)
ye = aC(nEnd, 2)
' Get unit vector in orthogonal direction
xd = xe - xs
yd = ye - ys
s_length = Sqr(xd * xd + yd * yd)
If s_length > 0 Then
n_x = -yd / s_length
n_y = xd / s_length
Else
n_x = 0
n_y = 0
End If
x1 = xs + n_x * t / 2
y1 = ys + n_y * t / 2
x2 = xe + n_x * t / 2
y2 = ye + n_y * t / 2
x3 = xe - n_x * t / 2
y3 = ye - n_y * t / 2
x4 = xs - n_x * t / 2
y4 = ys - n_y * t / 2
'End If
If ApplyTransform Then
Dim builder As FreeformBuilder
Set builder = ActiveWindow.Selection.SlideRange(1).Shapes.BuildFreeform(msoEditingCorner, x1, y1)
builder.AddNodes msoSegmentLine, msoEditingAuto, x2, y2
builder.AddNodes msoSegmentLine, msoEditingAuto, x3, y3
builder.AddNodes msoSegmentLine, msoEditingAuto, x4, y4
builder.AddNodes msoSegmentLine, msoEditingAuto, x1, y1
Dim oSh As Shape
Set oSh = builder.ConvertToShape
oSh.Fill.ForeColor = s.Line.ForeColor
oSh.Fill.Visible = msoTrue
oSh.Line.Visible = msoFalse
oSh.Rotation = s.Rotation
Set LineToFreeform = oSh
Else
Set LineToFreeform = s
End If
End Function
Edit:
Here is a visual comparison between several ways to insert the EMF file linked above or a modified version of it, where colors are added for illustration:
The EMF file cleaned by John Korchok to remove a clipping mask and a rectangle, and ungrouped with the GUI. Apart from being distorted (the curves are not smooth, and the "a" and "s" are taller than in the original file), the file indeed behaves the same when ungrouping with VBA of with the GUI. That's unfortunately not a viable solution for my problem.
The EMF file ungrouped using VBA (rectangles/autoshapes are normally removed by IguanaTex). "a" and "s" are clearly taller, as can be seen thanks to the horizontal line added as reference.
The EMF file ungrouped with the GUI. This is the desired outcome.
The corresponding PNG file (obtained by converting from PDF using Ghostscript) whose aspect ratio was modified to match the size of the inserted EMF file. Because I trust the PDF/PNG output more, IguanaTex has an option to "vectorize" a PNG display which resizes the ungrouped EMF to match the PNG's size.
When you get variable and unpredictable results, it makes it likely that it's some property of the source file causing the issue. I opened it in both Adobe Illustrator and InkScape. Your sample file has problems:
The text size is really small, about 2.5 points. This means even slight errors will have large visual results.
The top of the k is definitely clipped by the edge of the EMF. I believe the m may be clipped on the left, but the image is so small I can't zoom in enough to see. Since those are the two letters that get resized, that may be a source of the problem.
Your EMF also includes a rectangle that is 3.91" wide and 1.06" tall, enormous by comparison with the tiny text. The upper left corner of this rectangle is at the same position as the rectangle masking the text.
I think it likely that if you test with more real-world files, you'll get better results.
Public Class Form1
Private Sub Timer1_Tick() Handles Timer1.Tick
Label1.Text = TimeOfDay
Label2.Text = System.DateTime.Now.ToString("MM/d/yyy")
Me.BackColor = ColorTranslator.FromHtml("#" & DateAndTime.Now.ToString("HHmmss"))
Label1.ForeColor = Color.White
Label2.ForeColor = Color.White
End Sub
End Class
In my code above, the background color changes to a hex color code depending on what the time is. However, I would like to change this because the colors that come with these codes are too dark.
Instead I am looking for the code to make the background color the % in red, green, and blue containers. (RGB colors)
For ex, if the time is 11:22:33, then I would like the background color to be 11% red, 22% green and 33% blue. Does this make sense? I am a beginner, and any help is much appreciated.
You need to interpolate between 0 and 255 and use the interpolated value as either red, green or blue value, instead of using the time component directly, if you want to use the full color range. This is because the color components are represented 1 Byte each.
You basically stretch your 0-24 hours to values of 0-255, where Hour=0 corresponds to Red=0 and Hour=24 corresponds to Red=255.
Dim R As Byte = CByte(Date.Now.Hour / 23 * 255)
This is quite similar to your "11% Red" approach.
The other parts would be defined similar,
Dim G As Byte = CByte(Date.Now.Minute / 59 * 255)
Dim B As Byte = CByte(Date.Now.Second / 59 * 255)
The linear interpolation formula in general is
New_Value = (Value - Min) / (Max - Min) * (New_Max - New_Min) + New_Min
Here Min and New_Min is 0, which simplifies the formula somewhat.
To actually assign the color you don't need to set it through construction of a HTML color. You simply can use the Color.FromArgb function. Just type it in in Visual Studio. For some reason IntelliSense (the feature that shows you what methods there are available while typing in the IDE) hides the function in some cases.
Me.BackColor = Color.FromArgb(R, G, B)
This is nothing different than your HTML approach, just simpler (the #321224 value is just a representation of three bytes in hexadecimal, in the form of #RRGGBB).
In the strictest sense the answer above is not exactly what you wanted to use. To use your percentage based approach you would construct the RGB values as
Dim R As Byte = CByte(Date.Now.Hour / 100 * 255)
Dim G As Byte = CByte(Date.Now.Minute / 100 * 255)
Dim B As Byte = CByte(Date.Now.Second / 100 * 255)
but this would not yield you the full color range as well (even 59% of 255 is only 150, so you would never see values between 150 and 255). Linear interpolation is the way to go.
I have a Problem: I am using Interop to create a chart in Powerpoint and this works well. But I have a problem: I need to get the exact position of the dataseries datalabels to draw some shapes. But how to get the damned position?
The DataLabel has left and top values, but they seem to be invalid, e.g.: if i draw something on that position, it appears way of. Is there some kind of transformation, that I have to do?
My code looks like this:
Imports pptNS = Microsoft.Office.Interop.PowerPoint
for i = 1 to Targetchart.Seriescollection.count
Dim DtL = DirectCast(TargetChart.SeriesCollection(i).datalabels, pptNS.DataLabels)
For x = 1 To DtL.count
Dim DTS = DirectCast(DTL.Item(DTLItem), pptNS.DataLabel)
Dim Left =dts.left 'seems to be wrong?
next
next
Any help would be great!
I found a solution: The Topposition will be:
TopPos = DTS.Top + TargetChart.ChartArea.Top + TargetShape.Top + 1.5
Dim LeftPos = DTS.Left + TargetChart.ChartArea.Left + TargetShape.Left
1.5. added for the Topposition because there was a little gap...
Recently we upgraded one our PowerPoint addin to support 2007 and 2010. most of the items we were able to port without problem. one problem we have is that indentations doesn't work when create tables or shapes using the addin.
for eg: same table gets dropped with proper indentation in 2003 but same thing doesn't get indentation when added to using 2007.
below is the code snippet that allows indenting:
With PropertyValues.ObjShape.Table.Cell(row, col).Shape.TextFrame.Ruler
For rulerCount = 0 To 5
.Levels(rulerCount).FirstMargin = rulerFirstMargin(rulerCount) '.LeftMargin = rulerLeftMargin
.Levels(rulerCount).LeftMargin = rulerLeftMargin(rulerCount) 'Left indent marker
Next rulerCount
End With
any idea why this is not working ?
I read the following thread too but didn't help much http://answers.microsoft.com/en-us/office/forum/office_2007-customize/why-shapetextframerulerlevelsi-cant-set-the-bullet/9eac3e46-b13b-433e-b588-216ead1d9c1a?tab=AllReplies#tabs
Updated Code:
PropertyValues.ObjShape.Table.Cell(row, col).Shape.TextFrame.TextRange.Text = "N/A"
With PropertyValues.ObjShape.Table.Cell(row, col).Shape.TextFrame
'Dim rulerCount As Short
For rulerCount = 1 To 5
.Ruler.Levels(rulerCount).FirstMargin = 10 * rulerCount 'rulerFirstMargin(rulerCount) '.LeftMargin = rulerLeftMargin
.Ruler.Levels(rulerCount).LeftMargin = 20 * rulerCount 'rulerLeftMargin(rulerCount) 'Left indent marker
Next rulerCount
End With
PropertyValues.ObjShape.Table.Cell(row, col).Shape.TextFrame.TextRange.Text = text
FWIW, in 2007 and up, you can now have up to 9 ruler levels instead of 5 as in earler versions. But your code should work as is. Here's a simplified version that does work on an arbitrary cell (2,2) of a table:
Dim oSh As Shape
Dim x As Long
Set oSh = ActiveWindow.Selection.ShapeRange(1)
With oSh.Table.Cell(2, 2).Shape.TextFrame
For x = 1 To 9
.Ruler.Levels(x).LeftMargin = x * 10
.Ruler.Levels(x).FirstMargin = x * 20
Next
End With
The other thing you might be running into is that you can apply certain types of formatting (including ruler settings) all you like; if there's no text at the level you're applying it to, PPT won't bark. It'll ignore you. Your settings will have no effect. Sometimes you need to check for text, supply some if there's none there (something highly improbable in the real world) then delete all instances of your improbable text afterwards.
Ugly. Yes.
Here we add text and set indent levels before trying to FORMAT each indent level:
Sub test()
Dim oSh As Shape
Set oSh = ActiveWindow.Selection.ShapeRange(1)
Dim RulerCount As Long
Dim sTemp As String
sTemp = "##$%" ' dummy text
With oSh.Table.Cell(2, 3).Shape.TextFrame
For RulerCount = 1 To 5
.TextRange.Paragraphs(RulerCount).Text = sTemp & vbCrLf
.TextRange.Paragraphs(RulerCount).IndentLevel = RulerCount
Next
For RulerCount = 1 To 5
.Ruler.Levels(RulerCount).FirstMargin = 10 * RulerCount 'rulerFirstMargin(rulerCount) '.LeftMargin = rulerLeftMargin
.Ruler.Levels(RulerCount).LeftMargin = 20 * RulerCount 'rulerLeftMargin(rulerCount) 'Left indent marker
Next RulerCount
End With
End Sub