.avi is a default filetype but other formats can be called.
Some might not work, others will.
I have kept the Win api as simple as possible, running in the main module (__FB_MAINPROC__)
Code: Select all
#define WIN_INCLUDEALL
#include "Windows.bi"
#include "win/mmsystem.bi"
#Include once "/win/commctrl.bi"
#define nul chr(0)
Dim As MSG msg
Dim As String req
req="Media (.avi) files"+NUL+"*.AVI"+NUL+"Others (.mp3,.wav, . . .)"+NUL+"*.MP3;*.WAV"+NUL+"All files (*.*)"+NUL+"*.*"+NUL+NUL
Dim As Long x,y,l,xres=800,yres=600
Dim As String xs="770",ys="510"
Var Main_Win=CreateWindowEx(0,"#32770","Control",WS_OVERLAPPEDWINDOW Or WS_VISIBLE,5,5,800,600,0,0,0,0)
Var starter=CreateWindowEx(0,"Button","Open", WS_VISIBLE Or WS_CHILD,0,0,60,30,Main_win,0,0,0)
Var stopper=CreateWindowEx(0,"Button","Stop", WS_VISIBLE Or WS_CHILD,60,0,60,30,Main_win,0,0,0)
Var player=CreateWindowEx(0,"Button","Play", WS_VISIBLE Or WS_CHILD,120,0,60,30,Main_win,0,0,0)
Var finish=CreateWindowEx(0,"Button","End", WS_VISIBLE Or WS_CHILD,180,0,60,30,Main_win,0,0,0)
Var message=CreateWindowEx(0,"static","", WS_VISIBLE Or WS_CHILD,430,0,300,30,Main_win,0,0,0)
Var restart=CreateWindowEx(0,"button","Restart", WS_VISIBLE Or WS_CHILD,240,0,60,30,Main_win,0,0,0)
Var vscreen=CreateWindowEx(0,"static","", WS_VISIBLE Or WS_CHILD Or WS_BORDER,5,50,770,510,Main_win,0,0,0)
Var vol1=CreateWindowEx(0,"button","Vol +", WS_VISIBLE Or WS_CHILD,300,0,60,30,Main_win,0,0,0)
Var vol2=CreateWindowEx(0,"button","Vol -", WS_VISIBLE Or WS_CHILD,360,0,60,30,Main_win,0,0,0)
Declare Function fb_Set_Font (Font As String,Size As Integer,Bold As Integer=0,Italic As Integer=0,Underline As Integer=0,StrikeThru As Integer=0) As HFONT
Declare Function getfiles(filetypes As String) As String
Declare Function SetWindowTheme Lib "UxTheme.dll" Alias "SetWindowTheme"(As Any Ptr,As zstring Ptr,As zstring Ptr) As Long
Function map(a As Double,b As Double,_x_ As Double,c As Double,d As Double) As Double
Return (((d)-(c))*((_x_)-(a))/((b)-(a))+(c))
End Function
freeconsole 'dont show the console box
SetWindowTheme(main_win," "," ")
Dim As rect r
Dim As Double diagonal,lastdiagonal
getwindowrect(main_win,@r)
diagonal = Sqr((r.right-r.left)*(r.right-r.left) + (r.bottom-r.top)*(r.bottom-r.top))
lastdiagonal=diagonal
Dim As zstring * 20 position
Dim As zstring * 20 length
dim as zstring * 20 ans
Dim As HFONT f2=fb_Set_Font("times new roman",12,,false),f1=fb_Set_Font("times new roman",9,,false)
SendMessage(starter,WM_SETFONT,Cast(WPARAM,f2),0)
SendMessage(stopper ,WM_SETFONT,Cast(WPARAM,f2),0)
SendMessage(player ,WM_SETFONT,Cast(WPARAM,f2),0)
SendMessage(finish,WM_SETFONT,Cast(WPARAM,f2),0)
SendMessage(message ,WM_SETFONT,Cast(WPARAM,f1),0)
SendMessage(restart ,WM_SETFONT,Cast(WPARAM,f2),0)
SendMessage(vol1 ,WM_SETFONT,Cast(WPARAM,f2),0)
SendMessage(vol2 ,WM_SETFONT,Cast(WPARAM,f2),0)
Dim As hdc hdc
hdc=GetDC(vscreen)
Static As Double t
t=Timer
dim as long inplay
dim as string file
Dim As Long vol=400
#macro twitch
Scope
Dim As rect r
Var k=Iif(Rnd>.5,1,-1)
getwindowrect(main_win,@r)
movewindow(main_win,r.left+k,r.top-k,r.right-r.left,r.bottom-r.top,false)
End Scope
#endmacro
While true
While (PeekMessage(@Msg,0, 0, 0, PM_REMOVE)) > 0
TranslateMessage(@msg)
DispatchMessage(@msg)
Select Case msg.hwnd
Case Main_Win
Select Case msg.message
Case 273 'close by clicking X
mciSendString("close file1", NULL, 0,0)
End
End Select
'-----------------------------
Case starter
Select Case msg.message
Case WM_LBUTTONDOWN
if inplay then exit select
file= getfiles(req)
if len(file)=0 then inplay=0
mciSendString("open " +Chr(34)+file+Chr(34)+ " type mpegvideo alias file1", NULL, 0, 0)
mciSendString("window file1 handle " & vscreen, 0, 0, 0)
Var s=Mid(file,1+Instrrev(file,Any"\\/"))
setwindowtext(main_win,file)
setwindowtext(message,s)
End Select
'-----------------------------
Case stopper
Select Case msg.message
Case WM_LBUTTONDOWN
mciSendString("pause file1", NULL, 0,0)
End Select
'------------------------------
Case player
Select Case msg.message
Case WM_LBUTTONDOWN
mcisendstring("put file1 destination at "+"0"+" "+"10"+" "+xs+" "+ys,0,0,0)
mciSendString("play file1", NULL, 0,0)
mciSendString("setaudio file1 volume to " & vol,(0), 0, 0)
inplay=len(file)
Sleep 50
twitch
End Select
'------------------------------
Case restart
Select Case msg.message
Case WM_LBUTTONDOWN
mciSendString("play file1 from 0", NULL, 0,0)
inplay=len(file)
Sleep 50
twitch
Var hdc=GetDC(vscreen)
SelectObject(hdc,GetStockObject(DC_PEN))
SetDCpenColor(hdc,bgr(240,240,240))
MoveToEx(hdc,0, 5, NULL)
LineTo(hdc,2000, 5)
deletedc(hdc)
End Select
'------------------------------
Case finish
Select Case msg.message
Case WM_LBUTTONDOWN
mciSendString("close file1", NULL, 0,0)
inplay=0
Var hdc=GetDC(vscreen)
SelectObject(hdc,GetStockObject(DC_PEN))
SetDCPenColor(hdc,bgr(240,240,240))
MoveToEx(hdc,0, 5, NULL)
LineTo(hdc,2000, 5)
deletedc(hdc)
End Select
'--------------------------------
Case vol1
Select Case msg.message
Case WM_LBUTTONDOWN
vol+=50
if vol<0 then vol=0
mciSendString("setaudio file1 volume to " & vol,(0), 0, 0)
End Select
'-------------------------------
Case vol2
Select Case msg.message
Case WM_LBUTTONDOWN
vol-=50
mciSendString("setaudio file1 volume to " & vol,(0), 0, 0)
End Select
End Select'(case main_win)
getwindowrect(main_win,@r)
diagonal = Sqr((r.right-r.left)*(r.right-r.left) + (r.bottom-r.top)*(r.bottom-r.top))
If (lastdiagonal<>diagonal) Then
movewindow(main_win,r.left,r.top,r.right-r.left,r.bottom-r.top,true)
movewindow(vscreen,5,50,(r.right-r.left)-30,(r.bottom-r.top)-90,true)
ShowScrollBar(main_win, SB_BOTH, FALSE)
xs= Str(Int(r.right-r.left)-30)
Var wd=(r.right-r.left)
ys= Str(Int(r.bottom-r.top)-90)
Var p1= "0"
Var p2= "10"
Dim As zString * 200 moveposition= "put file1 destination at "+p1+" "+p2+" "+xs+" "+ys
mcisendstring(@moveposition,null,0,0)
lastdiagonal=diagonal
Sleep 50
twitch
End If
Wend
If Timer-t>1 Then
t=Timer
mciSendString("status file1 position ",@position, 20,0)
mciSendString("status file1 length",@length, 20,0)
mciSendString("status file1 mode ",@ans,20,0)
If ans="stopped" and inplay Then
Var s=Mid(file,1+Instrrev(file,Any"\\/"))
messagebox(0,s,"Finished",MB_OK)
setwindowtext(message,"Done")
mciSendString("close file1", NULL, 0, 0)
inplay=0
end if
Var lngth=Val(length)
Var pst=Vallng(position)
Var wd=r.right-r.left
Var xpos=Iif(Lngth,map(0,1,pst/Lngth,0,wd-30),0)
MoveToEx(hdc,0, 5, NULL)
LineTo(hdc,xpos, 5)
End If
Sleep 1
Wend
Sub done Destructor
mciSendString("close file1", NULL, 0, 0)
End Sub
Function getfiles(filetypes As String) As String
Dim As zstring * 2048 SELFILE
Dim As String MYFILTER
myfilter=filetypes
Dim As OpenFileName SomeFile
With SomeFile
.lStructSize = Sizeof(OpenFileName)
.hInstance = null
.lpstrFilter = Strptr(MYFILTER)
.lpstrFile = @SELFILE
.nMaxFile = 2048
.nMaxFileTitle = 0
.lpstrTitle =@"Movies and songs"
.Flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
End With
GetOpenFileName(@SomeFile)
Return *SomeFile.lpstrFile
End Function
Function fb_Set_Font (Font As String,Size As Integer,Bold As Integer,Italic As Integer,Underline As Integer,StrikeThru As Integer) As HFONT
Dim As HDC hDC=GetDC(HWND_DESKTOP)
Dim As Integer CyPixels=GetDeviceCaps(hDC,LOGPIXELSY)
ReleaseDC(HWND_DESKTOP,hDC)
Return CreateFont(0-(Size*CyPixels)/72,0,0,0,Bold,Italic,Underline,StrikeThru,ANSI_CHARSET _
,OUT_TT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,FF_DONTCARE,Font)
End Function