I've been asked to code the ability to click on an image in Excel and add a shape on top of it (it's a body diagram for a physiotherapist, the shape will indicate the site of the patient's pain). My code does this OK by using the mouse down event of an ActiveX image control:
Private Sub bodypic_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
ClickShape x, y
End Sub
Sub ClickShape(x As Single, y As Single)
Dim shp As Shape
Dim cursor As Point
Set shp = ActiveSheet.Shapes.AddShape(msoShapeMathMultiply, x + ActiveSheet.Shapes("bodypic").Left, _
y + ActiveSheet.Shapes("bodypic").Top, 26, 26)
With shp.Fill
.ForeColor.RGB = RGB(255, 0, 0)
.BackColor.RGB = RGB(255, 0, 0)
End With
shp.Line.Visible = False
End Sub
The problem is that while the mouse cursor is over the diagram the shape is not visible. Only when the mouse is moved off of the diagram does the shape appear.
I've tried various methods to refresh the screen, selecting a cell, even changing the cursor position via the SetCursor method in Lib user32. Nothing seems to work except for the user actually moving the mouse.
To recreate the issue: insert an ActiveX image control roughly 200 x 500 px, add a jpeg image to the control, add the mouse down code to the worksheet and the click shape code to a module.
This is very hacky but I discovered that hiding and unhiding the image solves the problem:
ActiveSheet.Shapes("bodypic").Visible = False
ActiveSheet.Shapes("bodypic").Visible = True
End Sub
I'd welcome more elegant answers!
I have a limited amount of success with this code:-
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Integer, ByVal y As Integer) As Integer
Sub ClickShape(ByVal x As Single, ByVal y As Single)
Dim Shp As Shape
Dim Pos As POINTAPI
GetCursorPos Pos
SetCursorPos Pos.x + 300, Pos.y
With ActiveSheet
With .Shapes("bodypic")
x = x + .Left
y = y + .Top
End With
Set Shp = .Shapes.AddShape(msoShapeMathMultiply, x, y, 26, 26)
End With
With Shp
.Name = "Mark1"
.Line.Visible = False
With .Fill
.ForeColor.RGB = RGB(255, 0, 0)
.BackColor.RGB = RGB(255, 0, 0)
End With
End With
End Sub
In essence, what it does is to move the cursor out of the image. Then it takes about a second for the mark to appear. The delay will be longer the more marks there are. Note that my movement of 300 pixels is random. You would have to work out where to move it, so long as it is outside the image. I tried moving it back immediately, but that didn't work, and timing the return would be tricky because of the variations in the delay.
I experimented with another concept where I created the mark first and made it invisible. Then, on MouseUp (MouseUp is the more suitable event), I moved the mark and made it visible. That was faster, but it limits you to a single mark or condemns you to a lot of name management. Giving a name to the mark is a leftover from that experiment. Actually, it looked quite nice since I could move the mark by repeatedly clicking on different positions. If you need only one mark I recommend to pursue that idea.
If you need several marks, another leftover from my experiments is the idea to add a feature to delete (or hide) a mark, perhaps on double-click.
Related
I am trying to find where the color differs and then crop that part of the image out of it.
Is there any method to get a pixel by pixel image color?
I don't think I can based off of these methods and because it is a bitmap image.
I know there is a set transparent method but the problem is I need to set the widths or heights of logos to be the same height/width and the transparent function doesn't change the size of the picture
If a method does this I would write a function that finds where the image changes from white and then crop from the top middle and bottom.
Example image
As far as I can tell it is impossible to do so within Powerpoint, however there might be a way using outside conditions such as by opening an excel project and using the code from this post VBA Get Colour of Pixel. I'm sorry that I cannot help you in any other way. My main suggestion would be to use normal numbers to crop it. Perhaps if you found a specific thing between the images that was different (Such as one type of image's height was different than the other type of image so you could use that to know how far to crop the image.), however as far as I can tell, No. There is no way to do this with powerpoint unless they added a feature.
I was recently working on a similar problem, and I developed a VBA solution for automatically cropping a white border from an image
In that answer, I am only looking at one side of the image because I assume that the border is uniform all of the way around, so it would not directly work for this case. Also, that example only modifies the slide, and it does not produce an output file
In the below example, each side of the image is examined and cropped according to how much whitespace is found. The resultant slide is then exported back to the original directory with the name croppedFile.
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Function PixelTest(objPict As Object, ByVal X As Long, ByVal Y As Long) As Long
Dim lDC As Variant
lDC = CreateCompatibleDC(0)
SelectObject lDC, objPict.Handle
PixelTest = GetPixel(lDC, X, Y)
DeleteDC lDC
End Function
Sub AutoCropper()
Dim myDocument As Slide, fileSystem As Object, fileFolder As Object
Dim fileItem As Object, objPict As Object, objImage As Object
Dim i As Integer, startingPoint As Integer, endingPoint As Integer
Dim MidPoint As Integer, filePath As String, fileName As String
Dim cropScale As Single, margin As Single, reverseScan As Integer
Dim importHeight As Single, importWidth As Single, resolutionScale As Integer
Dim xlocation As Single, yLocation As Single
Dim restoreLayout As Boolean
filePath = "D:\Pictures"
fileName = "Example.bmp"
Set fileSystem = CreateObject("Scripting.FileSystemObject")
Set fileFolder = fileSystem.GetFolder(filePath)
Set objImage = CreateObject("WIA.ImageFile")
cropScale = 3.4
resolutionScale = 10
importWidth = 330
importHeight = 250
xlocation = 390
yLocation = 200
For Each fileItem In fileFolder.Files
If fileItem.Name = fileName Then
i = i + 1
On Error GoTo insertSlide
Set myDocument = ActivePresentation.Slides(i)
If myDocument.CustomLayout.Name = "Picture with Caption" Then
myDocument.Layout = ppLayoutText
restoreLayout = True
End If
Set preCroppedPic = myDocument.Shapes.AddPicture(fileName:=fileFolder & "\" & _
fileItem.Name, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, _
Left:=xlocation, Top:=yLocation, Width:=importWidth, Height:=importHeight)
preCroppedPic.Export filePath & "\Temp.bmp", ppShapeFormatBMP, preCroppedPic.Width, preCroppedPic.Height, ppScaleToFit
Set objImage = CreateObject("WIA.ImageFile")
objImage.LoadFile filePath & "\Temp.bmp"
Set objPict = LoadPicture(filePath & "\Temp.BMP")
endingPoint = objImage.Width
MidPoint = (0.5 * objImage.Height)
For marginScan = 1 To endingPoint
On Error Resume Next
If Not (PixelTest(objPict, marginScan, MidPoint) Like "1677*") Then
margin = marginScan * cropScale
preCroppedPic.PictureFormat.CropLeft = margin
Exit For
End If
Next
For marginScan = 1 To endingPoint
reverseScan = endingPoint - marginScan
If Not (PixelTest(objPict, reverseScan, MidPoint) Like "1677*") Then
margin = marginScan * cropScale
preCroppedPic.PictureFormat.CropRight = margin
Exit For
End If
Next
endingPoint = objImage.Height
MidPoint = (0.5 * objImage.Width)
For marginScan = 1 To endingPoint
If Not (PixelTest(objPict, MidPoint, marginScan) Like "1677*") Then
margin = marginScan * cropScale
preCroppedPic.PictureFormat.CropTop = margin
Exit For
End If
Next
For marginScan = 1 To endingPoint
reverseScan = endingPoint - marginScan
If Not (PixelTest(objPict, MidPoint, reverseScan) Like "1677*") Then
margin = marginScan * cropScale
preCroppedPic.PictureFormat.CropBottom = margin
' finalHeight = finalHeight - margin
Exit For
End If
Next
If restoreLayout Then
myDocument.Layout = ppLayoutPictureWithCaption
restoreLayout = False
End If
preCroppedPic.Export filePath & "\CroppedImage.bmp", ppShapeFormatBMP, (resolutionScale * importWidth), (resolutionScale * importHeight), ppScaleToFit
Exit For
End If
Next fileItem
Exit Sub
insertSlide:
Set myDocument = ActivePresentation.Slides.Add(i, ppLayoutText)
Resume Next
End Sub
The preceding code produces the following result with the precropped image on the left and the postcropped image on the right:
Obviously, a correct file path and file name have to be supplied, but here are a few not so obvious things that need to be taken into consideration when working with this script:
• This program has been tested and confirmed to work for BMP, JPEG, GIF, and PNG files, but the file name and extension are case sensitive, so if you run the code and nothing happens, I would check that first.
• I've tested this on multiple systems, and I've found that the pixel analyzer in this program will not work for PNGs. To make this script PNG compatible, because that is what I normally work with, I had to perform an intermediary file conversion that creates a temporary BMP file. Between the different environments I tested this script on, I found that the export size varied quite a bit, but it was always proportional to the original picture. For this reason, there is a cropScale value that can be used to account for this ratio. A cropScale value of 2 for example will crop 2 white pixels from the original photo for every 1 pixel detected in the temporary bmp.
• Also, due to the export descrepencies, I've found that the export file will often have a lower resolution than the original, so a resolutionScale parameter has been added to compensate for this in the output file. This along with the cropScale parameters should make it simple to get this script working on wide variety of systems.
• Finally, this script can be modified to crop any border color or even gradient colors by modifying the If Not Like parameters in the four cropping loops, but the colors returned from the pixel analyzer are not RGB values. Rather they are Long values.
• A list of Long color values can be found here: Long Color Chart
• For more information on scaling picture sizes and resolutions in PowerPoint, I found this excellent resource while researching this solution:Unravelling PowerPoint picture size and resolution
I have a loop that generates rectangles automatically on a visio drawing but I need to have the script to arrange them automatically right know I recorded a macro while I rearranged the rectangles manually under the title box. But my rectangle count change constantly because the results from my if statement change constantly because my data continuously changes. I need for my loop to start drawing them under the title box in columns of six or seven rectangles.
For I = 1 To WS_Count
Set vsoShape =
Application.ActiveWindow.Page.Drop(Application.DefaultRectangleDataObject,
aoffset, boffset)
vsoShape.Text = ActiveWorkbook.Worksheets(I).Name
aoffset = aoffset
boffset = boffset + 0.75
Dev_Count = Dev_Count + 1
ActiveDocument.DiagramServicesEnabled = DiagramServices
Next I
I need to be able to set a starting position to begin dropping the rectangles below the title rectangle creating a new column every six to seven rectangles. Thanks
Increment aOffset every time I is divisible by the number of shapes you want horizontally...
You can do this with the Mod Operator If (iterator Mod runEveryXIterations = 0) Then ...
The example below should clarify the idea, the code is not exactly what you need but you should be able to grasp the idea:
Option Explicit
Public Sub printXY()
xyDistribute 10, 3, 0, 0, 0.75, 1.5
End Sub
Private Function xyDistribute(ByRef iterations As Long, _
ByRef newColAfter As Long, _
ByRef xPosInitial As Double, _
ByRef yPosInitial As Double, _
ByRef xStep As Double, _
ByRef yStep As Double)
Dim iter As Long
Dim xPos As Double
Dim yPos As Double
yPos = yPosInitial
xPos = xPosInitial
Debug.Print "xPos", "yPos"
For iter = 1 To iterations
Debug.Print xPos, yPos
' your code goes here
If (iter Mod newColAfter = 0) Then
yPos = yPos + yStep
xPos = xPosInitial
Else
xPos = xPos + xStep
End If
Next iter
End Function
I'm writing a macro to add a shape on top of a picture (ActiveX) when it's clicked on:
Private Sub clickpic_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
ClickShape CLng(x), CLng(y)
End Sub
Public addedShapes() As Shape
Public sIndex As Integer
Sub ClickShape(x As Long, y As Long)
Dim shp As Shape
Application.ScreenUpdating = False
Set shp = ActiveSheet.Shapes.AddShape(msoShapeMathMultiply, x + ActiveSheet.Shapes("clickpic").Left - 10, _
y + ActiveSheet.Shapes("clickpic").Top - 10, 20, 20)
With shp.Fill
.ForeColor.RGB = RGB(255, 0, 0)
.backColor.RGB = RGB(255, 0, 0)
End With
shp.Line.Visible = False
shp.Name = CStr(shp.Top & shp.Left)
ReDim Preserve addedShapes(sIndex)
sIndex = sIndex + 1
Set addedShapes(UBound(addedShapes)) = shp
ActiveSheet.Shapes("clickpic").Visible = False
ActiveSheet.Shapes("clickpic").Visible = True
Application.ScreenUpdating = True
End Sub
I've found the only way to display the shape immediately is to enable and disable the picture:
ActiveSheet.Shapes("clickpic").Visible = False
ActiveSheet.Shapes("clickpic").Visible = True
However, despite turning screen updating off this still causes the screen to refresh / flicker. Any idea how I can prevent this?
Read somewhere that Visible = True/False may trigger recalculation of the sheet, which may cause the flicker. It's worth trying to set calculation to manual during your code.
I have a vba script that runs during presentation on a slide on a power point presentation. On the same slide, I have an animation. The script is running fine "in the background" when the animation is run, but at a certain step of the animation, I would like to change how the vba-script is run. Either by checking the timeline object or somewhere else to check how far the animation has been run, or by triggering an event when reaching the correct step, but I have not been able to find anything.
This is my script at the moment (illustrating a radioactive source, sending out radiation in all directions)
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Running As Boolean ' Switched on or off by another sub
Sub DrawLines()
Dim endx As Long
Dim endy As Long
Dim Slideid As Long
Dim tetha As Double
Dim origx As Long
Dim origy As Long
Dim linelength As Long
Dim tl As TimeLine
Slideid = 2
origx = 100
origy = 430
linelength = 2000
Dim newline As Shape
While Running
With ActivePresentation.Slides(Slideid).Shapes
tetha = 2 * 3.1415 * Rnd()
endx = Int(linelength * Sin(tetha))
endy = Int(linelength * Cos(tetha))
' Here I want to alter endx and endy after a certain step in the animation
Dim sleeptime As Long
sleeptime = Int(500 * Rnd())
Set newline = .AddLine(origx, origy, endx, endy)
DoEvents ' needed to redraw
Sleep (30)
newline.Delete
DoEvents ' needed to redraw
Sleep (sleeptime)
End With
Wend
End Sub
At the point where I would like to alter endx and endy, I have been looking for something either like
IF Activepresentation.slides(slideid).timeline.activestep>=5 THEN
dosomething()
End if
or if I could make something like
Public Changed as boolean
Sub OnSlideShowAnimationStep( .... )
IF currentstep >=5
Changed = TRUE
end if
end sub
and then I can check for Changed in drawlines, but I can neither find any attribute telling me the current animation step nor any event that is fired on animation steps. Any other places I should have looked?
If the animations are On Click you can use SlideShowWindow(1),View.GetClickCount
Otherwise you can maybe use OnSlideShowNextBuild(ByVal Wn As SlideShowWindow) to count
I don't know about any events or ways of checking on what step or where on the timeline
but you have one hack that might fix this.
when you are in your loop you can always check for the (left, top) position of the shape. And that changes while the animation run.
But on the other hand you might be able to manually iterate the animation by using the MoveTo function of the Effect object.
MSDN
But I haven't used that myself.
Nodes of a TreeView control do not have a 'mouse over' property to test for. I was hoping to "highlight" the node (to give the user feedback on which one is selected).
For example, when the MouseMove event fires on the TreeView control, I can set a node object to what "HitTest" returns:
Set nde = trvChoices.HitTest(x, y * 15)
I am looking for a way to have this node "highlighted" (or something) when the mouse is over it, in order to give the user feedback of which node in the TreeView is selected. Yes, I am using TreeView as a 'right-click' menu. I do not wish to use a different control, although I may have to...
It was a no-brainer to get the node to be Bold on hover. However, setting the BackColor or ForeColor to any color e.g. wdYellow would just black out the entire node...
Posting example code in case anyone else runs into this:
Private Sub trvChoices_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
If Not (trvChoices.HitTest(x, y * 15) Is Nothing) Then
Dim nde As Node
Set nde = trvChoices.HitTest(x, y * 15)
'I have three nodes only, but the proper way would be to loop through the trvChoices and set each node to Bold = False
trvChoices.Nodes(1).Bold = False
trvChoices.Nodes(2).Bold = False
trvChoices.Nodes(3).Bold = False
nde.Bold = True
Set nde = Nothing
End If
End Sub
I've been trying to get OLEDragDrop to work with a Treeview and Listview and had run into an issue where the StartDrag tried to take across the item that was active in the Treeview before the user had started the StartDrag, rather than the item that they were trying to drag across. I had seen solutions elsewhere that required the user to click on an item before dragging, but this was counterintuitive. By modifying your code slightly I was able to set the item under the mouse as the active item which:
(a) gives feedback to the user and
(b) makes the OLEDragDrop work correctly.
Private Sub trvChoices_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
If Not (trvChoices.HitTest(x * 15, y * 15) Is Nothing) Then
Dim nde As node
Set nde = trvChoices.HitTest(x * 15, y * 15)
nde.Selected = True
Set nde = Nothing
End If
End Sub
The * 15 is for pixel/twip conversion. Unfortunately it doesn't work for all monitors as different monitors have a different rate between pixel and twips depending on monitor ratio. BUT 15 does comply to standard 4:3 monitors.
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Const WU_LOGPIXELSX = 88
Const WU_LOGPIXELSY = 90
Use above to get this.
Additionally you need to check if you need to do the conversion at all as different versions use different output x,y values.