【メモ帳】Windows Intel Fortran で GDI+ による画像ファイル（jpg/png/gif/etc）読み書き その３

Windows GDI+ API 呼び出しによる画像ファイル読み書き　静的ライブラリリンク

以前の記事では、DLL からルーチンを引き出してくる形で、動的なライブラリ利用を行いました。 最近出た ChatGPT o4 などに聞いたところ、静的なライブラリ・リンクでできるというので、ChatGPT の力を借りてつくってみました。

コメントは自分で書くのがだるいので、ChatGPT に書かせました。

fortran66.hatenablog.com

しかし、ChatGPT は基本的なプログラム作成ではよかったのですが、その後はコンパイラを通らないコードを吐きだし、人間が修正してもまた、狂ったような書き換えをすることを繰り返して、こちらもパワハラ発言連発してしまい反省しています。

でも、本当に腹が立つ。人間様が苦労して動くように修正しても、勝手な書き換えをしては、コンパイラすら通らなくして、そのくせヘラヘラと調子のいいことばかり言うし。殺したくなりました。

ジェームズ・ボンド 007 殺しのライセンス ロゴ スパイ 映画 / 抜群の耐久性! [黒 ブラック] 防水、耐油性 高品質プレミアム / アート ステッカー ウォールステッカー / 車 カー用品 バイク 壁 PC インテリア スーツケース ほとんど何にでも貼れる! ウィンドウ デカール シール 部屋 ノートPC ノートパソコン 【並行輸入品】

ソース・プログラム

うまくいくなら、画面には何も出力しません。入出力ファイルの拡張子を変えると、それに見合った画像ファイル形式で入出力します。

リンク時に必要となるライブラリ "C:\Program Files (x86)\Windows Kits\10\Lib\10.0.22621.0\um\x64\gdiplus.lib"　を与える必要があります。パス名はバージョンによって変わってきます。

module gdiplus_m
    use iso_c_binding, only: c_int, c_int8_t, c_int16_t, c_int64_t, c_ptr
    implicit none
    private
    
    ! Public symbols: encoder CLSIDs and GDI+ startup types & functions
    public :: clsid_bmp, clsid_jpeg, clsid_gif, clsid_tiff, clsid_png
    public :: GdiplusStartupInput_t
    public :: GdiplusStartup, GdiplusShutdown
    public :: GdipCreateBitmapFromFile, GdipSaveImageToFile, GdipDisposeImage
    public :: MultiByteToWideChar

    !-----------------------------------------------------------------------
    ! GUID type: represents a Windows CLSID or interface ID (16 bytes)
    ! Data1-Data3 and Data4 compose the 128-bit GUID value
    !-----------------------------------------------------------------------
    type, bind(c) :: GUID
        integer(c_int)    :: Data1        ! first 32 bits
        integer(c_int16_t):: Data2, Data3 ! next two 16-bit segments
        integer(c_int8_t) :: Data4(8)     ! final 8 bytes
    end type GUID

    !-----------------------------------------------------------------------
    ! Predefined encoder CLSIDs for various image formats
    ! Use C_LOC on these to pass to GdipSaveImageToFile
    !-----------------------------------------------------------------------
    type(GUID), target :: clsid_bmp  = GUID(z'557CF400', z'1A04', z'11D3', [z'9A',z'73',z'00',z'00',z'F8',z'1E',z'F3',z'2E'])
    type(GUID), target :: clsid_jpeg = GUID(z'557CF401', z'1A04', z'11D3', [z'9A',z'73',z'00',z'00',z'F8',z'1E',z'F3',z'2E'])
    type(GUID), target :: clsid_gif  = GUID(z'557CF402', z'1A04', z'11D3', [z'9A',z'73',z'00',z'00',z'F8',z'1E',z'F3',z'2E'])
    type(GUID), target :: clsid_tiff = GUID(z'557CF405', z'1A04', z'11D3', [z'9A',z'73',z'00',z'00',z'F8',z'1E',z'F3',z'2E'])
    type(GUID), target :: clsid_png  = GUID(z'557CF406', z'1A04', z'11D3', [z'9A',z'73',z'00',z'00',z'F8',z'1E',z'F3',z'2E'])

    !-----------------------------------------------------------------------
    ! GDI+ startup input structure
    ! Fill this with version and optional callbacks before calling GdiplusStartup
    !-----------------------------------------------------------------------
    type, bind(c) :: GdiplusStartupInput_t
        integer(c_int) :: GdiplusVersion          ! GDI+ version (set to 1)
        type(c_ptr)   :: DebugEventCallback      ! pointer to debug callback, or C_NULL_PTR
        integer(c_int) :: SuppressBackgroundThread ! disable internal threading if non-zero
        integer(c_int) :: SuppressExternalCodecs   ! disable external codecs if non-zero
    end type GdiplusStartupInput_t

    !-----------------------------------------------------------------------
    ! Interface to GDI+ functions
    ! All functions return C_INT status codes (0 = Ok)
    !-----------------------------------------------------------------------
    interface

        !-------------------------------------------------------------------
        ! GdiplusStartup: initialize GDI+ library
        ! tok   : out, GDI+ token for shutdown
        ! inp   : in,  configuration structure
        ! outp  : unused (must be C_NULL_PTR)
        !-------------------------------------------------------------------
        function GdiplusStartup(tok, inp, outp) bind(C, name="GdiplusStartup")
            import :: c_int, c_int64_t, c_ptr, GdiplusStartupInput_t
            integer(c_int)            :: GdiplusStartup
            integer(c_int64_t), intent(out) :: tok
            type(GdiplusStartupInput_t), value :: inp
            type(c_ptr), value        :: outp
        end function GdiplusStartup

        !-------------------------------------------------------------------
        ! GdiplusShutdown: clean up GDI+ library
        ! tok : in, the token returned by GdiplusStartup
        !-------------------------------------------------------------------
        subroutine GdiplusShutdown(tok) bind(C, name="GdiplusShutdown")
            import :: c_int64_t
            integer(c_int64_t), value :: tok
        end subroutine GdiplusShutdown

        !-------------------------------------------------------------------
        ! GdipCreateBitmapFromFile: load image file into GDI+ Bitmap
        ! fn  : in, wide-string filename pointer
        ! bmp : out, pointer to created Bitmap object
        !-------------------------------------------------------------------
        function GdipCreateBitmapFromFile(fn, bmp) bind(C, name="GdipCreateBitmapFromFile")
            import :: c_int, c_ptr
            integer(c_int)           :: GdipCreateBitmapFromFile
            type(c_ptr), value       :: fn
            type(c_ptr), intent(out) :: bmp
        end function GdipCreateBitmapFromFile

        !-------------------------------------------------------------------
        ! GdipSaveImageToFile: save GDI+ Bitmap to file using a specified encoder
        ! img : in, Bitmap object pointer
        ! fn  : in, wide-string filename pointer
        ! cls : in, pointer to encoder CLSID
        ! prm : in, encoder parameters (pass C_NULL_PTR for defaults)
        !-------------------------------------------------------------------
        function GdipSaveImageToFile(img, fn, cls, prm) bind(C, name="GdipSaveImageToFile")
            import :: c_int, c_ptr
            integer(c_int)           :: GdipSaveImageToFile
            type(c_ptr), value       :: img, fn, cls, prm
        end function GdipSaveImageToFile

        !-------------------------------------------------------------------
        ! GdipDisposeImage: release GDI+ Bitmap object
        ! img : in, Bitmap object pointer
        !-------------------------------------------------------------------
        function GdipDisposeImage(img) bind(C, name="GdipDisposeImage")
            import :: c_int, c_ptr
            integer(c_int)           :: GdipDisposeImage
            type(c_ptr), value       :: img
        end function GdipDisposeImage

        !-------------------------------------------------------------------
        ! MultiByteToWideChar: convert ANSI string to UTF-16 buffer
        ! cp    : in, code page (0 = system default)
        ! flags : in, conversion flags (use 0)
        ! mb    : in, pointer to ANSI string
        ! mbLen : in, length of ANSI buffer (including null)
        ! wb    : out, pointer to UTF-16 buffer
        ! wbLen : in/out length of UTF-16 buffer (in wide chars)
        ! returns number of wide characters written (including null)
        !-------------------------------------------------------------------
        function MultiByteToWideChar(cp, flags, mb, mbLen, wb, wbLen) bind(C, name="MultiByteToWideChar")
            import :: c_int, c_ptr
            integer(c_int), value :: cp, flags, mbLen, wbLen
            type(c_ptr),   value :: mb, wb
            integer(c_int)       :: MultiByteToWideChar
        end function MultiByteToWideChar
    end interface
end module gdiplus_m

module bmp_m
    use iso_c_binding, only: c_int, c_long, c_ptr
    implicit none

    !-----------------------------------------------------------------------
    ! bmp_m: Provides GDI+ bitmap-locking functions and related types
    !-----------------------------------------------------------------------
    private
    public :: Rect_t, BitmapData_t
    public :: GdipBitmapLockBits, GdipBitmapUnlockBits
    public :: GdipGetImageWidth, GdipGetImageHeight

    !-----------------------------------------------------------------------
    ! Rect_t: Defines a rectangle (X, Y, Width, Height) for lock region
    !-----------------------------------------------------------------------
    type, bind(c) :: Rect_t
        integer(c_long) :: X = 0           ! Left coordinate
        integer(c_long) :: Y = 0           ! Top coordinate
        integer(c_long) :: Width = 0       ! Rectangle width
        integer(c_long) :: Height = 0      ! Rectangle height
    end type Rect_t

    !-----------------------------------------------------------------------
    ! BitmapData_t: Holds information about locked bitmap pixels
    !-----------------------------------------------------------------------
    type, bind(c) :: BitmapData_t
        integer(c_int) :: Width            ! Image width in pixels
        integer(c_int) :: Height           ! Image height in pixels
        integer(c_int) :: Stride           ! Byte width of one scan line
        integer(c_int) :: PixelFormat      ! Pixel format constant
        type(c_ptr)    :: Scan0            ! Pointer to pixel data
        type(c_ptr)    :: Reserved         ! Reserved for future use
    end type BitmapData_t

    interface
        !-------------------------------------------------------------------
        ! GdipBitmapLockBits:
        !   Locks a region of bitmap into system memory for direct access
        ! bitmap          : in, Bitmap pointer
        ! rect            : in, Rect_t specifying region to lock
        ! flags           : in, read/write mode flags
        ! format          : in, pixel format constant
        ! lockedBitmapData: out, filled with BitmapData_t info
        ! returns status code (0 = Ok)
        !-------------------------------------------------------------------
        function GdipBitmapLockBits(bitmap, rect, flags, format, lockedBitmapData) bind(c, name="GdipBitmapLockBits")
            import :: c_int, c_long, c_ptr, Rect_t, BitmapData_t
            integer(c_long)  :: GdipBitmapLockBitsFunc
            type(c_ptr), value       :: bitmap
            type(Rect_t), intent(in):: rect
            integer(c_int), value    :: flags
            integer(c_int), value    :: format
            type(BitmapData_t)       :: lockedBitmapData   ! out parameter
        end function GdipBitmapLockBits

        !-------------------------------------------------------------------
        ! GdipBitmapUnlockBits:
        !   Releases the lock and writes back any changes
        ! bitmap          : in, Bitmap pointer
        ! lockedBitmapData: in, previously filled data
        ! returns status code
        !-------------------------------------------------------------------
        function GdipBitmapUnlockBits(bitmap, lockedBitmapData) bind(c, name="GdipBitmapUnlockBits")
            import :: c_long, c_ptr, BitmapData_t
            integer(c_long) :: GdipBitmapUnlockBitsFunc
            type(c_ptr), value             :: bitmap
            type(BitmapData_t), intent(in):: lockedBitmapData
        end function GdipBitmapUnlockBits

        !-------------------------------------------------------------------
        ! GdipGetImageWidth:
        !   Retrieves the width of the image
        ! image : in, Bitmap pointer
        ! width : out, filled with width in pixels
        ! returns status code
        !-------------------------------------------------------------------
        function GdipGetImageWidth(image, width) bind(c, name="GdipGetImageWidth")
            import :: c_int, c_long, c_ptr
            integer(c_long) :: GdipGetImageWidthFunc
            type(c_ptr), value        :: image
            integer(c_int), intent(out):: width
        end function GdipGetImageWidth

        !-------------------------------------------------------------------
        ! GdipGetImageHeight:
        !   Retrieves the height of the image
        ! image  : in, Bitmap pointer
        ! height : out, filled with height in pixels
        ! returns status code
        !-------------------------------------------------------------------
        function GdipGetImageHeight(image, height) bind(c, name="GdipGetImageHeight")
            import :: c_int, c_long, c_ptr
            integer(c_long) :: GdipGetImageHeightFunc
            type(c_ptr), value         :: image
            integer(c_int), intent(out):: height
        end function GdipGetImageHeight
    end interface
end module bmp_m

program simple_gdiplus
    use gdiplus_m
    use, intrinsic :: iso_c_binding, only:  &
         c_int, c_int64_t, c_char, &
         c_ptr, c_loc, c_null_char, c_null_ptr
    implicit none

    ! Input and output file paths (ANSI, null-terminated)
    character(len=*), parameter :: inFile  = "C:\work\input.jpg"
    character(len=*), parameter :: outFile = "C:\work\output.png"

    ! Runtime variables for conversion, GDI+, and image handle
    integer(c_int)                  ::  lenW, stat, status
    character(kind=c_char,len=:), allocatable, target :: mbuf, wbuf
    integer(c_int64_t)              :: token
    type(c_ptr)                     :: imagePtr
    type(c_ptr)                     :: ptrClsid

    ! Convert ANSI input path to UTF-16 wide string
    mbuf = trim(inFile)//c_null_char
    lenW = MultiByteToWideChar(0,0, c_loc(mbuf), len(mbuf), c_null_ptr, 0)
    if (lenW <= 0) stop "WideChar length error"
    allocate(character(kind=c_char,len=2*lenW) :: wbuf)
    stat = MultiByteToWideChar(0,0, c_loc(mbuf), len(mbuf), c_loc(wbuf), lenW)
    if (stat /= lenW) stop "WideChar convert error"

    ! Start GDI+ runtime
    status = GdiplusStartup(token, GdiplusStartupInput_t(1, c_null_ptr,0,0), c_null_ptr)
    if (status /= 0) stop "GdiplusStartup failed"

    ! Load image from file into GDI+ Bitmap object
    status = GdipCreateBitmapFromFile(c_loc(wbuf), imagePtr)
    if (status /= 0) then
        print *, "Load failed:", status
        call GdiplusShutdown(token); stop 1
    end if

BMP: block
        use bmp_m 
        use, intrinsic :: iso_c_binding, only: c_f_pointer

        ! Access image data directly as a 2D pixel array
        integer(c_int)           :: iwidth, iheight
        type(Rect_t)             :: rect_in
        type(BitmapData_t), target :: bmpData
        integer(c_int), pointer  :: pixels(:, :)
        ! Constants for pixel format and lock mode flags
        integer(c_int), parameter :: PixelFormat32bppARGB = 2498570
        integer(c_int), parameter :: ImageLockModeRead = 1, ImageLockModeWrite = 2    

        ! Retrieve image width and height (in pixels)
        status = GdipGetImageWidth (imagePtr, iwidth)
        status = GdipGetImageHeight(imagePtr, iheight)

        ! Configure BitmapData structure for locking the full image
        bmpData%Width       = iwidth
        bmpData%Height      = iheight
        bmpData%Stride      = iwidth*4 !((iwidth*32 + 31)/32)*4
        bmpData%PixelFormat = PixelFormat32bppARGB

        ! Lock the image data for direct read/write pixel access
        rect_in = rect_t(0, 0, iwidth, iheight)
        status = GdipBitmapLockBits( imagePtr, rect_in,               &
            ImageLockModeRead+ImageLockModeWrite, PixelFormat32bppARGB, bmpData )
        if (status /= 0) then
            print *, "BitmapLockBits failed:", status
            stop
        end if

        ! Convert raw pointer to 2D integer pixel array
        call c_f_pointer(bmpData%Scan0, pixels, [iwidth, iheight])

  RGBA: block
            integer(c_int) :: ir, ig, ib, ia
            ! Process each pixel to invert RGB channels
            ! Note: Each pixel is 4 bytes in ARGB order
            ! Alpha channel is preserved
            do concurrent (integer::ix = 1:size(pixels, 1), iy = 1:size(pixels, 2))
                ia = iand(ishft(pixels(ix, iy), -24), 255)
                ir = iand(ishft(pixels(ix, iy), -16), 255)
                ig = iand(ishft(pixels(ix, iy),  -8), 255)
                ib = iand(      pixels(ix, iy)      , 255)
                pixels(ix, iy) = (256 - ib) + 256 * (256 - ig + 256 * (256 - ir + 256 * ia))  
            end do
        end block RGBA

        ! Unlock image after modification
        status = GdipBitmapUnlockBits(imagePtr, bmpData)
        if (status /= 0) then
            print *, "BitmapUnlockBits failed:", status
        end if
    end block BMP

    ! Convert ANSI output path to UTF-16 wide string
    deallocate(mbuf,wbuf)
    mbuf = trim(outFile)//c_null_char

    lenW = MultiByteToWideChar(0,0, c_loc(mbuf), len(mbuf), c_null_ptr, 0)
    if (lenW <= 0) stop "WideChar length error"
    allocate(character(kind=c_char,len=2*lenW) :: wbuf)
    stat = MultiByteToWideChar(0,0, c_loc(mbuf), len(mbuf), c_loc(wbuf), lenW)
    if (stat /= lenW) stop "WideChar convert error" 

    ! Save image using encoder determined by file extension
    ptrClsid = get_clsid(outFile)
    status   = GdipSaveImageToFile(imagePtr, c_loc(wbuf), ptrClsid, c_null_ptr)
    if (status /= 0) print *, "Save failed:", status

    ! Release image and shut down GDI+
    status = GdipDisposeImage(imagePtr)
    call GdiplusShutdown(token)
    
contains 
    ! Determine encoder CLSID based on file extension
    type(c_ptr) function get_clsid(fn) result(res)
        character(len = *), intent(in) :: fn   ! Input filename
        integer :: k
        character(len = :), allocatable :: ext
        ! Extract extension from the last period onward
        k = index(fn, '.', back = .true.) + 1
        ext = fn(k:)
        ! Map known extensions to encoder CLSID
        select case(trim(ext))
        case('bmp')
            res = c_loc(clsid_png)  ! Intentionally uses PNG encoder even for BMP
        case('jpg', 'jpeg') 
            res = c_loc(clsid_jpeg)
        case('gif')
            res = c_loc(clsid_gif)
        case('tif', 'tiff')
            res = c_loc(clsid_tiff)
        case('png')
            res = c_loc(clsid_png)
        case default ! Unknown extension: return null and warn
            print *, ext, ':unknown file type'
            res = c_null_ptr
        end select
    end function get_clsid
end program simple_gdiplus