' Eigen routines en aanvullingen, verzamelde handige routines ' Eingenroutines.inc ' exist bestaat een bestand? ' AlleenPad strip de bestandsnaam van een drive/pad/bestand ' fProgPath geeft programma pad aan van de applicatie (locatie executable) ' fProgName geeft programma naam aan van de applicatie (naam executable) ' fProgPathName geeft programma pad inclusief volledig pad aan van de applicatie ' BrowseForFolder laat gebruiker een directorie uit de boom kiezen $INCLUDE "win32api.inc" 'include file voor messageboxes in het Nederlands %MBOk =0 %MBOkAfbreken =1 %MBOkAfbrekenOpnieuwNegeren =2 %MBJaNeeAfbreken =3 %MBJaNee =4 %MBNogmalsAfbreken =5 %MBKruis =16 'fout %MBVraag =32 'vraag messagebox %MBUitroep =48 'uitroepteken waarschuwing %MBInfo =64 'info balloon %MBFout = %MBKruis 'ten behoeve van Copieer() %BestaandOverschrijven=0 %WaarschuwenOverschrijven=1 %WaarschuwenNietOverschrijven=2 'declaraties voor het registry gebeuren GLOBAL REG_SZ AS LONG GLOBAL REG_DWORD AS LONG GLOBAL HKEY_CLASSES_ROOT AS LONG GLOBAL HKEY_CURRENT_USER AS LONG GLOBAL HKEY_LOCAL_MACHINE AS LONG GLOBAL HKEY_PERFORMANCE_DATA AS LONG GLOBAL HKEY_USERS AS LONG GLOBAL HKEY_DYN_DATA AS LONG GLOBAL HKEY_CURRENT_CONFIG AS LONG GLOBAL ERROR_NONE AS LONG GLOBAL ERROR_BADDB AS LONG GLOBAL ERROR_BADKEY AS LONG GLOBAL ERROR_CANTOPEN AS LONG GLOBAL ERROR_CANTREAD AS LONG GLOBAL ERROR_CANTWRITE AS LONG GLOBAL ERROR_OUTOFMEMORY AS LONG GLOBAL ERROR_INVALID_PARAMETER AS LONG GLOBAL ERROR_ACCESS_DENIED AS LONG GLOBAL ERROR_INVALID_PARAMETERS AS LONG GLOBAL ERROR_NO_MORE_ITEMS AS LONG GLOBAL KEY_ALL_ACCESS AS LONG GLOBAL REG_OPTION_NON_VOLATILE AS LONG GLOBAL NULLSTRING AS STRING '---------------------------------------------------------------------------------- ' exist bestaat een bestand of directorie? ' IF exist(filename,0) om files te testen ' IF exist(filename,16) om directories te testen FUNCTION exist(BYVAL fspec AS STRING,BYVAL atb AS LONG) AS LONG 'atb=0 for files; 16 for directories LOCAL f AS STRING f=DIR$(fspec,atb) IF LEN(f)=0 THEN FUNCTION=0 ELSE FUNCTION=1 END IF END FUNCTION '----------------------------------- FUNCTION ExistFile(BYVAL fspec AS STRING) AS LONG FUNCTION=exist(fspec,0) END FUNCTION FUNCTION ExistDir(BYVAL fspec AS STRING) AS LONG FUNCTION=exist(fspec,16) END FUNCTION '----------------------------------------------------- FUNCTION AlleenPad (BestandMetPad AS STRING) AS STRING 'strip een drive:\pad\bestandsnaam.exe tot alleen drive:\pad\ LOCAL directorie AS STRING directorie=BestandMetPad WHILE RIGHT$(directorie,1)<>"\" directorie=LEFT$(directorie,LEN(directorie)-1) WEND FUNCTION=directorie END FUNCTION '-------------------------------------------------------------------------------- FUNCTION AlleenBestand (BestandMetPad AS STRING) AS STRING 'strip een drive:\pad\bestandsnaam.exe tot alleen bestandsnaam LOCAL bestand AS STRING bestand=BestandMetPad WHILE INSTR(bestand,"\")<>0 bestand=RIGHT$(bestand,LEN(bestand)-1) WEND FUNCTION=bestand END FUNCTION '-------------------------------------------------------------------------------- ' Via Don Schullian ' fProgPath geeft huidig programma pad aan van de applicatie (locatie executable) ' fProgName geeft programma naam aan van de applicatie (naam executable) ' fProgPathName geeft programma pad inclusief volledig pad aan van de applicatie ' Gebruik: ' FUNCTION PBMAIN() AS LONG ' MSGBOX "Name is: "+fProgName ' MSGBOX "Path is: "+fProgPath ' MSGBOX "Full name including path: "+fProgPathName ' END FUNCTION '--------------------------------------------------------------------------- FUNCTION fProgPath () AS STRING DIM zFileName AS LOCAL ASCIIZ * 260 DIM P AS LOCAL LONG IF GetModuleFileName(0,zFileName,260) <> 0 THEN P = INSTR(-1,zFileName, ANY ":\") FUNCTION = LEFT$(zFileName,P) END IF END FUNCTION '--------------------------------------------------------------------------- FUNCTION fProgPathName () AS STRING DIM zFileName AS LOCAL ASCIIZ * 260 DIM P AS LOCAL LONG IF GetModuleFileName(0,zFileName,260) <> 0 THEN FUNCTION = zFileName END IF END FUNCTION '--------------------------------------------------------------------------- FUNCTION fProgName() AS STRING DIM zFileName AS LOCAL ASCIIZ * 260 DIM P AS LOCAL LONG IF GetModuleFileName(0,zFileName,260) <> 0 THEN P = INSTR(-1,zFileName, ANY ":\") FUNCTION = MID$(zFileName,P+1) END IF END FUNCTION 'Copieer een bestand van BRON naar DOEL, met de opties: altijd overschrijven, alleen na waarschuwing of nooit FUNCTION Copieer(bron AS ASCIIZ, doel AS ASCIIZ , Waarschuwen AS LONG) AS LONG LOCAL Resultaat AS LONG LOCAL Knop AS LONG LOCAL optie AS LONG 'CopyFile(lpExistingFileName AS ASCIIZ, lpNewFileName AS ASCIIZ, BYVAL bFailIfExists AS LONG) AS LONG '1 of 2 --> optie 1 (niet overschrijven) '0 --> zonodig overschrijven IF Waarschuwen<>0 THEN optie=1 ELSE optie=0 Resultaat=CopyFile(bron, doel, optie) IF Resultaat=0 THEN SELECT CASE Waarschuwen CASE 0 'er mocht overschreven worden, maar toch niet gelukt! Oorzaak dus onbekend... MSGBOX("Copiëren van "+bron+" is niet gelukt. Oorzaak onbekend. ") CASE 1 'copiëren niet gelukt, bij optie 1 kan dit komen door bestaand bestand 'bij optie 1 mag dit bestand door de gebruiker worden overschreven Knop=MSGBOX("Copiëren van bestand "+bron+$CR+"Bestand "+doel+" bestaat al!"+$CR+"Dit bestand overschrijven?",%MB_OKCANCEL OR %MB_ICONWARNING,"Let op!" ) 'copiëren met overschrijven bij een 1 (OK) IF Knop=1 THEN Resultaat=CopyFile(bron, doel, 0) 'altijd copieëren CASE 2 'copiëren niet gelukt, bij optie 1/2 kan dit komen door bestaand bestand 'bij optie 2 mocht nooit worden overschreven, dus waarschuwen zonder selectiemogelijkheid Knop=MSGBOX("Copiëren van bestand "+bron+$CR+"Bestand "+doel+" bestaat al!"+$CR+"Dit bestand mag niet worden overschreven!",%MB_OK OR %MB_ICONERROR,"Let op!" ) END SELECT END IF FUNCTION=Resultaat END FUNCTION $IF 0 FUNCTION PBMAIN() AS LONG LOCAL Resultaat AS LONG LOCAL Waarschuwen AS LONG Waarschuwen=2 '0: altijd copiëren, zonodig overschrijven '1: waarschuwen voor overschrijven '2: overschrijven mag nooit! Resultaat=Copieer($bron,$doel,Waarschuwen) ' 1: succes 0: mislukt MSGBOX(STR$(Resultaat)) END FUNCTION $ENDIF ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Return true if OS is Windows 95 ' From PbDll Common32.bas ' Copyright (c) 1997 by PowerBASIC, Inc. ' FUNCTION IsWin95() EXPORT AS LONG LOCAL vi AS OSVERSIONINFO vi.dwOsVersionInfoSize = SIZEOF(vi) GetVersionEx vi FUNCTION = (vi.dwPlatformId = %VER_PLATFORM_WIN32_WINDOWS) END FUNCTION FUNCTION QueryValueEx(lhKey AS LONG,BYVAL szValueName AS STRING, _ vValue AS STRING) AS LONG DIM cch AS LONG DIM lRetVal AS LONG DIM lType AS LONG DIM lValue AS LONG DIM sValue AS ASCIIZ * 255 ON ERROR GOTO QueryValueExError ' Determine the size and type of data to be read lRetVal = RegQueryValueEx(lhKey, BYCOPY szValueName, 0& , lType , BYVAL ERROR_NONE , cch ) IF lRetVal <> ERROR_NONE THEN ERROR 5 SELECT CASE lType CASE REG_SZ: ' For strings sValue = STRING$(cch, 0) lRetVal = RegQueryValueEx(lhKey, BYCOPY szValueName, 0&, lType, sValue, cch) IF lRetVal = ERROR_NONE THEN vValue = LEFT$(sValue, cch) ELSE vValue = "" END IF CASE REG_DWORD: ' For DWORDS lRetVal = RegQueryValueEx(lhKey, BYCOPY szValueName, 0&, lType, lValue, cch) IF lRetVal = ERROR_NONE THEN vValue = STR$(lValue) CASE ELSE 'all other data types not supported lRetVal = -1 END SELECT QueryValueExExit: QueryValueEx = lRetVal EXIT FUNCTION QueryValueExError: RESUME QueryValueExExit END FUNCTION FUNCTION SetRegString(hKey AS LONG, BYVAL sValueName AS STRING, _ BYVAL lType AS LONG, sValue AS ASCIIZ) AS LONG DIM lLength AS LONG lLength = LEN(sValue) SetRegString = RegSetValueEx(hKey, BYCOPY sValueName, 0&, lType, sValue, lLength) END FUNCTION FUNCTION SetRegLong(hKey AS LONG, BYVAL sValueName AS STRING, _ BYVAL lType AS LONG, BYVAL lValue AS LONG) AS LONG DIM lLength AS LONG lLength = 4& SetRegLong = RegSetValueEx(hKey, BYCOPY sValueName, 0&, lType, lValue, lLength) END FUNCTION FUNCTION QueryValue(lPredefinedKey AS LONG, sKeyName AS STRING, _ sValueName AS STRING) AS STRING DIM lRetVal AS LONG 'result of the API FUNCTIONs DIM hKey AS LONG 'handle of opened key DIM sValue AS STRING 'setting of queried value lRetVal = RegOpenKeyEx(lPredefinedKey, BYCOPY sKeyName, 0&, BYVAL KEY_ALL_ACCESS, hKey) lRetVal = QueryValueEx(hKey, sValueName, sValue) lRetVal = RegCloseKey(hKey) FUNCTION = sValue END FUNCTION SUB SetStringKeyValue(lPredefinedKey AS LONG, sKeyName AS STRING, _ sValueName AS STRING, sValueSetting AS STRING, lValueType AS LONG) DIM lRetVal AS LONG 'result of the SetStringKeyValue DIM hKey AS LONG 'handle of open key LOCAL SecurAtt AS SECURITY_ATTRIBUTES 'user defined type SecurAtt.nLength = 0& SecurAtt.lpSecurityDescriptor = 0& SecurAtt.bInheritHandle = 0& 'open and set the specified key lRetVal = RegCreateKeyEx(BYVAL lPredefinedKey, BYCOPY sKeyName, 0&, _ BYCOPY NULLSTRING, BYVAL REG_OPTION_NON_VOLATILE, BYVAL KEY_ALL_ACCESS, _ SecurAtt, hKey, lRetVal) lRetVal = SetRegString(hKey, sValueName, lValueType, BYCOPY sValueSetting) lRetVal = RegCloseKey(hKey) END SUB SUB SetLongKeyValue(lPredefinedKey AS LONG, sKeyName AS STRING, _ sValueName AS STRING, lValueSetting AS LONG, lValueType AS LONG) DIM lRetVal AS LONG 'result of the SetLongKeyValue DIM hKey AS LONG 'handle of open key LOCAL SecurAtt AS SECURITY_ATTRIBUTES 'user defined type SecurAtt.nLength = 0& SecurAtt.lpSecurityDescriptor = 0& SecurAtt.bInheritHandle = 0& 'open and set the specified key lRetVal = RegCreateKeyEx(BYVAL lPredefinedKey, BYCOPY sKeyName, 0&, _ BYCOPY NULLSTRING, BYVAL REG_OPTION_NON_VOLATILE, BYVAL KEY_ALL_ACCESS, _ SecurAtt, hKey, lRetVal) lRetVal = SetRegLong(hKey, sValueName, lValueType, BYVAL lValueSetting) lRetVal = RegCloseKey (hKey) END SUB