BAS File Association Utility

This is the source code for a utility made in LB, that makes it easy to associate .BAS files to Liberty BASIC, no matter the version.

It automatically find LB installs, assuming they're in default locations, and gives the option to associate any of them to the .BAS file extension.

It also has a manual selection option, to allow it to associate any EXE(or any copy of LB in a non-standard location) to the BAS file extension.

 call InitRegistry 
 gosub [findLBexes] 
 
 dim LBExeList$(numLBexes) 
 For x = 1 to numLBexes 
 LBExeList$(x) = word$(LBExes$, x, "|") 
 Next x 
 
 'Form created with the help of Freeform 3 v07-15-08 
 'Generated on Jan 15, 2016 at 22:13:48 
 
 
 [setup.m.Window] 
 nomainwin 
 '-----Begin code for #m 
 
 WindowWidth = 520 
 WindowHeight = 245 
 UpperLeftX=int((DisplayWidth-WindowWidth)/2) 
 UpperLeftY=int((DisplayHeight-WindowHeight)/2) 
 
 
 '-----Begin GUI objects code 
 
 button #m.btnFindExe,"Locate custom EXE",[findEXE], UL, 40, 172, 140, 25 
 TextboxColor$ = "white" 
 textbox #m.tbExePath, 40, 132, 415, 25 
 button #m.btnSetAssociation,"Set Association",[setAssociation], UL, 350, 172, 103, 25 
 ListboxColor$ = "white" 
 listbox #m.lbExeList, LBExeList$(), [selectListEntry], 40, 17, 415, 100 
 
 '-----End GUI objects code 
 
 open "Set BAS file association" for window as #m 
 print #m, "font ms_sans_serif 10" 
 #m.btnSetAssociation, "!disable" 
 #m.lbExeList, "singleclickselect" 
 
 
 [m.inputLoop] 'wait here for input event 
 wait 
 
 [selectListEntry] 
 #m.lbExeList, "selection? LBPath$" 
 #m.tbExePath, LBPath$ 
 #m.btnSetAssociation, "!enable" 
 wait 
 
 [findEXE] 'Perform action for the button named 'btnFindExe' 
 
 'Insert your own code here 
 
 filedialog "Locate LB exe...", "*.exe", LBPath$ 
 if LBPath$ = "" then 
 #m.tbExePath, "<no EXE file selected>" 
 #m.btnSetAssociation, "!disable" 
 else 
 #m.btnSetAssociation, "!enable" 
 end if 
 
 #m.tbExePath, LBPath$ 
 
 wait 
 
 
 [setAssociation] 'Perform action for the button named 'btnSetAssociation' 
 
 'Insert your own code here 
 assocPath$ = chr$(34) + LBPath$ + chr$(34) + " " + chr$(34) + "%1" + chr$(34) 
 a = RegCreateKeyEx(_HKEY_CURRENT_USER, "Software\Classes\.bas", 0, _KEY_ALL_ACCESS, hBas) 
 If a <> 0 then 
 errMsg$ = "Registry error" + chr$(13) + "Unable to open HKCU\Software\Classes\.bas for writing." 
 errMsg$ = errMsg$ + chr$(13) + chr$(13) + "RegCreateKeyEx() returned ";a 
 notice errMsg$ 
 wait 
 end if 
 
 bufSize = 0 
 [bufferLoop] 
 buf$ = space$(bufSize) 
 
 a = RegQueryValueEx(hBas, "", buf$, bufSize) 
 if a = ERROR.MORE.DATA then [bufferLoop] 
 
 if a <> 0 then 
 errMsg$ = "Registry error" + chr$(13) + "Unable to get current BAS association." 
 errMsg$ = errMsg$ + chr$(13) + chr$(13) + "RegQueryValueEx() returned ";a 
 notice errMsg$ 
 a = RegCloseKey(hBas) 
 wait 
 end if 
 
 originalBasAssocation$ = trim$(buf$) 
 
 a = RegSetValueEx(hBas, "", "LibertyBASIC.BasFile") 
 If a <> 0 then 
 errMsg$ = "Registry error" + chr$(13) + _ 
 "Unable to write new association identifier to HKCU\Software\Classes\.bas\(default)." 
 errMsg$ = errMsg$ + chr$(13) + chr$(13) + "RegSetValueEx() returned ";a 
 notice errMsg$ 
 a = RegCloseKey(hBas) 
 wait 
 End If 
 
 a = RegCreateKeyEx(_HKEY_CURRENT_USER, "Software\Classes\LibertyBASIC.BasFile\shell\open\command",_ 
 0, _KEY_ALL_ACCESS, hCommand) 
 
 If a <> 0 then 
 errMsg$ = "Registry error" + chr$(13) + _ 
 "Unable to open HKCU\Software\Classes\LibertyBASIC.BasFile\shell\open\command for writing." 
 errMsg$ = errMsg$ + chr$(13) + chr$(13) + "RegCreateKeyEx() returned ";a 
 notice errMsg$ 
 
 'Restore the original BAS association 
 a = RegSetValueEx(hBas, "", originalBasAssociation$) 
 a = RegCloseKey(hBas) 
 wait 
 end if 
 
 a = RegSetValueEx(hCommand, "", assocPath$) 
 If a <> 0 then 
 errMsg$ = "Registry error" + chr$(13) + _ 
 "Unable to write new association to HKCU\Software\Classes\LibertyBASIC.BasFile\shell\open\command\(default)" 
 errMsg$ = errMsg$ + chr$(13) + chr$(13) + "RegSetValueEx() returned ";a 
 notice errMsg$ 
 
 'Restore the original BAS association 
 a = RegSetValueEx(hBas, "", originalBasAssociation$) 
 a = RegCloseKey(hCommand) 
 a = RegCloseKey(hBas) 
 wait 
 end if 
 
 Call SHNotifyAssocChange 
 
 a = RegCloseKey(hCommand) 
 a = RegCloseKey(hBas) 
 
 Notice "New association set!" 
 wait 
 
 [quit.m] 'End the program 
 call EndRegistry 
 close #m 
 end 
 
 
 '=============================================== 
 ' SUBS/FUNCTIONS BELOW 
 '=============================================== 
 
 [findLBexes] 
 CSIDL.PROGRAMFILES = 38 
 programFilesName$ = GetFileName$(GetSpecialFolder$(CSIDL.PROGRAMFILES)) 
 
 'EXE names to search for 
 searchExes$ = "liberty.exe lbpro.exe lbworkshop.exe jbasic.exe" 
 driveNum = 1 
 driveLetter$ = word$(Drives$, driveNum) + "\" 
 dim info$(10, 10) 
 
 [nextDrive] 
 files driveLetter$, info$() 
 
 numFiles = val(info$(0,0)) 
 numFolders = val(info$(0,1)) 
 
 searchPath$ = "" 
 
 'Confirm that the folder <driveLetter>\<programFilesName> exists 
 if numFolders = 0 then [skipSearchFolder] 
 for x = numFiles+1 to (numFiles+numFolders) 
 folderName$ = info$(x, 1) 
 if folderName$ = programFilesName$ then 
 searchPath$ = driveLetter$ + folderName$ 
 end if 
 next x 
 
 print "searchPath$ = ";searchPath$ 
 
 'Search through <programFilesName> for LB-related program folders 
 
 LBFolderList$ = "" 
 numLBFolders = 0 
 if searchPath$ <> "" then 
 files searchPath$, info$() 
 numFiles = val(info$(0,0)) 
 numFolders = val(info$(0,1)) 
 
 if numFolders = 0 then [skipSearchFolder] 
 
 for x = numFiles+1 to (numFiles+numFolders) 
 folderName$ = info$(x, 1) 
 
 foundLBfolder = 0 
 if left$(folderName$, 13) = "Liberty BASIC" then foundLBfolder = 1 
 if left$(folderName$, 10) = "Just BASIC" then foundLBfolder = 1 
 if folderName$ = "LB Workshop" then foundLBfolder = 1 
 
 if foundLBfolder = 1 then 
 LBFolderList$ = LBFolderList$ + searchPath$ + "\" + folderName$ + "|" 
 numLBFolders = numLBFolders + 1 
 end if 
 next x 
 end if 
 
 print LBFolderList$ 
 
 
 'For each LB-related program folder, find the EXE name 
 if numLBFolders = 0 then [skipSearchFolder] 
 for x = 1 to numLBFolders 
 searchPath$ = word$(LBFolderList$, x, "|") 
 
 files searchPath$, info$() 
 numFiles = val(info$(0, 0)) 
 
 if numFiles = 0 then [doNextFolder] 
 For y = 1 to numFiles 
 if instr(searchExes$, info$(y, 0)) > 0 then 
 LBExes$ = LBExes$ + searchPath$ + "\" + info$(y, 0) + "|" 
 numLBexes = numLBexes + 1 
 end if 
 next y 
 
 [doNextFolder] 
 next x 
 [skipSearchFolder] 
 
 driveNum = driveNum + 1 
 driveLetter$ = word$(Drives$, driveNum) + "\" 
 if driveLetter$ <> "\" then [nextDrive] 
 
 return 
 
 [theEnd] 
 end 
 
 Function GetFileName$(fullPath$) 
 lenFullPath = len(fullPath$) 
 
 For x = lenFullPath to 1 step -1 
 if mid$(fullPath$, x, 1) = "\" then 
 GetFileName$ = mid$(fullPath$, x+1) 
 goto [skip] 
 end if 
 next x 
 [skip] 
 End Function 
 
 Function GetSpecialFolder$(CSIDL) 
 struct IDL, _ 
 cb As uLong, _ 
 abID As short 
 calldll #shell32, "SHGetSpecialFolderLocation",_ 
 0 as ulong, _ 
 CSIDL as ulong, _ 
 IDL as struct,_ 
 ret as ulong 
 if ret=0 then 
 Path$ = Space$(_MAX_PATH) 
 id = IDL.cb.struct 
 calldll #shell32, "SHGetPathFromIDListA",_ 
 id as ulong, _ 
 Path$ as ptr, _ 
 ret as ulong 
 GetSpecialFolder$ = trim$(Path$) 
 end if 
 if GetSpecialFolder$ = "" then GetSpecialFolder$ = "Not Applicable" 
 End Function 
 
 Sub SHNotifyAssocChange 
 SHCNE.ASSOCCHANGED = hexdec("08000000") 
 SHCNF.IDLIST = 0 
 
 CallDLL #shell32, "SHChangeNotify",_ 
 SHCNE.ASSOCCHANGED as long,_ 
 SHCNF.IDLIST as long,_ 
 0 as long,_ 
 0 as long,_ 
 ret as void 
 End Sub 
 
 Sub InitRegistry 
 Open "advapi32" for DLL as #advapi32 
 Global ERROR.MORE.DATA : ERROR.MORE.DATA = 234 
 End Sub 
 
 Sub EndRegistry 
 close #advapi32 
 End Sub 
 
 Function RegCreateKeyEx(hKey, subKey$, dwOptions, samDesired, byref phkResult) 
 struct res, a as ulong 
 
 CallDLL #advapi32, "RegCreateKeyExA",_ 
 hKey as ulong,_ 
 subKey$ as ptr,_ 
 0 as long,_ 'Reserved, must be 0. 
 0 as ulong,_ 'User-defined class type of key. 
 _ 'Very unlikely to be used, so 0. 
 dwOptions as long,_ 
 samDesired as long,_ 
 0 as ulong,_ 'lpSecurityAttributes, used for setting permissions on 
 _ 'the key, among other things. Unlikely to be used. 
 res as struct,_ 
 0 as ulong,_ 'lpDisposition, tells us if the key was opened or created. 
 _ 'Again, unlikely to be used, so 0. 
 RegCreateKeyEx as long 
 
 phkResult = res.a.struct 
 End Function 
 
 'For ease of function use, all registry keys will be strings. 
 Function RegSetValueEx(hKey, valueName$, data$) 
 cbSize = len(data$) 
 CallDLL #advapi32, "RegSetValueExA",_ 
 hKey as ulong,_ 
 valueName$ as ptr,_ 
 0 as long,_ 'Reserved. 
 _REG_SZ as long,_ 'Always string. 
 data$ as ptr,_ 
 cbSize as long,_ 
 RegSetValueEx as long 
 End Function 
 
 Function RegQueryValueEx(hKey, valueName$, byref data$, byref bufSize) 
 struct a, size as long 
 a.size.struct = bufSize 
 
 CallDLL #advapi32, "RegQueryValueExA",_ 
 hKey as ulong,_ 
 valueName$ as ptr,_ 
 0 as long,_ 'Reserved. 
 0 as ulong,_ 'Datatype. Not used, this function only uses REG_SZ. 
 data$ as ptr,_ 
 a as struct,_ 
 RegQueryValueEx as long 
 
 bufSize = a.size.struct 
 End Function 
 
 Function RegDeleteValue(hKey, valueName$) 
 CallDLL #advapi32, "RegDeleteValueA",_ 
 hKey as ulong,_ 
 valueName$ as ptr,_ 
 RegDeleteValue as long 
 End Function 
 
 Function RegDeleteKey(hKey, keyName$) 
 CallDLL #advapi32, "RegDeleteKeyA",_ 
 hKey as ulong,_ 
 keyName$ as ptr,_ 
 RegDeleteKey as long 
 End Function 
 
 Function RegCloseKey(hKey) 
 CallDLL #advapi32, "RegCloseKey",_ 
 hKey as ulong,_ 
 RegCloseKey as long 
 End Function