'画像ファイルの解像度をクリアするサンプルマクロ

Sub Test()
    Dim sFilename As Variant
    Dim sTmpFile As String
    Dim sFileType As String
    sTmpFile = ThisWorkbook.Path & "\tmp.tmp"
    sFilename = Application.GetOpenFilename( _
        "*.bmp;*.gif;*.jpg;*.png,*.bmp;*.gif;*.jpg;*.png")
    If VarType(sFilename) = vbBoolean Then Exit Sub

    Application.ScreenUpdating = False

    sFileType = Right$(sFilename, 3)
    Select Case UCase(sFileType)
      Case "BMP", "JPG", "PNG"
        sTmpFile = sTmpFile & "." & sFileType
        FileCopy sFilename, sTmpFile
        If ClearResolution(sTmpFile) Then
            ActiveSheet.Pictures.Insert sTmpFile
            'ActiveSheet.Pictures.Insert sFilename
        Else
            MsgBox "解像度の変更に失敗しました。"
        End If
        Kill sTmpFile
      Case Else
        ActiveSheet.Pictures.Insert sFilename
    End Select
    Application.ScreenUpdating = True
End Sub


'画像ファイルの解像度をクリアする関数
Function ClearResolution(ByVal sFilename As String) As Boolean
    Dim f As Long
    Dim i As Integer
    Dim l As Long
    Dim p As Long
    Dim n As Long
    Dim crc As Long
    Dim buf() As Byte

    On Error GoTo ErrorHandler
    If Dir$(sFilename) = "" Then Exit Function

    Select Case UCase$(Right$(sFilename, 3))
      Case "BMP"
        f = FreeFile()
        Open sFilename For Binary As #f
        Get #f, , i
        If i = &H4D42 Then
            Seek #f, 15
            Get #f, , l
            If l = &H28 Then 'Windows
                Seek #f, 39
                Put #f, , 0&
                Put #f, , 0&
                ClearResolution = True
            ElseIf l = &HC Then 'OS/2
                ClearResolution = True
            End If
        End If
        Close #f
      Case "JPG"
        f = FreeFile()
        Open sFilename For Binary As #f
        Get #f, , i
        If i = &HD8FF Then
            Get #f, , i
            If i = &HE0FF Then
                Seek #f, 15
                Put #f, , 0&
                ClearResolution = True
            End If
        End If
        Close #f
      Case "PNG"
        f = FreeFile()
        Open sFilename For Binary As #f
        Get #f, , n
        If n = &H474E5089 Then
            Seek #f, Seek(f) + 4
            Do Until EOF(f)
                Get #f, , l
                Get #f, , n
                If EOF(f) Then Exit Do
                l = ((l And &H7F000000) \ &H1000000) Or ((l And &H80000000) \ -&H1000000) _
                    Or ((l And &HFF0000) \ &H100&) Or ((l And &HFF00&) * &H100&) _
                    Or ((l And &H7F&) * &H1000000) Or ((l And &H80) * -&H1000000)
                p = Seek(f)
                If n = &H73594870 Then 'pHYs chunk
                    Seek #f, p - 4
                    ReDim buf(0 To l + 3)
                    Get #f, , buf
                    If EOF(f) Then Exit Do
                    crc = GetCRC(buf)
                    For i = 4 To 12
                        buf(i) = 0
                    Next
                    crc = GetCRC(buf)
                    Seek #f, p - 4
                    Put #f, , buf
                    Put #f, , crc
                    Exit Do
                End If
                Seek #f, p + l + 4
            Loop
        End If
        Close #f
        ClearResolution = True
    End Select
    Exit Function
ErrorHandler:
    If f <> 0 Then Close #f
End Function


'CRC計算関数（PNG用）
Function GetCRC(buf() As Byte) As Long
    Dim crc_table(0 To 255) As Long
    Dim c As Long
    Dim n As Long
    Dim k As Long
    For n = 0 To 255
        c = n
        For k = 0 To 7
            If (c And &H1&) <> 0 Then
                c = &HEDB88320 Xor _
                    (CLng((c And &H7FFFFFFF) \ 2) Or CLng((c And &H80000000) \ -2))
            Else
                c = CLng((c And &H7FFFFFFF) \ 2) Or CLng((c And &H80000000) \ -2)
            End If
        Next
        crc_table(n) = c
    Next

    c = &HFFFFFFFF
    For n = 0 To UBound(buf)
        c = crc_table((c Xor buf(n)) And &HFF) Xor _
            (CLng((c And &H7FFFFFFF) \ 256) Or CLng((c And &H80000000) \ -256))
    Next
    GetCRC = Not (((c And &H7F000000) \ &H1000000) Or ((c And &H80000000) \ -&H1000000) _
        Or ((c And &HFF0000) \ &H100&) Or ((c And &HFF00&) * &H100&) _
        Or ((c And &H7F&) * &H1000000) Or ((c And &H80) * -&H1000000))
End Function