Palette Finder (ANY Bitmap Image!)

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
datwill310
Posts: 355
Joined: May 29, 2015 20:37

Re: Palette Finder (ANY Bitmap Image!)

Post by datwill310 »

MrSwiss wrote:
datwill310 wrote:I may want to only get dimensions of an image in certain situations.
Just give me one viable sample, of that ...
Such as with a file explorer: show only dimensions in the listview control.

Such as with a paint program, displaying info in the status bar (though actually, that would come with the raw image format internally).

Mainly showing the user info.
MrSwiss
Posts: 3910
Joined: Jun 02, 2013 9:27
Location: Switzerland

Re: Palette Finder (ANY Bitmap Image!)

Post by MrSwiss »

datwill310 wrote:Mainly showing the user info.
OK, accepted but:

Code: Select all

ImageCreate(GetBitmapWidth(img), GetBitmapHeight(img))
is definitely not for information retrieval ... (stick with your own examples, so to speak).
You'll need variables too, for that. (unless you want the calls within a print statement -- I'd call that: messy)
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Palette Eyeball (ANY Bitmap Image!)

Post by dodicat »

Peeker
edit: with a tip.

Code: Select all



#include "windows.bi"
#include "win\Commdlg.bi"
#Include once "/win/commctrl.bi"

Dim As Any Ptr Main=CreateWindowEx(0,"#32770","ONLY BITMAPS ONLY",WS_OVERLAPPEDWINDOW Or WS_VISIBLE,0,0,800,300,0,0,0,0)
Dim As Any Ptr btn=CreateWindowEx( 0,"BUTTON","Open", ws_border Or WS_VISIBLE Or WS_CHILD ,150,50,100,30,  Main,0,0,0)
Dim As Any Ptr fname  =createwindowex(0,"Static",""  , WS_VISIBLE Or WS_CHILD,0,150,800,30,Main,0,0,0)
Dim As Any Ptr lbl  =createwindowex(0,"Static",""  , WS_VISIBLE Or WS_CHILD,0,200,800,30,Main,0,0,0)
dim as hwnd tip 'tooltip
Declare Sub getfiles(As OpenFileName)
Declare Function GetSize(As String,byref as ushort) As Long 
declare Function CreateToolTip(As hwnd,As String="") As hwnd
Dim BMPfile As OpenFileName
Dim As msg msg1
tip=CreateToolTip(btn,"Search for bitmaps")
While GetMessage(@msg1,0,0,0)
    TranslateMessage(@msg1)
    DispatchMessage(@msg1)
    Select Case msg1.hwnd
    Case Main
        Select Case msg1.message
        Case 273  'close by clicking X
            End
        End Select
        '-----------------------------     
    Case btn
        Select Case msg1.message  
        Case WM_LBUTTONDOWN
            getfiles(BMPfile)
            dim as string s=*BMPfile.lpstrFile
            dim as ushort b
             Dim As Long L= GetSize(*BMPfile.lpstrFile,b)
            if L then
                screenres loword(L), hiword(L),b
                screencontrol 100,0,300
                bload s
                end if
            setWindowText(fname,s) 
            setwindowtext(lbl,"Width " & loword(L) & " , " & "Height " & hiword(L) & "  (" & b & "  bits)" )
        End Select
        '------------------------------ 
    End Select
    
Wend
Sub getfiles(Byref BMPfile As OpenFileName)
    Dim As zstring * 2048 SELFILE
    Dim As String MYFILTER
    MYFILTER = "Bitmap Files"+Chr(0)+"*.bmp"+Chr(0)
    With BMPfile
        .lStructSize = Sizeof(OpenFileName)
        .hInstance = null 
        .lpstrFilter = Strptr(MYFILTER)
        .lpstrFile = @SELFILE
        .nMaxFile = 2048
        .nMaxFileTitle = 0
        .lpstrTitle =@"Open Bitmap"
    End With
    GetOpenFileName(@BMPfile)
End Sub

Function GetSize(BMP As String,byref bts as ushort=0) As Long
    #define mk(a,b) a Or b Shl 16
    Dim As Short a,b,n=Freefile
    If Open(BMP For Binary Access Read As #n) = 0 Then 
        Get #n, 19, a          ' width 
        Get #n, 23, b          ' height 
        get #n, 29, bts
        Close #n                 
        Return mk(a,b) ' concatenate
    End If
End Function

Function CreateToolTip(X As hwnd,msg As String="") As hwnd
    Dim As hwnd  TT= CreateWindowEx(0,"ToolTips_Class32","",64,0,0,0,0,X,0,GetModuleHandle(0),0)
                                                           '64=bubble,0 = rectangle
    SendMessage(TT, TTM_SETMAXTIPWIDTH, 0 , 180) 
    SendMessage(TT, TTM_SETDELAYTIME, TTDT_INITIAL ,40) 
    SendMessage(TT, TTM_SETDELAYTIME, TTDT_RESHOW  ,60)
    Dim bubble As TOOLINFO 
    bubble.cbSize = Len(TOOLINFO) 
    bubble.uFlags = TTF_IDISHWND Or TTF_SUBCLASS 
    bubble.uId = Cast(Uinteger,X) 
    bubble.lpszText = Strptr(msg)
    SendMessage(TT, TTM_ADDTOOL, 0,Cast(LPARAM,@bubble))
    Return TT
End Function

 
Post Reply