Mostrar los tags: VBA

Sub RemoveWhiteBackground()

    Dim doc As Document

    Dim sr As ShapeRange

    Dim shape As shape

    Dim bmp As Bitmap

    Dim x As Long, y As Long

    Dim bgColor As Long ' Utilizamos Long para almacenar el valor RGB

    Dim tolerance As Integer

    Set doc = ActiveDocument

    Set sr = doc.ActivePage.Shapes.All

    ' Obtener el valor RGB para el color blanco

    bgColor = RGB(255, 255, 255)

    ' Definir la tolerancia para el rango de colores que consideras "blanco"

    tolerance = 30

    For Each shape In sr

        If shape.Type = cdrBitmapShape Then

            Set bmp = shape.Bitmap

            For x = 1 To bmp.SizeWidth ' Usar SizeWidth en lugar de GetWidth

                For y = 1 To bmp.SizeHeight ' Usar SizeHeight en lugar de GetHeight

                    If ColorDistance(bmp.Pixel(x, y), bgColor) < tolerance Then

                        bmp.Pixel(x, y) = RGB(0, 0, 0) ' Cambiar el píxel a negro

                    End If

                Next y

            Next x

        End If

    Next shape

End Sub

Function ColorDistance(color1 As Color, color2 As Long) As Double

    Dim redDiff As Double

    Dim greenDiff As Double

    Dim blueDiff As Double

    redDiff = color1.Red - GetRValue(color2)

    greenDiff = color1.Green - GetGValue(color2)

    blueDiff = color1.Blue - GetBValue(color2)

    ColorDistance = Sqr(redDiff ^ 2 + greenDiff ^ 2 + blueDiff ^ 2)

End Function