I would like to place a graphic in the center of a cell of a PPT table using a VBA macro. This graphic should act as button for starting a movie.
Example of table
Now I have 2 questions:
How can I place the graphics in a cell
How do I tell PPT to use such a predefined graphics
Or are there better ways to start an animation by clicking on a cell.
Sub table_with_button()
Dim PR As Presentation
Dim FOL As Slide
Dim xx, yy, dx, dy As Integer
Dim Bild, tabelle As Shape
Dim video As String
Set PR = ActivePresentation
Set FOL = PR.Slides.Add(PR.Slides.Count + 1, ppLayoutBlank)
' create table
Set tabelle = FOL.Shapes.AddTable(NumRows:=2, NumColumns:=2, _
Left:=cm2Points(1), Top:=cm2Points(1), _
Width:=cm2Points(5), Height:=cm2Points(5))
' get position of table cell
xx = tabelle.Table.Cell(2, 2).Shape.Left
yy = tabelle.Table.Cell(2, 2).Shape.Top
dx = tabelle.Table.Cell(2, 2).Shape.Width
dy = tabelle.Table.Cell(2, 2).Shape.Height
' insert button
Set Bild = FOL.Shapes.AddShape(msoShapeActionButtonForwardorNext, xx, yy, _
dy * 0.5, dy * 0.5)
' move button to cell center
Bild.Left = xx + (dx / 2) - (Bild.Width / 2)
Bild.Top = yy + (dy / 2) - (Bild.Height / 2)
' insert hyperlink
video = "c:\video.avi"
Bild.AlternativeText = video
Bild.ActionSettings(ppMouseClick).Hyperlink.Address = video
End Sub
Function cm2Points(inVal As Single)
cm2Points = inVal * 28.346
End Function
Function Points2cm(ByVal inVal As Single)
Points2cm = inVal / 28.346
End Function
Related
I've been working through a YouTube tutorial for creating a Drag and Drop game in PowerPoint using VBA, and have got the VBA code working as expected, but I'm wondering if anyone could give me some advice on how to add to the code in order to do something that I'm trying to do. I have some programming experience in Python, but no experience scripting PPT files or VBA. Any help you can give here would be appreciated!
What I'm trying to do is apply the code to multiple slides in the same presentation. For example, I want to have some items on one slide be affected by the Drag and Drop code, and then move on to the next slide and do the same with other items. From looking at the code, and from my understanding, it's the sections that have
ActivePresentation.Slides(2)
that are what needs changing. Now, I know that the (2) refers to the slide number, but could you advise what to change this to in order for it to work on ANY slide number (I'm guessing this would need to refer to the current slide somehow). I've tried various commands that I've found online, but none seem to do what I want - anything I enter in the brackets that looks like it should affect the current slide results in the drag and drop not working at all on any slide, including the original slide that was working before the change to the code.
The relevant code is below:
Sub DragAndDrop(selectedShape As Shape)
obj_end = selectedShape.Name + "_end"
dragMode = Not dragMode
DoEvents
' If the shape has text and we're starting to drag, copy it with its formatting to the clipboard
If selectedShape.HasTextFrame And dragMode Then selectedShape.TextFrame.TextRange.Copy
dx = GetSystemMetrics(SM_SCREENX)
dy = GetSystemMetrics(SM_SCREENY)
' Shirt start position
objStart.X = selectedShape.left
objStart.Y = selectedShape.top
objEnd.X = ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes(obj_end).left
objEnd.Y = ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes(obj_end).top
'objEnd.X = ActivePresentation.Slides(2).Shapes(obj_end).left
'objEnd.Y = ActivePresentation.Slides(2).Shapes(obj_end).top
Drag selectedShape
' Paste the original text while maintaining its formatting, back to the shape
If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Paste
DoEvents
End Sub
Private Sub Drag(selectedShape As Shape)
#If VBA7 Then
Dim mWnd As LongPtr
#Else
Dim mWnd As Long
#End If
Dim sx As Long, sy As Long
Dim WR As RECT ' Slide Show Window rectangle
Dim StartTime As Single
' Change this value to change the timer to automatically drop the shape (can by integer or decimal)
Const DropInSeconds = 2
' Get the system cursor coordinates
GetCursorPos mPoint
' Find a handle to the window that the cursor is over
mWnd = WindowFromPoint(mPoint.X, mPoint.Y)
' Get the dimensions of the window
GetWindowRect mWnd, WR
sx = WR.lLeft
sy = WR.lTop
Debug.Print sx, sy
With ActivePresentation.PageSetup
dx = (WR.lRight - WR.lLeft) / .SlideWidth
dy = (WR.lBottom - WR.lTop) / .SlideHeight
Select Case True
Case dx > dy
sx = sx + (dx - dy) * .SlideWidth / 2
dx = dy
Case dy > dx
sy = sy + (dy - dx) * .SlideHeight / 2
dy = dx
End Select
End With
StartTime = Timer
While dragMode
GetCursorPos mPoint
selectedShape.left = (mPoint.X - sx) / dx - selectedShape.Width / 2
selectedShape.top = (mPoint.Y - sy) / dy - selectedShape.Height / 2
Dim left As Integer
Dim top As Integer
left = selectedShape.left
top = selectedShape.top
' Comment out the next line if you do NOT want to show the countdown text within the shape
If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes("lblInfo").TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
'ActivePresentation.Slides(2).Shapes("lblInfo").TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
DoEvents
If Timer > StartTime + DropInSeconds Then
dragMode = False
With ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes(obj_end) ' EXAMPLE:square_end is where you want the square to land
If selectedShape.left >= .left And selectedShape.top >= .top And (selectedShape.left + selectedShape.Width) <= (.left + .Width) And (selectedShape.top + selectedShape.Height) <= (.top + .Height) Then
ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes("talk").TextFrame.TextRange = "Got it! Great job!"
'totalPoints = totalPoints + 1
Else
' Try again
selectedShape.left = objStart.X
selectedShape.top = objStart.Y
ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes("talk").TextFrame.TextRange = "Sorry! Try again!"
End If
End With
End If
Wend
DoEvents
End Sub
I have looked for GetDIBits all over and only seem to find discussion in every other application other than Excel 2016.
I keep getting back 0 for all of the pixel values. I don't know if using Image1.Picture.Handle is the proper statement for the hdc, and I don't know if Image1.Picture is the proper statement for the hbitmap.
I can't even get a result to show up in an image box using the SetDIBits function.
Most of the content on the web uses PictureBox, and Autodraw, and stuff that doesn't seem to be in Excel.
Can anyone please help me solve this problem. It would be greatly appreciated. I would post all the Declarations but I didn't want to be booted of the site my question was too long. Thanks in advance.
Private Sub CommandButton2_Click() 'Userform command button
Dim X As Long 'X coordinates for the pixels
Dim Y As Long 'Y coordinates for the pixels
Dim sw As BITMAP
Dim bmapinfo As BITMAPINFO 'Information about the bitmap
Dim xtPixels() As RGBPixel 'Array to place pixel data into
Dim oPic As IPictureDisp 'Declaration of picture used in this program
Set oPic = Image1.Picture 'making the picture an object
'All of the data below gives information about the picture
bmapinfo.bmiHeader.biSize = 40
bmapinfo.bmiHeader.biWidth = oPic.Width
bmapinfo.bmiHeader.biHeight = oPic.Height
bmapinfo.bmiHeader.biPlanes = 1
bmapinfo.bmiHeader.biBitCount = 24
'bmapinfo.bmiHeader.biCompression = BI_RGB
bmapinfo.bmiHeader.biXPelsPerMeter = ((((bmapinfo.bmiHeader.biWidth * bmapinfo.bmiHeader.biBitCount) + _
31) \ 32) * 4)
bmapinfo.bmiHeader.biYPelsPerMeter = bmapinfo.bmiHeader.biXPelsPerMeter - (((bmapinfo.bmiHeader.biWidth _
* bmapinfo.bmiHeader.biBitCount) + 7) \ 8)
bmapinfo.bmiHeader.biSizeImage = bmapinfo.bmiHeader.biXPelsPerMeter * Abs(bmapinfo.bmiHeader.biHeight)
' GetObjectAPI voPicture.Handle, LenB(tBmp), tBmp
' nBitCount = tBmp.bmWidth * tBmp.bmBitsPixel * tBmp.bmHeight \ 4
ReDim xtPixels(1 To bmapinfo.bmiHeader.biWidth, 1 To bmapinfo.bmiHeader.biHeight)
'All of the data above gives information about the picture
GetDIBits Image1.Picture.Handle, sw.bmBitsPixel, _
0, bmapinfo.bmiHeader.biHeight, xtPixels(1, 1), bmapinfo, _
DIB_RGB_COLORS
For Y = 1 To UBound(xtPixels, 1) - 1
For X = 1 To UBound(xtPixels, 2) - 1
'With xtPixels(Y, X)
xtPixels(Y, X).Blue = xtPixels(Y, X).Blue
xtPixels(Y, X).Green = xtPixels(Y, X).Green
xtPixels(Y, X).Red = xtPixels(Y, X).Red
Next X, Y
SetDIBits oPic.Handle, oPic.Handle, _
0, bmapinfo.bmiHeader.biHeight, xtPixels(1, 1), _
bmapinfo, DIB_RGB_COLORS
'Set Image2.Picture = oPic.Render
End Sub
I created some kind of phone protocol sheet in excel and I wanted to add a section with quadrille paper for sketching purposes. Therefore I wrote a quite simple macro in VBA that draws horizontal and vertical lines in a selected range:
Public Sub Fill()
Dim angepeilteMaschenWeiteInPixel As Integer
angepeilteMaschenWeiteInPixel = 15
Dim LinienFarbe As Long
LinienFarbe = RGB(220, 220, 220)
Dim obenLinks As Double, obenRechts As Double
Dim untenLinks As Double, untenRechts As Double
Dim ausgewaehlteRange As Range
Set ausgewaehlteRange = Selection
' Anzahl Spalten und Zeilen ermitteln bei idealer Breite/Höhe 10px
Dim idealeSpaltenAnzahl As Integer
Dim idealeZeilenAnzahl As Integer
idealeSpaltenAnzahl = CInt(Round((ausgewaehlteRange.Width / angepeilteMaschenWeiteInPixel), 0))
idealeZeilenAnzahl = CInt(Round((ausgewaehlteRange.Height / angepeilteMaschenWeiteInPixel), 0))
' Aus der idealen Spalten- und Zeilenanzahl die ideale Maschenweite und - höhe in Pixeln ermitteln
Dim idealeMaschenBreite As Double
Dim idealeMaschenHoehe As Double
idealeMaschenBreite = ausgewaehlteRange.Width / CDbl(idealeSpaltenAnzahl)
idealeMaschenHoehe = ausgewaehlteRange.Height / CDbl(idealeZeilenAnzahl)
' vertikale Linien zeichnen
Dim i As Integer
For i = 1 To idealeSpaltenAnzahl - 1
Dim horizontal As Integer
horizontal = CInt(ausgewaehlteRange.Left + i * idealeMaschenBreite)
Dim oben As Integer
oben = Round(ausgewaehlteRange.Top, 0)
Dim unten As Integer
unten = Round(oben + ausgewaehlteRange.Height, 0)
With ActiveSheet.Shapes.AddLine(horizontal, oben, horizontal, unten).Line
.ForeColor.RGB = LinienFarbe
End With
Next i
' horizontale Linien zeichnen
Dim j As Integer
For j = 1 To idealeZeilenAnzahl - 1
Dim vertikal As Integer
vertikal = CInt(ausgewaehlteRange.Top + j * idealeMaschenHoehe)
Dim links As Integer
links = CInt(Round(ausgewaehlteRange.Left, 0))
Dim rechts As Integer
rechts = CInt(Round(links + ausgewaehlteRange.Width, 0))
With ActiveSheet.Shapes.AddLine(links, vertikal, rechts, vertikal).Line
.ForeColor.RGB = LinienFarbe
End With
Next j
End Sub
in excel everything looks fine:
but in the print preview and also printed out, the horizontal line gap is uneven and I have no idea why:
Anybody out there who can help me?
I suspect the lines are moving with the cells. Try setting the object positioning property to "Don't move or size with cells" which the English value is xlFreeFloating.
Example:
With ActiveSheet.Shapes.AddLine(links, vertikal, rechts, vertikal)
.Line.ForeColor.RGB = LinienFarbe
.Placement = xlFreeFloating
End With
Edit
Interesting behavior... I still think it's related to cells & margins as the lines move with cell width changes in print preview even though position is set to freeform.
I did find a workaround by grouping the lines together.
Added three lines of code. Add the following to both With blocks after Horizontal and Vertical lines are created.
.Select Replace:=False
Now add this line at the end of the sub:
Selection.Group
Now all the lines that were just created are grouped together.
Result image from print preview.
Example of last code block for your reference:
' horizontale Linien zeichnen
Dim j As Integer
For j = 1 To idealeZeilenAnzahl - 1
Dim vertikal As Integer
vertikal = CInt(ausgewaehlteRange.Top + j * idealeMaschenHoehe)
Dim links As Integer
links = CInt(Round(ausgewaehlteRange.Left, 0))
Dim rechts As Integer
rechts = CInt(Round(links + ausgewaehlteRange.Width, 0))
With ActiveSheet.Shapes.AddLine(links, vertikal, rechts, vertikal)
.Line.ForeColor.RGB = LinienFarbe
.Placement = xlFreeFloating
.Select Replace:=False
End With
Next j
Selection.Group
End Sub
I searched before posting but couldn't find anything close to my issue.
What I need to figure out is how to come with the optimal width and height of picture boxes (with a 4:3 ratio), given the required number of boxes to be displayed, and the available space.
Now, it's not as simple as a just dividing the available space by the number of required boxes, because the available space is not a uniform shape, but rather two rectangles of which size may vary (see this picture, it's the a+b space).
If fact, I have tried starting from there with the following code :
Private Sub LayoutSnapshots()
Dim lTotalSpace As Single, lSnapsize As Single, sXSize As Single, sYSize As Single
Dim I As Integer, J As Integer, X As Integer = 0, Y As Integer = 0, oPic As PictureBox
' bSnaps is the number of picture boxes to be displayed
If stSetting.bSnaps = 0 Then Exit Sub
' oSnaps is a List(Of PictureBoxe) to groupp the actual picture boxes
If oSnaps.Count > 0 Then
For Each oCtrl As PictureBox In oSnaps
Me.Controls.Remove(oCtrl)
Next
End If
oSnaps.Clear()
' Calculating the a+b space shown on the picture
lTotalSpace = ((Me.ClientSize.Height - MenuStrip1.Height) * Me.ClientSize.Width) - ((picPreview.Width + iMargin) * (picPreview.Height + iMargin))
If lTotalSpace < 1 Then
MsgBox("Window is too small. Please adjust one of these settings : Window size, Snapshots count, Live free view size.", MsgBoxStyle.ApplicationModal Or MsgBoxStyle.Exclamation Or MsgBoxStyle.OkOnly)
Exit Sub
End If
'calculating a single picture's size by dividing total space by the number of snaps
lSnapsize = Math.Truncate(lTotalSpace / stSetting.bSnaps)
'Calculating Height and Width, with 4:3 ratio
sXSize = Math.Truncate(Math.Sqrt((4 * lSnapsize) / 3))
sYSize = Math.Truncate(Math.Sqrt((3 * lSnapsize) / 4))
For I = 1 To stSetting.bSnaps
If oPic IsNot Nothing Then oPic = Nothing
oPic = New PictureBox
oPic.BackColor = Color.White
oPic.BorderStyle = BorderStyle.FixedSingle
oPic.Size = New Size(sXSize - 1, sYSize - 1)
oPic.Location = New Point(X * sXSize, (Y * sYSize) + MenuStrip1.Height)
oSnaps.Add(oPic)
' Layed them successively on screen, need to optimize this
If ((X + 2) * sXSize) > (Me.ClientSize.Width) Then
X = 0
Y += 1
Else
X += 1
End If
Next
For Each oCtrl As PictureBox In oSnaps
Me.Controls.Add(oCtrl)
Next
End Sub
But obviously with all the possibilities of windows resizing, I couldn't think of any practical way to optimize it.
I am pretty sure this has to do with "operation research", as I recall we did optimization problems like this back then when I was a student, but I'm not sure how to actually model this or even if it is solvable by linear programming.
I have figured this out. The solution is kind of a "brute force" technique, it doesn't always return the optimum BUT the error is merely a few pixels. I used the code below, it works but it might need further optimization in terms of spacing. I couldn't comment on everything since I have a time pressure right now, but still wanted to share the answer, so just take some time to analyze it :
Private Sub LayoutSnapshots()
Dim sA As Single, sB As Single, sTotal As Single, sSnap As Single, sWidth As Single, sHeight As Single
Dim iCount As Integer = stSetting.bSnaps, iFit As Integer, iX As Integer, iY As Integer, iYg As Integer, I As Integer
Dim rA As Rectangle, rB As Rectangle, oPic As PictureBox, lpLoc As New List(Of Point), pLoc As New Point
Static bWarn As Boolean
Dim gPic As Graphics
' bSnaps is the number of picture boxes to be displayed
If stSetting.bSnaps = 0 Then Exit Sub
' If controls already on form, remove them and start form scratch
If oSnaps.Count > 0 Then
For Each oCtrl As PictureBox In oSnaps
Me.Controls.Remove(oCtrl)
Next
End If
' oSnaps is a List(Of PictureBox) grooping the picture boxes. Clear it for now
oSnaps.Clear()
'sA, sB are the sizes of spaces A and B respectively
sA = (Me.ClientSize.Width * (Me.ClientSize.Height - (MenuStrip1.Height + picPreview.Height + iMargin)))
sB = ((Me.ClientSize.Width - (picPreview.Width + iMargin)) * (picPreview.Height + iMargin))
' Total free space
sTotal = sA + sB
' This condition is important. It ensures there is at least one solution
' before entering the loops bellow. Otherwise we might get stuck in an infinite loop
If (sTotal < (stSetting.bSnaps * stSetting.bSnaps)) Then
' bWarn is a static boolean. Since this Sub is called from Form_Resize event, we
' want to warn the user only once when there is no space.
' Otherwise it becomes annoying.
If bWarn Then MsgBox("Window is too small. Please adjust one of these settings : Window size, Snapshots count, Live free view size.", MsgBoxStyle.ApplicationModal Or MsgBoxStyle.Exclamation Or MsgBoxStyle.OkOnly)
bWarn = False
Exit Sub
End If
bWarn = True
Me.UseWaitCursor = True
Do
'rA, rB are the bounding rectangles of spaces A and B respectively
rA = New Rectangle(0, MenuStrip1.Height, Me.ClientSize.Width, Me.ClientSize.Height - (MenuStrip1.Height + picPreview.Height + iMargin))
rB = New Rectangle(0, picPreview.Top, Me.ClientSize.Width - (picPreview.Width + iMargin), picPreview.Height + iMargin)
' A single box's size
sSnap = Math.Truncate(sTotal / iCount)
' Width and Height with 4:3 aspect ratio.
sWidth = Math.Truncate(Math.Sqrt((4 * sSnap) / 3))
sHeight = Math.Truncate(Math.Sqrt((3 * sSnap) / 4))
' iFit keeps track of how many boxes we could fit in total
iFit = 0
iYg = 0
lpLoc.Clear()
' It would be a bit too long to explain the next block of code and I have a deadline to meet
' I'll comenting on that later
iX = 0
iY = 0
Do While (rA.Height >= ((sHeight * (iY + 1)) + 1))
If (((iX + 1) * sWidth) + 1) <= rA.Width Then
iFit += 1
lpLoc.Add(New Point(rA.X + ((iX * sWidth) + 1), rA.Y + ((iYg * sHeight) + 1)))
iX += 1
Else
iX = 0
iY += 1
iYg += 1
End If
Loop
'Add unused space from A to B.
rB.Height = rB.Height + (rA.Height - ((iYg * sHeight) + 1))
iX = 0
iY = 0
Do While (rB.Height >= ((sHeight * (iY + 1)) + 1))
If (((iX + 1) * sWidth) + 1) <= rB.Width Then
iFit += 1
lpLoc.Add(New Point(rB.X + ((iX * sWidth) + 1), rA.Y + ((iYg * sHeight) + 1)))
iX += 1
Else
iX = 0
iY += 1
iYg += 1
End If
Loop
Application.DoEvents()
iCount += 1
Loop While iFit < stSetting.bSnaps
' Add controls to form. Lay them one next to each other.
iX = 0
iY = 0
For I = 1 To stSetting.bSnaps
If oPic IsNot Nothing Then oPic = Nothing
oPic = New PictureBox
oPic.BackColor = Color.Cyan
oPic.BorderStyle = BorderStyle.FixedSingle
oPic.Size = New Size(sWidth - 1, sHeight - 1)
oPic.Location = lpLoc(I - 1)
' Just for debugging, displays index of each box inside it.
oPic.Image = New Bitmap(oPic.Width, oPic.Height)
gPic = Graphics.FromImage(oPic.Image)
gPic.DrawString(I, New Font("Arial", 10, FontStyle.Regular), Brushes.Red, New Point(0, 0))
oSnaps.Add(oPic)
Me.Controls.Add(oSnaps.Last)
Next
'Catch Ex As Exception
'Finally
Me.UseWaitCursor = False
'End Try
End Sub
P.S : Anyone please feel free to add more explanation to the code if you want.
I was tasked today after creating a program to Add watermarks to also create one to remove that same watermark.
My thoughts are that it is now part of the image and can't be removed so easily.
Is this accurate or is the actually a way? ( that doesnt take 10 years)
thanks for any hints
Here is my code to add the watermarks:
Dim watermark_bm As Bitmap = Global.AnchorAuditor.My.Resources.Logo_White
Dim watermark_bm2 As Bitmap = Global.AnchorAuditor.My.Resources.CLS_Logo_White_Engineering
'watermark_bm2.MakeTransparent()
' WATERMARK IMAGE 1 - AA
Using str As Stream = File.OpenRead(s)
Dim or_bm As Bitmap = Image.FromStream(str)
'''''''''''''''''''''''''START IMAGE 1''''''''''''''''''''''''''
or_bm.SetResolution(20, 20)
Dim x1 As Integer = or_bm.Width - 300
Dim Y As Integer = or_bm.Height - 300
Const ALPHA As Byte = 128
' Set the watermark's pixels' Alpha components.
Dim clr As Color
For py As Integer = 0 To watermark_bm.Height - 1
For px As Integer = 0 To watermark_bm.Width - 1
clr = watermark_bm.GetPixel(px, py)
watermark_bm.SetPixel(px, py, _
Color.FromArgb(ALPHA, clr.R, clr.G, clr.B))
Next px
Next py
' Set the watermark's transparent color.
watermark_bm.MakeTransparent(watermark_bm.GetPixel(0, _
0))
' Copy onto the result image.
Dim gr As Graphics = Graphics.FromImage(or_bm)
gr.DrawImage(watermark_bm, x1, Y)
'''''''''''''''''''''''''END IMAGE 1 START IMAGE 2''''''''''''''''''''''''''
or_bm.SetResolution(60, 60)
Dim x2 As Integer = 75
Dim Y1 As Integer = 75
Const ALPHA1 As Byte = 128
' Set the watermark's pixels' Alpha components.
Dim clr1 As Color
For py As Integer = 0 To watermark_bm2.Height - 1
For px As Integer = 0 To watermark_bm2.Width - 1
clr1 = watermark_bm2.GetPixel(px, py)
watermark_bm2.SetPixel(px, py, _
Color.FromArgb(ALPHA1, clr1.R, clr1.G, clr1.B))
Next px
Next py
' Set the watermark's transparent color.
watermark_bm2.MakeTransparent(watermark_bm2.GetPixel(0, _
0))
' Copy onto the result image.
Dim gr1 As Graphics = Graphics.FromImage(or_bm)
gr1.DrawImage(watermark_bm2, x2, Y1)
''''''''''''''''''''''''END IMAGE 2'''''''''''''''''''''''''''
or_bm.Save(s & "deleteme.jpg", _
System.Drawing.Imaging.ImageFormat.Jpeg)
End Using
You're correct - adding a watermark is far easier than removing it. The standard approach is to keep a copy of the original someplace and use that instead of trying to manipulate the image afterwards.