This is my 6th and final article in my series looking at using the GDI+ API(s) to working with images:
Today, I decided to demonstrate how you can add a textual watermark to an image.
GDI+ API(s) offer a full range of capabilities that go well beyond this article and it can draw shapes (rectangle, circles, ellipses, …) and much, much more! So if you need more advanced editing capabilities do look further into GDI+ as it most probably will be able to do the job.
The Code
To write on an image we will use the GdipDrawString function, but to do so we first have to use several other GDI+ API functions to define the font, font styles and then also define a brush to draw it with.
Enough talk, here’s the code.
Option Explicit
'API Declarations, ENUMS, TYPES, Global Variables, ...
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
Private Const GdiPlusVersion As Long = 1
Private Const ImageCodecBMP = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Private Const ImageCodecGIF = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Private Const ImageCodecJPG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const ImageCodecPNG = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Private Const ImageCodecTIF = "{557CF405-1A04-11D3-9A73-0000F81EF32E}"
Private Const EncoderQuality = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Const EncoderCompression = "{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"
Private Const TiffCompressionNone = 6
Private Const EncoderParameterValueTypeLong = 4
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter(15) As EncoderParameter
End Type
Private Type RECTF
Left As Single
Top As Single
Right As Single
Bottom As Single
End Type
'GDI+ Status Constants
Public Enum Status
'https://docs.microsoft.com/en-us/windows/win32/api/gdiplustypes/ne-gdiplustypes-status
OK = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
ProfileNotFound = 21
End Enum
Public Enum StringAlignment
StringAlignmentNear = &H0
StringAlignmentCenter = &H1
StringAlignmentFar = &H2
End Enum
'Image Property Tag Constants
Public Enum PropertyTagId
'https://docs.microsoft.com/en-us/windows/win32/gdiplus/-gdiplus-constant-property-tags-in-alphabetical-order
'https://docs.microsoft.com/en-us/windows/win32/gdiplus/-gdiplus-constant-property-tags-in-numerical-order
' 0x0... => &H...
' https://docs.microsoft.com/en-us/windows/win32/gdiplus/-gdiplus-constant-property-item-descriptions
GpsVer = 0 '&H0&
GpsLatitudeRef = 1 '&H1&
GpsLatitude = 2 '&H2&
GpsLongitudeRef = 3 '&H3&
GpsLongitude = 4 '&H4&
GpsAltitudeRef = 5 '&H5&
GpsAltitude = 6 '&H6&
GpsGpsTime = 7 '&H7&
GpsGpsSatellites = 8 '&H8&
GpsGpsStatus = 9 '&H9&
GpsGpsMeasureMode = 10 '&HA&
GpsGpsDop = 11 '&HB&
GpsSpeedRef = 12 '&HC&
GpsSpeed = 13 '&HD&
GpsTrackRef = 14 '&HE&
GpsTrack = 15 '&HF&
GpsImgDirRef = 16 '&H10&
GpsImgDir = 17 '&H11&
GpsMapDatum = 18 '&H12&
GpsDestLatRef = 19 '&H13&
GpsDestLat = 20 '&H14&
GpsDestLongRef = 21 '&H15&
GpsDestLong = 22 '&H16
GpsDestBearRef = 23 '&H17&
GpsDestBear = 24 '&H18&
GpsDestDistRef = 25 '&H19&
GpsDestDist = 26 '&H1A&
NewSubfileType = 254 '&HFE&
SubfileType = 255 '&HFF&
ImageWidth = 256 '&H100&
ImageHeight = 257 '&H101&
BitsPerSample = 258 '&H102&
Compression = 259 '&H103&
PhotometricInterp = 262 '&H106&
ThreshHolding = 263 '&H107&
CellWidth = 264 '&H108&
CellHeight = 265 '&H109&
FillOrder = 266 '&H10A&
DocumentName = 269 '&H10D&
ImageDescription = 270 '&H10E&
EquipMake = 271 '&H10F&
EquipModel = 272 '&H110&
StripOffsets = 273 '&H111&
Orientation = 274 '&H112&
SamplesPerPixel = 277 '&H115&
RowsPerStrip = 278 '&H116&
StripBytesCount = 279 '&H117&
MinSampleValue = 280 '&H118&
MaxSampleValue = 281 '&H119&
XResolution = 282 '&H11A&
YResolution = 283 '&H11B&
PlanarConfig = 284 '&H11C&
PageName = 285 '&H11D&
XPosition = 286 '&H11E&
YPosition = 287 '&H11F&
FreeOffset = 288 '&H120&
FreeByteCounts = 289 '&H121&
GrayResponseUnit = 290 '&H122&
GrayResponseCurve = 291 '&H123&
T4Option = 292 '&H124&
T6Option = 293 '&H125&
ResolutionUnit = 296 '&H128&
PageNumber = 297 '&H129&
TransferFunction = 301 '&H12D&
SoftwareUsed = 305 '&H131&
DateTime = 306 '&H132&
Artist = 315 '&H13B&
HostComputer = 316 '&H13C&
Predictor = 317 '&H13D&
WhitePoint = 318 '&H13E&
PrimaryChromaticities = 319 '&H13F&
ColorMap = 320 '&H140&
HalftoneHints = 321 '&H141&
TileWidth = 322 '&H142&
TileLength = 323 '&H143&
TileOffset = 324 '&H144&
TileByteCounts = 325 '&H145&
InkSet = 332 '&H14C&
InkNames = 333 '&H14D&
NumberOfInks = 334 '&H14E&
DotRange = 336 '&H150&
TargetPrinter = 337 '&H151&
ExtraSamples = 338 '&H152&
SampleFormat = 339 '&H153&
TransferRange = 342 '&H156&
JPEGProc = 512 '&H200&
JPEGInterFormat = 513 '&H201&
JPEGInterLength = 514 '&H202&
JPEGRestartInterval = 515 '&H203&
JPEGLosslessPredictors = 517 '&H205&
JPEGPointTransforms = 518 '&H206&
JPEGQTables = 519 '&H207&
JPEGDCTables = 520 '&H208&
JPEGACTables = 521 '&H209&
YCbCrCoefficients = 529 '&H211&
YCbCrSubsampling = 530 '&H212&
YCbCrPositioning = 531 '&H213&
REFBlackWhite = 532 '&H214&
Gamma = 769 '&H301&
ICCProfileDescriptor = 770 '&H302&
SRGBRenderingIntent = 771 '&H303&
ImageTitle = 800 '&H320&
ResolutionXUnit = 20481 '&H5001&
ResolutionYUnit = 20482 '&H5002&
ResolutionXLengthUnit = 20483 '&H5003&
ResolutionYLengthUnit = 20484 '&H5004&
PrintFlags = 20485 '&H5005&
PrintFlagsVersion = 20486 '&H5006&
PrintFlagsCrop = 20487 '&H5007&
PrintFlagsBleedWidth = 20488 '&H5008&
PrintFlagsBleedWidthScale = 20489 '&H5009&
HalftoneLPI = 20490 '&H500A&
HalftoneLPIUnit = 20491 '&H500B&
HalftoneDegree = 20492 '&H500C&
HalftoneShape = 20493 '&H500D&
HalftoneMisc = 20494 '&H500E&
HalftoneScreen = 20495 '&H500F&
JPEGQuality = 20496 '&H5010&
GridSize = 20497 '&H5011&
ThumbnailFormat = 20498 '&H5012&
ThumbnailWidth = 20499 '&H5013&
ThumbnailHeight = 20500 '&H5014&
ThumbnailColorDepth = 20501 '&H5015&
ThumbnailPlanes = 20502 '&H5016&
ThumbnailRawBytes = 20503 '&H5017&
ThumbnailSize = 20504 '&H5018&
ThumbnailCompressedSize = 20505 '&H5019&
ColorTransferFunction = 20506 '&H501A&
ThumbnailData = 20507 '&H501B&
ThumbnailImageWidth = 20512 '&H5020&
ThumbnailImageHeight = 20513 '&H5021&
ThumbnailBitsPerSample = 20514 '&H5022&
ThumbnailCompression = 20515 '&H5023&
ThumbnailPhotometricInterp = 20516 '&H5024&
ThumbnailImageDescription = 20517 '&H5025&
ThumbnailEquipMake = 20518 '&H5026&
ThumbnailEquipModel = 20519 '&H5027&
ThumbnailStripOffsets = 20520 '&H5028&
ThumbnailOrientation = 20521 '&H5029&
ThumbnailSamplesPerPixel = 20522 '&H502A&
ThumbnailRowsPerStrip = 20523 '&H502B&
ThumbnailStripBytesCount = 20524 '&H502C&
ThumbnailResolutionX = 20525 '&H502D&
ThumbnailResolutionY = 20526 '&H502E&
ThumbnailPlanarConfig = 20527 '&H502F&
ThumbnailResolutionUnit = 20528 '&H5030&
ThumbnailTransferFunction = 20529 '&H5031&
ThumbnailSoftwareUsed = 20530 '&H5032&
ThumbnailDateTime = 20531 '&H5033&
ThumbnailArtist = 20532 '&H5034&
ThumbnailWhitePoint = 20533 '&H5035&
ThumbnailPrimaryChromaticities = 20534 '&H5036&
ThumbnailYCbCrCoefficients = 20535 '&H5037&
ThumbnailYCbCrSubsampling = 20536 '&H5038&
ThumbnailYCbCrPositioning = 20537 '&H5039&
ThumbnailRefBlackWhite = 20538 '&H503A&
ThumbnailCopyRight = 20539 '&H503B&
LuminanceTable = 20624 '&H5090&
ChrominanceTable = 20625 '&H5091&
FrameDelay = 20736 '&H5100&
LoopCount = 20737 '&H5101&
GlobalPalette = 20738 '&H5102&
IndexBackground = 20739 '&H5103&
IndexTransparent = 20740 '&H5104&
PixelUnit = 20752 '&H5110&
PixelPerUnitX = 20753 '&H5111&
PixelPerUnitY = 20754 '&H5112&
PaletteHistogram = 20755 '&H5113&
Copyright = 33432 '&H8298&
ExifExposureTime = 33434 '&H829A&
ExifFNumber = 33437 '&H829D&
ExifIFD = 34665 '&H8769&
ICCProfile = 34675 '&H8773&
ExifExposureProg = 34850 '&H8822&
ExifSpectralSense = 34852 '&H8824&
GpsIFD = 34853 '&H8825&
ExifISOSpeed = 34855 '&H8827&
ExifOECF = 34856 '&H8828&
ExifVer = 36864 '&H9000&
ExifDTOrig = 36867 '&H9003&
ExifDTDigitized = 36868 '&H9004&
ExifCompConfig = 37121 '&H9101&
ExifCompBPP = 37122 '&H9102&
ExifShutterSpeed = 37377 '&H9201&
ExifAperture = 37378 '&H9202&
ExifBrightness = 37379 '&H9203&
ExifExposureBias = 37380 '&H9204&
ExifMaxAperture = 37381 '&H9205&
ExifSubjectDist = 37382 '&H9206&
ExifMeteringMode = 37383 '&H9207&
ExifLightSource = 37384 '&H9208&
ExifFlash = 37385 '&H9209&
ExifFocalLength = 37386 '&H920A&
ExifMakerNote = 37500 '&H927C&
ExifUserComment = 37510 '&H9286&
ExifDTSubsec = 37520 '&H9290&
ExifDTOrigSS = 37521 '&H9291&
ExifDTDigSS = 37522 '&H9292&
ExifFPXVer = 40960 '&HA000&
ExifColorSpace = 40961 '&HA001&
ExifPixXDim = 40962 '&HA002&
ExifPixYDim = 40963 '&HA003&
ExifRelatedWav = 40964 '&HA004&
ExifInterop = 40965 '&HA005&
ExifFlashEnergy = 41483 '&HA20B&
ExifSpatialFR = 41484 '&HA20C&
ExifFocalXRes = 41486 '&HA20E&
ExifFocalYRes = 41487 '&HA20F&
ExifFocalResUnit = 41488 '&HA210&
ExifSubjectLoc = 41492 '&HA214&
ExifExposureIndex = 41493 '&HA215&
ExifSensingMethod = 41495 '&HA217&
ExifFileSource = 41728 '&HA300&
ExifSceneType = 41729 '&HA301&
ExifCfaPattern = 41730 '&HA302&
End Enum
'GDI - General
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Status
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Status
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal FileName As Long, ByRef Bitmap As Long) As Status
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Status
'GDI - Image / Properties
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal Image As Long, graphics As Long) As Status
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Status
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Status
Private Declare Function GdipGetImageDimension Lib "gdiplus" (ByVal Image As Long, Width As Single, Height As Single) As Status
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal Image As Long, Width As Long) As Status
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal Image As Long, Height As Long) As Status
'GDI - Text
'https://docs.microsoft.com/en-us/previous-versions//ms535991(v=vs.85)
Private Declare Function GdipCreateFontFamilyFromName Lib "gdiplus" (ByVal FontName As String, ByVal fontCollection As Long, fontFamily As Long) As Status
Private Declare Function GdipCreateFont Lib "gdiplus" (ByVal fontFamily As Long, ByVal emSize As Single, ByVal style As Integer, ByVal unit As Integer, font As Long) As Status
Private Declare Function GdipCreateStringFormat Lib "gdiplus" (ByVal formatAttributes As Long, ByVal language As Integer, StringFormat As Long) As Status
Private Declare Function GdipSetStringFormatAlign Lib "gdiplus" (ByVal StringFormat As Long, ByVal Align As StringAlignment) As Status
Private Declare Function GdipSetStringFormatLineAlign Lib "gdiplus" (ByVal StringFormat As Long, ByVal Align As StringAlignment) As Status
'Private Declare Function GdipSetStringFormatFlags Lib "GdiPlus.dll" (ByVal mFormat As Long, ByVal mFlags As StringFormatFlags) As Status
'Private Declare Function GdipSetStringFormatTrimming Lib "GdiPlus.dll" (ByVal mFormat As Long, ByVal mTrimming As StringTrimming) As Status
Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal color As Long, Brush As Long) As Status
Private Declare Function GdipDrawString Lib "gdiplus" (ByVal graphics As Long, ByVal str As String, ByVal Length As Long, ByVal thefont As Long, layoutRect As RECTF, ByVal StringFormat As Long, ByVal Brush As Long) As Status
Private Declare Function GdipMeasureString Lib "gdiplus" (ByVal graphics As Long, ByVal str As String, ByVal Length As Long, ByVal thefont As Long, layoutRect As RECTF, ByVal StringFormat As Long, boundingBox As RECTF, codepointsFitted As Long, LinesFilled As Long) As Long
Private Declare Function GdipDrawRectangle Lib "gdiplus" (ByVal graphics As Long, ByVal pen As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Status
Private Declare Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As Integer, pen As Long) As Status
Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal Brush As Long) As Status
Private Declare Function GdipDeletePen Lib "gdiplus" (ByVal pen As Long) As Status
Private Declare Function GdipDeleteFontFamily Lib "gdiplus" (ByVal fontFamily As Long) As Status
Private Declare Function GdipDeleteFont Lib "gdiplus" (ByVal curFont As Long) As Status
'Helper API Declarations
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Dim lGDIpToken As Long
Dim bGDIpInitialized As Boolean
Dim lBitmap As Long
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
Private Function GDIErrorToString(ByVal lGDIError As Status) As String
Select Case lGDIError
Case GenericError
GDIErrorToString = "Generic Error."
Case InvalidParameter
GDIErrorToString = "Invalid Parameter."
Case OutOfMemory
GDIErrorToString = "Out Of Memory."
Case ObjectBusy
GDIErrorToString = "Object Busy."
Case InsufficientBuffer
GDIErrorToString = "Insufficient Buffer."
Case NotImplemented
GDIErrorToString = "Not Implemented."
Case Win32Error
GDIErrorToString = "Win32 Error."
Case WrongState
GDIErrorToString = "Wrong State."
Case Aborted
GDIErrorToString = "Aborted."
Case FileNotFound
GDIErrorToString = "File Not Found."
Case ValueOverflow
GDIErrorToString = "Value Overflow."
Case AccessDenied
GDIErrorToString = "Access Denied."
Case UnknownImageFormat
GDIErrorToString = "Unknown Image Format."
Case FontFamilyNotFound
GDIErrorToString = "FontFamily Not Found."
Case FontStyleNotFound
GDIErrorToString = "FontStyle Not Found."
Case NotTrueTypeFont
GDIErrorToString = "Not TrueType Font."
Case UnsupportedGdiplusVersion
GDIErrorToString = "Unsupported Gdiplus Version."
Case GdiplusNotInitialized
GDIErrorToString = "Gdiplus Not Initialized."
Case PropertyNotFound
GDIErrorToString = "Property Not Found."
Case PropertyNotSupported
GDIErrorToString = "Property Not Supported."
Case Else
GDIErrorToString = "Unknown Error."
End Select
End Function
'---------------------------------------------------------------------------------------
' Procedure : AddTextToImage
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose :
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile : Fully qualified path and filename of the image file to get info about
' sText : Text to add to image
'
' Usage:
' ~~~~~~
' Call AddTextToImage("C:\Temp\IMG01 - Copy.jpg", "©CARDA Consultants Inc.")
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2022-01-08 Initial Blog Release
'---------------------------------------------------------------------------------------
Public Function AddTextToImage(ByVal sFile As String, ByVal sText As String) As Boolean
On Error GoTo Error_Handler
Dim GDIpStartupInput As GDIPlusStartupInput
Dim GDIStatus As Status
Dim tEncoder As GUID
Dim tParams As EncoderParameters
Dim sTmp As String
Dim sExt As String
Dim lPropertyItemSize As Long
Dim graphics As Long
Dim family As Long
Dim font As Long
Dim Brush As Long
Dim layout As RECTF
Dim lBitmapWidth As Long
Dim lBitmapHeight As Long
Dim box As RECTF
Dim points As Long
Dim LinesFilled As Long
Dim lFormat As Long
Const lBuffer As Long = 10
'Start GDI
'-------------------------------------------------------------------------------------
If bGDIpInitialized = False Then
GDIpStartupInput.GdiPlusVersion = 1
GDIStatus = GdiplusStartup(lGDIpToken, GDIpStartupInput, ByVal 0)
If GDIStatus <> Status.OK Then
MsgBox "Unable to start the GDI+ API" & vbCrLf & vbCrLf & GDIErrorToString(GDIStatus), vbCritical Or vbOKOnly, "Operation Aborted"
GoTo Error_Handler_Exit
Else
bGDIpInitialized = True
End If
End If
'Load our Image to work with
'-------------------------------------------------------------------------------------
'In case we already have something in memory let's dispose of it properly
If lBitmap <> 0 Then
GDIStatus = GdipDisposeImage(lBitmap)
If GDIStatus <> Status.OK Then
MsgBox "Unable to dispose of the current image in memory" & vbCrLf & vbCrLf & GDIErrorToString(GDIStatus), vbCritical Or vbOKOnly, "Operation Aborted"
GoTo Error_Handler_Exit
End If
End If
'Now let's proceed with loading the actual image we want to work with
Kill sFile
FileCopy "C:\Temp\IMG01.jpg", sFile
GDIStatus = GdipCreateBitmapFromFile(StrPtr(sFile), lBitmap)
If GDIStatus <> Status.OK Then
MsgBox "Unable to load the specified image" & vbCrLf & vbCrLf & GDIErrorToString(GDIStatus), vbCritical Or vbOKOnly, "Operation Aborted"
GoTo Error_Handler_Exit
End If
'Work with the image
'-------------------------------------------------------------------------------------
If lBitmap Then
'Add Text
GDIStatus = GdipGetImageGraphicsContext(lBitmap, graphics)
If GDIStatus <> Status.OK Then
MsgBox "Unable to get the image's graphical context." & vbCrLf & vbCrLf & GDIErrorToString(GDIStatus), vbCritical Or vbOKOnly, "Operation Aborted"
GoTo Error_Handler_Exit
End If
'Get the image dimensions
GdipGetImageWidth lBitmap, lBitmapWidth
GdipGetImageHeight lBitmap, lBitmapHeigh
'Define the Font
GdipCreateFontFamilyFromName StrConv("Arial", vbUnicode), 0, family
GdipCreateFont family, 96, 0, 2, font ' Regular=0 Bold=1 Italic=2 BoldItalic=3 Underline=4 Strikeout=8
' World=0 Display=1 Pixel=2 Point=3 Inch=4 Document=5 Millimeter=6
'Define the Font Formatting
GdipCreateStringFormat 0, 0, lFormat
GdipSetStringFormatAlign lFormat, StringAlignmentFar 'StringAlignmentNear = Left, StringAlignmentCenter = Center, StringAlignmentFar = Right
'Define the Font Color (ARGB)
GdipCreateSolidFill &HFF000000, Brush 'Black Writing
'GdipCreateSolidFill &HFFFFFFFF, Brush 'White writing
'GdipCreateSolidFill &HFFFF3300, brush 'Orange writing
'GdipCreateSolidFill &HFF0000CC, brush 'Navy writing
GdipMeasureString graphics, StrConv(sText, vbUnicode), Len(StrConv(sText, vbUnicode)), font, layout, lFormat, box, points, LinesFilled
'Position the String in the Y-axis by changing the .Top value, X-axis is controlled by the StringFormatAlign (above)
'Using +/- 10 as a buffer
With layout
.Left = 0 '****Do Not Change This Value! X-axis is controlled by the StringFormatAlign (above)
'.Top = 0 'Vertical - Top
'.Top = lBitmapHeight / 2 'Vertical - Middle
.Top = lBitmapHeight - (box.Bottom - box.Top) 'Vertical - Bottom
.Right = lBitmapWidth
.Bottom = lBitmapHeight
End With
'GdipDrawString graphics, StrConv(sText, vbUnicode), -1, font, layout, 0&, brush 'No format applied
GdipDrawString graphics, StrConv(sText, vbUnicode), -1, font, layout, lFormat, Brush 'No format applied
'Save the changes
' Cannot save over the file itself, so create a tmp file, release the current one then copy the image over
sExt = Mid(sFile, InStrRev(sFile, ".") + 1)
Select Case sExt
Case "bmp", "dib"
CLSIDFromString StrPtr(ImageCodecBMP), tEncoder
Case "gif"
CLSIDFromString StrPtr(ImageCodecGIF), tEncoder
Case "jpg", "jpeg", "jpe", "jfif"
CLSIDFromString StrPtr(ImageCodecJPG), tEncoder
With tParams
.Count = 1
.Parameter(0).NumberOfValues = 1
.Parameter(0).type = EncoderParameterValueTypeLong
.Parameter(0).Value = VarPtr(100) '100% Quality
CLSIDFromString StrPtr(EncoderQuality), .Parameter(0).GUID
End With
Case "png"
CLSIDFromString StrPtr(ImageCodecPNG), tEncoder
Case "tif", "tiff"
CLSIDFromString StrPtr(ImageCodecTIF), tEncoder
With tParams
.Count = 1
.Parameter(0).NumberOfValues = 1
.Parameter(0).type = EncoderParameterValueTypeLong
.Parameter(0).Value = VarPtr(TiffCompressionNone)
CLSIDFromString StrPtr(EncoderCompression), .Parameter(0).GUID
End With
Case Else
Exit Function
End Select
sTmp = Environ("Temp") & "\TempSave." & sExt
GDIStatus = GdipSaveImageToFile(lBitmap, StrPtr(sTmp), tEncoder, ByVal tParams)
If GDIStatus <> Status.OK Then
MsgBox "Unable to save the image" & vbCrLf & vbCrLf & GDIErrorToString(GDIStatus), vbCritical Or vbOKOnly, "Operation Aborted"
Exit Function
End If
End If
Error_Handler_Exit:
On Error Resume Next
'Shutdown GDI
'-------------------------------------------------------------------------------------
If bGDIpInitialized = True Then
If lBitmap <> 0 Then
GDIStatus = GdipDeleteBrush(Brush)
GDIStatus = GdipDeleteFont(font)
GDIStatus = GdipDeleteFontFamily(family)
GDIStatus = GdipDeleteGraphics(graphics)
If GDIStatus <> Status.OK Then
MsgBox "Unable to the image graphics." & vbCrLf & vbCrLf & GDIErrorToString(GDIStatus), vbCritical Or vbOKOnly, "Operation Aborted"
Exit Function
End If
'Release the current file
GDIStatus = GdipDisposeImage(lBitmap)
If GDIStatus <> Status.OK Then
MsgBox "Unable to dispose of the processed image." & vbCrLf & vbCrLf & GDIErrorToString(GDIStatus), vbCritical Or vbOKOnly, "Operation Aborted"
Exit Function
Else
lBitmap = 0
'Overwrite the file with our Temp File and Cleanup
If sTmp <> "" Then
Call FileCopy(sTmp, sFile)
If Len(Dir(sFile)) > 0 Then
AddTextToImage = True
Kill sTmp
FollowHyperlink sFile
End If
End If
End If
End If
GDIStatus = GdiplusShutdown(lGDIpToken)
If GDIStatus <> Status.OK Then
MsgBox "Unable to shutdown the GDI+ API." & vbCrLf & vbCrLf & GDIErrorToString(GDIStatus), vbCritical Or vbOKOnly, "Operation Aborted"
Exit Function
Else
bGDIpInitialized = False
End If
End If
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: AddTextToImage" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
and now you can add a textual watermark to an image with a single line of code, such as
Call AddTextToImage("C:\Temp\IMG01 - Copy.jpg", "©CARDA Consultants Inc.")
A Few Comments About the Code
Font
You can set the font family by editing the value Arial in the line
GdipCreateFontFamilyFromName StrConv("Arial", vbUnicode), 0, family
Font Size
You can set the font size by editing the value 96 in the line
GdipCreateFont family, 96, 0, 2, font
Font Color
You can set the font color by editing the value &HFF000000 in the line
GdipCreateSolidFill &HFF000000, Brush 'Black Writing
Watermark Positioning
Horizontal Alignment
You can control the horizontal alignment by editing the value StringAlignmentFar in the line
GdipSetStringFormatAlign lFormat, StringAlignmentFar
You can use:
StringAlignmentNear ‘Left Align
StringAlignmentCenter ‘Center
StringAlignmentFar ‘Right Align
Vertical Alignment
You can specify the vertical alignment by editing the .Top value in the following block of code
With layout
.Left = 0 '****Do Not Change This Value! X-axis is controlled by the StringFormatAlign (above)
'.Top = 0 'Vertical - Top
'.Top = lBitmapHeight / 2 'Vertical - Middle
.Top = lBitmapHeight - (box.Bottom - box.Top) 'Vertical - Bottom
.Right = lBitmapWidth
.Bottom = lBitmapHeight
End With
You can set the value to anything you wish that doesn’t exceed the lBitmapHeight value (or else it will fall outside the bounds of the image), but below are the 3 value I thought could be most useful:
.Top = 0 ‘Top Align
.Top = lBitmapHeight / 2 ‘Middle Align
.Top = lBitmapHeight – (box.Bottom – box.Top) ‘Bottom Align
A Final Word
I found VBA documentation to be very scarce and poor. Microsoft truly couldn’t do a poorer job! When searching I kept coming up against dead links because Microsoft has removed many resources that used to exist. The only resources I could find most of the time were for C++. So, if you decided to further explorer GDI+ do arm yourself with lots of patience as it takes a bit of time to get used to the way it works. I also found one API misbehaving and have been unable to get anyone able to help/explain why, so there may be some issues.
Well this ends my exploration of the GDI+ API(s) (for now, I may dabble again at a later date) and I truly hope this helps a few of you out there.
A Few Resources on the Subject



I’m unable to get this to work unfortunately..
Firstly, i assume there is a typo or copy/paste error in the line below specifically “lBitmapHeig”
‘Get the image dimensions
GdipGetImageWidth lBitmap, lBitmapWidth
GdipGetImageHeight lBitmap, lBitmapHeigh
I have changed this to:-
‘Get the image dimensions
GdipGetImageWidth lBitmap, lBitmapWidth
GdipGetImageHeight lBitmap, lBitmapHeight
All good in compiling after change however when calling function i get the message “file not found”?
I have crated a JPEG file using the exact same name and is stored in same Temp folder.
After calling using the following:-
Call AddTextToImage(“C:\Temp\IMG01 – Copy.jpg”, “©CARDA Consultants Inc.”)
I receive an error stating file not found?
On checking Temp folder content the file is deleted (So the Kill function is working) but i dont see a new file with the watermark in…
This function is something i could definitely use so any help would be appreciated.. I will keep investigating what the issue may be but i’m confident the path/filename and file type are correct…
Hi,
All sorted….
I got confused, i didn’t realise :-
Call AddTextToImage(“C:\Temp\IMG01 – Copy.jpg”, “©CARDA Consultants Inc.”)
This represents the file path and image name to be created after watermarking NOT the source file Path & Image Name.
Excellent – Thankyou