Solved Creating a Black & White copy of an Image using WIA Filter (1 Viewer)

[Jason Lee Hayes]

Hi,

I am curious; is it possible to change an image to Black & White maybe using WIA and the Filter?

I have found this link:-

Unfortunately i cannot get it implemented with modification into my project...

I also have an issue with the following line from the code below:-

v(i) = &HFFFF00FF 'opaque pink (A=255,R=255,G=0,B=255)

& is causing the issue; i believe this has been interpreted incorrectly through the browser and should by &..

Any help is appreciated.

Regards,

Jason

How to Use Filters

This topic provides examples that show how to use each of the filters available with the Windows Image Acquisition (WIA) Automation Layer.

learn.microsoft.com

Dim Img 'As ImageFile
Dim IP 'As ImageProcess
Dim v 'As Vector
Dim i 'As Long

Set Img = CreateObject("WIA.ImageFile")
Set IP = CreateObject("WIA.ImageProcess")

Img.LoadFile "C:\WINDOWS\Web\Wallpaper\Bliss.bmp"

Set v = Img.ARGBData

For i = 1 To v.Count Step 21
    v(i) = &HFFFF00FF 'opaque pink (A=255,R=255,G=0,B=255)
Next

IP.Filters.Add IP.FilterInfos("ARGB").FilterID
Set IP.Filters(1).Properties("ARGBData") = v

Set Img = IP.Apply(Img)

Img.SaveFile "C:\WINDOWS\Web\Wallpaper\BlissARGB.bmp"

 

[sonic8]

I also have an issue with the following line from the code below:-

v(i) = &HFFFF00FF 'opaque pink (A=255,R=255,G=0,B=255)

& is causing the issue; i believe this has been interpreted incorrectly through the browser and should by &..

In VBA you can use the Val function to convert from a string containing hexadecimal notation to decimal number. You must prefix the hex value with &H.

For i = 1 To v.Count Step 21
    v(i) = val("&HFFFF00FF") 'opaque pink (A=255,R=255,G=0,B=255)
Next

Edit/PS: You don't even need the val function. Writing the hex value in VBA directly also works:

For i = 1 To v.Count Step 21
    v(i) = &HFFFF00FF 'opaque pink (A=255,R=255,G=0,B=255)
Next

 

[arnelgp]

maybe what the "source" is saying is to And it:

For i = 1 To v.Count Step 21
    v(i) = v(i) And &HFFFF00FF   'opaque pink (A=255,R=255,G=0,B=255)
Next

 

[arnelgp]

using Word automation you can create a Black and White (new picture),

' arnelgp
Private Sub testRecolor()
Dim orig As String, out As String
'put the path of the original image below
orig = Environ("userprofile") & "\downloads\snail.bmp"
'put the path of the New image below
out = Environ("userprofile") & "\downloads\snail_new.bmp"
Call Recolor(orig, out)
End Sub

' https://stackoverflow.com/questions/60146765/recolor-picture-to-black-and-white-75-using-word-vba
Sub Recolor(ByVal picPath As String, ByVal newPic As String)
    Dim doc As Word.Document
    Dim pic As InlineShape

    Set doc = WdApp.Documents.Add
    Set pic = doc.InlineShapes.AddPicture(picPath)
    'Set pic = Selection.InlineShapes(1)
    With pic
        With .PictureFormat
            .Brightness = 0.24
            .Contrast = 1
        End With
        With .Fill.PictureEffects
            .Insert(msoEffectSaturation).EffectParameters(1).Value = 0
        End With
    End With
    'saveImage doc, newPic
    WriteInlineShapesToFile doc, newPic
    WdApp.ActiveDocument.Close False
    WdApp.Quit

End Sub

Public Function WdApp() As Word.Application
Static e As Word.Application
If e Is Nothing Then
    Set e = New Word.Application
End If
Set WdApp = e
End Function


' https://www.appsloveworld.com/vba/100/9/how-to-save-word-shapes-to-image-using-vba
Private Sub WriteInlineShapesToFile(ByRef doc As Word.Document, ByVal out As String)
    Dim k As Integer
    For k = 1 To ActiveDocument.InlineShapes.Count
        'saveImage ActiveDocument.InlineShapes(k), "C:\images\s" & k & ".png"
        save_Image doc.InlineShapes(k), out
    Next
End Sub

Private Sub save_Image(shp As InlineShape, path As String)

    Dim s As String
    Dim r As Range
    Dim i As Long
    Dim j As Long
    
    s = shp.Range.WordOpenXML
  
    i = InStr(s, "<pkg:binaryData>")
    
    If i = 0 Then
        Set r = shp.Range.Duplicate
        r.End = r.End + 1
        s = r.WordOpenXML
        i = InStr(s, "<pkg:binaryData>")
        If i = 0 Then
            r.Start = r.Start - 1
            s = r.WordOpenXML
            i = InStr(s, "<pkg:binaryData>")
            If i = 0 Then
                MsgBox "No binary data found"
                Exit Sub
            End If
        End If
    End If
    
    ''move i to end of "<pkg:binaryData>"
    i = i + 16

    j = InStr(i, s, "</pkg:binaryData>")
    
    s = Mid$(s, i, j - i)
    
    Dim DecodeBase64() As Byte
    Dim objXML As Object 'MSXML2.DOMDocument
    Dim objNode As Object 'MSXML2.IXMLDOMElement

    Set objXML = CreateObject("MSXML2.DOMDocument")

    'create node with type of base 64 and decode
    Set objNode = objXML.createElement("b64")
    objNode.DataType = "bin.base64"
    objNode.Text = s
    DecodeBase64 = objNode.nodeTypedValue

    Set objNode = Nothing
    Set objXML = Nothing

    Open path For Binary As #1
        Put #1, 1, DecodeBase64
    Close #1

End Sub

 

[Jason Lee Hayes]

using Word automation you can create a Black and White (new picture),

' arnelgp
Private Sub testRecolor()
Dim orig As String, out As String
'put the path of the original image below
orig = Environ("userprofile") & "\downloads\snail.bmp"
'put the path of the New image below
out = Environ("userprofile") & "\downloads\snail_new.bmp"
Call Recolor(orig, out)
End Sub

' https://stackoverflow.com/questions/60146765/recolor-picture-to-black-and-white-75-using-word-vba
Sub Recolor(ByVal picPath As String, ByVal newPic As String)
    Dim doc As Word.Document
    Dim pic As InlineShape

    Set doc = WdApp.Documents.Add
    Set pic = doc.InlineShapes.AddPicture(picPath)
    'Set pic = Selection.InlineShapes(1)
    With pic
        With .PictureFormat
            .Brightness = 0.24
            .Contrast = 1
        End With
        With .Fill.PictureEffects
            .Insert(msoEffectSaturation).EffectParameters(1).Value = 0
        End With
    End With
    'saveImage doc, newPic
    WriteInlineShapesToFile doc, newPic
    WdApp.ActiveDocument.Close False
    WdApp.Quit

End Sub

Public Function WdApp() As Word.Application
Static e As Word.Application
If e Is Nothing Then
    Set e = New Word.Application
End If
Set WdApp = e
End Function


' https://www.appsloveworld.com/vba/100/9/how-to-save-word-shapes-to-image-using-vba
Private Sub WriteInlineShapesToFile(ByRef doc As Word.Document, ByVal out As String)
    Dim k As Integer
    For k = 1 To ActiveDocument.InlineShapes.Count
        'saveImage ActiveDocument.InlineShapes(k), "C:\images\s" & k & ".png"
        save_Image doc.InlineShapes(k), out
    Next
End Sub

Private Sub save_Image(shp As InlineShape, path As String)

    Dim s As String
    Dim r As Range
    Dim i As Long
    Dim j As Long
 
    s = shp.Range.WordOpenXML

    i = InStr(s, "<pkg:binaryData>")
 
    If i = 0 Then
        Set r = shp.Range.Duplicate
        r.End = r.End + 1
        s = r.WordOpenXML
        i = InStr(s, "<pkg:binaryData>")
        If i = 0 Then
            r.Start = r.Start - 1
            s = r.WordOpenXML
            i = InStr(s, "<pkg:binaryData>")
            If i = 0 Then
                MsgBox "No binary data found"
                Exit Sub
            End If
        End If
    End If
 
    ''move i to end of "<pkg:binaryData>"
    i = i + 16

    j = InStr(i, s, "</pkg:binaryData>")
 
    s = Mid$(s, i, j - i)
 
    Dim DecodeBase64() As Byte
    Dim objXML As Object 'MSXML2.DOMDocument
    Dim objNode As Object 'MSXML2.IXMLDOMElement

    Set objXML = CreateObject("MSXML2.DOMDocument")

    'create node with type of base 64 and decode
    Set objNode = objXML.createElement("b64")
    objNode.DataType = "bin.base64"
    objNode.Text = s
    DecodeBase64 = objNode.nodeTypedValue

    Set objNode = Nothing
    Set objXML = Nothing

    Open path For Binary As #1
        Put #1, 1, DecodeBase64
    Close #1

End Sub

Thanks for the help arnelgp...

So; i set a reference to Microsoft Word 16.0 Object Library....
Changed the paths and file name in Private Sub testRecolor() to reflect a test image in BitMap Picture Format ensuring path and filename(s) were correct...
Code compiles with no issues however i get the following error message when i evoke the TestRecolor Subroutine:-

Not sure what the error line specifically means...

I did look at the original code i posted and tried to get that to work even with the suggested Post 3 but get no error codes and just hangs.
I could shell out to a 3rd party application such as Paint.net but would rather try acheive this using API or even word automation.
I've managed to implement Flip, Mirror, rotate & resize of an image using WIA in my project but just needed to crack the Black & White (GrayScale) function..

BTH - As I'm simply converting an image to GrayScale can i not use With .PictureFormat .ColorType = msoPictureGrayScale ?

 

[Jason Lee Hayes]

In VBA you can use the Val function to convert from a string containing hexadecimal notation to decimal number. You must prefix the hex value with &H.

For i = 1 To v.Count Step 21
    v(i) = val("&HFFFF00FF") 'opaque pink (A=255,R=255,G=0,B=255)
Next

Edit/PS: You don't even need the val function. Writing the hex value in VBA directly also works:

For i = 1 To v.Count Step 21
    v(i) = &HFFFF00FF 'opaque pink (A=255,R=255,G=0,B=255)
Next

Thanks sonic8

Learning all the time; i made the changed and code compiled no issue however when i try to execute MS Access just hangs...
I need to bread the code down to see if i can make it useful...

 

[sonic8]

Learning all the time; i made the changed and code compiled no issue however when i try to execute MS Access just hangs...

I tried the sample code you provided and after applying my changes from #2 it works as expected. (You need a very light picture to actually see the opaque pink lines added.)
I ran the code on JPG images between 500kb and 800kb in size and didn't notice any significant delays or hanging. Nonetheless, the Microsoft page of the sample code warns: "This operation can be slow on certain computers."
So, maybe you should be patient and wait some time when Access appears to hang. - Not as a solution, but to check if the code really hangs on your computer or if it is just very slow.

Unfortunately, I cannot help you with the b/w color change. - No clue about that.

 

[Jason Lee Hayes]

I tried the sample code you provided and after applying my changes from #2 it works as expected. (You need a very light picture to actually see the opaque pink lines added.)
I ran the code on JPG images between 500kb and 800kb in size and didn't notice any significant delays or hanging. Nonetheless, the Microsoft page of the sample code warns: "This operation can be slow on certain computers."
So, maybe you should be patient and wait some time when Access appears to hang. - Not as a solution, but to check if the code really hangs on your computer or if it is just very slow.

Unfortunately, I cannot help you with the b/w color change. - No clue about that.

Thanks sonic8

Double checked and i can confirm it does work as you suggest..
Work in that it does produce a copy of the image with overlay..
I think i should be able to work with this and create a grayscale image - will look into the .PictureFormat.ColorType = msoPictureGrayScale and see if i can implement that...

Regards,

Jason

 

[arnelgp]

you

Not sure what the error line specifically means...

the mso definitions are in Microsoft Office, so you need to add Reference also to Microsoft Office X.XX Library.
here is the video of when you run the sub.

 

[Jason Lee Hayes]

you

the mso definitions are in Microsoft Office, so you need to add Reference also to Microsoft Office X.XX Library.
here is the video of when you run the sub.

Hi arnelgp...

The output in your video is exactly what I'm trying to achieve

i have now added a references to the following:-
Microsoft Office 16.0 Object Library
Microsoft Word 16.0 Object Library

I have created a folder with Read/Write Priveledges Named "ImagesToConvert"
I have a Image in BMP format 600x800 pixels and is 32bit colour depth and only 1.37mb in size
The image filename inside the folder is called "Test.bmp"

When i click the button on the form "Click To Test Conversion" nothing happens; i'm sure it does but does not produce a secondry image in Black and White as your video demonstraights.

If a wait a while and click it again it errors...

Cannot understand why it doesnt work.
I'm sure i have the references now set correctly. (Not sure about reference order/if it matters)
The folder is read/right and the image file is read/right so thats not the issue.
Ive tried other folders like Documents / Pictures and even tried the root C

I have zipped what i have put together.

Any help would be appreciated.

 

[arnelgp]

put the image and the db on Same folder.

Edit:// new file uploaded since found an error on Sub, WriteInlineShapesToFile.
now it is fixed.

 

[Jason Lee Hayes]

put the image and the db on Same folder.

Edit:// new file uploaded since found an error on Sub, WriteInlineShapesToFile.
now it is fixed.

Big thanks to you for this solution; i can confirm it works perfectly. Your method also opens up many other possibilities with Word automation that i did not even consider in my project. Thanks for taking the time out to help me. Much appreciated...

 

[Jason Lee Hayes]

I tried the sample code you provided and after applying my changes from #2 it works as expected. (You need a very light picture to actually see the opaque pink lines added.)
I ran the code on JPG images between 500kb and 800kb in size and didn't notice any significant delays or hanging. Nonetheless, the Microsoft page of the sample code warns: "This operation can be slow on certain computers."
So, maybe you should be patient and wait some time when Access appears to hang. - Not as a solution, but to check if the code really hangs on your computer or if it is just very slow.

Unfortunately, I cannot help you with the b/w color change. - No clue about that.

Big thankyou sonic8, arnelgp has come up with the exact solution however you help with the alternative method has now not only fixed the issue but has have me contemplating that if i can now write values to a specific range within an image i could also expand on this and compare a specific position within the image against set values in which i could then consider this a watermark so to speak. If i can do this then i could use this to validate image authenticity. Both your solution and arnelgp's have proven successful in their own way to which i am very thankful.