Show main.bas syntax highlighted
Attribute VB_Name = "general"
'***************************************************
'*
'* AllToAVI
'*
'* Genesis Kiith 2006-2007
'*
'* genesis.kiith@gmail.com
'*
'***************************************************
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" _
(ByVal nSize As Long, _
ByVal lpBuffer As String) As Long
Public Const DBLNL = vbCrLf + vbCrLf
Public Const NL = vbCrLf
'Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const HWND_TOPMOST = -1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const SYNCHRONIZE = &H100000
Private Const INFINITE = &HFFFF ' Infinite timeout
Public H264_Mode As Boolean
Public noShow As Boolean
Public cache_width As String
Public aspects As Double
Public fFlag As Integer '1 = Directory | 0 = File
Public editIndex As Integer
Public Temp As String
Public sub_ext As String
Public au_ext As String
Public Is_H264 As Boolean
Public AATTEN As String
Public VATTEN As String
Public FastBoot As Boolean
Public totalnum As Integer
Public currentjob As Integer
Public Type TagInitCommonControlsEx
lngSize As Long
lngICC As Long
End Type
Public Declare Function InitCommonControlsEx Lib "comctl32.dll" _
(iccex As TagInitCommonControlsEx) As Boolean
Public Const ICC_USEREX_CLASSES = &H200
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const BIF_DONTGOBELOWDOMAIN = 2
'Public Const MAX_PATH = 260
Public Declare Function SHBrowseForFolder Lib "shell32" _
(lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As Long, _
ByVal lpBuffer As String) As Long
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
(ByVal lpString1 As String, ByVal _
lpString2 As String) As Long
Public Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Public alph As Integer
Public Function Rand(ByVal Low As Long, ByVal High As Long) As Long
Randomize
Rand = Int((High - Low + 1) * Rnd) + Low
End Function
Public Function TrimNull(Item As String)
Dim pos As Integer
'double check that there is a chr$(0) in the string
pos = InStr(Item, Chr$(0))
If pos Then
TrimNull = left$(Item, pos - 1)
Else
TrimNull = Item
End If
End Function
Public Function InitCommonControlsVB() As Boolean
On Error Resume Next
Dim iccex As TagInitCommonControlsEx
' Ensure CC available:
With iccex
.lngSize = LenB(iccex)
.lngICC = ICC_USEREX_CLASSES
End With
InitCommonControlsEx iccex
InitCommonControlsVB = (Err.Number = 0)
On Error GoTo 0
End Function
Public Sub Main()
'InitCommonControlsVB
PrepareThemeSupport
'Load frm_Main
'frm_Main.Show
Load frmSplash
frmSplash.Show
End Sub
Public Sub initProg()
'MsgBox "This is a beta!" + vbCrLf + vbCrLf + "So please contact me if you have any problems or if you have a suggestion, Thank you", vbInformation + vbOKOnly
Dim nSize As Long
Dim fso As Object
Dim a As Object
Dim chk_type As Integer '1=Folder from app.path, 2=Folder with full path, 3=File from app.path, 4=File with full path
Dim critLevel As Integer '1=Critical, 2=Create from app.path, 3=Create with full path
Dim comp_name As String
Dim line As String
Dim pos As Integer
Dim rtn As Boolean
Dim gui_update As Integer
Dim strData As String
Dim desc As String
'update.Show
Dim test As String
If App.PrevInstance = True Then
MsgBox "Another instance of AllToAVI is already running. please finish with that first"
End
End If
test = GetSetting("alltoavi", "main", "firsttime", "45391")
Debug.Print test
ShownOnce1 = False
ShownOnce2 = False
H264_Mode = False
FastBoot = False
If test = "45391" Then
On Error Resume Next
MsgBox "Welcome! Please take the time to read the manual!"
REG_CreateNewKey "*\shell", HKEY_CLASSES_ROOT
REG_DeleteKey HKEY_CLASSES_ROOT, "*\shell\Convert with Alltoavi"
REG_DeleteKey HKEY_CLASSES_ROOT, "Folder\shell\Convert With Alltoavi"
MsgBox "If you want to add Shell Extension (Right click convert), please click the button on the Main screen"
'REG_CreateNewKey "*\shell\Convert with Alltoavi", HKEY_CLASSES_ROOT
'REG_CreateNewKey "*\shell\Convert with Alltoavi\command", HKEY_CLASSES_ROOT
'REG_SetKeyValue "*\shell\Convert with Alltoavi\command", "", Chr(34) + App.path + "\AlltoaviV4.exe" + Chr(34) + " %1", REG_SZ, HKEY_CLASSES_ROOT
'REG_CreateNewKey "Folder\shell\Convert With Alltoavi", HKEY_CLASSES_ROOT
'REG_CreateNewKey "Folder\shell\Convert With Alltoavi\command", HKEY_CLASSES_ROOT
'REG_SetKeyValue "Folder\shell\Convert With Alltoavi\command", "", Chr(34) + App.path + "\AlltoaviV4.exe" + Chr(34) + " %1", REG_EXPAND_SZ, HKEY_CLASSES_ROOT
'MsgBox "First Only - Shell Extensions added", vbInformation + vbOKOnly
ShellExecute 0, vbNullString, App.path + "\doc\manual\index_whatsnew.html", vbNullString, vbNullString, vbMaximizedFocus
Call SaveSetting("alltoavi", "main", "firsttime", "DHXG")
End If
With frmSplash.Label1
totalnum = 0
currentjob = 0
SaveSetting "alltoavi", "plugins", "tmp", App.path
frm_options.Check1.Value = GetSetting("alltoavi", "Settings", "SuppressNote", vbUnchecked)
frm_action.lb_action.Caption = "> Checking Resolution"
If (Screen.width / Screen.TwipsPerPixelX) < 760 Then MsgBox "This application is designed for a screen resolution of 1024x768 or more" + DBLNL + ">>However<< It also works on 800x600, but not less", vbCritical + vbOKOnly
'SaveSetting "alltoavi", "Settings", "aspect", chk_aspect.Value
'gui_update = GetSetting("alltoavi", "GUI", "update", 0)
'If gui_update < 5 Then
' gui_update = gui_update + 1
' SaveSetting "alltoavi", "GUI", "update", gui_update
' GoTo SKIP_UPDATE
'End If
' SaveSetting "alltoavi", "GUI", "update", 0
' .Caption = "> Fetching Update News... "
' frmSplash.Refresh
'With browserWnd
' .Label1.Text = "http://alltoavi.sf.net/update/" + str(App.Major) + str(App.Minor) + str(App.Revision) + ".html"
' .Label1.Text = Replace(.Label1.Text, " ", "")
' .WB1.Resizable = False
' .WB1.Navigate .Label1.Text
' Sleep 4000
' .Show
'End With
' strData = INT_GetFileHTTP("genesis-kiith.com", 80, "genesis-kiith.com/alltoavi/update/" + Replace(str(App.Major), " ", "") + Replace(str(App.Minor), " ", "") + Replace(str(App.Revision), " ", "") + ".html")
' strData = INT_StripHTTPHeader(strData)
' If strData = "" Then
' Load browserWnd
' With browserWnd
' .Show
' .Label1.Text = "http://genesis-kiith.com/alltoavi/update/" + Replace(str(App.Major), " ", "") + Replace(str(App.Minor), " ", "") + Replace(str(App.Revision), " ", "") + ".html"
' .WB1.Resizable = False
' .WB1.Navigate "http://genesis-kiith.com/alltoavi/update/" + Replace(str(App.Major), " ", "") + Replace(str(App.Minor), " ", "") + Replace(str(App.Revision), " ", "") + ".html"
' End With
' Else
' FILE_SaveTEXTFile WRITE_NEW, strData, App.path + "\update\" + Replace(str(App.Major), " ", "") + Replace(str(App.Minor), " ", "") + Replace(str(App.Revision), " ", "") + ".html"
' showUpdate
' End If
SKIP_UPDATE:
'should we start fast boot?
If (GetSetting("alltoavi", "main", "fastboot", "false") = "true") Then GoTo FastBoot
.Caption = "> Recreating \tmp... "
On Error Resume Next
Kill App.path + "\tmp\*.*"
FILE_KillFolder App.path + "\tmp"
MkDir App.path + "\tmp"
.Caption = .Caption + "OK"
.Caption = "> Getting %Temp% Path"
Temp = Space$(255)
nSize = Len(Temp)
Call GetTempPath(nSize, Temp)
Temp = TrimNull(Temp)
.Caption = "> Checking Comp_lst.dll... "
If FILE_FileExists(App.path + "\Comp_lst.dll") = False Then
.Caption = .Caption + "Failed!"
MsgBox "A critical component is missing, please reinstall! (Component Registry) , please reinstall!"
End
End If
.Caption = .Caption + "OK"
.Caption = "Reading Component Registry"
Set fso = CreateObject("Scripting.FileSystemObject")
fullp = App.path + "\Comp_lst.dll"
Set RHead = fso.OpenTextFile(fullp, 1)
While Not RHead.AtEndOfStream
DoEvents
frmSplash.Refresh
Sleep 100
'CHK TYPE|CRIT LEVEL|DESC|COMP NAME
line = RHead.ReadLine
chk_type = Mid(line, 1, 1)
critLevel = Mid(line, 3, 1)
desc = Mid(line, 5, InStr(5, line, "|") - 5)
comp_name = Mid(line, InStrRev(line, "|") + 1)
.Caption = "> Checking " + comp_name + "... "
Select Case chk_type
Case 1
rtn = FILE_FolderExists(App.path + comp_name)
Case 2
rtn = FILE_FolderExists(comp_name)
Case 3
rtn = FILE_FileExists(App.path + comp_name)
Case 4
rtn = FILE_FileExists(comp_name)
End Select
If rtn = False Then
.Caption = "> Checking " + comp_name + "... Failed!"
Select Case critLevel
Case 1
MsgBox "A critical component is missing, please reinstall!" + vbCrLf + vbCrLf + "Component ID: " + desc
End
Case 2
.Caption = "> Creating " + App.path + comp_name
MkDir (App.path + comp_name)
Case 3
.Caption = "> Creating " + comp_name
MkDir (comp_name)
Case 4
MsgBox "A codec is missing, althought not critical, some file formats may not be supported because of this." + vbCrLf + "To fix this, either reinstall, or go download the extra codec pack from alltoavi.sourceforge.net and follow the instructions in there" + vbCrLf + vbCrLf + "->Format Now Unsupported: " + desc
End Select
End If
.Caption = .Caption + "OK"
'If chk_type = 1 Then rtn = FolderExists(App.Path + com_name)
Wend
End With
'showUpdate
' Check for:
' - tmp, logs, font folder
GoTo Normal
FastBoot:
On Error Resume Next
Kill App.path + "\tmp\*.*"
FILE_KillFolder App.path + "\tmp"
MkDir App.path + "\tmp"
Temp = Space$(255)
nSize = Len(Temp)
Call GetTempPath(nSize, Temp)
Temp = TrimNull(Temp)
Normal:
End Sub
Public Sub showUpdate()
'Load browserWnd
'With browserWnd
' .Show
' .Label1.Text = App.path + "\update\" + Replace(str(App.Major), " ", "") + Replace(str(App.Minor), " ", "") + Replace(str(App.Revision), " ", "") + ".html"
' .WB1.Resizable = False
' .WB1.Navigate .Label1.Text
'End With
End Sub
Public Sub ShellAndWait(ByVal program_name As String, _
ByVal window_style As VbAppWinStyle)
Dim process_id As Long
Dim process_handle As Long
' Start the program.
On Error GoTo ShellError
process_id = Shell(program_name, window_style)
On Error GoTo 0
' Hide.
DoEvents
' Wait for the program to finish.
' Get the process handle.
process_handle = OpenProcess(SYNCHRONIZE, 0, process_id)
If process_handle <> 0 Then
WaitForSingleObject process_handle, INFINITE
CloseHandle process_handle
End If
' Reappear.
Exit Sub
ShellError:
MsgBox "ShellError"
End Sub
Public Sub ClearControls()
aspects = 0
With frm_options
.cmb_abitrate.Enabled = True
.cmb_audio.Enabled = True
.cmb_codec.Enabled = True
.cmb_bitrate.Enabled = True
.lb_vcodec.Caption = "Video Codec: "
.lb_vbitrate.Caption = "Video Bitrate: "
.lb_acodec.Caption = "Audio Codec: "
.lb_abitrate.Caption = "Audio Bitrate: "
.lb_fourcc.Caption = "Codec FourCC: "
.lb_aspect.Caption = "Aspect Ratio: "
.lb_screen.Caption = "Screen Size: "
.lb_FPS.Caption = "FPS: "
.chk_aspect.Value = vbChecked
.lb_ext.Caption = "Current Extension: "
.chk_manualalign.Value = vbUnchecked
.chk_pcm.Value = vbUnchecked
.chk_streamcopy.Value = vbUnchecked
.chk_aspect.Value = vbChecked
.chk_nodup.Value = vbUnchecked
.chk_noskip.Value = vbUnchecked
.chk_quantizer.Value = vbUnchecked
.txt_audio = "0"
.txt_align.Text = ""
.txt_align.Visible = False
.txt_bitrate = ""
.txt_codec = ""
.txt_height = "Hegiht"
.txt_sub = "-1"
.txt_width = "Width"
.cmb_audio.Clear
.cmb_audio.Text = "Default audio [ID 0]"
.cmb_bitrate.ListIndex = -1
.cmb_bitrate.Text = "Choose bitrate"
.cmb_codec.ListIndex = -1
.cmb_codec.Text = "Choose codec"
.cmb_sub.Clear
.cmb_sub.Text = "Default subtitle [NONE]"
.Label8.Visible = False
.lb_align1.Visible = False
.lb_align2.Visible = False
'.File1.Visible = False
'.txt_ext.Text = GetSetting("alltoavi", "GUI", "ext")
'.txt_bitrate.Text = GetSetting("alltoavi", "GUI", "bitrate")
'.txt_codec.Text = GetSetting("alltoavi", "GUI", "codec")
'.txt_abitrate.Text = GetSetting("alltoavi", "GUI", "abitrate")
End With
End Sub
Public Sub OutOfDo()
currentjob = currentjob + 1
Unload frm_working
End Sub
Public Sub ProcUpdate(strin As String)
Dim pos As Integer
pos = InStr(1, strin, vbCrLf)
MsgBox (Mid(strin, 1, pos - 1))
End Sub
See more files for this project here