Могу ли я добавить альфа-канал к существующему PNG, используя VBA? - PullRequest
Новая
       51

Могу ли я добавить альфа-канал к существующему PNG, используя VBA?

0 голосов
/ 18 апреля 2020

Я использую VBA для надстройки Inventor для сбора изображений деталей. Когда я собираю PNG, у них нет альфа-канала [IsAlphaPixelFormat = False]. Мне нужно применить прозрачность к ним. Существует ли код VBA для прямого добавления альфа-канала в файл PNG? В настоящее время я использую библиотеку Windows Image Acquisition и преобразую PNG в GIF, а затем обратно в PNG в качестве обходного пути. Это приводит к IsAlphaPixelFormat = True для ImageFile, поэтому я могу установить альфа-байт в 0 для каждого пикселя, который соответствует моему альфа-цвету. При преобразовании в формат GIF наблюдается некоторое ухудшение качества изображения, поэтому я хочу избежать преобразования. Может быть, у WIA есть способ сделать это? Каким бы ни было решение, мне нужно будет запустить его из VBA.

Заранее большое спасибо.

Рафаэль

Вот мой код в его нынешнем виде. 

Public Enum wiaFormat
    BMP = 0
    GIF = 1
    JPEG = 2
    PNG = 3
    TIFF = 4
End Enum
Sub test()

AlphaR = 0
AlphaG = 255
AlphaB = 0
Call MakeTransparent("C:\temp\BOM Thumbs\MCM 6391K879 Sleeve Bearing d.376 D.502 L.188 Bronze Oil-Embedded.ipt") 'I append the .png in the routine

End Sub
Sub MakeTransparent(strFile As String)

ExportBOMLoadingForm.Label_Status = ExportBOMLoadingForm.Label_Status & vbCr & "Adding transparency"

Dim strSource As String
Dim strTarget As String

strSource = strFile & imageFormat 'imageFormat=".png"
strTarget = Left(strFile, InStrRev(strFile, "\")) & "Alpha_" & Right(strFile, Len(strFile) - InStrRev(strFile, "\")) & ".gif"
Call WIA_ConvertImage(strSource, strTarget, GIF)
strSource = strTarget
strTarget = strFile & ".png"
Call WIA_ConvertImage(strSource, strTarget, PNG)
strSource = strTarget
strTarget = strSource
Call SetTransparency(strSource, strTarget)

End Sub
Public Function WIA_ConvertImage(sInitialImage As String, sOutputImage As String, lFormat As wiaFormat, Optional lQuality As Long = 85) As Boolean

On Error GoTo Error_Handler
Dim oImage As WIA.ImageFile
Dim oIP As WIA.ImageProcess
Dim sFormatID As String
Dim sExt As String

'Convert our Enum over to the proper value used by WIA
Select Case lFormat
    Case 0
        sFormatID = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"
        sExt = "BMP"
    Case 1
        sFormatID = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}"
        sExt = "GIF"
    Case 2
        sFormatID = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
        sExt = "JPG"
    Case 3
        sFormatID = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
        sExt = "PNG"
    Case 4
        sFormatID = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}"
        sExt = "TIFF"
End Select

If lQuality > 100 Then lQuality = 100

Set oImage = New WIA.ImageFile
Set oIP = New WIA.ImageProcess

oIP.Filters.Add oIP.FilterInfos("Convert").FilterID
oIP.Filters(1).Properties("FormatID") = sFormatID
oIP.Filters(1).Properties("Quality") = lQuality

oImage.LoadFile sInitialImage
Call DeleteFile(sOutputImage) 'Deletes using Kill

Set oImage = oIP.Apply(oImage)
'Overide the specified ext with the appropriate one for the choosen format
oImage.SaveFile Left(sOutputImage, InStrRev(sOutputImage, ".")) & LCase(sExt)
WIA_ConvertImage = True

Error_Handler_Exit:
    On Error Resume Next
    If Not oIP Is Nothing Then Set oIP = Nothing
    If Not oImage Is Nothing Then Set oImage = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.number & vbCrLf & _
           "Error Source: WIA_ConvertImage" & vbCrLf & _
           "Error Description: " & Err.description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function
Sub SetTransparency(strSource As String, strTarget As String)

'Transparent (A=0, R=255, G=255, B=255)
Dim Img As WIA.ImageFile
Dim IP As WIA.ImageProcess
Dim v As WIA.Vector
Dim i As Long
Dim strAlpha As String

Set Img = New WIA.ImageFile
Set IP = New WIA.ImageProcess

Img.LoadFile strSource

Set v = Img.ARGBData
strAlpha = HexFromRGBA(255, AlphaR, AlphaG, AlphaB)

For i = 1 To v.Count Step 1
    If v(i) = Val(strAlpha) Then
        v(i) = &HFFFFFF    'Transparent (A=0, R=255, G=255, B=255)
    End If
Next

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

Call DeleteFile(strTarget) 'Delete output file if already exist.
Img.SaveFile strTarget

Set Img = Nothing
Set IP = Nothing
Set v = Nothing

End Sub
Function HexFromRGBA(a As Byte, r As Byte, g As Byte, b As Byte) As String

'Returns a string containing the hex equivalent of input A,R,G,B
HexFromRGBA = "&H0"
Dim strValue As String
Dim sA As String, sR As String, sG As String, sB As String
sA = Hex(a)
sR = Hex(r)
sG = Hex(g)
sB = Hex(b)
If Len(sA) = 1 Then sA = "0" & sA
If Len(sR) = 1 Then sR = "0" & sR
If Len(sG) = 1 Then sG = "0" & sG
If Len(sB) = 1 Then sB = "0" & sB
strValue = sA & sR & sG & sB
Dim i As Byte
For i = 1 To 8
    If Len(strValue) < 2 Then Exit For
    If Left(strValue, 1) = "0" Then strValue = Right(strValue, Len(strValue) - 1)
Next i
strValue = "&H" & strValue
'MsgBox strValue & vbCr & Val(strValue)
HexFromRGBA = strValue

End Function
...