(Windows)
Code: Select all
#include "windows.bi"
#include "win\Commdlg.bi"
#Include once "/win/commctrl.bi"
#Include "win/shellapi.bi"
freeconsole
Dim As hwnd Main=CreateWindowEx(0,"#32770","Picture finder",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 btn2 =createwindowex(0,"BUTTON","Open Clipboard" ,ws_border Or WS_VISIBLE Or WS_CHILD,280,50,120,30,Main,0,0,0)
Dim As hwnd tip 'tooltip
Declare Sub getfiles(As OpenFileName)
Declare Function CreateToolTip(As hwnd,As String="") As hwnd
Declare Function loadfile(file As String) As String
Declare Sub savefile(filename As String,p As String)
Declare Function compress(Byval num As String) As String
Declare Function uncompress(Byval num As String) As String
declare Function get_clipboard() As String
Dim BMPfile As OpenFileName
Dim As msg msg1
tip=CreateToolTip(btn,"Search for zipped pictures or imagefile.txt")
tip=CreateToolTip(btn2,"Get a text file from the clipboard")
freeconsole
setWindowText(fname,".zip or imagefile.txt")
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
Case WM_RBUTTONDOWN
Screen 0
End Select
'-----------------------------
case btn2 'clipboard option
Select Case msg1.message
Case WM_LBUTTONDOWN
var f=get_clipboard
Screen 19
Color 0,9
Cls
print
print "Length of clipboard file ";len(f)
print
print "Directory in use "; curdir
if len(f)>1000 then
savefile("imagefile.txt",f)
print "Clipboard saved as imagefile.txt"
print
print "You can use the open button to navigate to this file."
else
print "File seems too small for an image, so it has not been processed."
end if
end select
Case btn
Select Case msg1.message
Case WM_LBUTTONDOWN
getfiles(BMPfile)
Dim As String s=*BMPfile.lpstrFile
Screen 19
Color 0,7
Cls
Screencontrol 100,50,300
Print
If Right(s,3)<>"txt" Then
Print "please wait"
Print "File to modify ---> ";s
Var s1 =loadfile(s)
If Len(s1)=0 Then Print "no file chosen":Exit select
Print "Length of Original file "; Len(s1)
' If Len(s1)>35000 Then Print "File too large at ";Len(s1);" characters, press a key and choose another ":Sleep:Cls::Exit Select
Print "Building ..."
Print "Compressing ..."
Var c=compress(s1)
savefile("imagefile.txt",c)
Print "Length of compressed file"; Len(c);" <----- FORUM READABLE------> (Imagefile.txt)"
Print
Print "Press a key to see the text file"
Sleep
Var cc=Curdir
Print "Text file path is " + cc+"\image.txt"
ShellExecute (0,"","notepad.exe ",cc+"\imagefile.txt","",SW_SHOWNORMAL)
End If
'if a text file is chosen
If Right(s,3)="txt" Then
Print "please wait ... (a text file has been chosen)"
Var s1 =loadfile(s)
Print "File to modify ---> ";s
If Len(s1)=0 Then Print "no file chosen":Exit select
Print "Length of text file "; Len(s1)
Var uc=uncompress(s1)
Print "Length of image file "; Len(uc)
savefile("imagefile"+".zip",uc)
Print
Print "imagefile"+".zip has been saved in the same folder"
Print
Print "You can close the program and unzip this file"
End If
End Select
'------------------------------
End Select
Wend
Sub getfiles(Byref BMPfile As OpenFileName)
Dim As zstring * 2048 SELFILE
Dim As String MYFILTER
MYFILTER = "image Files"+Chr(0)+"*.zip;imagefile.txt"+Chr(0)
With BMPfile
.lStructSize = Sizeof(OpenFileName)
.hInstance = null
.lpstrFilter = Strptr(MYFILTER)
.lpstrFile = @SELFILE
.nMaxFile = 2048
.nMaxFileTitle = 0
.lpstrTitle =@"Open"
End With
GetOpenFileName(@BMPfile)
End Sub
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
Function get_clipboard() As String
If IsClipboardFormatAvailable(CF_TEXT) = 0 Then Return "Error"
If OpenClipboard(0) = 0 Then Return "Error"
Function = *Cast(zstring Ptr,GetClipboardData(CF_TEXT))
CloseClipboard()
End Function
Function build(ByVal s As String) As String
Dim As String acc
For n As Long=0 To Len(s)-1
acc+=Right("000" + Str(s[n]),3)
Next
Return acc
End Function
Function rebuild(ByVal s As String) As String
Dim As String acc
For n As Long=1 To Len(s) Step 3
acc+=Chr(ValLng(Mid(s,n,3)))
Next
Return acc
End Function
Function loadfile(file As String) As String
Var f=Freefile
Open file For Binary Access Read As #f
Dim As String text
If Lof(1) > 0 Then
text = String(Lof(f), 0)
Get #f, , text
End If
Close #f
Return text
End Function
Sub savefile(filename As String,p As String)
Dim As Integer n
n=Freefile
If Open (filename For Binary Access Write As #n)=0 Then
Put #n,,p
Close
Else
Print "Unable to load " + filename
End If
End Sub
Function to128(ByVal i As ULong) As String
Dim As String g
Dim As ULong d,m,begin=32
Do
d=i\128
m=i And 127
g=chr((m)+begin)+g
i=d
loop until i=0
Return g
End Function
Function To10(ByVal Number As String) As ULong
Dim As ULong sum,begin=32
sum=(Asc(Left(Number,1))-begin)
For n As Integer=2 To Len(Number)
Var z=(Number[n-1])
sum=(sum Shl 7)+ z-begin
Next n
Return sum
End Function
Function compress(ByVal b256 As String) As String
Var b=build(b256),d=String(4,Chr(32))
Dim As String acc
For n As Long=1 To Len(b) Step 9
Var tmp=(Mid(b,n,9))
acc+= Right(d+ Str(to128(ValuLng(tmp))),4)
Next
Return acc
End Function
Function uncompress(ByVal b128 As String) As String
Var d=String(9,"0")
Dim As String acc
For n As Long=1 To Len(b128) Step 4
Var tmp=(Mid(b128,n,4))
acc+= (Right(d+ Str(to10(tmp)),9))
Next
Return rebuild(acc)
End Function