Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Yet Another GDI Plus Based Image Viewer

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • PBWin Yet Another GDI Plus Based Image Viewer

    Yet Another GDI Plus Based Image Viewer

    Note: Despite my copyright message, feel free to reuse and/or extract whatever you want.

    I have previously written a PB native Gif viewer and PNG viewer, but I feel unable
    to tackle a jpg decoder.
    So I took the plunge to learn about GDI Plus.

    The forum really helped and especial thanks for Jose Roca's GDI+ info on his website
    and his include and help files.

    The viewer is designed to be added to the Explorer's right-click context menu or
    to the SendTo menu.
    You could also drop an image file on the exe item in Explorer or, if you really
    want to, invoke it with the *full* pathname to an image as the parameter.

    I created a GDI Plus include file with just the function declarations, types,
    constants etc. and Image related helper functions.

    Press F1 in the app for help.

    Written with PB10.04 and PB includes on Win7 Prof 64-bit

    Features:
    • Leverages GDI Plus to open jpg, png, animated and plain gif, bmp (and rle), tiff,
    • and icon.
    • Sets for best GDI Plus rendering for zooms.
    • DDT based and no Graphic Control.
    • Brief Image info.
    • Click and drag to move the window.
    • Keeps the window fully visible at all times (handle WM_WindowPosChanging)
    • Automatic zoom of large images to fit the display.
    • Mouse Wheel zoom in and out.
    • For animated gifs:
    • pause and resume
    • single frame step forwards and backwards
    • speed control
    • Sub-classed owner draw static control (Label) to get keystrokes
    • Flat GDI Plus API (No classes required)

    I have attached a zip with code, icon, and executable.

    The app ... [SetTabs to 4]
    Code:
    '======================================================================='
    ' QVU.PBA                Copyright (c) AardSoft                24th Dec 18    '
    '            But Free For Personal or Educational Use                    '
    '======================================================================='
    
    ' vim: set ts=4 sw=4:    ' [tabs:4]
    
    #Compile    Exe "QVu.exe"
    #Compiler    PBWin 10
    #Optimize    Size
    #Option        Version5        ' 2K/XP, NT4
    
    #Dim        All
    
    '-----------------------------------------------------------------------'
    ' Resources                                                                '
    '-----------------------------------------------------------------------'
    
    #Resource    Icon    appIcon        "QVu.ico"
    
    #Resource    VersionInfo
    #Resource    FileFlags        0
    #Resource    FileVersion        1,0,0,1
    #Resource    ProductVersion    1,0,0,1
    #Resource    StringInfo        "0809", "04E4"
    
    #Resource    Version$ "Comments",        "Free For Personal or Educational Use"
    #Resource    Version$ "CompanyName",        "Aardsoft (Mike P. Simmonds)"
    #Resource    Version$ "FileDescription", "Quick view for PNG/GIF/JPG/BMP files"
    #Resource    Version$ "FileVersion",        "1.00.0001"
    #Resource    Version$ "InternalName",    "QVu"
    #Resource    Version$ "LegalCopyright",    "Copyright © 2015, Aardsoft"
    #Resource    Version$ "OriginalFilename","QVu.exe"
    #Resource    Version$ "ProductName",        "QVu"
    #Resource    Version$ "ProductVersion",    "1.00.0001"
    #Resource    Version$ "Breakfast",        "A toasted bagel and a cup of tea."
    #Resource    Version$ "Toolset",            "Developed with PowerBASIC PBWin 10"
    
    '-----------------------------------------------------------------------'
    ' Includes                                                                '
    '-----------------------------------------------------------------------'
    
    #Include Once    "Win32Api.inc"
    #Include Once    "GdiPlusStuff.pbc"
    
    '-----------------------------------------------------------------------'
    ' Constants                                                                '
    '-----------------------------------------------------------------------'
    
    %fgc        = &h800000&                ' label text colour
    %bgc        = &hEAB79B&                ' light blue (dialog background)
    %bgt        = &h00FFFF&                ' text box  background
    
    %imgDpy        = 1066
    %tTip        = 1955
    %TimerID    =   42                    ' just a number
    %PlayRate    =  100                    ' 10 fps
    
    '-----------------------------------------------------------------------'
    ' Globals                                                                '
    '-----------------------------------------------------------------------'
    
    Global    mWnd, helpBox as dword
    'lobal    mdc, sbm, obm as dword
    
    Global    fName, dName as string, img as GPImg, pause as dword
    Global    nzm, dzm, zm(), nsp, dsp, sp() as dword
    
    '-----------------------------------------------------------------------'
    ' PBMAIN                                                                '
    '-----------------------------------------------------------------------'
    
    Function PbMain() as Long
    
        local r as dword
    
        GetArgs                                '
    
        r = GPStart()                        '
        if r then                            '    
            msgBox Using$("GdiPlus Startup Failed (#)", r),, "Poot!"
            Function = 1: Exit Function        '
        end if                                '
    
        r = GPOpen(img, fName)                ' open it
        if r then                            '    
            msgBox Using$("Open Failed for & (&)", dName, GPError(r)),, "Oh Dear!"
            Function = 1: Exit Function        '
        end if                                '
    
        img.sz = FileSize(fName)            ' actual size on disk
    
        Setup()                                '
        ShowMainWin(0, img)                    ' show the image
        GPClose(img)                        ' release memory
        GPStop()                            ' shutdown GdiPlus
    
    End Function
    
    '-----------------------------------------------------------------------'
    ' GetArgs                                                                '
    '-----------------------------------------------------------------------'
    
    Sub GetArgs()
    
        local    p as long
    
        fName = Remove$(Command$(1), $DQ)
        p = Instr(-1, fName, any "\/")+1    ' find last path sep and skip over
        dName = Mid$(fName, p)                ' extract name plus ext
    
    End Sub
    
    '-----------------------------------------------------------------------'
    ' Setup                                                                    '
    '-----------------------------------------------------------------------'
    
    Sub Setup()
    
        nzm = 25: dzm = 7                    '
        Dim zm(nzm-1)                        ' setup zoom options
        Array Assign zm() =                    _
             25,  33,  50,  60,  66,  75,    _
             80,                            _
            100,                            _ 7 = 100% = default
            125, 150, 175, 200, 250, 300,    _
            350, 400, 450, 500, 550, 600,    _
            700, 800, 900,1000,1500
    
        img.z  = dzm                        ' set initial zoom (100%)
        img.zm = zm(img.z)                    '
        if img.zm > img.zx then img.zm = img.zx
    
        '-----------------------------------'
        nsp = 12: dsp = 5                    '
        Dim sp(nsp-1)                        ' setup speed options
        Array Assign sp() =                    _
            400, 300, 200, 150, 133,        _ 1/4 1/3 1/2 2/3 3/4
            100,                            _ 1
             67,  57,  50,  40,  33, 25        ' 3/2 7/4 2   5/2 3   4
    
        img.sp = dsp                        ' set initial speed (x1)
    
    End Sub
    
    '-----------------------------------------------------------------------'
    ' FileSize                                                                '
    '-----------------------------------------------------------------------'
    
    Function FileSize(fn as string) as dword
    
        local    x as DirData, z as string
    
        z = Dir$(fn, 6, to x)
        Function = x.FileSizeLow
    
    End Function
    
    '-----------------------------------------------------------------------'
    ' ShowHelp                                                                '
    '-----------------------------------------------------------------------'
    
    Sub ShowHelp()
    
        local t as string
    
        t =   "QVu version 1.0.0.1"+$CrLf
        t = t+$CrLf
        t = t+"Quick viewer for jpg, png, (ani)gif, bmp/rle, tiff & ico"+$CrLf
        t = t+$CrLf
        t = t+"F1"+$Tab+$Tab+"This Help"+$CrLf
        t = t+"LMouse+drag"+$Tab+"Move window"+$CrLf
        t = t+"MMouse (hold)"+$Tab+"Show info"+$CrLf
        t = t+"RMouse"+$Tab+$Tab+"Exit"+$CrLf
        t = t+"Escape"+$Tab+$Tab+"Exit"+$CrLf
        t = t+$CrLf
        t = t+"Ctrl+WheelUp"+$Tab+"* Zoom in"+$CrLf
        t = t+"Ctrl+WheelDown"+$Tab+"* Zoom out"+$CrLf
        t = t+"Home"+$Tab+$Tab+"Zoom 100%"+$CrLf
        t = t+$Tab+$Tab+"* Use PgUp/PgDn if no Wheel"+$CrLf
        t = t+$CrLf
        t = t+"Animated Gifs"+$CrLf
        t = t+$CrLf
        t = t+"Space"+$Tab+$Tab+"Pause/Resume"+$CrLf
        t = t+"Right"+$Tab+$Tab+"* Step forwards"+$CrLf
        t = t+"Left"+$Tab+$Tab+"* Step backwards"+$CrLf
        t = t+"Period"+$Tab+$Tab+"* Goto first frame (also NumKP)"+$CrLf
        t = t+"Up"+$Tab+$Tab+"Faster"+$CrLf
        t = t+"Down"+$Tab+$Tab+"Slower"+$CrLf
        t = t+"BackSpace"+$Tab+"Reset speed x1"+$CrLf
        t = t+$Tab+$Tab+"* when paused"
    
        helpBox = 1                            ' kludge work around for MsgBox
        MsgBox t,, "QVu"                    ' not eating Ret and Esc
    
    End Sub
    
    '-----------------------------------------------------------------------'
    ' NewFrame                                                                '
    '-----------------------------------------------------------------------'
    
    Function NewFrame(delta as long) as dword
    
        local    m as dword
    
        select case as long delta                    '
        case  0:                                    ' nothing to do
        case  1: if img.fr < img.nfr-1 then            _ forwards
                 img.fr = img.fr+1 else img.fr = 0
        case -1: if img.fr > 0         then            _ backwards
                 img.fr = img.fr-1 else img.fr = img.nfr-1
        end select                                    '
    
        GPImgSelFrame(img.pImg, img.dID, img.fr)    ' select frame
        Control    Set Text mWnd, %tTip, GetToolTip()    ' update tool tip
    
        if img.nfr > 1 then                                ' is it a gif?
            m = 0                                        ' assume no delay list
            if img.dly then                                _ is there a delay list?
                m = Peek(dword, img.dly+(16+img.fr*4))*10 ' get delay (millisecs)
            if m = 0 then m = 100                        ' handle zero delay
            m = (m*sp(img.sp))\100                            ' apply speed factor
    
            if pause = 0 then SetTimer(mWnd, %TimerID, m, byVal 0)
        end if                                            '
    
        InvalidateRect(GetDlgItem(mWnd, %imgDpy), byVal 0, 0)
    
    End Function
    
    '-----------------------------------------------------------------------'
    ' Zoom                                                                    '
    '-----------------------------------------------------------------------'
    
    Function Zoom(zf as dword) as dword
    
        local    q(), m, x, y, w, h, bx, by as dword, p as dword ptr
        ' sz/win/cli/ws/wsx/st/bx/by/atom-ver    [l/t/r/b]
    
        Dim q(15-1): p = VarPtr(q(0))                    ' 15 dwords
        @p[0] = 15*4                                    ' set size
    
        NewZoom(zf)
    
        '-----------------------------------'
        m = mWnd                                        ' the main window
        GetWindowInfo(m, byVal p)                        ' get size
        x  = @p[1]: y = @p[2]: w = @p[3]-x: h = @p[4]-y    '
        bx = w-(@p[7][email protected][5])                            ' borders-x
        by = h-(@p[8][email protected][6])                            ' borders-y
    
        w = (img.pw*img.zm)\100: h = (img.ph*img.zm)\100' zoom
        w = w+bx: h = h+by                                ' add borders
    
        MoveWindow(m, x, y, w, h, 1)                    ' resize
    
        '-----------------------------------'
        m = GetDlgItem(mWnd, %tTip)                        ' the info window
        GetWindowInfo(m, byVal p)                        ' get size
        h = @p[4][email protected][2]                                    '
        w = (img.pw*img.zm)\100                            ' zoom
    
        MoveWindow(m, 0, 0, w, h, 0)                    ' resize
    
        '-----------------------------------'
        m = GetDlgItem(mWnd, %imgDpy)                    ' the image window
        w = (img.pw*img.zm)\100: h = (img.ph*img.zm)\100    ' zoom
    
        MoveWindow(m, 0, 0, w, h, 1)                    ' resize
        InvalidateRect(m, byVal 0, 0)                    ' redraw
    
    End Function
    
    '-----------------------------------------------------------------------'
    ' NewZoom                                                                '
    '-----------------------------------------------------------------------'
    
    Function NewZoom(zf as dword) as dword
    
        local z as dword
    
        z = img.z
        select case as long zf
        case  0:    z = dzm
        case  1:    if (z < nzm-1) and (img.zm < img.zx) then z = z+1
        case -1:    if z >     0 then z = z-1
        end select
    
        img.z  = z
        img.zm = zm(z)
    
        if img.zm > img.zx then img.zm = img.zx
    
        Control    Set Text mWnd, %tTip, GetToolTip()
    
    End Function
    
    '-----------------------------------------------------------------------'
    ' Speed                                                                    '
    '-----------------------------------------------------------------------'
    
    Function Speed(sf as dword) as dword
    
        NewSpeed(sf)                                    '
    
    End Function
    
    '-----------------------------------------------------------------------'
    ' NewSpeed                                                                '
    '-----------------------------------------------------------------------'
    
    Function NewSpeed(sf as dword) as dword
    
        local s as dword
    
        s = img.sp
        select case as long sf
        case  0:    s = dsp
        case  1:    if s < nsp-1 then s = s+1
        case -1:    if s >     0 then s = s-1
        end select
    
        img.sp  = s
    
    End Function
    
    '-----------------------------------------------------------------------'
    ' KeepToScreen                                                                    '
    '-----------------------------------------------------------------------'
    
    Function KeepToScreen(byVal p as long ptr) as dword
    
        local    x, y, w, h as dword
    
        ' p:    hWin, zPos, x, y, w, h, flags
    
        w = GetSystemMetrics(%SM_CXScreen)                ' display width
        h = GetSystemMetrics(%SM_CYScreen)                ' display height
    
        '-----------------------------------'
        if @p[2] < 0 then @p[2] = 0                        ' fix off screen left
        if @p[3] < 0 then @p[3] = 0                        ' fix off screen top
    
        '-----------------------------------'
        x = @p[2][email protected][4]                                    ' calc right  edge
        y = @p[3][email protected][5]                                    ' calc bottom edge
    
        if w < x then @p[2] = @p[2]-(x-w)                ' if reqd, slide left
        if h < y then @p[3] = @p[3]-(y-h)                ' if reqd, slide up
    
    End Function
    
    '-----------------------------------------------------------------------'
    ' HideWin                                                                '
    '-----------------------------------------------------------------------'
    
    Sub HideWin(wnd as dword, state as dword)
    
        local    ws as dword
    
        ws = GetWindowLong(wnd, %GWL_Style)
    
        if state then
            ws = ws or %WS_Visible
            SetWindowLong(wnd, %GWL_Style, ws)
            InvalidateRect(wnd, byVal 0, 0)
        else
            ws = ws and not %WS_Visible
            SetWindowLong(wnd, %GWL_Style, ws)
            InvalidateRect(GetDlgItem(mWnd, %imgDpy), byVal 0, 0)
        end if
    
    End Sub
    
    '-----------------------------------------------------------------------'
    ' SetFilter                                                                '
    '-----------------------------------------------------------------------'
    
    Sub SetFilter(ByVal id as long, ByVal userProc as dword)
    
        local    wnd as dword, old as dword
    
        wnd = GetDlgItem(mWnd, id)
        old = SetWindowLong(wnd, %GWL_WNDPROC, userProc)
        Control Set User mWnd, id, 1, old
    
    End Sub
    
    '-----------------------------------------------------------------------'
    ' Filter Proc Pass KB messages from a static control                    '
    '-----------------------------------------------------------------------'
    
    Function FilterProc(ByVal wnd as dword, ByVal wMsg as dword, _
                      ByVal wParam as dword, ByVal lParam as dword) as long
    
        local    old as dword
    
        Control Get User mWnd, GetDlgCtrlID(wnd), 1 to old
    
        Select Case as long wMsg
        Case %WM_GetDlgCode
            Function = %DLGC_WantMessage    ' all sodding keys!
            Exit Function
    
        Case %WM_KeyUp
            Dialog Send mWnd, wMsg, wParam, lParam
            Exit Function
    
        End Select
        Function = CallWindowProc(old, wnd, wMsg, wParam, lParam)
    
    End Function
    
    '-----------------------------------------------------------------------'
    ' MainWinProc                                                            '
    '-----------------------------------------------------------------------'
    
    CallBack Function MainWinProc()
    
        Select Case As Long Cb.Msg
    
        Case %WM_InitDialog
            mWnd = Cb.Hndl
            HideWin(GetDlgItem(Cb.Hndl, %tTip), 0)
            SetFilter(%imgDpy, CodePtr(FilterProc))
            if img.nfr > 1 then pause = 0 else pause = 1
            Zoom(0)
            NewFrame(0)
    
    '-----------------------------------------------------------------------'
        Case %WM_Close
    
        Case %WM_Destroy
            KillTimer(mWnd, %TimerID)        ' just in case
    
    '-----------------------------------------------------------------------'
        Case %WM_Command
    
            Function = 0                    ' IDM_OK IDM_Esc from MsgBox ???
    
    '-----------------------------------------------------------------------'
        Case %WM_WindowPosChanging            '
    
        KeepToScreen(Cb.lParam)                ' keep fully on the display
                                            ' Function = 0 prevents
                                            ' WM_Move and WM_Size messages
    
    '-----------------------------------------------------------------------'
        Case %WM_NCRButtonUp                ' Statics don't pass mouse clicks
            Dialog End Cb.Hndl
    
        Case %WM_NCMButtonDown                ' Statics don't pass mouse clicks
            HideWin(GetDlgItem(Cb.Hndl, %tTip), 1)
    
        Case %WM_NCMButtonUp                ' Statics don't pass mouse clicks
            HideWin(GetDlgItem(Cb.Hndl, %tTip), 0)
    
    '-----------------------------------------------------------------------'
        Case %WM_NCHITTEST                    ' click-drag L mouse for moving
            Function = %HTCaption
    
    '-----------------------------------------------------------------------'
        Case %WM_Notify
    
    '-----------------------------------------------------------------------'
        Case %WM_MouseWheel
    
            if (Cb.wParam and &h08) then                                    _
                if (Cb.wParam and &h80000000) then Zoom(-1) else Zoom(1)
    
    '-----------------------------------------------------------------------'
        case %WM_Timer
            NewFrame(1)
    
    '-----------------------------------------------------------------------'
        case %WM_KeyUp
    
            Dialog Set Text mWnd, Using$(" KeyUp [&] Shift [&] Ctrl[&]",    _
                        Hex$(Cb.wParam,8),                                    _
                Hex$(GetKeyState(%VK_Shift),   8),                            _
                Hex$(GetKeyState(%VK_Control), 8))
    
            if helpBox then helpBox = 0: exit select    ' eat the sodding key
    
            Select case as long Cb.wParam
            case %VK_Escape
                Dialog End Cb.Hndl
    
            case %VK_F1                        ' help me
                ShowHelp                    '
    
        '-----------------------------------'
            case %VK_Home                    ' reset zoom
                Zoom(0)                        '
    
            case %VK_Prior                    ' PgUp = Wheel Up
                Zoom(1)                        '
    
            case %VK_Next                    ' PgDn = Wheel Down
                Zoom(-1)                    '
    
        '-----------------------------------'
            case %VK_Space
                pause = pause xor 1
                if pause then KillTimer(mWnd, %TimerID) else NewFrame(0)
    
            case %VK_Right
                NewFrame(1)
    
            case %VK_Left
                NewFrame(-1)
    
            case &h6E, &h2E, &hBE            ' '.' on KB, NumKeyPad (w/wo NumLock)
                img.fr = 0: NewFrame(0)
    
        '-----------------------------------'
            case %VK_Back                    '
                Speed(0)                    '
    
            case %VK_Up                        '
                Speed(1)                    '
    
            case %VK_Down                    '
                Speed(-1)                    '
    
            case else
                Function = 0
            End Select
    
    '-----------------------------------------------------------------------'
        Case %WM_DrawItem                    ' handle owner-draw items
            local    p as dword ptr, w, h as dword
    
            Select Case as long Cb.wParam
            Case %imgDpy
    
                p = Cb.lParam
    
                w = (img.pw*img.zm)\100                    ' zoomed width
                h = (img.ph*img.zm)\100                    ' zoomed height
                GPGfxFromDC(@p[6], img.pGfx)            ' the dc from the owner draw struct
                GPSetMode(img.pGfx, %GPHighBiCubic)        ' highest resize quality
                GPDrawImageR(img.pGfx, img.pImg, 0, 0, w, h)
                GPFreeGfx(img.pGfx)                        ' GdiPlus cleanup
    
            End Select
    
    '-----------------------------------------------------------------------'
        End Select
    
    End Function
    
    '-----------------------------------------------------------------------'
    ' GetToolTip                                                            '
    '-----------------------------------------------------------------------'
    
    Function GetToolTip() as string
    
        local t as string
    
        t = Using$(" &"+$CrLf+" #,x#,x#", dName, img.pw, img.ph, img.pd)
        if img.nfr > 1 then    t = Using$("& fr #/#", t, img.fr+1, img.nfr)
        t = Using$("& zoom #% (#, bytes)", t, img.zm, img.sz)
    
        Function = t
    
    End Function
    
    '-----------------------------------------------------------------------'
    ' Show Main Window                                                        '
    '-----------------------------------------------------------------------'
    
    Function ShowMainWin(ByVal owner As Dword, img as GPImg) As Long
    
        local r   as long
        local dlg, fnt8 as dword
    
        local sDlg, xDlg as dword
        local sImg, xImg as dword
        local sTip, xTip as dword
    
        local x, y, w, h, g as dword
    
    '-----------------------------------------------------------------------
        Font New "Tahoma",      8, 1, 0 To fnt8
    
        sDlg = %WS_Popup Or %WS_DlgFrame Or    _
               %WS_ClipSiblings Or    %WS_ClipChildren Or %WS_Visible 'Or %WS_Caption
        xDlg = %WS_Ex_ControlParent
    
        sImg = %WS_Child Or %WS_Visible Or %SS_OwnerDraw
        xImg = 0 ' %WS_Ex_ClientEdge
    
        sTip = %WS_Child Or %WS_Visible Or %SS_Left
        xTip = 0
    
    '-----------------------------------------------------------------------
        g = 0
        w = img.pw: h = img.ph
    
    '-----------------------------------------------------------------------
        Dialog    New Pixels, owner, "QVu: "+dName, ,, w, h, sDlg, xDlg to dlg
        Dialog    Set Icon      dlg, "appIcon"
        Dialog    Set Color      dlg, %fgc, %bgc
    
    '-----------------------------------------------------------------------
        Control Add Line,     dlg, %imgDpy, "img",  0,0,w,h,  sImg, xImg
    
        Control Add Label,    dlg, %tTip,   "",     0,0,w,36, sTip, xTip
        Control    Set Color      dlg, %tTip,   %fgc, %bgt
        Control    Set Font      dlg, %tTip,   fnt8
        Control    Set Text      dlg, %tTip,   GetToolTip()
    
    '-----------------------------------------------------------------------
        Dialog Show Modal dlg, Call MainWinProc To r
    
        Font End fnt8
    
        Function = r
    End Function
    
    '======================================================================='
    The declaration and support file ...[SetTabs to 4]
    Code:
    '---------------------------------------------------------------------------'
    ' GDIPlus Functions (just for images)                                        '
    '---------------------------------------------------------------------------'
    
    '---------------------------------------------------------------------------'
    ' Constants                                                                    '
    '---------------------------------------------------------------------------'
    
    '---------------------------------------------------------------------------'
    ' Status return values from GDI+ methods
    
    %GPStOk                            =  0
    %GPStGenericError                =  1
    %GPStInvalidParameter            =  2
    %GPStOutOfMemory                =  3
    %GPStObjectBusy                    =  4
    %GPStInsufficientBuffer            =  5
    %GPStNotImplemented                =  6
    %GPStWin32Error                    =  7
    %GPStWrongState                    =  8
    %GPStAborted                    =  9
    %GPStFileNotFound                = 10
    %GPStValueOverflow                = 11
    %GPStAccessDenied                = 12
    %GPStUnknownImageFormat            = 13
    %GPStFontFamilyNotFound            = 14
    %GPStFontStyleNotFound            = 15
    %GPStNotTrueTypeFont            = 16
    %GPStUnsupportedGdiPlusVersion    = 17
    %GPStGdiPlusNotInitialized        = 18
    %GPStPropertyNotFound            = 19
    %GPStPropertyNotSupported        = 20
    %GPStProfileNotFound            = 21
    
    '---------------------------------------'
    Type GPStartIn    dword
        GPVer        as dword
        GPBugProc    as dword
        GPNoThread    as dword
        GPNoCodecs    as dword
    End Type
    
    Type GPStartOut    dword
        GPHook        as dword
        GPUnhook    as dword
    End Type
    
    '---------------------------------------'
    Type GPImg
    
        sz        as dword        ' input file size
        pw        as dword        ' image width
        ph        as dword        ' image height
        pd        as dword        ' image depth
        flg        as dword        ' image flags
        fmt        as dword        ' image pixel format
        ft        as dword        ' image pixel format type
        z        as dword        ' image zoom option (0..25) def 7
        zm        as dword        ' image zoom (100 = 1:1)
        zx        as dword        ' image zoom max (to fit on display)
    
        bd        as dword        ' image depth  for bitmap
        bs        as dword        ' image stride for bitmap
    
        nfr        as dword        ' frame count
        fr        as dword        ' current frame
        sp        as dword        ' speed option (0..11) def 5
        dly        as dword        ' pointer to heap based frame delay array
    
        dID        as GUID            ' for animated gifs
        pImg    as dword        ' GdiPlus image
        pGfx    as dword        ' GdiPlus graphic
    
    End Type
    
    %GPTagDly        = &h5100
    %GPHighBiCubic    = 7
    
    '---------------------------------------------------------------------------'
    ' Declares                                                                    '
    '---------------------------------------------------------------------------'
    
    Declare Function GPStartup        Import "Gdiplus.dll" Alias "GdiplusStartup" (    _
        byRef token  as dword,                                                    _
        byRef input  as GPStartIn,                                                _
        byRef output as GPStartOut) as long
    
    Declare Sub      GPShutDown        Import "Gdiplus.dll" Alias "GdiplusShutdown" (    _
        byVal token  as dword)
    
    Declare Function GPFreeImg        Import "Gdiplus.dll" Alias "GdipDisposeImage" (    _
        byVal pImg   as dword) as long
    
    Declare Function GPFreeGfx        Import "Gdiplus.dll" Alias "GdipDeleteGraphics" (_
        byVal pGfx   as dword) as long
    
    Declare Function GPLoadFF        Import "Gdiplus.dll" Alias "GdipLoadImageFromFile" (_
        byVal fn     as dword,                                                    _
        byRef pImg   as dword) as long
    
    Declare Function GPImgWidth        Import "Gdiplus.dll" Alias "GdipGetImageWidth" (_
        byVal pImg   as dword,                                                    _
        byRef f      as dword) as long
    
    Declare Function GPImgHeight    Import "Gdiplus.dll" Alias "GdipGetImageHeight" (_
        byVal pImg   as dword,                                                    _
        byRef h      as dword) as long
    
    Declare Function GPImgFlags        Import "Gdiplus.dll" Alias "GdipGetImageFlags" (_
        byVal pImg   as dword,                                                    _
        byRef flags  as dword) as long
    
    Declare Function GPImgFormat    Import "Gdiplus.dll" Alias "GdipGetImagePixelFormat" (_
        byVal pImg   as dword,                                                    _
        byRef fmt    as dword) as long
    
    Declare Function GPGfxFromDC    Import "Gdiplus.dll" Alias "GdipCreateFromHDC" (_
        byVal dc     as dword,                                                    _
        byRef pGfx   as dword) as long
    
    Declare Function GPSetMode        Import "Gdiplus.dll" Alias "GdipSetInterpolationMode" (_
        byVal pGfx   as dword,                                                    _
        byVal m      as dword) as long
    
    Declare Function GPDrawImage    Import "Gdiplus.dll" Alias "GdipDrawImageI" (_
        byVal pGfx   as dword,                                                    _
        byVal pImg   as dword,                                                    _
        byVal x      as dword,                                                    _
        byVal y      as dword) as long
    
    Declare Function GPDrawImageR    Import "Gdiplus.dll" Alias "GdipDrawImageRectI" (_
        byVal pGfx   as dword,                                                    _
        byVal pImg   as dword,                                                    _
        byVal x      as dword,                                                    _
        byVal y      as dword,                                                    _
        byVal w      as dword,                                                    _
        byVal h      as dword) as long
    
    Declare Function GPDrawImageRR    Import "Gdiplus.dll" Alias "GdipDrawImageRectRectI" (_
        byVal pGfx   as dword,                                                    _
        byVal pImg   as dword,                                                    _
        byVal dx     as dword,                                                    _
        byVal dy     as dword,                                                    _
        byVal dw     as dword,                                                    _
        byVal dh     as dword,                                                    _
        byVal sx     as dword,                                                    _
        byVal sy     as dword,                                                    _
        byVal sw     as dword,                                                    _
        byVal sh     as dword,                                                    _
        byVal u      as dword,                                                    _
        byVal ia     as dword,                                                    _
        byVal cb     as dword,                                                    _
        byVal cbd    as dword) as long
    
    Declare Function GPImgDimCount    Import "Gdiplus.dll" Alias "GdipImageGetFrameDimensionsCount" (_
        byVal pImg   as dword,                                                    _
        byRef nDim   as dword) as long
    
    Declare Function GPImgDimList    Import "Gdiplus.dll" Alias "GdipImageGetFrameDimensionsList" (_
        byVal pImg   as dword,                                                    _
        byRef lst    as GUID,                                                    _
        byVal nDim   as dword) as long
    
    Declare Function GPImgFrCount    Import "Gdiplus.dll" Alias "GdipImageGetFrameCount" (_
        byVal pImg   as dword,                                                    _
        byRef ID     as GUID,                                                    _
        byRef nFr    as dword) as long
    
    Declare Function GPImgSelFrame    Import "Gdiplus.dll" Alias "GdipImageSelectActiveFrame" (_
        byVal pImg   as dword,                                                    _
        byRef ID     as GUID,                                                    _
        byVal fr     as dword) as long
    
    Declare Function GPPropSize        Import "Gdiplus.dll" Alias "GdipGetPropertyItemSize" (_
        byVal pImg   as dword,                                                    _
        byVal pID    as dword,                                                    _
        byRef sz     as dword) as long
    
    Declare Function GPGetProp        Import "Gdiplus.dll" Alias "GdipGetPropertyItem" (_
        byVal pImg   as dword,                                                    _
        byVal pID    as dword,                                                    _
        byVal sz     as dword,                                                    _
        byVal p      as dword) as long
    
    '---------------------------------------------------------------------------'
    ' Globals                                                                    '
    '---------------------------------------------------------------------------'
    
    global    gpToken as dword
    
    '---------------------------------------------------------------------------'
    ' GPStart                                                                    '
    '---------------------------------------------------------------------------'
    
    Function GPStart() as long
    
        local    r as dword, si as GPStartIn
    
        si.GPVer = 1
        r = GPStartUp(gpToken, si, byVal 0)
        Function = r
    
    End Function
    
    '---------------------------------------------------------------------------'
    ' GPStop                                                                    '
    '---------------------------------------------------------------------------'
    
    Function GPStop() as long
    
        GPShutDown(gpToken)
    
    End Function
    
    '---------------------------------------------------------------------------'
    ' GPClose                                                                    '
    '---------------------------------------------------------------------------'
    
    Function GPClose(g as GPImg) as long
    
        if g.pImg then GPFreeImg(g.pImg)        ' GdiPlus cleanup
        if g.pGfx then GPFreeGfx(g.pGfx)        ' GdiPlus cleanup
        if g.dly then                            _ free heap memory too
            HeapFree(GetProcessHeap(), 0, byVal g.dly)
    
    End Function
    
    '---------------------------------------------------------------------------'
    ' GPOpen                                                                    '
    '---------------------------------------------------------------------------'
    
    Function GPOpen(g as GPImg, byVal fn as string) as long
    
        local    r, n, sz as dword, z as string, ids() as GUID
    
        z = UCode$(fn)                            ' need unicode
        r = GPLoadFF(StrPtr(z), g.pImg)            ' attempt the open
    
        if r then Function = r: Exit Function    ' some sort of error
    
        GPImgWidth( g.pImg, g.pw)                ' get width
        GPImgHeight(g.pImg, g.ph)                ' get height
        GPImgFlags( g.pImg, g.flg)                ' get flags
        GPImgFormat(g.pImg, g.fmt)                ' get pixel format
    
         g.pd = (g.fmt\8) and &h0FF                ' bits per pixel
         g.ft = (g.fmt)   and &h0FF                ' format number
    
        g.zx = FindMaxZoom(g)                    ' calculate max zoom
    
    '    Not needed in current app                '
    '     select case as long g.ft                '
    '    case 1:        g.pd =  1: g.bd = 1: g.bs = (g.pd  +7)\8            ' | ( 1 << 8) | PixelFormatIndexed | PixelFormatGDI)
    '    case 2:        g.pd =  4: g.bd = 1: g.bs = (g.pd  +3)\4            ' | ( 4 << 8) | PixelFormatIndexed | PixelFormatGDI)
    '    case 3:        g.pd =  8: g.bd = 1: g.bs = (g.pw  +3) and (not 3)    ' | ( 8 << 8) | PixelFormatIndexed | PixelFormatGDI)
    '    case 4:        g.pd = 16: g.bd = 2: g.bs = (g.pw*2+3) and (not 3)    ' | (16 << 8) | PixelFormatExtended)
    '    case 5:        g.pd = 16: g.bd = 2: g.bs = (g.pw*2+3) and (not 3)    ' | (16 << 8) | PixelFormatGDI)
    '    case 6:        g.pd = 16: g.bd = 2: g.bs = (g.pw*2+3) and (not 3)    ' | (16 << 8) | PixelFormatGDI)
    '    case 7:        g.pd = 16: g.bd = 2: g.bs = (g.pw*2+3) and (not 3)    ' | (16 << 8) | PixelFormatAlpha | PixelFormatGDI)
    '    case 8:        g.pd = 24: g.bd = 3: g.bs = (g.pw*3+3) and (not 3)    ' | (24 << 8) | PixelFormatGDI)
    '    case 9:        g.pd = 32: g.bd = 4: g.bs = (g.pw*4+3) and (not 3)    ' | (32 << 8) | PixelFormatGDI)
    '    case 10:    g.pd = 32: g.bd = 4: g.bs = (g.pw*4+3) and (not 3)    ' | (32 << 8) | PixelFormatAlpha | PixelFormatGDI | PixelFormatCanonical)
    '    case 11:    g.pd = 32: g.bd = 4: g.bs = (g.pw*4+3) and (not 3)    ' | (32 << 8) | PixelFormatAlpha | PixelFormatPAlpha | PixelFormatGDI)
    '    case 12:    g.pd = 48: g.bd = 1: g.bs = (g.pw*6+3) and (not 3)    ' | (48 << 8) | PixelFormatExtended)
    '    case 13:    g.pd = 64: g.bd = 1: g.bs = (g.pw*8+3) and (not 3)    ' | (64 << 8) | PixelFormatAlpha  | PixelFormatCanonical | PixelFormatExtended)
    '    case 14:    g.pd = 64: g.bd = 1: g.bs = (g.pw*8+3) and (not 3)    ' | (64 << 8) | PixelFormatAlpha  | PixelFormatPAlpha | PixelFormatExtended)
    '    case 15:    g.pd = 32: g.bd = 1: g.bs = (g.pw*4+3) and (not 3)    ' | (32 << 8))
    '     end select                                '
    
        g.fr =   0                                ' first frame
        g.sp = 100                                ' speed x1
         GPImgDimCount(g.pImg, n)                ' get frame count
         Dim ids(n-1)                            '
         GPImgDimList(g.pImg, ids(0), n)            '
         GPImgFrCount(g.pImg, ids(0), g.nfr)        '
        g.dID = ids(0)                            ' for ani gifs
    
        GPPropSize(g.pImg, %GPTagDly, sz)        ' get frame delay list                        ' TO DO
        if sz <> 0 then                            ' if it exists
            g.dly = HeapAlloc(GetProcessHeap(), 8, sz)
            GPGetProp(g.pImg, %GPTagDly, sz, g.dly)
        end if                                    '
    
        Function = 0                            ' ok
    
    End Function
    
    '---------------------------------------------------------------------------'
    ' FindMaxZoom                                                                        '
    '---------------------------------------------------------------------------'
    
    Function FindMaxZoom(g as GPImg) as dword
    
        local sw, sh, mw, mh as dword
    
        ' get max horizontal & vertical image size (display-appBorders)
        ' if you want to get fancy, lookup border w/h I am assuming 3
    
        sw = GetSystemMetrics(%SM_CXScreen)-6        ' max image area w
        sh = GetSystemMetrics(%SM_CYScreen)-6        ' max image area h
    
        mw = (sw*100)\g.pw                            ' max zoom width
        mh = (sh*100)\g.ph                            ' max zoom height
    
        if mw < mh then Function = mw else Function = mh
    
    End Function
    
    '---------------------------------------------------------------------------'
    ' Dump                                                                        '
    '---------------------------------------------------------------------------'
    
    'Function Dump(ByVal p as byte ptr, ByVal n as long) as string
    '
    '    local   s as string, t as String, i as long, b as byte
    '
    '    s = Hex$(p, 8)+":"
    '    do
    '        t = Space$(68)
    '        for i = 0 to 15
    '            if i < n then _
    '                mid$(t, 1+i*3+i \ 4) = Hex$(@p[i], 2)
    '        next i
    '        for i = 0 to 15
    '            if i < n then
    '                b = @p[i]: if (b < 32 or 127 <= b) then b = &hB7
    '                mid$(t, 52+i) = chr$(b)
    '            end if
    '        next i
    '        p = p+16: n = n-16
    '        s = s+$CrLf+t
    '    loop while n > 0
    '    Function = s
    'End Function
    
    '---------------------------------------------------------------------------'
    ' GPError                                                                    '
    '---------------------------------------------------------------------------'
    
    Function GPError(e as long) as string
    
        select case as long e                    '
    
        case %GPStOk:                            Function = "Ok"
        case %GPStGenericError:                    Function = "Generic Error"
        case %GPStInvalidParameter:                Function = "Invalid Parameter"
        case %GPStOutOfMemory:                    Function = "Out Of Memory"
        case %GPStObjectBusy:                    Function = "Object Busy"
        case %GPStInsufficientBuffer:            Function = "Insufficient Buffer"
        case %GPStNotImplemented:                Function = "Not Implemented"
        case %GPStWin32Error:                    Function = "Win32 Error"
        case %GPStWrongState:                    Function = "Wrong State"
        case %GPStAborted:                        Function = "Aborted"
        case %GPStFileNotFound:                    Function = "File Not Found"
        case %GPStValueOverflow:                Function = "Value Overflow"
        case %GPStAccessDenied:                    Function = "Access Denied"
        case %GPStUnknownImageFormat:            Function = "Unknown Image Format"
        case %GPStFontFamilyNotFound:            Function = "Font Family Not Found"
        case %GPStFontStyleNotFound:            Function = "Font Style Not Found"
        case %GPStNotTrueTypeFont:                Function = "Not TrueType Font"
        case %GPStUnsupportedGdiPlusVersion:    Function = "Unsupported GdiPlus Version"
        case %GPStGdiPlusNotInitialized:        Function = "GdiPlus Not Initialized"
        case %GPStPropertyNotFound:                Function = "Property Not Found"
        case %GPStPropertyNotSupported:            Function = "Property Not Supported"
        case %GPStProfileNotFound:                Function = "Profile Not Found"
        case else:                                Function = "Unknown Error Code"
    
        end select                                '
    
    End Function
    
    '---------------------------------------------------------------------------'
    Enjoy, Mike.
    Attached Files
    There are only two speeds for computers: fast enough, and too bloody slow.
    And there are 10 types of programmer -- those that know binary, and those that don't.
Working...
X