├── info.bck ├── Avi.frx ├── TEST.frx ├── help.frx ├── .gitignore ├── ColorDialog.frx ├── FontDialog1.frx ├── GuiM2000.frx ├── NeoMsgBox.frx ├── tweakprive.frx ├── FileSelectorDialog.frx ├── glis4.ctx ├── testme.vbg ├── testme.vbw ├── bj.png ├── dbX.bas ├── dc.bas ├── jpg.bas ├── mexe.rc ├── pic.bas ├── Fcall.bas ├── M2000.PDM ├── M2000.RES ├── M2000.TLB ├── M2000.exp ├── M2000.lib ├── Math.cls ├── Mutex.cls ├── SMALL.frm ├── SMALL.frx ├── TEST.frm ├── csGUI.png ├── gpp1.bas ├── help.frm ├── m2000.ico ├── pipe.bas ├── tuple.cls ├── GuiImage.cls ├── GuiM2000.frm ├── LoadFile.frm ├── MemBlock.cls ├── MetaDc.cls ├── Mk2Base.cls ├── Mod_Text.bas ├── Mod_Util.bas ├── Module10.bas ├── MyPopUp.frm ├── RefArray.cls ├── ShapeEx.ctx ├── Socket.cls ├── TextP0.frm ├── TextP0.frx ├── ZipTool.cls ├── basetask.cls ├── cBarCode.cls ├── frmAbout.frx ├── help2000.mdb ├── m2000-2.gsb ├── m2000exe.RES ├── mArray.cls ├── mForm1.frx ├── mStiva.cls ├── mdbfile.mdb ├── meditor.png ├── mexe2_2.res ├── piechart.png ├── shapes.png ├── BigInteger.cls ├── CallBack2.cls ├── FontDialog.frm ├── GuiEditBox.cls ├── GuiListBox.cls ├── Idispatch.tlb ├── MyProcess.cls ├── SerialPort.cls ├── ServerMod.bas ├── StringMath.bas ├── TextViewer.cls ├── chessmove.png ├── clsOSInfo.cls ├── linechart.png ├── newbuttons.png ├── ppppLight.cls ├── spritesnew.png ├── tweakprive.frm ├── ComShinkEvent.cls ├── FontDialog1.frm ├── HiddenCursor.cur ├── IDispatch.tlbold ├── PropReference.cls ├── cDIBSection.cls ├── cTlsClient1.cls ├── constantclass.cls ├── mdlIDispatch.bas ├── BaseCollection.cls ├── FastCollection.cls ├── XmlMonoInternal.cls ├── radialprogress.png ├── stdCallFunction.cls ├── ComShinkEventNew.cls ├── FileSelectorDialog.frm ├── modGDIPlusResize.bas ├── modObjectExtender.bas ├── modTrickUnregCOM.bas ├── stack.bat ├── stackdll.bat ├── stackPro.bat ├── Info.bat ├── mexeMakeRes.cmd ├── .gitattributes ├── mexe.vbw ├── M2000.TXT ├── utf8 ├── interpress.cls.utf8.txt ├── comevents.cls.utf8.txt ├── copyinout.cls.utf8.txt ├── icontrolindex.cls.utf8.txt ├── errorbag.cls.utf8.txt ├── safeforms.cls.utf8.txt ├── xmlnode.cls.utf8.txt ├── testme.frm.utf8.txt ├── mthreadref.cls.utf8.txt ├── indexes.cls.utf8.txt ├── constantclass.cls.utf8.txt ├── sinkevent.cls.utf8.txt ├── clsprofiler.cls.utf8.txt ├── itask.cls.utf8.txt ├── newrnd.bas.utf8.txt ├── mutex.cls.utf8.txt ├── checkbox.cls.utf8.txt ├── class1.cls.utf8.txt ├── isprinter.bas.utf8.txt ├── extcontrol.cls.utf8.txt ├── taskbase.cls.utf8.txt ├── mybutton.cls.utf8.txt ├── varitem.cls.utf8.txt ├── mhandler.cls.utf8.txt ├── layer.frm.utf8.txt ├── coder.cls.utf8.txt ├── spbuffer.cls.utf8.txt ├── enumeration.cls.utf8.txt ├── longhash.cls.utf8.txt ├── propreference.cls.utf8.txt ├── musicbox.cls.utf8.txt ├── iboxarray.cls.utf8.txt └── servermod.bas.utf8.txt ├── InterPress.cls ├── ComEvents.cls ├── CopyInOut.cls ├── utf8_converter.gsb ├── IControlIndex.cls ├── ErrorBag.cls ├── testme.vbp ├── safeforms.cls ├── XmlNode.cls ├── testme.frm ├── mThreadref.cls ├── mexe.vbp ├── readme.txt ├── stack.gsb ├── stack.bck ├── Indexes.cls ├── m2000.manifest ├── SinkEvent.cls ├── clsProfiler.cls ├── manifest.manifest ├── ITask.cls ├── newRND.bas ├── ca.cer ├── ca.crt ├── m2000.cer ├── m2000dllcompact.iss ├── checkbox.cls ├── Class1.cls ├── IsPrinter.bas ├── ExtControl.cls ├── TaskBase.cls ├── myButton.cls ├── VarItem.cls ├── mHandler.cls ├── layer.frm ├── coder.cls ├── SPBuffer.cls ├── Enumeration.cls ├── M2000.vbw ├── LongHash.cls ├── ucRadialProgress.ctl └── MusicBox.cls /info.bck: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /Avi.frx: -------------------------------------------------------------------------------- 1 | lt -------------------------------------------------------------------------------- /TEST.frx: -------------------------------------------------------------------------------- 1 | lt -------------------------------------------------------------------------------- /help.frx: -------------------------------------------------------------------------------- 1 | lt -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | *.pdf 3 | -------------------------------------------------------------------------------- /ColorDialog.frx: -------------------------------------------------------------------------------- 1 | lt -------------------------------------------------------------------------------- /FontDialog1.frx: -------------------------------------------------------------------------------- 1 | lt -------------------------------------------------------------------------------- /GuiM2000.frx: -------------------------------------------------------------------------------- 1 | lt -------------------------------------------------------------------------------- /NeoMsgBox.frx: -------------------------------------------------------------------------------- 1 | lt -------------------------------------------------------------------------------- /tweakprive.frx: -------------------------------------------------------------------------------- 1 | lt -------------------------------------------------------------------------------- /FileSelectorDialog.frx: -------------------------------------------------------------------------------- 1 | lt -------------------------------------------------------------------------------- /glis4.ctx: -------------------------------------------------------------------------------- 1 |  StandardFontStandardColor -------------------------------------------------------------------------------- /testme.vbg: -------------------------------------------------------------------------------- 1 | VBGROUP 5.0 2 | StartupProject=M2000.vbp 3 | -------------------------------------------------------------------------------- /testme.vbw: -------------------------------------------------------------------------------- 1 | Form1 = 175, 175, 841, 594, , 150, 150, 816, 569, C 2 | -------------------------------------------------------------------------------- /bj.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/bj.png -------------------------------------------------------------------------------- /dbX.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/dbX.bas -------------------------------------------------------------------------------- /dc.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/dc.bas -------------------------------------------------------------------------------- /jpg.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/jpg.bas -------------------------------------------------------------------------------- /mexe.rc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/mexe.rc -------------------------------------------------------------------------------- /pic.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/pic.bas -------------------------------------------------------------------------------- /Fcall.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/Fcall.bas -------------------------------------------------------------------------------- /M2000.PDM: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/M2000.PDM -------------------------------------------------------------------------------- /M2000.RES: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/M2000.RES -------------------------------------------------------------------------------- /M2000.TLB: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/M2000.TLB -------------------------------------------------------------------------------- /M2000.exp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/M2000.exp -------------------------------------------------------------------------------- /M2000.lib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/M2000.lib -------------------------------------------------------------------------------- /Math.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/Math.cls -------------------------------------------------------------------------------- /Mutex.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/Mutex.cls -------------------------------------------------------------------------------- /SMALL.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/SMALL.frm -------------------------------------------------------------------------------- /SMALL.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/SMALL.frx -------------------------------------------------------------------------------- /TEST.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/TEST.frm -------------------------------------------------------------------------------- /csGUI.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/csGUI.png -------------------------------------------------------------------------------- /gpp1.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/gpp1.bas -------------------------------------------------------------------------------- /help.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/help.frm -------------------------------------------------------------------------------- /m2000.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/m2000.ico -------------------------------------------------------------------------------- /pipe.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/pipe.bas -------------------------------------------------------------------------------- /tuple.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/tuple.cls -------------------------------------------------------------------------------- /GuiImage.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/GuiImage.cls -------------------------------------------------------------------------------- /GuiM2000.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/GuiM2000.frm -------------------------------------------------------------------------------- /LoadFile.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/LoadFile.frm -------------------------------------------------------------------------------- /MemBlock.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/MemBlock.cls -------------------------------------------------------------------------------- /MetaDc.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/MetaDc.cls -------------------------------------------------------------------------------- /Mk2Base.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/Mk2Base.cls -------------------------------------------------------------------------------- /Mod_Text.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/Mod_Text.bas -------------------------------------------------------------------------------- /Mod_Util.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/Mod_Util.bas -------------------------------------------------------------------------------- /Module10.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/Module10.bas -------------------------------------------------------------------------------- /MyPopUp.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/MyPopUp.frm -------------------------------------------------------------------------------- /RefArray.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/RefArray.cls -------------------------------------------------------------------------------- /ShapeEx.ctx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/ShapeEx.ctx -------------------------------------------------------------------------------- /Socket.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/Socket.cls -------------------------------------------------------------------------------- /TextP0.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/TextP0.frm -------------------------------------------------------------------------------- /TextP0.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/TextP0.frx -------------------------------------------------------------------------------- /ZipTool.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/ZipTool.cls -------------------------------------------------------------------------------- /basetask.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/basetask.cls -------------------------------------------------------------------------------- /cBarCode.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/cBarCode.cls -------------------------------------------------------------------------------- /frmAbout.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/frmAbout.frx -------------------------------------------------------------------------------- /help2000.mdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/help2000.mdb -------------------------------------------------------------------------------- /m2000-2.gsb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/m2000-2.gsb -------------------------------------------------------------------------------- /m2000exe.RES: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/m2000exe.RES -------------------------------------------------------------------------------- /mArray.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/mArray.cls -------------------------------------------------------------------------------- /mForm1.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/mForm1.frx -------------------------------------------------------------------------------- /mStiva.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/mStiva.cls -------------------------------------------------------------------------------- /mdbfile.mdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/mdbfile.mdb -------------------------------------------------------------------------------- /meditor.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/meditor.png -------------------------------------------------------------------------------- /mexe2_2.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/mexe2_2.res -------------------------------------------------------------------------------- /piechart.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/piechart.png -------------------------------------------------------------------------------- /shapes.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/shapes.png -------------------------------------------------------------------------------- /BigInteger.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/BigInteger.cls -------------------------------------------------------------------------------- /CallBack2.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/CallBack2.cls -------------------------------------------------------------------------------- /FontDialog.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/FontDialog.frm -------------------------------------------------------------------------------- /GuiEditBox.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/GuiEditBox.cls -------------------------------------------------------------------------------- /GuiListBox.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/GuiListBox.cls -------------------------------------------------------------------------------- /Idispatch.tlb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/Idispatch.tlb -------------------------------------------------------------------------------- /MyProcess.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/MyProcess.cls -------------------------------------------------------------------------------- /SerialPort.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/SerialPort.cls -------------------------------------------------------------------------------- /ServerMod.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/ServerMod.bas -------------------------------------------------------------------------------- /StringMath.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/StringMath.bas -------------------------------------------------------------------------------- /TextViewer.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/TextViewer.cls -------------------------------------------------------------------------------- /chessmove.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/chessmove.png -------------------------------------------------------------------------------- /clsOSInfo.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/clsOSInfo.cls -------------------------------------------------------------------------------- /linechart.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/linechart.png -------------------------------------------------------------------------------- /newbuttons.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/newbuttons.png -------------------------------------------------------------------------------- /ppppLight.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/ppppLight.cls -------------------------------------------------------------------------------- /spritesnew.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/spritesnew.png -------------------------------------------------------------------------------- /tweakprive.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/tweakprive.frm -------------------------------------------------------------------------------- /ComShinkEvent.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/ComShinkEvent.cls -------------------------------------------------------------------------------- /FontDialog1.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/FontDialog1.frm -------------------------------------------------------------------------------- /HiddenCursor.cur: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/HiddenCursor.cur -------------------------------------------------------------------------------- /IDispatch.tlbold: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/IDispatch.tlbold -------------------------------------------------------------------------------- /PropReference.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/PropReference.cls -------------------------------------------------------------------------------- /cDIBSection.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/cDIBSection.cls -------------------------------------------------------------------------------- /cTlsClient1.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/cTlsClient1.cls -------------------------------------------------------------------------------- /constantclass.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/constantclass.cls -------------------------------------------------------------------------------- /mdlIDispatch.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/mdlIDispatch.bas -------------------------------------------------------------------------------- /BaseCollection.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/BaseCollection.cls -------------------------------------------------------------------------------- /FastCollection.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/FastCollection.cls -------------------------------------------------------------------------------- /XmlMonoInternal.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/XmlMonoInternal.cls -------------------------------------------------------------------------------- /radialprogress.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/radialprogress.png -------------------------------------------------------------------------------- /stdCallFunction.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/stdCallFunction.cls -------------------------------------------------------------------------------- /ComShinkEventNew.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/ComShinkEventNew.cls -------------------------------------------------------------------------------- /FileSelectorDialog.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/FileSelectorDialog.frm -------------------------------------------------------------------------------- /modGDIPlusResize.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/modGDIPlusResize.bas -------------------------------------------------------------------------------- /modObjectExtender.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/modObjectExtender.bas -------------------------------------------------------------------------------- /modTrickUnregCOM.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/M2000Interpreter/Environment/HEAD/modTrickUnregCOM.bas -------------------------------------------------------------------------------- /stack.bat: -------------------------------------------------------------------------------- 1 | Echo off 2 | Cls 3 | Echo Set Stack Size for M2000 - press enter 4 | C:\masm32\bin\editbin /stack:130000000 m2000.exe 5 | -------------------------------------------------------------------------------- /stackdll.bat: -------------------------------------------------------------------------------- 1 | Echo off 2 | Cls 3 | Echo Set Stack Size for M2000 - press enter 4 | C:\masm32\bin\editbin /stack:130000000 m2000.dll 5 | -------------------------------------------------------------------------------- /stackPro.bat: -------------------------------------------------------------------------------- 1 | Echo off 2 | Cls 3 | Echo Set Stack Size for M2000 - press enter 4 | C:\masm32\bin\editbin /stack:130000000 Project2000_1.exe 5 | -------------------------------------------------------------------------------- /Info.bat: -------------------------------------------------------------------------------- 1 | Echo off 2 | cd "C:\Users\moonbase\Documents\m2000v4\" 3 | Cls 4 | Echo Execute stack.bat to set stack size for m2000, ver 8, rev 142+ 5 | 6 | -------------------------------------------------------------------------------- /mexeMakeRes.cmd: -------------------------------------------------------------------------------- 1 | REM Update path to RC.EXE below as necessary. 2 | "C:\Microsoft Visual Studio\VB98\Wizards\RC.EXE" /r /fo mexe.res mexe.rc 3 | Pause 4 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.frm encoding=cp1253 eol=crlf 2 | *.bas encoding=cp1253 eol=crlf 3 | *.cls encoding=cp1253 eol=crlf 4 | *.ctl encoding=cp1253 eol=crlf 5 | *.vbp eol=crlf 6 | *.vbw eol=crlf 7 | 8 | -------------------------------------------------------------------------------- /mexe.vbw: -------------------------------------------------------------------------------- 1 | Module1 = 5, 0, 1008, 492, 2 | frmAbout = 330, 131, 696, 405, , 75, 75, 441, 349, C 3 | Form1 = 200, 201, 798, 652, , 75, 75, 673, 527, C 4 | RunM2000 = 125, 125, 304, 414, Z 5 | Module2 = 156, 156, 767, 475, 6 | cIEFeatures = 0, 0, 810, 435, 7 | -------------------------------------------------------------------------------- /M2000.TXT: -------------------------------------------------------------------------------- 1 | The cab file for your application has been built as 'C:\instal\m2000.CAB'. 2 | 3 | There is also a batch file in the support directory (C:\instal\Support\m2000.BAT) that will allow you to recreate the cab file in case you make changes to some of the files. 4 | -------------------------------------------------------------------------------- /utf8/interpress.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "InterPress" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Public Sub Press(Index As Long) 15 | End Sub -------------------------------------------------------------------------------- /InterPress.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "InterPress" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Public Sub Press(Index As Long) 15 | End Sub 16 | -------------------------------------------------------------------------------- /utf8/comevents.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "ComEvents" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | ' com events 15 | Public Sub id(Index As Long, ParamArray a()) 16 | End Sub -------------------------------------------------------------------------------- /ComEvents.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "ComEvents" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | ' com events 15 | Public Sub id(Index As Long, ParamArray a()) 16 | End Sub 17 | -------------------------------------------------------------------------------- /utf8/copyinout.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "CopyInOut" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Public actualvar As String 15 | Public ArrArg As String 16 | Public localvar As Long -------------------------------------------------------------------------------- /CopyInOut.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "CopyInOut" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Public actualvar As String 15 | Public ArrArg As String 16 | Public localvar As Long 17 | -------------------------------------------------------------------------------- /utf8_converter.gsb: -------------------------------------------------------------------------------- 1 | ΤΜΗΜΑ ΓΕΝΙΚΟ A {Const NoBomUtf8crlf = -2& 2 | Document tmp$ 3 | Dir Appdir$ 4 | Report Dir$ 5 | Try {Subdir UTF8} 6 | Dir UTF8 7 | Dest$ = dir$ 8 | Dir Appdir$ 9 | Files "BAS|CLS|FRM" 10 | Menu 11 | Files + "BAS|CLS|FRM" 12 | If MenuItems>0 then 13 | For i=1 to MenuItems 14 | Clear tmp$ 15 | Load.Doc tmp$, dir$+menu$(i), 1032 16 | Save.Doc tmp$, Dest$+menu$(i)+".utf8.txt", NoBomUtf8crlf 17 | Print Over $(0, 8),@(0), Int(i/MenuItems*100), "%" 18 | Next 19 | End If 20 | Print 21 | Dir User 22 | Report Dir$ 23 | } 24 | -------------------------------------------------------------------------------- /utf8/icontrolindex.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "IControlIndex" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Public Property Get Index() As Long 15 | End Property 16 | 17 | Public Property Let Index(ByVal RHS As Long) 18 | End Property 19 | Public Sub UnloadMe() 20 | End Sub 21 | 22 | -------------------------------------------------------------------------------- /IControlIndex.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "IControlIndex" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Public Property Get Index() As Long 15 | End Property 16 | 17 | Public Property Let Index(ByVal RHS As Long) 18 | End Property 19 | Public Sub UnloadMe() 20 | End Sub 21 | 22 | 23 | -------------------------------------------------------------------------------- /utf8/errorbag.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "ErrorBag" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Public Description As String 15 | Public Number As Long, LastDllNumber As Long 16 | 17 | Friend Sub CopyErr() 18 | Description = Err.Description 19 | Number = Err.Number 20 | LastDllNumber = Err.LastDllError 21 | End Sub 22 | 23 | -------------------------------------------------------------------------------- /ErrorBag.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "ErrorBag" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Public Description As String 15 | Public Number As Long, LastDllNumber As Long 16 | 17 | Friend Sub CopyErr() 18 | Description = Err.Description 19 | Number = Err.Number 20 | LastDllNumber = Err.LastDllError 21 | End Sub 22 | 23 | 24 | -------------------------------------------------------------------------------- /testme.vbp: -------------------------------------------------------------------------------- 1 | Type=Exe 2 | Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\..\Windows\system32\stdole2.tlb#OLE Automation 3 | Reference=*\G{778FACA7-C845-4169-9E9D-A67B895D2D82}#1.0#0#m2000.exe#M2000 4 | Form=testme.frm 5 | IconForm="Form1" 6 | Startup="Form1" 7 | HelpFile="" 8 | Title="testme" 9 | Command32="" 10 | Name="Project1" 11 | HelpContextID="0" 12 | CompatibleMode="0" 13 | MajorVer=1 14 | MinorVer=0 15 | RevisionVer=0 16 | AutoIncrementVer=0 17 | ServerSupportFiles=0 18 | VersionCompanyName="space" 19 | CompilationType=0 20 | OptimizationType=0 21 | FavorPentiumPro(tm)=0 22 | CodeViewDebugInfo=0 23 | NoAliasing=0 24 | BoundsCheck=0 25 | OverflowCheck=0 26 | FlPointCheck=0 27 | FDIVCheck=0 28 | UnroundedFP=0 29 | StartMode=0 30 | Unattended=0 31 | Retained=0 32 | ThreadPerObject=0 33 | MaxNumberOfThreads=1 34 | -------------------------------------------------------------------------------- /utf8/safeforms.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "safeforms" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | ' do something 15 | Public mylist As New LongHash 16 | 17 | Private Sub Class_Terminate() 18 | Dim i As Long, j As Long, start As Long 19 | j = Forms.count 20 | While j > 0 21 | For i = start To Forms.count - 1 22 | If mylist.ExistKey(Forms(i).hWnd) Then 23 | If mylist.Value = "" Then 24 | Forms(i).icon = LoadPicture("") 25 | Unload Forms(i): start = i: Exit For 26 | End If 27 | End If 28 | Next i 29 | j = j - 1 30 | Wend 31 | End Sub -------------------------------------------------------------------------------- /utf8/xmlnode.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "XmlNode" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | ' Node class 15 | Private node, iamobject As Boolean 16 | Friend Sub CreateNodeArray(v) 17 | node = v 18 | iamobject = False 19 | End Sub 20 | 21 | Friend Sub putnode(ByRef v) 22 | If IsObject(v) Then 23 | Set node = v 24 | iamobject = True 25 | Else 26 | node = v 27 | iamobject = False 28 | End If 29 | End Sub 30 | Friend Sub getnode(ByRef v) 31 | If iamobject Then 32 | Set v = node 33 | Else 34 | v = node 35 | End If 36 | End Sub -------------------------------------------------------------------------------- /safeforms.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "safeforms" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | ' do something 15 | Public mylist As New LongHash 16 | 17 | Private Sub Class_Terminate() 18 | Dim i As Long, j As Long, start As Long 19 | j = Forms.count 20 | While j > 0 21 | For i = start To Forms.count - 1 22 | If mylist.ExistKey(Forms(i).hWnd) Then 23 | If mylist.Value = "" Then 24 | Forms(i).icon = LoadPicture("") 25 | Unload Forms(i): start = i: Exit For 26 | End If 27 | End If 28 | Next i 29 | j = j - 1 30 | Wend 31 | End Sub 32 | -------------------------------------------------------------------------------- /XmlNode.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "XmlNode" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | ' Node class 15 | Private node, iamobject As Boolean 16 | Friend Sub CreateNodeArray(v) 17 | node = v 18 | iamobject = False 19 | End Sub 20 | 21 | Friend Sub putnode(ByRef v) 22 | If IsObject(v) Then 23 | Set node = v 24 | iamobject = True 25 | Else 26 | node = v 27 | iamobject = False 28 | End If 29 | End Sub 30 | Friend Sub getnode(ByRef v) 31 | If iamobject Then 32 | Set v = node 33 | Else 34 | v = node 35 | End If 36 | End Sub 37 | -------------------------------------------------------------------------------- /utf8/testme.frm.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form Form1 3 | Caption = "Form1" 4 | ClientHeight = 3030 5 | ClientLeft = 120 6 | ClientTop = 450 7 | ClientWidth = 4560 8 | LinkTopic = "Form1" 9 | ScaleHeight = 3030 10 | ScaleWidth = 4560 11 | StartUpPosition = 3 'Windows Default 12 | Begin VB.CommandButton Command1 13 | Caption = "Command1" 14 | Height = 720 15 | Left = 450 16 | TabIndex = 0 17 | Top = 660 18 | Width = 1800 19 | End 20 | End 21 | Attribute VB_Name = "Form1" 22 | Attribute VB_GlobalNameSpace = False 23 | Attribute VB_Creatable = False 24 | Attribute VB_PredeclaredId = True 25 | Attribute VB_Exposed = False 26 | Private Sub Command1_Click() 27 | Dim m As New M2000.callback 28 | Debug.Print m.Eval("100") 29 | End Sub -------------------------------------------------------------------------------- /testme.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form Form1 3 | Caption = "Form1" 4 | ClientHeight = 3030 5 | ClientLeft = 120 6 | ClientTop = 450 7 | ClientWidth = 4560 8 | LinkTopic = "Form1" 9 | ScaleHeight = 3030 10 | ScaleWidth = 4560 11 | StartUpPosition = 3 'Windows Default 12 | Begin VB.CommandButton Command1 13 | Caption = "Command1" 14 | Height = 720 15 | Left = 450 16 | TabIndex = 0 17 | Top = 660 18 | Width = 1800 19 | End 20 | End 21 | Attribute VB_Name = "Form1" 22 | Attribute VB_GlobalNameSpace = False 23 | Attribute VB_Creatable = False 24 | Attribute VB_PredeclaredId = True 25 | Attribute VB_Exposed = False 26 | Private Sub Command1_Click() 27 | Dim m As New M2000.callback 28 | Debug.Print m.Eval("100") 29 | End Sub 30 | -------------------------------------------------------------------------------- /utf8/mthreadref.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "mThreadref" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Private mReference As TaskInterface 16 | Private mThreadVar As String 17 | Private mThreadID As Long 18 | 19 | Property Let VarName(ByRef RHS As String) 20 | mThreadVar = RHS 21 | End Property 22 | 23 | Property Get VarName() As String 24 | VarName = mThreadVar 25 | End Property 26 | Property Set thread(ByRef RHS As TaskInterface) 27 | Set mReference = RHS 28 | End Property 29 | 30 | Property Get thread() As TaskInterface 31 | Set thread = mReference 32 | End Property 33 | Property Let Id(ByVal RHS As Long) 34 | mThreadID = RHS 35 | End Property 36 | 37 | Property Get Id() As Long 38 | Id = mThreadID 39 | End Property -------------------------------------------------------------------------------- /mThreadref.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "mThreadref" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Private mReference As TaskInterface 16 | Private mThreadVar As String 17 | Private mThreadID As Long 18 | 19 | Property Let VarName(ByRef RHS As String) 20 | mThreadVar = RHS 21 | End Property 22 | 23 | Property Get VarName() As String 24 | VarName = mThreadVar 25 | End Property 26 | Property Set thread(ByRef RHS As TaskInterface) 27 | Set mReference = RHS 28 | End Property 29 | 30 | Property Get thread() As TaskInterface 31 | Set thread = mReference 32 | End Property 33 | Property Let Id(ByVal RHS As Long) 34 | mThreadID = RHS 35 | End Property 36 | 37 | Property Get Id() As Long 38 | Id = mThreadID 39 | End Property 40 | -------------------------------------------------------------------------------- /mexe.vbp: -------------------------------------------------------------------------------- 1 | Type=Exe 2 | Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\..\Windows\SysWOW64\stdole2.tlb#OLE Automation 3 | Module=Module1; mexe.bas 4 | Form=frmAbout.frm 5 | Form=mForm1.frm 6 | Class=RunM2000; Class1.cls 7 | Module=Module2; ActiveX.bas 8 | Class=cIEFeatures; cIEFeatures.cls 9 | ResFile32="m2000exe.RES" 10 | IconForm="frmAbout" 11 | Startup="Sub Main" 12 | HelpFile="" 13 | Title="mexe" 14 | ExeName32="m2000.exe" 15 | Command32="" 16 | Name="m2000exe" 17 | HelpContextID="0" 18 | CompatibleMode="0" 19 | CompatibleEXE32="mexe.exe" 20 | MajorVer=2 21 | MinorVer=5 22 | RevisionVer=0 23 | AutoIncrementVer=0 24 | ServerSupportFiles=0 25 | VersionComments="M2000.dll loader" 26 | VersionCompanyName="space" 27 | CompilationType=0 28 | OptimizationType=0 29 | FavorPentiumPro(tm)=0 30 | CodeViewDebugInfo=0 31 | NoAliasing=0 32 | BoundsCheck=0 33 | OverflowCheck=0 34 | FlPointCheck=0 35 | FDIVCheck=0 36 | UnroundedFP=0 37 | StartMode=0 38 | Unattended=0 39 | Retained=0 40 | ThreadPerObject=0 41 | MaxNumberOfThreads=1 42 | DebugStartupOption=0 43 | 44 | [VBCompiler] 45 | LinkSwitches=/STACK:32180000 46 | -------------------------------------------------------------------------------- /readme.txt: -------------------------------------------------------------------------------- 1 | M2000 Interpreter and Environment 2 | Version 14 revision 6 active-X 3 | 4 | One bug on STACK statement when we pass a variable which hold a string with a stack as a string (for numbers/strings only). Name for variables now works with numbers inside name, so variable a1212$ can be used now. 5 | 6 | 7 | 8 | George Karras, Kallithea Attikis, Greece. 9 | fotodigitallab@gmail.com 10 | 11 | The first time Windows make some work behind the scene so the M200 console slow down. So type END and open it again. 12 | 13 | To get the INFO file, from M2000 console do these: 14 | dir appdir$ 15 | load info 16 | then press F1 to save info.gsb to M2000 user directory 17 | 18 | You can also execute statement SETTINGS to change font/language/colors and size of console letters. 19 | 20 | Read wiki at Github for compiling M2000 from source. 21 | 22 | From version 9.0 revision 50: 23 | there is a new ca.crt - install ca.crt as root certificate (optional) 24 | install ca.crt as root certificate (optional). 25 | 26 | 27 | http://georgekarras.blogspot.gr/ 28 | 29 | https://rosettacode.org/wiki/Category:M2000_Interpreter (544 tasks) 30 | 31 | Code/Exe files can be found here: 32 | 33 | https://github.com/M2000Interpreter -------------------------------------------------------------------------------- /stack.gsb: -------------------------------------------------------------------------------- 1 | ΤΜΗΜΑ B {\\ script for making needed batch files for setting stack for m2000.exe 2 | \\ when we make the final exe 3 | curdir$=dir$ 4 | \\ use editbin from masm32 5 | rem defaultpath$="C:\masm32\bin\" 6 | \\ or use the one from VC98 7 | defaultpath$="C:\Program Files\Microsoft Visual Studio\VC98\Bin\" 8 | if not exist(defaultpath$+"editbin.exe") then { 9 | dir ? "c:", "Need Editbin.exe Folder - no spaces please" 10 | defaultpath$=dir$ 11 | dir curdir$ 12 | if not exist(defaultpath$+"editbin.exe") then break 13 | } 14 | document dd$= {Echo off 15 | Cls 16 | Echo Set Stack Size for M2000 - press enter 17 | } 18 | \\ = is append for document - use clear dd$ to clear it. 19 | dd$ = shortdir$(defaultpath$) + {editbin /stack:102440960 m2000.exe} 20 | dir appdir$ 21 | \\ without "for wide output" we place ascii text 22 | open "stack.bat" for output as i 23 | print #i, dd$ 24 | close #i 25 | clear dd$ 26 | dd$ ={Cls 27 | Echo Execute stack.bat to set stack size for m2000, ver 8, rev 142+ 28 | } 29 | open "Info.bat" for output as i 30 | print #i,"Echo off" 31 | print #i, "cd "+quote$(appdir$) 32 | print #i, dd$ 33 | close #i 34 | dos "cd "+quote$(appdir$) + " && Info.bat" 35 | set end 36 | } 37 | ΤΜΗΜΑ A {function rec { 38 | read bb 39 | if bb<=0 then =0 : exit function 40 | print bb 41 | =rec(bb-1) 42 | 43 | } 44 | 45 | a= rec(14500) 46 | } 47 | -------------------------------------------------------------------------------- /stack.bck: -------------------------------------------------------------------------------- 1 | MODULE A {function rec { 2 | read bb 3 | if bb<=0 then =0 : exit function 4 | print bb 5 | =rec(bb-1) 6 | 7 | } 8 | 9 | a= rec(14500) 10 | } 11 | MODULE B {\\ script for making needed batch files for setting stack for m2000.exe 12 | \\ when we make the final exe 13 | curdir$=dir$ 14 | \\ use editbin from masm32 15 | rem defaultpath$="C:\masm32\bin\" 16 | \\ or use the one from VC98 17 | defaultpath$="C:\Program Files\Microsoft Visual Studio\VC98\Bin\" 18 | if not exist(defaultpath$+"editbin.exe") then { 19 | dir ? "c:", "Need Editbin.exe Folder - no spaces please" 20 | defaultpath$=dir$ 21 | dir curdir$ 22 | if not exist(defaultpath$+"editbin.exe") then break 23 | } 24 | document dd$= {Echo off 25 | Cls 26 | Echo Set Stack Size for M2000 - press enter 27 | } 28 | \\ = is append for document - use clear dd$ to clear it. 29 | dd$ = shortdir$(defaultpath$) + {editbin /stack:102440960 m2000.exe} 30 | dir appdir$ 31 | \\ without "for wide output" we place ascii text 32 | open "stack.bat" for output as i 33 | print #i, dd$ 34 | close #i 35 | clear dd$ 36 | dd$ ={Cls 37 | Echo Execute stack.bat to set stack size for m2000, ver 8, rev 142+ 38 | } 39 | open "Info.bat" for output as i 40 | print #i,"Echo off" 41 | print #i, "cd "+quote$(appdir$) 42 | print #i, dd$ 43 | close #i 44 | dos "cd "+quote$(appdir$) + " && Info.bat" 45 | set end 46 | } 47 | -------------------------------------------------------------------------------- /utf8/indexes.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "mIndexes" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Dim ar() 15 | Public Linkto As mIndexes 16 | Private Sub Class_Initialize() 17 | ReDim ar(0) 18 | End Sub 19 | Friend Sub Dump(n As Long, RHS As Variant) 20 | SwapVariant ar(n), RHS 21 | End Sub 22 | Sub GetArr(that) 23 | that = ar() 24 | Erase ar() 25 | End Sub 26 | Property Get Value(n As Long) As Variant 27 | Attribute Value.VB_UserMemId = 0 28 | If n >= 0 And n < UBound(ar) Then 29 | Value = ar(n) 30 | End If 31 | End Property 32 | Property Let Value(n As Long, RHS As Variant) 33 | If n >= 0 And n < UBound(ar) Then 34 | ar(n) = RHS 35 | ElseIf n >= UBound(ar) Then 36 | ReDim Preserve ar(n + 1) 37 | ar(n) = RHS 38 | End If 39 | End Property 40 | Public Sub IndexOpt(n As Long) 41 | If n >= 0 And n < UBound(ar) Then 42 | OptVariant ar(n) 43 | ElseIf n >= UBound(ar) Then 44 | ReDim Preserve ar(n + 1) 45 | OptVariant ar(n) 46 | End If 47 | End Sub 48 | Property Get count() 49 | count = UBound(ar) 50 | End Property -------------------------------------------------------------------------------- /Indexes.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "mIndexes" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Dim ar() 15 | Public Linkto As mIndexes 16 | Private Sub Class_Initialize() 17 | ReDim ar(0) 18 | End Sub 19 | Friend Sub Dump(n As Long, RHS As Variant) 20 | SwapVariant ar(n), RHS 21 | End Sub 22 | Sub GetArr(that) 23 | that = ar() 24 | Erase ar() 25 | End Sub 26 | Property Get Value(n As Long) As Variant 27 | Attribute Value.VB_UserMemId = 0 28 | If n >= 0 And n < UBound(ar) Then 29 | Value = ar(n) 30 | End If 31 | End Property 32 | Property Let Value(n As Long, RHS As Variant) 33 | If n >= 0 And n < UBound(ar) Then 34 | ar(n) = RHS 35 | ElseIf n >= UBound(ar) Then 36 | ReDim Preserve ar(n + 1) 37 | ar(n) = RHS 38 | End If 39 | End Property 40 | Public Sub IndexOpt(n As Long) 41 | If n >= 0 And n < UBound(ar) Then 42 | OptVariant ar(n) 43 | ElseIf n >= UBound(ar) Then 44 | ReDim Preserve ar(n + 1) 45 | OptVariant ar(n) 46 | End If 47 | End Sub 48 | Property Get count() 49 | count = UBound(ar) 50 | End Property 51 | -------------------------------------------------------------------------------- /m2000.manifest: -------------------------------------------------------------------------------- 1 | 2 | 3 | 9 | M2000 Environment 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | true 23 | true 24 | true 25 | true 26 | false 27 | true 28 | 29 | system 30 | 31 | -------------------------------------------------------------------------------- /utf8/constantclass.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "Constant" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | Dim mValue As Variant 16 | Private mflag As Integer, mSubCall As Integer 17 | Public Property Get Value() As Variant 18 | Attribute Value.VB_UserMemId = 0 19 | If flag Then 20 | Set Value = mValue 21 | Else 22 | Value = mValue 23 | End If 24 | End Property 25 | Public Property Let Value(RHS As Variant) 26 | MyEr "Constant value", "Σταθερή τιμή" 27 | Err.Raise 20 28 | End Property 29 | Public Property Set Value(RHS As Variant) 30 | MyEr "Constant value", "Σταθερή τιμή" 31 | Err.Raise 20 32 | End Property 33 | Public Property Get flag() As Boolean 34 | flag = (mflag And 1) <> 0 35 | End Property 36 | Public Property Get vType() As Boolean 37 | vType = (mflag And 2) <> 0 38 | End Property 39 | Public Property Get SUBPord() As Boolean 40 | SUBPord = mSubCall 41 | End Property 42 | Public Sub DefineOnce(RHS, Optional ByVal vType, Optional fromsubcall As Boolean) 43 | mSubCall = fromsubcall 44 | If myVarType(mValue, vbEmpty) Then 45 | If MyIsObject(RHS) Then 46 | mflag = mflag Or 1 47 | Set mValue = RHS 48 | Else 49 | If Not IsMissing(vType) Then 50 | mflag = mflag Or 2 51 | End If 52 | mValue = RHS 53 | End If 54 | End If 55 | End Sub -------------------------------------------------------------------------------- /utf8/sinkevent.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "SinkEvent" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | Public Event fire() 16 | Public Event GetString(a$) 17 | Public Event GetVariantRef(ByRef a As Variant) 18 | Public Event GetValueRef(a As Variant) 19 | Public Event GetData() 20 | Private resp() 21 | 'Mark as default member via Tools|Procedure Attributes... dialog. 22 | Public Sub FireMe() 23 | Attribute FireMe.VB_UserMemId = 0 24 | RaiseEvent fire 25 | End Sub 26 | Public Sub SendString(a) 27 | 28 | 29 | On Error Resume Next 30 | Dim b$ 31 | If Not myVarType(a, vbString) Then a = vbNullString 32 | SwapString2Variant b$, a 33 | RaiseEvent GetString(b$) 34 | SwapString2Variant b$, a 35 | End Sub 36 | Public Sub SendVariantRef(ByRef a As Variant) 37 | On Error Resume Next 38 | Dim k 39 | ' k = a 40 | RaiseEvent GetVariantRef(a) 41 | ' a = k 42 | End Sub 43 | Public Sub SendValueRef(a) 44 | On Error Resume Next 45 | RaiseEvent GetValueRef(a) 46 | End Sub 47 | Public Sub SendData(ParamArray flds()) 48 | resp() = flds() 49 | RaiseEvent GetData 50 | End Sub 51 | Public Function GetData() As Object 52 | Dim m As New mArray, H As New mHandler 53 | m.LoadTuple resp 54 | H.t1 = 3 55 | Set H.objref = m 56 | Set GetData = H 57 | End Function -------------------------------------------------------------------------------- /utf8/clsprofiler.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "clsProfiler" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Private mark1 As Currency 16 | Private Declare Function QueryPerformanceCounter Lib "kernel32" _ 17 | (lpPerformanceCount As Currency) _ 18 | As Boolean 19 | Private Declare Function QueryPerformanceFrequency Lib "kernel32" _ 20 | (lpPerformanceCount As Currency) _ 21 | As Boolean 22 | Private CountsPerSecond As Currency 23 | 24 | Public Sub MARKONE() 25 | Dim CTR As Currency 26 | QueryPerformanceCounter CTR 27 | mark1 = CTR 28 | End Sub 29 | Public Function MARKTWO() As Double 30 | Dim mark2 As Currency 31 | If QueryPerformanceCounter(mark2) Then 32 | If CountsPerSecond = 0 Then QueryPerformanceFrequency CountsPerSecond 33 | MARKTWO = ((mark2 - mark1) / CountsPerSecond) * 1000 34 | End If 35 | End Function 36 | Public Property Get getAPIOverhead() As Currency 37 | Dim a As Currency, b As Currency, c As Currency 38 | If QueryPerformanceCounter(a) Then 39 | QueryPerformanceCounter b 40 | 41 | If CountsPerSecond = 0 Then QueryPerformanceFrequency CountsPerSecond 42 | c = b - a 43 | If c = 0 Then 44 | getAPIOverhead = 0 45 | Else 46 | 47 | getAPIOverhead = c ' 48 | End If 49 | Else 50 | getAPIOverhead = -1 51 | 52 | End If 53 | End Property 54 | -------------------------------------------------------------------------------- /SinkEvent.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "SinkEvent" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | Public Event fire() 16 | Public Event GetString(a$) 17 | Public Event GetVariantRef(ByRef a As Variant) 18 | Public Event GetValueRef(a As Variant) 19 | Public Event GetData() 20 | Private resp() 21 | 'Mark as default member via Tools|Procedure Attributes... dialog. 22 | Public Sub FireMe() 23 | Attribute FireMe.VB_UserMemId = 0 24 | RaiseEvent fire 25 | End Sub 26 | Public Sub SendString(a) 27 | 28 | 29 | On Error Resume Next 30 | Dim b$ 31 | If Not myVarType(a, vbString) Then a = vbNullString 32 | SwapString2Variant b$, a 33 | RaiseEvent GetString(b$) 34 | SwapString2Variant b$, a 35 | End Sub 36 | Public Sub SendVariantRef(ByRef a As Variant) 37 | On Error Resume Next 38 | Dim k 39 | ' k = a 40 | RaiseEvent GetVariantRef(a) 41 | ' a = k 42 | End Sub 43 | Public Sub SendValueRef(a) 44 | On Error Resume Next 45 | RaiseEvent GetValueRef(a) 46 | End Sub 47 | Public Sub SendData(ParamArray flds()) 48 | resp() = flds() 49 | RaiseEvent GetData 50 | End Sub 51 | Public Function GetData() As Object 52 | Dim m As New mArray, H As New mHandler 53 | m.LoadTuple resp 54 | H.t1 = 3 55 | Set H.objref = m 56 | Set GetData = H 57 | End Function 58 | -------------------------------------------------------------------------------- /clsProfiler.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "clsProfiler" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Private mark1 As Currency 16 | Private Declare Function QueryPerformanceCounter Lib "kernel32" _ 17 | (lpPerformanceCount As Currency) _ 18 | As Boolean 19 | Private Declare Function QueryPerformanceFrequency Lib "kernel32" _ 20 | (lpPerformanceCount As Currency) _ 21 | As Boolean 22 | Private CountsPerSecond As Currency 23 | 24 | Public Sub MARKONE() 25 | Dim CTR As Currency 26 | QueryPerformanceCounter CTR 27 | mark1 = CTR 28 | End Sub 29 | Public Function MARKTWO() As Double 30 | Dim mark2 As Currency 31 | If QueryPerformanceCounter(mark2) Then 32 | If CountsPerSecond = 0 Then QueryPerformanceFrequency CountsPerSecond 33 | MARKTWO = ((mark2 - mark1) / CountsPerSecond) * 1000 34 | End If 35 | End Function 36 | Public Property Get getAPIOverhead() As Currency 37 | Dim a As Currency, b As Currency, c As Currency 38 | If QueryPerformanceCounter(a) Then 39 | QueryPerformanceCounter b 40 | 41 | If CountsPerSecond = 0 Then QueryPerformanceFrequency CountsPerSecond 42 | c = b - a 43 | If c = 0 Then 44 | getAPIOverhead = 0 45 | Else 46 | 47 | getAPIOverhead = c ' 48 | End If 49 | Else 50 | getAPIOverhead = -1 51 | 52 | End If 53 | End Property 54 | 55 | -------------------------------------------------------------------------------- /manifest.manifest: -------------------------------------------------------------------------------- 1 | 2 | 3 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | M2000 Starter 17 | 18 | 19 | true 20 | true 21 | true 22 | true 23 | false 24 | true 25 | 26 | system 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /utf8/itask.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "TaskInterface" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | ' The interface class simply gives names 16 | ' to the required properties, methods, 17 | ' and parameters. 18 | 19 | 20 | ' OBJECTS 21 | 22 | 23 | Public Property Set Owner(ByRef RHS As Object) 24 | End Property 25 | 26 | Public Property Get Owner() As Object 27 | End Property 28 | 29 | 30 | ' SCALARS 31 | 32 | 33 | Public Property Let Done(ByVal Value As Boolean) 34 | End Property 35 | 36 | Public Property Get Done() As Boolean 37 | End Property 38 | 39 | Public Property Let Priority(ByVal Value As PriorityLevel) 40 | End Property 41 | 42 | Public Property Get Priority() As PriorityLevel 43 | End Property 44 | Public Property Let id(ByVal Value As Long) 45 | End Property 46 | Public Property Get id() As Long 47 | End Property 48 | Public Property Let Busy(ByVal Value As Boolean) 49 | End Property 50 | Public Property Get Busy() As Boolean 51 | End Property 52 | Public Property Get Interval() As Currency 53 | End Property 54 | Public Property Let Interval(ByVal Value As Currency) 55 | End Property 56 | Public Property Get CodeData() As String 57 | End Property 58 | ' METHODS 59 | 60 | 61 | 62 | Public Sub Dispose(ByVal Action As DisposeAction) 63 | End Sub 64 | 65 | Public Sub Parameters(ParamArray Values()) 66 | End Sub 67 | Public Property Get Process() As basetask 68 | End Property 69 | Public Property Set Process(Value As basetask) 70 | End Property 71 | Public Function Tick() As Boolean 72 | 73 | End Function 74 | -------------------------------------------------------------------------------- /ITask.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "TaskInterface" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | ' The interface class simply gives names 16 | ' to the required properties, methods, 17 | ' and parameters. 18 | 19 | 20 | ' OBJECTS 21 | 22 | 23 | Public Property Set Owner(ByRef RHS As Object) 24 | End Property 25 | 26 | Public Property Get Owner() As Object 27 | End Property 28 | 29 | 30 | ' SCALARS 31 | 32 | 33 | Public Property Let Done(ByVal Value As Boolean) 34 | End Property 35 | 36 | Public Property Get Done() As Boolean 37 | End Property 38 | 39 | Public Property Let Priority(ByVal Value As PriorityLevel) 40 | End Property 41 | 42 | Public Property Get Priority() As PriorityLevel 43 | End Property 44 | Public Property Let id(ByVal Value As Long) 45 | End Property 46 | Public Property Get id() As Long 47 | End Property 48 | Public Property Let Busy(ByVal Value As Boolean) 49 | End Property 50 | Public Property Get Busy() As Boolean 51 | End Property 52 | Public Property Get Interval() As Currency 53 | End Property 54 | Public Property Let Interval(ByVal Value As Currency) 55 | End Property 56 | Public Property Get CodeData() As String 57 | End Property 58 | ' METHODS 59 | 60 | 61 | 62 | Public Sub Dispose(ByVal Action As DisposeAction) 63 | End Sub 64 | 65 | Public Sub Parameters(ParamArray Values()) 66 | End Sub 67 | Public Property Get Process() As basetask 68 | End Property 69 | Public Property Set Process(Value As basetask) 70 | End Property 71 | Public Function Tick() As Boolean 72 | 73 | End Function 74 | 75 | -------------------------------------------------------------------------------- /utf8/newrnd.bas.utf8.txt: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Module8" 2 | 'Author: Merri of vbforums.com 3 | 'http://www.vbforums.com/showthread.php?t=499661 4 | ' timeGetTime Lib "kernel32.dll" Alias "GetTickCount" 5 | ' Declare Function timeGetTime Lib "winmm.dll" () As Long 6 | Option Explicit 7 | Private Declare Function timeGetTime Lib "kernel32.dll" Alias "GetTickCount" () As Long 8 | Public Type rndvars 9 | lngX As Long 10 | lngY As Long 11 | lngZ As Long 12 | blnInit As Boolean 13 | End Type 14 | Public Sub RandomizeIt(m As rndvars, NeoNumber As Long) 15 | Dim D As Double 16 | If NeoNumber = 0 Then m.blnInit = False 17 | D = RndM(m, NeoNumber) 18 | End Sub 19 | Public Function RndM(m As rndvars, Optional ByVal Number As Long) As Double 20 | ' Static lngX As Long, lngY As Long, lngZ As Long, blnInit As Boolean 21 | With m 22 | Dim dblRnd As Double 23 | ' if initialized and no input number given 24 | If .blnInit And Number = 0 Then 25 | ' lngX, lngY and lngZ will never be 0 26 | .lngX = (171 * .lngX) Mod 30269 27 | .lngY = (172 * .lngY) Mod 30307 28 | .lngZ = (170 * .lngZ) Mod 30323 29 | Else 30 | ' if no initialization, use Timer, otherwise ensure positive Number 31 | If Number = 0 Then Number = timeGetTime And &H7FFFFFFF Else Number = Number And &H7FFFFFFF 32 | .lngX = (Number Mod 30269) 33 | .lngY = (Number Mod 30307) 34 | .lngZ = (Number Mod 30323) 35 | ' lngX, lngY and lngZ must be bigger than 0 36 | If .lngX > 0 Then Else .lngX = 171 37 | If .lngY > 0 Then Else .lngY = 172 38 | If .lngZ > 0 Then Else .lngZ = 170 39 | ' mark initialization state 40 | .blnInit = True 41 | End If 42 | ' generate a random number 43 | dblRnd = CDbl(.lngX) / 30269# + CDbl(.lngY) / 30307# + CDbl(.lngZ) / 30323# 44 | ' return a value between 0 and 1 45 | RndM = dblRnd - Int(dblRnd) 46 | End With 47 | End Function 48 | 49 | -------------------------------------------------------------------------------- /newRND.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Module8" 2 | 'Author: Merri of vbforums.com 3 | 'http://www.vbforums.com/showthread.php?t=499661 4 | ' timeGetTime Lib "kernel32.dll" Alias "GetTickCount" 5 | ' Declare Function timeGetTime Lib "winmm.dll" () As Long 6 | Option Explicit 7 | Private Declare Function timeGetTime Lib "kernel32.dll" Alias "GetTickCount" () As Long 8 | Public Type rndvars 9 | lngX As Long 10 | lngY As Long 11 | lngZ As Long 12 | blnInit As Boolean 13 | End Type 14 | Public Sub RandomizeIt(m As rndvars, NeoNumber As Long) 15 | Dim D As Double 16 | If NeoNumber = 0 Then m.blnInit = False 17 | D = RndM(m, NeoNumber) 18 | End Sub 19 | Public Function RndM(m As rndvars, Optional ByVal Number As Long) As Double 20 | ' Static lngX As Long, lngY As Long, lngZ As Long, blnInit As Boolean 21 | With m 22 | Dim dblRnd As Double 23 | ' if initialized and no input number given 24 | If .blnInit And Number = 0 Then 25 | ' lngX, lngY and lngZ will never be 0 26 | .lngX = (171 * .lngX) Mod 30269 27 | .lngY = (172 * .lngY) Mod 30307 28 | .lngZ = (170 * .lngZ) Mod 30323 29 | Else 30 | ' if no initialization, use Timer, otherwise ensure positive Number 31 | If Number = 0 Then Number = timeGetTime And &H7FFFFFFF Else Number = Number And &H7FFFFFFF 32 | .lngX = (Number Mod 30269) 33 | .lngY = (Number Mod 30307) 34 | .lngZ = (Number Mod 30323) 35 | ' lngX, lngY and lngZ must be bigger than 0 36 | If .lngX > 0 Then Else .lngX = 171 37 | If .lngY > 0 Then Else .lngY = 172 38 | If .lngZ > 0 Then Else .lngZ = 170 39 | ' mark initialization state 40 | .blnInit = True 41 | End If 42 | ' generate a random number 43 | dblRnd = CDbl(.lngX) / 30269# + CDbl(.lngY) / 30307# + CDbl(.lngZ) / 30323# 44 | ' return a value between 0 and 1 45 | RndM = dblRnd - Int(dblRnd) 46 | End With 47 | End Function 48 | 49 | 50 | -------------------------------------------------------------------------------- /utf8/mutex.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "Mutex" 10 | Attribute VB_GlobalNameSpace = True 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Private Mymutexs As New FastCollection 15 | Private Const ERROR_ALREADY_EXISTS = 183& 16 | Private Const MUTEX_ALL_ACCESS = &H1F0001 17 | Public LastError As Long 18 | Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexW" (ByVal lpMutexAttributes As Long, ByVal bInitialOwner As Long, ByVal lpName As Long) As Long 19 | Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hObject As Long) As Long 20 | Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long 21 | 22 | Function create(Name$) As Long 23 | If Mymutexs.ExistKey(Name$) Then exist: Exit Function 24 | Dim myMutex As Variant 25 | myMutex = CVar(CreateMutex(0, 1, StrPtr(Name$))) 26 | LastError = Err.LastDllError 27 | If LastError = 0 Then Mymutexs.AddKey2 Name$, myMutex: Exit Function 28 | If LastError = ERROR_ALREADY_EXISTS Then CloseHandle myMutex 29 | 30 | MyEr "Mutex object exist", "Υπάρχει ήδη το αντικείμενο" 31 | create = LastError 32 | End Function 33 | 34 | Private Sub notexist() 35 | MyEr "named mutex not exist", "το αντικείμενο δεν υπάρχει" 36 | End Sub 37 | 38 | Private Sub exist() 39 | MyEr "named mutex exist", "το αντικείμενο υπάρχει" 40 | End Sub 41 | Sub Destroy(Name$) 42 | If Not Mymutexs.ExistKey(Name$) Then notexist: Exit Sub 43 | ReleaseMutex CLng(Mymutexs.Value) 44 | CloseHandle CLng(Mymutexs.Value) 45 | Mymutexs.Remove Name$ 46 | End Sub 47 | 48 | Private Sub Class_Terminate() 49 | Dim i As Long, myMutex As Long 50 | If Mymutexs.count > 0 Then 51 | For i = 0 To Mymutexs.count - 1 52 | Mymutexs.index = i 53 | ReleaseMutex CLng(Mymutexs.Value) 54 | CloseHandle CLng(Mymutexs.Value) 55 | Next i 56 | End If 57 | End Sub -------------------------------------------------------------------------------- /ca.cer: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIGFzCCA/+gAwIBAgIJAL7th00Xhpt5MA0GCSqGSIb3DQEBBQUAMIGgMQswCQYD 3 | VQQGEwJHUjEPMA0GA1UECAwGQVRIRU5TMQ8wDQYDVQQHDAZBVEhFTlMxFjAUBgNV 4 | BAoMDUdFT1JHRSBLQVJSQVMxFjAUBgNVBAsMDUdFT1JHRSBLQVJSQVMxFjAUBgNV 5 | BAMMDUdFT1JHRSBLQVJSQVMxJzAlBgkqhkiG9w0BCQEWGGZvdG9kaWdpdGFsbGFi 6 | QGdtYWlsLmNvbTAgFw0xOTA4MTExNzAzNTRaGA8yMTE5MDgwNzE3MDM1NFowgaAx 7 | CzAJBgNVBAYTAkdSMQ8wDQYDVQQIDAZBVEhFTlMxDzANBgNVBAcMBkFUSEVOUzEW 8 | MBQGA1UECgwNR0VPUkdFIEtBUlJBUzEWMBQGA1UECwwNR0VPUkdFIEtBUlJBUzEW 9 | MBQGA1UEAwwNR0VPUkdFIEtBUlJBUzEnMCUGCSqGSIb3DQEJARYYZm90b2RpZ2l0 10 | YWxsYWJAZ21haWwuY29tMIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEA 11 | 5Up2PMg2mI06hY3Y+jmsSIrfMO992xn5WSvGofha2z4u/nDnIvpWDmpE5YAPZufw 12 | 8oqxfYvFY984nspK4lRCKIzByPFIXzXYhBAtQkyGl5ZYFliMSdJzfDlv8v3/JwAp 13 | 7bs9oqptqrzYhxnaZDFQkUTUVxXRMpQo9AdFXGquziRUNtcLs/c0XNx8KL4yfdcm 14 | rSBqugPJ5anzwCZd6qP+TlowZ7c0Vq5YxV3vvicnTUtP+WOtn/M7VCxcw73sI3dn 15 | FzR4kaG2czH8h3Y9svDhPr2VVQsXbzS27LO6jLcUbaFopHTk+ubNMyXlxsUPTNQj 16 | Hn/WCtyWwtoFiOKJSkeyHBAs625556dq7XX3OHzzrcR+0P6l/ueIrXpcPX/70M/w 17 | xg33nIimqPVxx+COb+YzWiZcbfOLaTyKheZvl1tAkqHwHd3V4odiqTqf1r49FTpy 18 | q8Ek9vMMbzXvvYWtOmKQqoH/ADALDcCnpzbKrhvWqXBl94jPujbrqKBCkBPCsmAt 19 | tI2XDERJpH7X8e4I8JbTUrAaoztxY0FTjEtcDY9L89JlD52pLF4kBe9jIhyBbPcq 20 | lPL7T50gWdhyteNlqXzN1npU/3gQe13Hcxao1ly8DwOPRCpLYDVre9eW2Oa8WKRO 21 | Jt25QuyrAVQaMIl78b0irqLu7+IPLJneX5JONUaD6l0CAwEAAaNQME4wHQYDVR0O 22 | BBYEFOh9i7Ga/xYdpBYGoZoMoyU9mKaRMB8GA1UdIwQYMBaAFOh9i7Ga/xYdpBYG 23 | oZoMoyU9mKaRMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcNAQEFBQADggIBAAr1fiaU 24 | Q+c37NCyuM/zgToUwiT7TlfbRR9JFb3mdXz6ye0c4LL/yQO+i2hqsr1t9GOaW4ZE 25 | kPdvhA8KqxLHsh9zF2pZ45vdNJ1I1ZNRYApxxjjGiFwqiZvAxi0m6L+UKE3c9I4E 26 | /l4nahEGonk1wKiERC4mX2ounnRmZhsVyyfI+BH5lqHIwvFhz4nkS7ozvFjHoNNS 27 | YUixyMXpSRk/N/LOlNaeMtJdygeRuIK9ZQ7BPaQFM14bbTyXrGsYOAoHebvQOyJJ 28 | 8TOGf1DpdDL1ivKEb9s3HVQxhLf2Peu+qhy5kGSQ165/zuzCd0+rqtPzFlM5LlrU 29 | 1jlvD7YUblRzz5A9XqDGhnF6cgtLEVmI8P7Jd27DD6UvSNpzQ3T3/Si1iCGU0amJ 30 | NxmKA695Br0FhqDUQPKqJd4zJpewqn1cMfqiYB7nIE/9xnY6M6dfbF3XQd2H8rOI 31 | A/4EZI/PtxKryeXfSm1mZVbfjQdeRP3B3Q40niqGQpiNM7BBrGnzxCLjgL//Ee5g 32 | wJT28Dyy6J6pBzr0k/g2UW2KOQ9z1zxlR2kvNbfzsosdoaAHWxrx6Iv+FI4n9mW7 33 | oqw6Ix4TeyyRsrUb6n1zAGtKLR5T1rFxxrJZZUPMHpFP67NNy1pD7MmPr5mgkKEB 34 | YuCu3+OP2NOATowxdeDxr3Xk2+YJq9dZjzvl 35 | -----END CERTIFICATE----- 36 | -------------------------------------------------------------------------------- /ca.crt: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIGFzCCA/+gAwIBAgIJAL7th00Xhpt5MA0GCSqGSIb3DQEBBQUAMIGgMQswCQYD 3 | VQQGEwJHUjEPMA0GA1UECAwGQVRIRU5TMQ8wDQYDVQQHDAZBVEhFTlMxFjAUBgNV 4 | BAoMDUdFT1JHRSBLQVJSQVMxFjAUBgNVBAsMDUdFT1JHRSBLQVJSQVMxFjAUBgNV 5 | BAMMDUdFT1JHRSBLQVJSQVMxJzAlBgkqhkiG9w0BCQEWGGZvdG9kaWdpdGFsbGFi 6 | QGdtYWlsLmNvbTAgFw0xOTA4MTExNzAzNTRaGA8yMTE5MDgwNzE3MDM1NFowgaAx 7 | CzAJBgNVBAYTAkdSMQ8wDQYDVQQIDAZBVEhFTlMxDzANBgNVBAcMBkFUSEVOUzEW 8 | MBQGA1UECgwNR0VPUkdFIEtBUlJBUzEWMBQGA1UECwwNR0VPUkdFIEtBUlJBUzEW 9 | MBQGA1UEAwwNR0VPUkdFIEtBUlJBUzEnMCUGCSqGSIb3DQEJARYYZm90b2RpZ2l0 10 | YWxsYWJAZ21haWwuY29tMIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEA 11 | 5Up2PMg2mI06hY3Y+jmsSIrfMO992xn5WSvGofha2z4u/nDnIvpWDmpE5YAPZufw 12 | 8oqxfYvFY984nspK4lRCKIzByPFIXzXYhBAtQkyGl5ZYFliMSdJzfDlv8v3/JwAp 13 | 7bs9oqptqrzYhxnaZDFQkUTUVxXRMpQo9AdFXGquziRUNtcLs/c0XNx8KL4yfdcm 14 | rSBqugPJ5anzwCZd6qP+TlowZ7c0Vq5YxV3vvicnTUtP+WOtn/M7VCxcw73sI3dn 15 | FzR4kaG2czH8h3Y9svDhPr2VVQsXbzS27LO6jLcUbaFopHTk+ubNMyXlxsUPTNQj 16 | Hn/WCtyWwtoFiOKJSkeyHBAs625556dq7XX3OHzzrcR+0P6l/ueIrXpcPX/70M/w 17 | xg33nIimqPVxx+COb+YzWiZcbfOLaTyKheZvl1tAkqHwHd3V4odiqTqf1r49FTpy 18 | q8Ek9vMMbzXvvYWtOmKQqoH/ADALDcCnpzbKrhvWqXBl94jPujbrqKBCkBPCsmAt 19 | tI2XDERJpH7X8e4I8JbTUrAaoztxY0FTjEtcDY9L89JlD52pLF4kBe9jIhyBbPcq 20 | lPL7T50gWdhyteNlqXzN1npU/3gQe13Hcxao1ly8DwOPRCpLYDVre9eW2Oa8WKRO 21 | Jt25QuyrAVQaMIl78b0irqLu7+IPLJneX5JONUaD6l0CAwEAAaNQME4wHQYDVR0O 22 | BBYEFOh9i7Ga/xYdpBYGoZoMoyU9mKaRMB8GA1UdIwQYMBaAFOh9i7Ga/xYdpBYG 23 | oZoMoyU9mKaRMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcNAQEFBQADggIBAAr1fiaU 24 | Q+c37NCyuM/zgToUwiT7TlfbRR9JFb3mdXz6ye0c4LL/yQO+i2hqsr1t9GOaW4ZE 25 | kPdvhA8KqxLHsh9zF2pZ45vdNJ1I1ZNRYApxxjjGiFwqiZvAxi0m6L+UKE3c9I4E 26 | /l4nahEGonk1wKiERC4mX2ounnRmZhsVyyfI+BH5lqHIwvFhz4nkS7ozvFjHoNNS 27 | YUixyMXpSRk/N/LOlNaeMtJdygeRuIK9ZQ7BPaQFM14bbTyXrGsYOAoHebvQOyJJ 28 | 8TOGf1DpdDL1ivKEb9s3HVQxhLf2Peu+qhy5kGSQ165/zuzCd0+rqtPzFlM5LlrU 29 | 1jlvD7YUblRzz5A9XqDGhnF6cgtLEVmI8P7Jd27DD6UvSNpzQ3T3/Si1iCGU0amJ 30 | NxmKA695Br0FhqDUQPKqJd4zJpewqn1cMfqiYB7nIE/9xnY6M6dfbF3XQd2H8rOI 31 | A/4EZI/PtxKryeXfSm1mZVbfjQdeRP3B3Q40niqGQpiNM7BBrGnzxCLjgL//Ee5g 32 | wJT28Dyy6J6pBzr0k/g2UW2KOQ9z1zxlR2kvNbfzsosdoaAHWxrx6Iv+FI4n9mW7 33 | oqw6Ix4TeyyRsrUb6n1zAGtKLR5T1rFxxrJZZUPMHpFP67NNy1pD7MmPr5mgkKEB 34 | YuCu3+OP2NOATowxdeDxr3Xk2+YJq9dZjzvl 35 | -----END CERTIFICATE----- 36 | -------------------------------------------------------------------------------- /m2000.cer: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIGFzCCA/+gAwIBAgIJAL7th00Xhpt5MA0GCSqGSIb3DQEBBQUAMIGgMQswCQYD 3 | VQQGEwJHUjEPMA0GA1UECAwGQVRIRU5TMQ8wDQYDVQQHDAZBVEhFTlMxFjAUBgNV 4 | BAoMDUdFT1JHRSBLQVJSQVMxFjAUBgNVBAsMDUdFT1JHRSBLQVJSQVMxFjAUBgNV 5 | BAMMDUdFT1JHRSBLQVJSQVMxJzAlBgkqhkiG9w0BCQEWGGZvdG9kaWdpdGFsbGFi 6 | QGdtYWlsLmNvbTAgFw0xOTA4MTExNzAzNTRaGA8yMTE5MDgwNzE3MDM1NFowgaAx 7 | CzAJBgNVBAYTAkdSMQ8wDQYDVQQIDAZBVEhFTlMxDzANBgNVBAcMBkFUSEVOUzEW 8 | MBQGA1UECgwNR0VPUkdFIEtBUlJBUzEWMBQGA1UECwwNR0VPUkdFIEtBUlJBUzEW 9 | MBQGA1UEAwwNR0VPUkdFIEtBUlJBUzEnMCUGCSqGSIb3DQEJARYYZm90b2RpZ2l0 10 | YWxsYWJAZ21haWwuY29tMIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEA 11 | 5Up2PMg2mI06hY3Y+jmsSIrfMO992xn5WSvGofha2z4u/nDnIvpWDmpE5YAPZufw 12 | 8oqxfYvFY984nspK4lRCKIzByPFIXzXYhBAtQkyGl5ZYFliMSdJzfDlv8v3/JwAp 13 | 7bs9oqptqrzYhxnaZDFQkUTUVxXRMpQo9AdFXGquziRUNtcLs/c0XNx8KL4yfdcm 14 | rSBqugPJ5anzwCZd6qP+TlowZ7c0Vq5YxV3vvicnTUtP+WOtn/M7VCxcw73sI3dn 15 | FzR4kaG2czH8h3Y9svDhPr2VVQsXbzS27LO6jLcUbaFopHTk+ubNMyXlxsUPTNQj 16 | Hn/WCtyWwtoFiOKJSkeyHBAs625556dq7XX3OHzzrcR+0P6l/ueIrXpcPX/70M/w 17 | xg33nIimqPVxx+COb+YzWiZcbfOLaTyKheZvl1tAkqHwHd3V4odiqTqf1r49FTpy 18 | q8Ek9vMMbzXvvYWtOmKQqoH/ADALDcCnpzbKrhvWqXBl94jPujbrqKBCkBPCsmAt 19 | tI2XDERJpH7X8e4I8JbTUrAaoztxY0FTjEtcDY9L89JlD52pLF4kBe9jIhyBbPcq 20 | lPL7T50gWdhyteNlqXzN1npU/3gQe13Hcxao1ly8DwOPRCpLYDVre9eW2Oa8WKRO 21 | Jt25QuyrAVQaMIl78b0irqLu7+IPLJneX5JONUaD6l0CAwEAAaNQME4wHQYDVR0O 22 | BBYEFOh9i7Ga/xYdpBYGoZoMoyU9mKaRMB8GA1UdIwQYMBaAFOh9i7Ga/xYdpBYG 23 | oZoMoyU9mKaRMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcNAQEFBQADggIBAAr1fiaU 24 | Q+c37NCyuM/zgToUwiT7TlfbRR9JFb3mdXz6ye0c4LL/yQO+i2hqsr1t9GOaW4ZE 25 | kPdvhA8KqxLHsh9zF2pZ45vdNJ1I1ZNRYApxxjjGiFwqiZvAxi0m6L+UKE3c9I4E 26 | /l4nahEGonk1wKiERC4mX2ounnRmZhsVyyfI+BH5lqHIwvFhz4nkS7ozvFjHoNNS 27 | YUixyMXpSRk/N/LOlNaeMtJdygeRuIK9ZQ7BPaQFM14bbTyXrGsYOAoHebvQOyJJ 28 | 8TOGf1DpdDL1ivKEb9s3HVQxhLf2Peu+qhy5kGSQ165/zuzCd0+rqtPzFlM5LlrU 29 | 1jlvD7YUblRzz5A9XqDGhnF6cgtLEVmI8P7Jd27DD6UvSNpzQ3T3/Si1iCGU0amJ 30 | NxmKA695Br0FhqDUQPKqJd4zJpewqn1cMfqiYB7nIE/9xnY6M6dfbF3XQd2H8rOI 31 | A/4EZI/PtxKryeXfSm1mZVbfjQdeRP3B3Q40niqGQpiNM7BBrGnzxCLjgL//Ee5g 32 | wJT28Dyy6J6pBzr0k/g2UW2KOQ9z1zxlR2kvNbfzsosdoaAHWxrx6Iv+FI4n9mW7 33 | oqw6Ix4TeyyRsrUb6n1zAGtKLR5T1rFxxrJZZUPMHpFP67NNy1pD7MmPr5mgkKEB 34 | YuCu3+OP2NOATowxdeDxr3Xk2+YJq9dZjzvl 35 | -----END CERTIFICATE----- 36 | -------------------------------------------------------------------------------- /m2000dllcompact.iss: -------------------------------------------------------------------------------- 1 | ; Script generated by the Inno Setup Script Wizard. 2 | ; SEE THE DOCUMENTATION FOR DETAILS ON CREATING INNO SETUP SCRIPT FILES! 3 | 4 | #define MyAppName "M2000 Environment" 5 | #define MyAppVersion "10 Revision 36 compact" 6 | #define MyAppPublisher "George Karras" 7 | #define MyAppURL "http://georgekarras.blogspot.gr/" 8 | #define MyAppExeName "m2000.exe" 9 | 10 | [Setup] 11 | ;SignTool=standardtool 12 | SignedUninstaller=yes 13 | ; NOTE: The value of AppId uniquely identifies this application. 14 | ; Do not use the same AppId value in installers for other applications. 15 | ; (To generate a new GUID, click Tools | Generate GUID inside the IDE.) 16 | AppId={{52CEAC5B-6143-4E7D-AD2D-2C933A41AE6C}} 17 | AppName={#MyAppName} 18 | AppVersion={#MyAppVersion} 19 | ;AppVerName={#MyAppName} {#MyAppVersion} 20 | AppPublisher={#MyAppPublisher} 21 | AppPublisherURL={#MyAppURL} 22 | AppSupportURL={#MyAppURL} 23 | AppUpdatesURL={#MyAppURL} 24 | DefaultDirName={pf}\{#MyAppName} 25 | DisableProgramGroupPage=yes 26 | LicenseFile=C:\Users\person\Documents\newm2000v4\readme.txt 27 | OutputBaseFilename=M2000Setup 28 | SetupIconFile=C:\Users\person\Documents\newm2000v4\m2000.ico 29 | Compression=lzma 30 | SolidCompression=yes 31 | 32 | [Languages] 33 | Name: "english"; MessagesFile: "compiler:Default.isl" 34 | 35 | [Tasks] 36 | Name: "desktopicon"; Description: "{cm:CreateDesktopIcon}"; GroupDescription: "{cm:AdditionalIcons}"; Flags: unchecked 37 | 38 | [Files] 39 | Source: "C:\Users\person\Documents\newm2000v4\m2000.exe"; DestDir: "{app}"; Flags: sign 40 | Source: "C:\Users\person\Documents\newm2000v4\M2000.dll"; DestDir: "{app}"; Flags: sign 41 | Source: "C:\Users\person\Documents\newm2000v4\M2000.gsb"; DestDir: "{app}"; Flags: 42 | Source: "C:\Users\person\Documents\newm2000v4\m2000.cer"; DestDir: "{app}"; Flags: 43 | Source: "C:\Users\person\Documents\newm2000v4\help2000utf8.dat"; DestDir: "{app}"; Flags: 44 | Source: "C:\Users\person\Documents\newm2000v4\info.gsb"; DestDir: "{app}"; Flags: 45 | 46 | ; NOTE: Don't use "Flags: ignoreversion" on any shared system files 47 | 48 | [Icons] 49 | Name: "{commonprograms}\{#MyAppName}\M2000"; Filename: "{app}\{#MyAppExeName}" 50 | Name: "{commondesktop}\{#MyAppName}"; Filename: "{app}\{#MyAppExeName}"; Tasks: desktopicon 51 | 52 | [Run] 53 | Filename: "{app}\{#MyAppExeName}"; Description: "{cm:LaunchProgram,{#StringChange(MyAppName, '&', '&&')}}"; Flags: nowait postinstall unchecked skipifsilent 54 | -------------------------------------------------------------------------------- /utf8/checkbox.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "myCheckBox" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | ' From Tools make changed property as default 15 | 16 | Public WithEvents glistN As gList 17 | Attribute glistN.VB_VarHelpID = -1 18 | Dim check1focus As Boolean 19 | Event Changed(state As Boolean) 20 | Dim mCaptext As String 21 | Dim mValue As Boolean 22 | Public Property Set Container(glistNN As gList) 23 | Set glistN = glistNN 24 | glistN.Clear 25 | glistN.additem " " + mCaptext 26 | glistN.NoCaretShow = True 27 | glistN.VerticalCenterText = True 28 | glistN.restrictLines = 1 29 | glistN.MenuItem 1, True, False, mValue 30 | glistN.ListIndex = 0 31 | glistN.LeftMarginPixels = glistN.HeightPixels 32 | glistN.ShowMe 33 | glistN.enabled = True 34 | End Property 35 | Public Property Let Caption(myCap As String) 36 | ' 37 | mCaptext = myCap 38 | If Not glistN Is Nothing Then 39 | glistN.List(0) = " " + mCaptext 40 | glistN.ShowMe 41 | End If 42 | End Property 43 | Public Property Let CheckReset(RHS As Boolean) 44 | ' without event 45 | mValue = RHS 46 | If Not glistN Is Nothing Then 47 | glistN.ListSelected(0) = mValue 48 | glistN.ShowMe 49 | End If 50 | End Property 51 | 52 | 53 | 54 | Private Sub Class_Terminate() 55 | Set glistN = Nothing 56 | End Sub 57 | 58 | Private Sub glistN_CheckGotFocus() 59 | 60 | check1focus = True 61 | End Sub 62 | 63 | Private Sub gListN_ExposeRect(ByVal item As Long, ByVal thisrect As Long, ByVal thisHDC As Long, skip As Boolean) 64 | ' 65 | If check1focus Then 66 | glistN.FillThere thisHDC, thisrect, rgb(100, 200, 160) 67 | Else 68 | glistN.FillThere thisHDC, thisrect, rgb(200, 120, 60) 69 | End If 70 | skip = False 71 | End Sub 72 | 73 | 74 | Private Sub glistN_CheckLostFocus() 75 | check1focus = False 76 | glistN.ShowMe 77 | End Sub 78 | Private Sub glistN_MenuChecked(item As Long) 79 | ' always item is 1 so 1-1..0 (base 0) 80 | RaiseEvent Changed(glistN.ListSelected(0)) 81 | End Sub 82 | Public Property Get checked() As Boolean 83 | Attribute checked.VB_UserMemId = 0 84 | If Not glistN Is Nothing Then 85 | checked = glistN.ListSelected(0) 86 | Else 87 | ' error 88 | End If 89 | End Property 90 | 91 | Sub Shutdown() 92 | glistN.Shutdown 93 | glistN.enabled = False 94 | End Sub 95 | 96 | Private Sub glistN_OnResize() 97 | glistN.LeftMarginPixels = glistN.HeightPixels 98 | End Sub -------------------------------------------------------------------------------- /checkbox.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "myCheckBox" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | ' From Tools make changed property as default 15 | 16 | Public WithEvents glistN As gList 17 | Attribute glistN.VB_VarHelpID = -1 18 | Dim check1focus As Boolean 19 | Event Changed(state As Boolean) 20 | Dim mCaptext As String 21 | Dim mValue As Boolean 22 | Public Property Set Container(glistNN As gList) 23 | Set glistN = glistNN 24 | glistN.Clear 25 | glistN.additem " " + mCaptext 26 | glistN.NoCaretShow = True 27 | glistN.VerticalCenterText = True 28 | glistN.restrictLines = 1 29 | glistN.MenuItem 1, True, False, mValue 30 | glistN.ListIndex = 0 31 | glistN.LeftMarginPixels = glistN.HeightPixels 32 | glistN.ShowMe 33 | glistN.enabled = True 34 | End Property 35 | Public Property Let Caption(myCap As String) 36 | ' 37 | mCaptext = myCap 38 | If Not glistN Is Nothing Then 39 | glistN.List(0) = " " + mCaptext 40 | glistN.ShowMe 41 | End If 42 | End Property 43 | Public Property Let CheckReset(RHS As Boolean) 44 | ' without event 45 | mValue = RHS 46 | If Not glistN Is Nothing Then 47 | glistN.ListSelected(0) = mValue 48 | glistN.ShowMe 49 | End If 50 | End Property 51 | 52 | 53 | 54 | Private Sub Class_Terminate() 55 | Set glistN = Nothing 56 | End Sub 57 | 58 | Private Sub glistN_CheckGotFocus() 59 | 60 | check1focus = True 61 | End Sub 62 | 63 | Private Sub gListN_ExposeRect(ByVal item As Long, ByVal thisrect As Long, ByVal thisHDC As Long, skip As Boolean) 64 | ' 65 | If check1focus Then 66 | glistN.FillThere thisHDC, thisrect, rgb(100, 200, 160) 67 | Else 68 | glistN.FillThere thisHDC, thisrect, rgb(200, 120, 60) 69 | End If 70 | skip = False 71 | End Sub 72 | 73 | 74 | Private Sub glistN_CheckLostFocus() 75 | check1focus = False 76 | glistN.ShowMe 77 | End Sub 78 | Private Sub glistN_MenuChecked(item As Long) 79 | ' always item is 1 so 1-1..0 (base 0) 80 | RaiseEvent Changed(glistN.ListSelected(0)) 81 | End Sub 82 | Public Property Get checked() As Boolean 83 | Attribute checked.VB_UserMemId = 0 84 | If Not glistN Is Nothing Then 85 | checked = glistN.ListSelected(0) 86 | Else 87 | ' error 88 | End If 89 | End Property 90 | 91 | Sub Shutdown() 92 | glistN.Shutdown 93 | glistN.enabled = False 94 | End Sub 95 | 96 | Private Sub glistN_OnResize() 97 | glistN.LeftMarginPixels = glistN.HeightPixels 98 | End Sub 99 | -------------------------------------------------------------------------------- /utf8/class1.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "RunM2000" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Private m As Object, f As Form1 16 | Public Sub doit() 17 | Attribute doit.VB_UserMemId = 0 18 | Dim test 19 | Dim link$ 20 | 21 | If Dir(App.path + "\" + App.ExeName + ".gsb") <> "" Then 22 | link$ = "{dir " + Chr$(34) + App.path + Chr$(34) + " : load " & App.ExeName & "}" 23 | End If 24 | Set f = New Form1 25 | f.Move VirtualScreenWidth() + 2000, VirtualScreenHeight() + 2000 26 | 27 | On Error Resume Next 28 | If Dir(App.path + "\M2000.vbp") <> "" Then 29 | Set m = CreateObject("M2000.callback") 30 | If Not Err Then GoTo 1000 31 | End If 32 | Set m = NewObjectFromActivexDll(App.path + "\m2000.dll", "callback") 33 | If Err Then 34 | Err.Clear 35 | Set m = NewObjectFromActivexDll(App.path + "\lib.bin", "callback") 36 | If Err Then 37 | Err.Clear 38 | Set m = CreateObject("M2000.callback") 39 | End If 40 | End If 41 | If Err Then 42 | MsgBox "Install M2000.dll first", vbCritical 43 | Unload f 44 | Exit Sub 45 | End If 46 | 1000 47 | ' check for old m2000.dll 48 | test = m.WindowState 49 | If Err Then 50 | Debug.Assert (InIDECheck = True) 51 | m.run "start" 52 | m.StackMax -12345 53 | a$ = commandW 54 | If Trim$(a$) = "-h" Or Trim$(a$) = "/?" Then frmAbout.Show 1: ExitNow = True: Exit Sub 55 | If a$ = "" And link$ <> "" Then a$ = link$ 56 | If m.Status = 0 Then 57 | m.Cli a$, ">" 58 | End If 59 | Set m = Nothing 60 | ExitNow = True 61 | Exit Sub 62 | Else 63 | m.getform f 64 | Debug.Assert (InIDECheck = True) 65 | m.run "start" 66 | m.StackMax -12345 67 | a$ = commandW 68 | If Trim$(a$) = "-h" Or Trim$(a$) = "/?" Then frmAbout.Show 1: ExitNow = True: Exit Sub 69 | If a$ = "" And link$ <> "" Then a$ = link$ 70 | If m.Status = 0 Then 71 | Set f.mm = Me 72 | Set f.m = m 73 | Sleep 100 74 | m.AsyncCli a$, ">" 75 | Debug.Print "ok" 76 | Else 77 | Set m = Nothing 78 | ShutDownAll 79 | End If 80 | End If 81 | End Sub 82 | 83 | Private Sub Class_Initialize() 84 | Set f = Nothing 85 | 'If m Is Nothing Then Exit Sub 86 | 'm.ShowGui = False: m.ShutDown: Set m = Nothing 87 | 88 | End Sub 89 | 90 | Private Sub Class_Terminate() 91 | If m Is Nothing Then Exit Sub 92 | On Error Resume Next 93 | m.ShowGui = False: m.ShutDown 2: Set m = Nothing 94 | 95 | Debug.Print "exit now", m Is Nothing 96 | Set m = Nothing 97 | End Sub -------------------------------------------------------------------------------- /Class1.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "RunM2000" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Private m As Object, f As Form1 16 | Public Sub doit() 17 | Attribute doit.VB_UserMemId = 0 18 | Dim test 19 | Dim link$ 20 | 21 | If Dir(App.path + "\" + App.ExeName + ".gsb") <> "" Then 22 | link$ = "{dir " + Chr$(34) + App.path + Chr$(34) + " : load " & App.ExeName & "}" 23 | End If 24 | Set f = New Form1 25 | f.Move VirtualScreenWidth() + 2000, VirtualScreenHeight() + 2000 26 | 27 | On Error Resume Next 28 | If Dir(App.path + "\M2000.vbp") <> "" Then 29 | Set m = CreateObject("M2000.callback") 30 | If Not Err Then GoTo 1000 31 | End If 32 | Set m = NewObjectFromActivexDll(App.path + "\m2000.dll", "callback") 33 | If Err Then 34 | Err.Clear 35 | Set m = NewObjectFromActivexDll(App.path + "\lib.bin", "callback") 36 | If Err Then 37 | Err.Clear 38 | Set m = CreateObject("M2000.callback") 39 | End If 40 | End If 41 | If Err Then 42 | MsgBox "Install M2000.dll first", vbCritical 43 | Unload f 44 | Exit Sub 45 | End If 46 | 1000 47 | ' check for old m2000.dll 48 | test = m.WindowState 49 | If Err Then 50 | Debug.Assert (InIDECheck = True) 51 | m.run "start" 52 | m.StackMax -12345 53 | a$ = commandW 54 | If Trim$(a$) = "-h" Or Trim$(a$) = "/?" Then frmAbout.Show 1: ExitNow = True: Exit Sub 55 | If a$ = "" And link$ <> "" Then a$ = link$ 56 | If m.Status = 0 Then 57 | m.Cli a$, ">" 58 | End If 59 | Set m = Nothing 60 | ExitNow = True 61 | Exit Sub 62 | Else 63 | m.getform f 64 | Debug.Assert (InIDECheck = True) 65 | m.run "start" 66 | m.StackMax -12345 67 | a$ = commandW 68 | If Trim$(a$) = "-h" Or Trim$(a$) = "/?" Then frmAbout.Show 1: ExitNow = True: Exit Sub 69 | If a$ = "" And link$ <> "" Then a$ = link$ 70 | If m.Status = 0 Then 71 | Set f.mm = Me 72 | Set f.m = m 73 | Sleep 100 74 | m.AsyncCli a$, ">" 75 | Debug.Print "ok" 76 | Else 77 | Set m = Nothing 78 | ShutDownAll 79 | End If 80 | End If 81 | End Sub 82 | 83 | Private Sub Class_Initialize() 84 | Set f = Nothing 85 | 'If m Is Nothing Then Exit Sub 86 | 'm.ShowGui = False: m.ShutDown: Set m = Nothing 87 | 88 | End Sub 89 | 90 | Private Sub Class_Terminate() 91 | If m Is Nothing Then Exit Sub 92 | On Error Resume Next 93 | m.ShowGui = False: m.ShutDown 2: Set m = Nothing 94 | 95 | Debug.Print "exit now", m Is Nothing 96 | Set m = Nothing 97 | End Sub 98 | -------------------------------------------------------------------------------- /utf8/isprinter.bas.utf8.txt: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "AnyPrinter" 2 | ' module isprinter there! 3 | ' Get information about all of the local printers using structure 1. Note how 4 | ' the elements of the array are loaded into an array of data structures manually. Also 5 | ' note how the following special declares must be used to allow numeric string pointers 6 | ' to be used in place of strings: 7 | Private Declare Function EnumPrinters Lib "winspool.drv" Alias "EnumPrintersW" (ByVal flags As Long, ByVal name As Long, ByVal Level As Long, pPrinterEnum As Long, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long 8 | Const PRINTER_ENUM_LOCAL = &H2 9 | Private Type PRINTER_INFO_1 10 | flags As Long 11 | pDescription As String 12 | pname As String 13 | pComment As String 14 | End Type 15 | Private Const BIF_RETURNONLYFSDIRS As Long = &H1 16 | Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 17 | Private Const BIF_RETURNFSANCESTORS As Long = &H8 18 | Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 19 | Private Const BIF_BROWSEFORPRINTER As Long = &H2000 20 | Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 21 | Private Const MAX_PATH As Long = 260 22 | Type BrowseInfo 23 | hOwner As Long 24 | pIDLRoot As Long 25 | pszDisplayName As String 26 | lpszINSTRUCTIONS As String 27 | ulFlags As Long 28 | lpfn As Long 29 | lParam As Long 30 | iImage As Long 31 | End Type 32 | 33 | 34 | Function IsPrinter() As Boolean 35 | 'KPD-Team 1999 36 | 'URL: http://www.allapi.net/ 37 | 'E-Mail: KPDTeam@Allapi.net 38 | 39 | Dim longbuffer() As Long ' resizable array receives information from the function 40 | Dim printinfo() As PRINTER_INFO_1 ' values inside longbuffer() will be put into here 41 | Dim numbytes As Long ' size in bytes of longbuffer() 42 | Dim numneeded As Long ' receives number of bytes necessary if longbuffer() is too small 43 | Dim numprinters As Long ' receives number of printers found 44 | Dim c As Integer, retval As Long ' counter variable & return value 45 | ' Get information about the local printers 46 | n$ = String$(8192 / 2, Chr(0)) 47 | numbytes = 8192 ' should be sufficiently big, but it may not be 48 | ReDim longbuffer(0 To numbytes / 4) As Long ' resize array -- note how 1 Long = 4 bytes 49 | retval = EnumPrinters(PRINTER_ENUM_LOCAL, StrPtr(n$), 1, longbuffer(0), numbytes, numneeded, numprinters) 50 | If retval = 0 Then ' try enlarging longbuffer() to receive all necessary information 51 | numbytes = numneeded 52 | ReDim longbuffer(0 To numbytes / 4) As Long ' make it large enough 53 | retval = EnumPrinters(PRINTER_ENUM_LOCAL, StrPtr(n$), 1, longbuffer(0), numbytes, numneeded, numprinters) 54 | If retval = 0 Then ' failed again! 55 | GoTo there1 56 | Exit Function 57 | End If 58 | End If 59 | 60 | there1: 61 | On Error GoTo there 62 | If Printers.count > 0 Then 63 | IsPrinter = True 64 | Else 65 | there: 66 | Err.Clear 67 | IsPrinter = numprinters <> 0 68 | End If 69 | 70 | End Function 71 | -------------------------------------------------------------------------------- /IsPrinter.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "AnyPrinter" 2 | ' module isprinter there! 3 | ' Get information about all of the local printers using structure 1. Note how 4 | ' the elements of the array are loaded into an array of data structures manually. Also 5 | ' note how the following special declares must be used to allow numeric string pointers 6 | ' to be used in place of strings: 7 | Private Declare Function EnumPrinters Lib "winspool.drv" Alias "EnumPrintersW" (ByVal flags As Long, ByVal name As Long, ByVal Level As Long, pPrinterEnum As Long, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long 8 | Const PRINTER_ENUM_LOCAL = &H2 9 | Private Type PRINTER_INFO_1 10 | flags As Long 11 | pDescription As String 12 | pname As String 13 | pComment As String 14 | End Type 15 | Private Const BIF_RETURNONLYFSDIRS As Long = &H1 16 | Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 17 | Private Const BIF_RETURNFSANCESTORS As Long = &H8 18 | Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 19 | Private Const BIF_BROWSEFORPRINTER As Long = &H2000 20 | Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 21 | Private Const MAX_PATH As Long = 260 22 | Type BrowseInfo 23 | hOwner As Long 24 | pIDLRoot As Long 25 | pszDisplayName As String 26 | lpszINSTRUCTIONS As String 27 | ulFlags As Long 28 | lpfn As Long 29 | lParam As Long 30 | iImage As Long 31 | End Type 32 | 33 | 34 | Function IsPrinter() As Boolean 35 | 'KPD-Team 1999 36 | 'URL: http://www.allapi.net/ 37 | 'E-Mail: KPDTeam@Allapi.net 38 | 39 | Dim longbuffer() As Long ' resizable array receives information from the function 40 | Dim printinfo() As PRINTER_INFO_1 ' values inside longbuffer() will be put into here 41 | Dim numbytes As Long ' size in bytes of longbuffer() 42 | Dim numneeded As Long ' receives number of bytes necessary if longbuffer() is too small 43 | Dim numprinters As Long ' receives number of printers found 44 | Dim c As Integer, retval As Long ' counter variable & return value 45 | ' Get information about the local printers 46 | n$ = String$(8192 / 2, Chr(0)) 47 | numbytes = 8192 ' should be sufficiently big, but it may not be 48 | ReDim longbuffer(0 To numbytes / 4) As Long ' resize array -- note how 1 Long = 4 bytes 49 | retval = EnumPrinters(PRINTER_ENUM_LOCAL, StrPtr(n$), 1, longbuffer(0), numbytes, numneeded, numprinters) 50 | If retval = 0 Then ' try enlarging longbuffer() to receive all necessary information 51 | numbytes = numneeded 52 | ReDim longbuffer(0 To numbytes / 4) As Long ' make it large enough 53 | retval = EnumPrinters(PRINTER_ENUM_LOCAL, StrPtr(n$), 1, longbuffer(0), numbytes, numneeded, numprinters) 54 | If retval = 0 Then ' failed again! 55 | GoTo there1 56 | Exit Function 57 | End If 58 | End If 59 | 60 | there1: 61 | On Error GoTo there 62 | If Printers.count > 0 Then 63 | IsPrinter = True 64 | Else 65 | there: 66 | Err.Clear 67 | IsPrinter = numprinters <> 0 68 | End If 69 | 70 | End Function 71 | 72 | -------------------------------------------------------------------------------- /utf8/extcontrol.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "ExtControl" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Public WithEvents mycontrol As VBControlExtender 15 | Attribute mycontrol.VB_VarHelpID = -1 16 | Dim another As Object 17 | Dim myname$, mytypedef$ 18 | Dim Callback As GuiM2000 19 | Dim mIndex As Long 20 | Friend Property Get GetCallBack() As GuiM2000 21 | Set GetCallBack = Callback 22 | End Property 23 | Public Property Get Index() As Long 24 | Index = mIndex 25 | End Property 26 | Friend Property Let Index(ByVal RHS As Long) 27 | mIndex = RHS 28 | End Property 29 | Friend Property Get ControlName() As String 30 | ControlName = myname 31 | End Property 32 | Friend Property Get TypeDef() As String 33 | TypeDef = mytypedef$ 34 | End Property 35 | Friend Sub Attach(b As Control, aName$, typ$, mform As GuiM2000, Optional indx As Long = -1) 36 | Err.Clear 37 | On Error Resume Next 38 | Set mycontrol = b 39 | If Err.Number Then 40 | Err.Clear 41 | Set another = b 42 | End If 43 | mIndex = indx 44 | Set Callback = mform 45 | myname$ = aName$ 46 | End Sub 47 | Property Get FixEvent() As Boolean 48 | FixEvent = mycontrol Is Nothing 49 | End Property 50 | Property Get Value() As Object 51 | Attribute Value.VB_UserMemId = 0 52 | On Error Resume Next 53 | If Not another Is Nothing Then 54 | Set Value = another 55 | Else 56 | Set Value = mycontrol 57 | End If 58 | End Property 59 | Public Sub deconstruct() 60 | Set Callback = Nothing 61 | Set mycontrol = Nothing 62 | Set another = Nothing 63 | End Sub 64 | 65 | Private Sub mycontrol_ObjectEvent(Info As EventInfo) 66 | Dim Values(), m As Long, uk1 As Object 67 | If Info.EventParameters.Count > 0 Then 68 | ReDim Values(0 To Info.EventParameters.Count) 69 | Dim evinf As EventParameter 70 | m = 0 71 | Dim aa 72 | For Each evinf In Info.EventParameters 73 | Err.Clear 74 | On Error Resume Next 75 | aa = CVar(evinf.Value) 76 | If MyIsObject(aa) Then 77 | Set Values(m) = evinf.Value 78 | Else 79 | Values(m) = evinf.Value 80 | End If 81 | If Err Then 82 | Err.Clear 83 | Values(m) = "Error" 84 | End If 85 | 86 | m = m + 1 87 | Next evinf 88 | If mIndex <> -1 Then 89 | Callback.CallbackNow myname$ + "." + Info.Name + "(" & mIndex & ")", Values() 90 | Else 91 | Callback.CallbackNow myname$ + "." + Info.Name + "()", Values() 92 | End If 93 | With Info.EventParameters 94 | For m = m - 1 To 0 95 | If IsObject(Values(m)) Then 96 | Set .item(m).Value = Values(m) 97 | Err.Clear 98 | Else 99 | .item(m).Value = Values(m) 100 | End If 101 | Next m 102 | End With 103 | ElseIf mIndex <> -1 Then 104 | Callback.Callback myname$ + "." + Info.Name + "(" & mIndex & ")" 105 | Else 106 | Callback.Callback myname$ + "." + Info.Name + "()" 107 | End If 108 | End Sub -------------------------------------------------------------------------------- /ExtControl.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "ExtControl" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Public WithEvents mycontrol As VBControlExtender 15 | Attribute mycontrol.VB_VarHelpID = -1 16 | Dim another As Object 17 | Dim myname$, mytypedef$ 18 | Dim Callback As GuiM2000 19 | Dim mIndex As Long 20 | Friend Property Get GetCallBack() As GuiM2000 21 | Set GetCallBack = Callback 22 | End Property 23 | Public Property Get Index() As Long 24 | Index = mIndex 25 | End Property 26 | Friend Property Let Index(ByVal RHS As Long) 27 | mIndex = RHS 28 | End Property 29 | Friend Property Get ControlName() As String 30 | ControlName = myname 31 | End Property 32 | Friend Property Get TypeDef() As String 33 | TypeDef = mytypedef$ 34 | End Property 35 | Friend Sub Attach(b As Control, aName$, typ$, mform As GuiM2000, Optional indx As Long = -1) 36 | Err.Clear 37 | On Error Resume Next 38 | Set mycontrol = b 39 | If Err.Number Then 40 | Err.Clear 41 | Set another = b 42 | End If 43 | mIndex = indx 44 | Set Callback = mform 45 | myname$ = aName$ 46 | End Sub 47 | Property Get FixEvent() As Boolean 48 | FixEvent = mycontrol Is Nothing 49 | End Property 50 | Property Get Value() As Object 51 | Attribute Value.VB_UserMemId = 0 52 | On Error Resume Next 53 | If Not another Is Nothing Then 54 | Set Value = another 55 | Else 56 | Set Value = mycontrol 57 | End If 58 | End Property 59 | Public Sub deconstruct() 60 | Set Callback = Nothing 61 | Set mycontrol = Nothing 62 | Set another = Nothing 63 | End Sub 64 | 65 | Private Sub mycontrol_ObjectEvent(Info As EventInfo) 66 | Dim Values(), m As Long, uk1 As Object 67 | If Info.EventParameters.Count > 0 Then 68 | ReDim Values(0 To Info.EventParameters.Count) 69 | Dim evinf As EventParameter 70 | m = 0 71 | Dim aa 72 | For Each evinf In Info.EventParameters 73 | Err.Clear 74 | On Error Resume Next 75 | aa = CVar(evinf.Value) 76 | If MyIsObject(aa) Then 77 | Set Values(m) = evinf.Value 78 | Else 79 | Values(m) = evinf.Value 80 | End If 81 | If Err Then 82 | Err.Clear 83 | Values(m) = "Error" 84 | End If 85 | 86 | m = m + 1 87 | Next evinf 88 | If mIndex <> -1 Then 89 | Callback.CallbackNow myname$ + "." + Info.Name + "(" & mIndex & ")", Values() 90 | Else 91 | Callback.CallbackNow myname$ + "." + Info.Name + "()", Values() 92 | End If 93 | With Info.EventParameters 94 | For m = m - 1 To 0 95 | If IsObject(Values(m)) Then 96 | Set .item(m).Value = Values(m) 97 | Err.Clear 98 | Else 99 | .item(m).Value = Values(m) 100 | End If 101 | Next m 102 | End With 103 | ElseIf mIndex <> -1 Then 104 | Callback.Callback myname$ + "." + Info.Name + "(" & mIndex & ")" 105 | Else 106 | Callback.Callback myname$ + "." + Info.Name + "()" 107 | End If 108 | End Sub 109 | -------------------------------------------------------------------------------- /utf8/taskbase.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "TaskBase" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements TaskInterface 16 | ' Task Base provides common implementation for 17 | ' the TaskInterface interface. 18 | 19 | Private myOwner As Object 20 | Private myPriority As PriorityLevel 21 | Private myDone As Boolean 22 | Private myid As Long 23 | Private mybusy As Boolean 24 | Private myInterval As Currency 25 | Private myProcess As basetask 26 | 27 | Private Sub Class_Initialize() 28 | myid = -1 29 | End Sub 30 | 31 | 32 | Private Property Get TaskInterface_CodeData() As String 33 | 34 | End Property 35 | 36 | Private Property Get TaskInterface_Process() As basetask 37 | Set TaskInterface_Process = myProcess 38 | End Property 39 | 40 | Public Property Set TaskInterface_Process(Value As basetask) 41 | Set myProcess = Value 42 | 43 | End Property 44 | 45 | 46 | 47 | Private Property Let TaskInterface_busy(ByVal RHS As Boolean) 48 | mybusy = RHS 49 | End Property 50 | 51 | Private Property Get TaskInterface_busy() As Boolean 52 | TaskInterface_busy = mybusy 53 | End Property 54 | 55 | 56 | ' IMPLEMENTED PROPERTIES 57 | 58 | 59 | 60 | 61 | Private Property Let TaskInterface_Done(ByVal RHS As Boolean) 62 | myDone = RHS 63 | End Property 64 | 65 | 66 | Private Property Get TaskInterface_Done() As Boolean 67 | TaskInterface_Done = myDone 68 | End Property 69 | 70 | 71 | Private Property Let TaskInterface_ID(ByVal RHS As Long) 72 | myid = RHS 73 | End Property 74 | 75 | Private Property Get TaskInterface_ID() As Long 76 | TaskInterface_ID = myid 77 | End Property 78 | 79 | Private Property Let TaskInterface_interval(ByVal RHS As Currency) 80 | myInterval = RHS 81 | End Property 82 | 83 | Private Property Get TaskInterface_interval() As Currency 84 | TaskInterface_interval = myInterval 85 | End Property 86 | 87 | 88 | 89 | Private Property Get TaskInterface_Owner() As Object 90 | Set TaskInterface_Owner = myOwner 91 | End Property 92 | 93 | 94 | Private Property Set TaskInterface_Owner(RHS As Object) 95 | Set myOwner = RHS 96 | End Property 97 | 98 | 99 | Public Property Let TaskInterface_Priority(ByVal Value As PriorityLevel) 100 | myPriority = Value 101 | End Property 102 | 103 | 104 | Public Property Get TaskInterface_Priority() As PriorityLevel 105 | TaskInterface_Priority = myPriority 106 | End Property 107 | 108 | 109 | ' IMPLEMENTED METHODS 110 | 111 | Private Sub TaskInterface_Dispose(ByVal Action As DisposeAction) 112 | ' Releasing references, and chain if requested 113 | Set myOwner = Nothing 114 | '' 115 | '' 116 | 117 | End Sub 118 | 119 | 120 | 121 | 122 | 123 | 124 | ' NOT IMPLEMENTED - Required for interface 125 | 126 | Private Sub TaskInterface_Parameters(ParamArray Values() As Variant) 127 | myDone = True 128 | End Sub 129 | 130 | 131 | Private Function TaskInterface_Tick() As Boolean 132 | TaskInterface_Tick = True 133 | myDone = True 134 | End Function 135 | 136 | -------------------------------------------------------------------------------- /utf8/mybutton.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "myButton" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Dim WithEvents glistN As gList 16 | Attribute glistN.VB_VarHelpID = -1 17 | Dim mCaptext As String 18 | Dim mIndex As Long 19 | Private mCallback As InterPress 20 | 21 | Public Property Set Container(glistNN As gList) 22 | Set glistN = glistNN 23 | With glistN 24 | .NoCaretShow = True 25 | .NoPanRight = False 26 | .restrictLines = 1 27 | .CenterText = True 28 | .VerticalCenterText = True 29 | .Text = mCaptext 30 | .backcolor = rgb(200, 120, 60) 31 | '.bypassfirstClick = True 32 | ''.FontSize = 12 33 | .enabled = True 34 | .ShowMe 35 | '.PrepareClick 36 | End With 37 | End Property 38 | 39 | Private Sub Class_Initialize() 40 | mCaptext = "Button" 41 | End Sub 42 | 43 | Private Sub Class_Terminate() 44 | Set glistN = Nothing 45 | Set mCallback = Nothing 46 | End Sub 47 | 48 | Private Sub glistN_CheckGotFocus() 49 | glistN.backcolor = rgb(100, 200, 160) 50 | glistN.ShowMe 51 | glistN.PrepareClick 52 | End Sub 53 | 54 | Private Sub glistN_CheckLostFocus() 55 | If Me.enabled Then 56 | glistN.backcolor = rgb(200, 120, 60) 57 | glistN.PanPos = 0 58 | glistN.ShowMe 59 | glistN.DblClick 60 | End If 61 | End Sub 62 | 63 | Private Sub glistN_MouseMove(Button As Integer, shift As Integer, x As Single, y As Single) 64 | If Button <> 0 Then glistN.PrepareClick 65 | End Sub 66 | 67 | Private Sub glistN_PanLeftRight(direction As Boolean) 68 | If (Not mCallback Is Nothing) Then mCallback.Press Index 69 | End Sub 70 | 71 | Private Sub glistN_RegisterGlist(this As gList) 72 | this.NoWheel = True 73 | End Sub 74 | Private Sub glistN_Selected(item As Long) 75 | 'If item >= 0 Then 76 | ' If (Not mCallback Is Nothing) Then mCallback.Press Index 77 | ' End If 78 | End Sub 79 | Private Sub glistN_Selected2(item As Long) 80 | 'If item >= 0 Then 81 | If (Not mCallback Is Nothing) Then mCallback.Press Index 82 | ' End If 83 | End Sub 84 | Property Set Callback(ByRef newObj As InterPress) 85 | Set mCallback = newObj 86 | End Property 87 | 88 | Property Get Callback() As InterPress 89 | Set Callback = mCallback 90 | End Property 91 | Public Property Let Caption(myCap As String) 92 | ' 93 | mCaptext = myCap 94 | If Not glistN Is Nothing Then 95 | If glistN.CenterText Then 96 | glistN.list(0) = mCaptext 97 | Else 98 | glistN.list(0) = " " + mCaptext 99 | End If 100 | glistN.ShowMe 101 | End If 102 | End Property 103 | Public Property Get Caption() As String 104 | Caption = mCaptext 105 | End Property 106 | 107 | Public Property Get Index() As Long 108 | Index = mIndex 109 | End Property 110 | 111 | Public Property Let Index(ByVal RHS As Long) 112 | mIndex = RHS 113 | End Property 114 | Public Property Get enabled() As Long 115 | enabled = glistN.enabled 116 | End Property 117 | 118 | Public Property Let enabled(ByVal RHS As Long) 119 | glistN.enabled = RHS 120 | End Property 121 | 122 | Public Sub Shutdown() 123 | glistN.Shutdown 124 | glistN.enabled = False 125 | 126 | End Sub -------------------------------------------------------------------------------- /TaskBase.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "TaskBase" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements TaskInterface 16 | ' Task Base provides common implementation for 17 | ' the TaskInterface interface. 18 | 19 | Private myOwner As Object 20 | Private myPriority As PriorityLevel 21 | Private myDone As Boolean 22 | Private myid As Long 23 | Private mybusy As Boolean 24 | Private myInterval As Currency 25 | Private myProcess As basetask 26 | 27 | Private Sub Class_Initialize() 28 | myid = -1 29 | End Sub 30 | 31 | 32 | Private Property Get TaskInterface_CodeData() As String 33 | 34 | End Property 35 | 36 | Private Property Get TaskInterface_Process() As basetask 37 | Set TaskInterface_Process = myProcess 38 | End Property 39 | 40 | Public Property Set TaskInterface_Process(Value As basetask) 41 | Set myProcess = Value 42 | 43 | End Property 44 | 45 | 46 | 47 | Private Property Let TaskInterface_busy(ByVal RHS As Boolean) 48 | mybusy = RHS 49 | End Property 50 | 51 | Private Property Get TaskInterface_busy() As Boolean 52 | TaskInterface_busy = mybusy 53 | End Property 54 | 55 | 56 | ' IMPLEMENTED PROPERTIES 57 | 58 | 59 | 60 | 61 | Private Property Let TaskInterface_Done(ByVal RHS As Boolean) 62 | myDone = RHS 63 | End Property 64 | 65 | 66 | Private Property Get TaskInterface_Done() As Boolean 67 | TaskInterface_Done = myDone 68 | End Property 69 | 70 | 71 | Private Property Let TaskInterface_ID(ByVal RHS As Long) 72 | myid = RHS 73 | End Property 74 | 75 | Private Property Get TaskInterface_ID() As Long 76 | TaskInterface_ID = myid 77 | End Property 78 | 79 | Private Property Let TaskInterface_interval(ByVal RHS As Currency) 80 | myInterval = RHS 81 | End Property 82 | 83 | Private Property Get TaskInterface_interval() As Currency 84 | TaskInterface_interval = myInterval 85 | End Property 86 | 87 | 88 | 89 | Private Property Get TaskInterface_Owner() As Object 90 | Set TaskInterface_Owner = myOwner 91 | End Property 92 | 93 | 94 | Private Property Set TaskInterface_Owner(RHS As Object) 95 | Set myOwner = RHS 96 | End Property 97 | 98 | 99 | Public Property Let TaskInterface_Priority(ByVal Value As PriorityLevel) 100 | myPriority = Value 101 | End Property 102 | 103 | 104 | Public Property Get TaskInterface_Priority() As PriorityLevel 105 | TaskInterface_Priority = myPriority 106 | End Property 107 | 108 | 109 | ' IMPLEMENTED METHODS 110 | 111 | Private Sub TaskInterface_Dispose(ByVal Action As DisposeAction) 112 | ' Releasing references, and chain if requested 113 | Set myOwner = Nothing 114 | '' 115 | '' 116 | 117 | End Sub 118 | 119 | 120 | 121 | 122 | 123 | 124 | ' NOT IMPLEMENTED - Required for interface 125 | 126 | Private Sub TaskInterface_Parameters(ParamArray Values() As Variant) 127 | myDone = True 128 | End Sub 129 | 130 | 131 | Private Function TaskInterface_Tick() As Boolean 132 | TaskInterface_Tick = True 133 | myDone = True 134 | End Function 135 | 136 | 137 | -------------------------------------------------------------------------------- /myButton.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "myButton" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Dim WithEvents glistN As gList 16 | Attribute glistN.VB_VarHelpID = -1 17 | Dim mCaptext As String 18 | Dim mIndex As Long 19 | Private mCallback As InterPress 20 | 21 | Public Property Set Container(glistNN As gList) 22 | Set glistN = glistNN 23 | With glistN 24 | .NoCaretShow = True 25 | .NoPanRight = False 26 | .restrictLines = 1 27 | .CenterText = True 28 | .VerticalCenterText = True 29 | .Text = mCaptext 30 | .backcolor = rgb(200, 120, 60) 31 | '.bypassfirstClick = True 32 | ''.FontSize = 12 33 | .enabled = True 34 | .ShowMe 35 | '.PrepareClick 36 | End With 37 | End Property 38 | 39 | Private Sub Class_Initialize() 40 | mCaptext = "Button" 41 | End Sub 42 | 43 | Private Sub Class_Terminate() 44 | Set glistN = Nothing 45 | Set mCallback = Nothing 46 | End Sub 47 | 48 | Private Sub glistN_CheckGotFocus() 49 | glistN.backcolor = rgb(100, 200, 160) 50 | glistN.ShowMe 51 | glistN.PrepareClick 52 | End Sub 53 | 54 | Private Sub glistN_CheckLostFocus() 55 | If Me.enabled Then 56 | glistN.backcolor = rgb(200, 120, 60) 57 | glistN.PanPos = 0 58 | glistN.ShowMe 59 | glistN.DblClick 60 | End If 61 | End Sub 62 | 63 | Private Sub glistN_MouseMove(Button As Integer, shift As Integer, x As Single, y As Single) 64 | If Button <> 0 Then glistN.PrepareClick 65 | End Sub 66 | 67 | Private Sub glistN_PanLeftRight(direction As Boolean) 68 | If (Not mCallback Is Nothing) Then mCallback.Press Index 69 | End Sub 70 | 71 | Private Sub glistN_RegisterGlist(this As gList) 72 | this.NoWheel = True 73 | End Sub 74 | Private Sub glistN_Selected(item As Long) 75 | 'If item >= 0 Then 76 | ' If (Not mCallback Is Nothing) Then mCallback.Press Index 77 | ' End If 78 | End Sub 79 | Private Sub glistN_Selected2(item As Long) 80 | 'If item >= 0 Then 81 | If (Not mCallback Is Nothing) Then mCallback.Press Index 82 | ' End If 83 | End Sub 84 | Property Set Callback(ByRef newObj As InterPress) 85 | Set mCallback = newObj 86 | End Property 87 | 88 | Property Get Callback() As InterPress 89 | Set Callback = mCallback 90 | End Property 91 | Public Property Let Caption(myCap As String) 92 | ' 93 | mCaptext = myCap 94 | If Not glistN Is Nothing Then 95 | If glistN.CenterText Then 96 | glistN.list(0) = mCaptext 97 | Else 98 | glistN.list(0) = " " + mCaptext 99 | End If 100 | glistN.ShowMe 101 | End If 102 | End Property 103 | Public Property Get Caption() As String 104 | Caption = mCaptext 105 | End Property 106 | 107 | Public Property Get Index() As Long 108 | Index = mIndex 109 | End Property 110 | 111 | Public Property Let Index(ByVal RHS As Long) 112 | mIndex = RHS 113 | End Property 114 | Public Property Get enabled() As Long 115 | enabled = glistN.enabled 116 | End Property 117 | 118 | Public Property Let enabled(ByVal RHS As Long) 119 | glistN.enabled = RHS 120 | End Property 121 | 122 | Public Sub Shutdown() 123 | glistN.Shutdown 124 | glistN.enabled = False 125 | 126 | End Sub 127 | -------------------------------------------------------------------------------- /utf8/varitem.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "VarItem" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Public mItem As Variant 16 | Public slot As Byte 17 | Public mTypeName As Byte 18 | Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ 19 | lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) 20 | Friend Sub GrabItem(ByRef RHS) 21 | If MemInt(VarPtr(mItem)) = 36 Then 22 | SwapVariant mItem, RHS 23 | ElseIf slot = 1 Then 24 | Set RHS = mItem 25 | ElseIf slot = 4 Then 26 | SwapVariant mItem, RHS 27 | Else 28 | RHS = mItem 29 | End If 30 | End Sub 31 | Property Let Typename(ByRef RHS As String) 32 | mTypeName = Asc(RHS) 33 | End Property 34 | Property Get Typename() As String 35 | Typename = Chr(mTypeName) 36 | End Property 37 | Property Let ItemStrVar(ByRef RHS As Variant) 38 | slot = 4 39 | mItem = RHS 40 | End Property 41 | Property Let ItemStr(ByRef RHS As String) 42 | slot = 4 43 | MoveStringToVariant RHS, mItem 44 | End Property 45 | Public Sub PopString(S$) 46 | If slot = 4 Then 47 | If Not myVarType(mItem, vbString) Then 48 | mItem = 0 49 | S$ = vbNullString 50 | Else 51 | SwapString2Variant S$, mItem 52 | End If 53 | ElseIf slot = 5 Then 54 | S$ = mItem 55 | ElseIf slot = 2 Then 56 | If VarType(mItem) = vbString Then 57 | S$ = mItem 58 | Else 59 | S$ = vbNullString 60 | End If 61 | Else 62 | S$ = vbNullString 63 | End If 64 | End Sub 65 | Property Get ItemStr() As String 66 | If slot > 3 Then ItemStr = mItem 67 | End Property 68 | Property Let ItemDouble(ByVal RHS As Variant) 69 | slot = 2 70 | mItem = RHS 71 | End Property 72 | 73 | Property Get ItemDouble() As Variant 74 | If slot = 2 Then ItemDouble = mItem 75 | End Property 76 | Property Let ItemVariant(RHS As Variant) 77 | slot = 2 78 | mItem = RHS 79 | End Property 80 | Property Get ItemVariantOnly() As Variant 81 | If slot = 1 Then 82 | Set ItemVariantOnly = mItem 83 | Else 84 | ItemVariantOnly = mItem 85 | End If 86 | End Property 87 | 88 | Property Get ItemVariant() As Variant 89 | If slot = 2 Then ItemVariant = mItem 90 | End Property 91 | 92 | Property Get ItemNoObject() As Variant 93 | If slot <> 1 Then ItemNoObject = mItem 94 | End Property 95 | Property Get NoValue() As Boolean 96 | If slot = 1 Then NoValue = mItem Is Nothing Else NoValue = slot = 0 97 | End Property 98 | Public Property Set ObjectRef(RHS As Variant) 99 | slot = 1 100 | Set mItem = RHS 101 | End Property 102 | Public Property Get ObjectRef() As Variant 103 | If slot = 1 Then Set ObjectRef = mItem Else Set ObjectRef = Nothing 104 | End Property 105 | Public Sub Recycle() 106 | Dim obj As IUnknown, GetRefCount As Long 107 | Set obj = Me 108 | CopyMemory GetRefCount, ByVal (ObjPtr(obj)) + 4, 4 109 | If GetRefCount > 4 Then Exit Sub 110 | On Error Resume Next 111 | mItem = vbEmpty 112 | slot = 0 113 | mTypeName = 0 114 | TrushCount = TrushCount + 1 115 | If TrushCount > UBound(Trush) Then 116 | ReDim Preserve Trush(UBound(Trush) * 2) 117 | End If 118 | Set Trush(TrushCount) = Me 119 | End Sub 120 | -------------------------------------------------------------------------------- /utf8/mhandler.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "mHandler" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | ' Generic Handler 15 | Option Explicit 16 | Private mObjRef As Object 17 | Private mt1 As Variant, mindirect As Long 18 | Public ReadOnly As Boolean 19 | Public index_start As Variant ' 1 for start 20 | Public index_End As Variant ' -1 for end 21 | Public index_cursor As Variant 22 | Public sign As Variant 23 | Public UseIterator As Boolean 24 | Public oEnum As Variant 25 | Private mIamEnum As Boolean 26 | Friend Property Get objref() As Object 27 | Set objref = mObjRef 28 | End Property 29 | 30 | Friend Property Set objref(RHS As Object) 31 | Set mObjRef = RHS 32 | End Property 33 | 34 | Private Sub Class_Initialize() 35 | indirect = -1 36 | index_start = 0 37 | index_End = -1 38 | UseIterator = False 39 | sign = 1 40 | End Sub 41 | 42 | ''Public Par1 As Variant 43 | Private Sub Class_Terminate() 44 | If Not objref Is Nothing Then 45 | 'If Typename(objref) = "GuiM2000" Then Stop 46 | Set objref = Nothing 47 | End If 48 | End Sub 49 | Friend Sub CopyTo(A As mHandler) 50 | If IamEnum Then Set A = Me: Exit Sub 51 | Set A = New mHandler 52 | A.T1 = T1 53 | If T1 = 1 Then 54 | A.ReadOnly = ReadOnly 55 | Set A.objref = mObjRef 56 | ElseIf T1 = 3 Then 57 | If ReadOnly Then 58 | Dim mAr As mArray, mtu As tuple 59 | If TypeOf objref Is mArray Then 60 | Set mAr = New mArray 61 | objref.CopyArray mAr 62 | Set A.objref = mAr 63 | ElseIf TypeOf objref Is tuple Then 64 | Set mtu = New tuple 65 | objref.CopyArray mtu 66 | Set A.objref = mtu 67 | Else 68 | Set A.objref = mObjRef 69 | End If 70 | Else 71 | Set A.objref = mObjRef 72 | End If 73 | Else 74 | Set A.objref = mObjRef 75 | End If 76 | A.indirect = indirect 77 | A.index_start = index_start 78 | A.index_End = index_End 79 | A.index_cursor = index_cursor 80 | A.UseIterator = UseIterator 81 | A.sign = sign 82 | End Sub 83 | Friend Function Iterate() 84 | Iterate = GetNext(ObjPtr(oEnum), index_cursor) 85 | If IsObject(index_cursor) Then Set mObjRef = index_cursor: index_cursor = vbEmpty 86 | index_End = 1 87 | If Not Iterate Then index_End = -1 88 | End Function 89 | Friend Sub ConstructEnumerator(penum As Variant) 90 | IamEnum = True 91 | Set oEnum = penum 92 | If GetNext(ObjPtr(penum), index_cursor) Then 93 | If IsObject(index_cursor) Then Set mObjRef = index_cursor: index_cursor = vbEmpty 94 | index_End = 0 95 | End If 96 | End Sub 97 | Friend Function CreateFromPicture(b As Long, w1 As Long, w2 As Long, w3 As Long) As Object 98 | If T1 = 2 Then 99 | Dim mm As MemBlock 100 | Set mm = mObjRef 101 | Set CreateFromPicture = mm.CreateFromPicture(b, w1, w2, w3) 102 | End If 103 | End Function 104 | 105 | Property Get T1() As Variant 106 | T1 = mt1 107 | End Property 108 | 109 | Friend Property Let T1(ByVal RHS As Variant) 110 | mt1 = RHS 111 | End Property 112 | 113 | Property Get indirect() As Long 114 | indirect = mindirect 115 | End Property 116 | 117 | Friend Property Let indirect(ByVal RHS As Long) 118 | mindirect = RHS 119 | End Property 120 | Property Get IamEnum() As Boolean 121 | IamEnum = mIamEnum 122 | End Property 123 | 124 | Friend Property Let IamEnum(ByVal RHS As Boolean) 125 | mIamEnum = RHS 126 | End Property -------------------------------------------------------------------------------- /VarItem.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "VarItem" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Public mItem As Variant 16 | Public slot As Byte 17 | Public mTypeName As Byte 18 | Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ 19 | lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) 20 | Friend Sub GrabItem(ByRef RHS) 21 | If MemInt(VarPtr(mItem)) = 36 Then 22 | SwapVariant mItem, RHS 23 | ElseIf slot = 1 Then 24 | Set RHS = mItem 25 | ElseIf slot = 4 Then 26 | SwapVariant mItem, RHS 27 | Else 28 | RHS = mItem 29 | End If 30 | End Sub 31 | Property Let Typename(ByRef RHS As String) 32 | mTypeName = Asc(RHS) 33 | End Property 34 | Property Get Typename() As String 35 | Typename = Chr(mTypeName) 36 | End Property 37 | Property Let ItemStrVar(ByRef RHS As Variant) 38 | slot = 4 39 | mItem = RHS 40 | End Property 41 | Property Let ItemStr(ByRef RHS As String) 42 | slot = 4 43 | MoveStringToVariant RHS, mItem 44 | End Property 45 | Public Sub PopString(S$) 46 | If slot = 4 Then 47 | If Not myVarType(mItem, vbString) Then 48 | mItem = 0 49 | S$ = vbNullString 50 | Else 51 | SwapString2Variant S$, mItem 52 | End If 53 | ElseIf slot = 5 Then 54 | S$ = mItem 55 | ElseIf slot = 2 Then 56 | If VarType(mItem) = vbString Then 57 | S$ = mItem 58 | Else 59 | S$ = vbNullString 60 | End If 61 | Else 62 | S$ = vbNullString 63 | End If 64 | End Sub 65 | Property Get ItemStr() As String 66 | If slot > 3 Then ItemStr = mItem 67 | End Property 68 | Property Let ItemDouble(ByVal RHS As Variant) 69 | slot = 2 70 | mItem = RHS 71 | End Property 72 | 73 | Property Get ItemDouble() As Variant 74 | If slot = 2 Then ItemDouble = mItem 75 | End Property 76 | Property Let ItemVariant(RHS As Variant) 77 | slot = 2 78 | mItem = RHS 79 | End Property 80 | Property Get ItemVariantOnly() As Variant 81 | If slot = 1 Then 82 | Set ItemVariantOnly = mItem 83 | Else 84 | ItemVariantOnly = mItem 85 | End If 86 | End Property 87 | 88 | Property Get ItemVariant() As Variant 89 | If slot = 2 Then ItemVariant = mItem 90 | End Property 91 | 92 | Property Get ItemNoObject() As Variant 93 | If slot <> 1 Then ItemNoObject = mItem 94 | End Property 95 | Property Get NoValue() As Boolean 96 | If slot = 1 Then NoValue = mItem Is Nothing Else NoValue = slot = 0 97 | End Property 98 | Public Property Set ObjectRef(RHS As Variant) 99 | slot = 1 100 | Set mItem = RHS 101 | End Property 102 | Public Property Get ObjectRef() As Variant 103 | If slot = 1 Then Set ObjectRef = mItem Else Set ObjectRef = Nothing 104 | End Property 105 | Public Sub Recycle() 106 | Dim obj As IUnknown, GetRefCount As Long 107 | Set obj = Me 108 | CopyMemory GetRefCount, ByVal (ObjPtr(obj)) + 4, 4 109 | If GetRefCount > 4 Then Exit Sub 110 | On Error Resume Next 111 | mItem = vbEmpty 112 | slot = 0 113 | mTypeName = 0 114 | TrushCount = TrushCount + 1 115 | If TrushCount > UBound(Trush) Then 116 | ReDim Preserve Trush(UBound(Trush) * 2) 117 | End If 118 | Set Trush(TrushCount) = Me 119 | End Sub 120 | 121 | -------------------------------------------------------------------------------- /mHandler.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "mHandler" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | ' Generic Handler 15 | Option Explicit 16 | Private mObjRef As Object 17 | Private mt1 As Variant, mindirect As Long 18 | Public ReadOnly As Boolean 19 | Public index_start As Variant ' 1 for start 20 | Public index_End As Variant ' -1 for end 21 | Public index_cursor As Variant 22 | Public sign As Variant 23 | Public UseIterator As Boolean 24 | Public oEnum As Variant 25 | Private mIamEnum As Boolean 26 | Friend Property Get objref() As Object 27 | Set objref = mObjRef 28 | End Property 29 | 30 | Friend Property Set objref(RHS As Object) 31 | Set mObjRef = RHS 32 | End Property 33 | 34 | Private Sub Class_Initialize() 35 | indirect = -1 36 | index_start = 0 37 | index_End = -1 38 | UseIterator = False 39 | sign = 1 40 | End Sub 41 | 42 | ''Public Par1 As Variant 43 | Private Sub Class_Terminate() 44 | If Not objref Is Nothing Then 45 | 'If Typename(objref) = "GuiM2000" Then Stop 46 | Set objref = Nothing 47 | End If 48 | End Sub 49 | Friend Sub CopyTo(A As mHandler) 50 | If IamEnum Then Set A = Me: Exit Sub 51 | Set A = New mHandler 52 | A.T1 = T1 53 | If T1 = 1 Then 54 | A.ReadOnly = ReadOnly 55 | Set A.objref = mObjRef 56 | ElseIf T1 = 3 Then 57 | If ReadOnly Then 58 | Dim mAr As mArray, mtu As tuple 59 | If TypeOf objref Is mArray Then 60 | Set mAr = New mArray 61 | objref.CopyArray mAr 62 | Set A.objref = mAr 63 | ElseIf TypeOf objref Is tuple Then 64 | Set mtu = New tuple 65 | objref.CopyArray mtu 66 | Set A.objref = mtu 67 | Else 68 | Set A.objref = mObjRef 69 | End If 70 | Else 71 | Set A.objref = mObjRef 72 | End If 73 | Else 74 | Set A.objref = mObjRef 75 | End If 76 | A.indirect = indirect 77 | A.index_start = index_start 78 | A.index_End = index_End 79 | A.index_cursor = index_cursor 80 | A.UseIterator = UseIterator 81 | A.sign = sign 82 | End Sub 83 | Friend Function Iterate() 84 | Iterate = GetNext(ObjPtr(oEnum), index_cursor) 85 | If IsObject(index_cursor) Then Set mObjRef = index_cursor: index_cursor = vbEmpty 86 | index_End = 1 87 | If Not Iterate Then index_End = -1 88 | End Function 89 | Friend Sub ConstructEnumerator(penum As Variant) 90 | IamEnum = True 91 | Set oEnum = penum 92 | If GetNext(ObjPtr(penum), index_cursor) Then 93 | If IsObject(index_cursor) Then Set mObjRef = index_cursor: index_cursor = vbEmpty 94 | index_End = 0 95 | End If 96 | End Sub 97 | Friend Function CreateFromPicture(b As Long, w1 As Long, w2 As Long, w3 As Long) As Object 98 | If T1 = 2 Then 99 | Dim mm As MemBlock 100 | Set mm = mObjRef 101 | Set CreateFromPicture = mm.CreateFromPicture(b, w1, w2, w3) 102 | End If 103 | End Function 104 | 105 | Property Get T1() As Variant 106 | T1 = mt1 107 | End Property 108 | 109 | Friend Property Let T1(ByVal RHS As Variant) 110 | mt1 = RHS 111 | End Property 112 | 113 | Property Get indirect() As Long 114 | indirect = mindirect 115 | End Property 116 | 117 | Friend Property Let indirect(ByVal RHS As Long) 118 | mindirect = RHS 119 | End Property 120 | Property Get IamEnum() As Boolean 121 | IamEnum = mIamEnum 122 | End Property 123 | 124 | Friend Property Let IamEnum(ByVal RHS As Boolean) 125 | mIamEnum = RHS 126 | End Property 127 | -------------------------------------------------------------------------------- /utf8/layer.frm.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form Form5 3 | AutoRedraw = -1 'True 4 | BackColor = &H00000000& 5 | BorderStyle = 0 'None 6 | Caption = "Form5" 7 | ClientHeight = 3090 8 | ClientLeft = -30000 9 | ClientTop = 0 10 | ClientWidth = 4680 11 | FillStyle = 0 'Solid 12 | BeginProperty Font 13 | Name = "Verdana" 14 | Size = 8.25 15 | Charset = 161 16 | Weight = 400 17 | Underline = 0 'False 18 | Italic = 0 'False 19 | Strikethrough = 0 'False 20 | EndProperty 21 | ForeColor = &H8000000E& 22 | LinkTopic = "Form5" 23 | ScaleHeight = 3090 24 | ScaleWidth = 4680 25 | ShowInTaskbar = 0 'False 26 | End 27 | Attribute VB_Name = "Form5" 28 | Attribute VB_GlobalNameSpace = False 29 | Attribute VB_Creatable = False 30 | Attribute VB_PredeclaredId = True 31 | Attribute VB_Exposed = False 32 | Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoW" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As Long, ByVal cchData As Long) As Long 33 | Private Declare Function GetKeyboardLayout& Lib "user32" (ByVal dwLayout&) 34 | Private Const DWL_ANYTHREAD& = 0 35 | Const LOCALE_ILANGUAGE = 1 36 | Private Declare Function SetErrorMode Lib "kernel32" ( _ 37 | ByVal wMode As Long) As Long 38 | 39 | Private Const SEM_NOGPFAULTERRORBOX = &H2& 40 | Private Sub Form_Activate() 41 | 'If Form1.WindowState <> vbMinimized And Form1.Visible Then Form1.ActiveControl.SetFocus 42 | Me.ZOrder 1 43 | If Form1.Visible Then Form1.SetFocus 44 | End Sub 45 | 46 | Private Sub Form_Load() 47 | Set LastGlist = Nothing 48 | form5iamloaded = True 49 | If Not s_complete Then 50 | On Error Resume Next 51 | Me.move -100000 52 | If Err.Number > 0 Then Me.move -30000 53 | 54 | If Form1.Visible Then Form1.Hide 55 | 56 | End If 57 | 58 | End Sub 59 | 60 | 61 | 62 | Private Sub Form_Unload(Cancel As Integer) 63 | On Error Resume Next 64 | Set LastGlist = Nothing 65 | Set LastGlist2 = Nothing 66 | form5iamloaded = False ' 67 | MediaPlayer1.closeMovie 68 | DisableMidi 69 | If Not TaskMaster Is Nothing Then TaskMaster.Dispose 70 | Set TaskMaster = Nothing 71 | Set Basestack1.Owner = Nothing 72 | Set Basestack1 = Nothing 73 | Dim X As Form 74 | If IsWine Then 75 | Modalid = 0 76 | 77 | For Each X In Forms 78 | If X.Visible Then X.Visible = False 79 | Next 80 | Set X = Nothing 81 | 'Form1.helper1 82 | 'MsgBox "quit" 83 | 'Exit Sub 84 | Else 85 | For Each X In Forms 86 | If X.Name <> Me.Name Then Unload X 87 | Next 88 | Set X = Nothing 89 | End If 90 | 91 | If m_bInIDE Then Exit Sub 92 | 93 | SetErrorMode SEM_NOGPFAULTERRORBOX 94 | End Sub 95 | Public Sub BackPort() 96 | If Not IsWine Then Exit Sub 97 | On Error Resume Next 98 | Set LastGlist = Nothing 99 | Set LastGlist2 = Nothing 100 | form5iamloaded = False ' 101 | MediaPlayer1.closeMovie 102 | DisableMidi 103 | If Not TaskMaster Is Nothing Then TaskMaster.Dispose 104 | Set TaskMaster = Nothing 105 | 106 | Dim X As Form 107 | Modalid = 0 108 | 109 | For Each X In Forms 110 | If X.Name <> Me.Name Then 111 | Set X.icon = LoadPicture("") 112 | If X.Visible Then X.Visible = False 113 | End If 114 | Next 115 | Set X = Nothing 116 | Form1.helper1 117 | 118 | End Sub 119 | Private Sub Form_KeyPress(KeyAscii As Integer) 120 | INK$ = INK$ & GetKeY(KeyAscii) 121 | End Sub 122 | Public Sub RestoreSizePos() 123 | ' calling from form1 124 | Me.move Form1.Left, Form1.top, Form1.Width, Form1.Height 125 | End Sub 126 | Public Sub RestorePos() 127 | ' calling from form1 128 | 'Me.Move Form1.Left, Form1.Top 129 | End Sub 130 | Function GetKeY(ascii As Integer) As String 131 | Dim Buffer As String, ret As Long 132 | Buffer = String$(514, 0) 133 | Dim R&, k& 134 | R = GetKeyboardLayout(DWL_ANYTHREAD) And &HFFFF& 135 | R = val("&H" & Right(Hex(R), 4)) 136 | ret = GetLocaleInfo(R, LOCALE_ILANGUAGE, StrPtr(Buffer), Len(Buffer)) 137 | If ret > 0 Then 138 | GetKeY = ChrW$(AscW(StrConv(ChrW$(ascii Mod 256), 64, CLng(val("&h" + Left$(Buffer, ret - 1)))))) 139 | Else 140 | GetKeY = ChrW$(AscW(StrConv(ChrW$(ascii Mod 256), 64, 1033))) 141 | End If 142 | End Function -------------------------------------------------------------------------------- /layer.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form Form5 3 | AutoRedraw = -1 'True 4 | BackColor = &H00000000& 5 | BorderStyle = 0 'None 6 | Caption = "Form5" 7 | ClientHeight = 3090 8 | ClientLeft = -30000 9 | ClientTop = 0 10 | ClientWidth = 4680 11 | FillStyle = 0 'Solid 12 | BeginProperty Font 13 | Name = "Verdana" 14 | Size = 8.25 15 | Charset = 161 16 | Weight = 400 17 | Underline = 0 'False 18 | Italic = 0 'False 19 | Strikethrough = 0 'False 20 | EndProperty 21 | ForeColor = &H8000000E& 22 | LinkTopic = "Form5" 23 | ScaleHeight = 3090 24 | ScaleWidth = 4680 25 | ShowInTaskbar = 0 'False 26 | End 27 | Attribute VB_Name = "Form5" 28 | Attribute VB_GlobalNameSpace = False 29 | Attribute VB_Creatable = False 30 | Attribute VB_PredeclaredId = True 31 | Attribute VB_Exposed = False 32 | Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoW" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As Long, ByVal cchData As Long) As Long 33 | Private Declare Function GetKeyboardLayout& Lib "user32" (ByVal dwLayout&) 34 | Private Const DWL_ANYTHREAD& = 0 35 | Const LOCALE_ILANGUAGE = 1 36 | Private Declare Function SetErrorMode Lib "kernel32" ( _ 37 | ByVal wMode As Long) As Long 38 | 39 | Private Const SEM_NOGPFAULTERRORBOX = &H2& 40 | Private Sub Form_Activate() 41 | 'If Form1.WindowState <> vbMinimized And Form1.Visible Then Form1.ActiveControl.SetFocus 42 | Me.ZOrder 1 43 | If Form1.Visible Then Form1.SetFocus 44 | End Sub 45 | 46 | Private Sub Form_Load() 47 | Set LastGlist = Nothing 48 | form5iamloaded = True 49 | If Not s_complete Then 50 | On Error Resume Next 51 | Me.move -100000 52 | If Err.Number > 0 Then Me.move -30000 53 | 54 | If Form1.Visible Then Form1.Hide 55 | 56 | End If 57 | 58 | End Sub 59 | 60 | 61 | 62 | Private Sub Form_Unload(Cancel As Integer) 63 | On Error Resume Next 64 | Set LastGlist = Nothing 65 | Set LastGlist2 = Nothing 66 | form5iamloaded = False ' 67 | MediaPlayer1.closeMovie 68 | DisableMidi 69 | If Not TaskMaster Is Nothing Then TaskMaster.Dispose 70 | Set TaskMaster = Nothing 71 | Set Basestack1.Owner = Nothing 72 | Set Basestack1 = Nothing 73 | Dim X As Form 74 | If IsWine Then 75 | Modalid = 0 76 | 77 | For Each X In Forms 78 | If X.Visible Then X.Visible = False 79 | Next 80 | Set X = Nothing 81 | 'Form1.helper1 82 | 'MsgBox "quit" 83 | 'Exit Sub 84 | Else 85 | For Each X In Forms 86 | If X.Name <> Me.Name Then Unload X 87 | Next 88 | Set X = Nothing 89 | End If 90 | 91 | If m_bInIDE Then Exit Sub 92 | 93 | SetErrorMode SEM_NOGPFAULTERRORBOX 94 | End Sub 95 | Public Sub BackPort() 96 | If Not IsWine Then Exit Sub 97 | On Error Resume Next 98 | Set LastGlist = Nothing 99 | Set LastGlist2 = Nothing 100 | form5iamloaded = False ' 101 | MediaPlayer1.closeMovie 102 | DisableMidi 103 | If Not TaskMaster Is Nothing Then TaskMaster.Dispose 104 | Set TaskMaster = Nothing 105 | 106 | Dim X As Form 107 | Modalid = 0 108 | 109 | For Each X In Forms 110 | If X.Name <> Me.Name Then 111 | Set X.icon = LoadPicture("") 112 | If X.Visible Then X.Visible = False 113 | End If 114 | Next 115 | Set X = Nothing 116 | Form1.helper1 117 | 118 | End Sub 119 | Private Sub Form_KeyPress(KeyAscii As Integer) 120 | INK$ = INK$ & GetKeY(KeyAscii) 121 | End Sub 122 | Public Sub RestoreSizePos() 123 | ' calling from form1 124 | Me.move Form1.Left, Form1.top, Form1.Width, Form1.Height 125 | End Sub 126 | Public Sub RestorePos() 127 | ' calling from form1 128 | 'Me.Move Form1.Left, Form1.Top 129 | End Sub 130 | Function GetKeY(ascii As Integer) As String 131 | Dim Buffer As String, ret As Long 132 | Buffer = String$(514, 0) 133 | Dim R&, k& 134 | R = GetKeyboardLayout(DWL_ANYTHREAD) And &HFFFF& 135 | R = val("&H" & Right(Hex(R), 4)) 136 | ret = GetLocaleInfo(R, LOCALE_ILANGUAGE, StrPtr(Buffer), Len(Buffer)) 137 | If ret > 0 Then 138 | GetKeY = ChrW$(AscW(StrConv(ChrW$(ascii Mod 256), 64, CLng(val("&h" + Left$(Buffer, ret - 1)))))) 139 | Else 140 | GetKeY = ChrW$(AscW(StrConv(ChrW$(ascii Mod 256), 64, 1033))) 141 | End If 142 | End Function 143 | -------------------------------------------------------------------------------- /utf8/coder.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "coder" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Attribute VB_Description = "This is the Coder utility" 15 | Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes" 16 | Attribute VB_Ext_KEY = "Top_Level" ,"Yes" 17 | Option Explicit 18 | Private Function GOOD(ByRef counter As Long, ByVal Key As String, ByVal item As String) As String 19 | Dim i As Long, j As Long 20 | j = Len(Key) 21 | If j = 0 Then GOOD = item: Exit Function 22 | 23 | If ReduceKey(item) Then 24 | For i = 1 To Len(item) 25 | ' old function - but needed to stay as is 26 | ' possible problem..decode a greek coded file but Asc() use other than greek language. 27 | ' so a password must be in latin (standard language) to used everywhere. 28 | 29 | Mid$(item, i, 1) = ChrW(AscW(Mid$(item, i, 1)) Xor Asc(Mid$(Key, (counter Mod j) + 1))) 30 | 31 | counter = counter + 1 32 | Next i 33 | Else 34 | For i = 1 To Len(item) 35 | 36 | Mid$(item, i, 1) = Chr(Asc(Mid$(Key, (counter Mod j) + 1, 1)) Xor (Asc(Mid$(item, i, 1)))) 37 | 38 | counter = counter + 1 39 | Next i 40 | End If 41 | GOOD = item 42 | End Function 43 | Private Sub ExpandKey(Key As String) 44 | Dim i As Long, b As Long, k As Long, c As Long, cx1 As Long, c2 As Long, c1 As Long 45 | Dim Pad$ 46 | Randomize 47 | b = Len(Key) 48 | Key = String$(Len(Key), " ") + Key 49 | For i = 1 To Len(Key) - 1 Step 2 50 | k = Int(8 * Rnd) 51 | c = AscW(Mid$(Key, b + i \ 2 + 1, 1)) 52 | c1 = UINT(c And &HF00) + &H4000 53 | c2 = UINT(c And &HF000) \ 8 + &H4000 54 | c = c And &HFF 55 | Mid$(Key, i, 2) = ChrW(c1 + 128 + k + (c And &HF) * 8) + ChrW(c2 + 128 + k + (c And &HF0) / 2) 56 | Next i 57 | 58 | End Sub 59 | Private Function UINT(ByVal a As Long) As Long 60 | Dim b As Integer 61 | b = a And &HFFFF& 62 | If b < 0 Then 63 | UINT = CLng(&H10000 + b) 64 | Else 65 | UINT = CLng(b) 66 | End If 67 | 68 | End Function 69 | Private Function ReduceKey(Key As String) As Boolean 70 | Dim i As Long, j As Long, c1 As Long, c2 As Long, noANSI As Boolean 71 | On Error Resume Next 72 | If (Len(Key) Mod 2 = 1) Or Key = vbNullString Then Exit Function 73 | noANSI = Not ((UINT(AscW(Mid$(Key, 2, 1))) And &H4000) = 0 Or (UINT(AscW(Mid$(Key, i + 1, 1))) And &H4000) = 0) 74 | If noANSI Then 75 | For i = 1 To Len(Key) - 1 Step 2 76 | c2 = UINT(AscW(Mid$(Key, i + 1, 1))) 77 | c1 = UINT(AscW(Mid$(Key, i, 1))) 78 | Mid$(Key, i \ 2 + 1, 1) = ChrW((c1 And &HF00) + (c1 And &H78) \ 8 + (c2 And &H1E00) * 8 + (c2 And &H78) * 2) 79 | Next i 80 | Else 81 | For i = 1 To Len(Key) - 1 Step 2 82 | Mid$(Key, i \ 2 + 1, 1) = Chr((Asc(Mid$(Key, i, 1)) And &H78) \ 8 + (Asc(Mid$(Key, i + 1, 1)) And &H78) * 2) 83 | Next i 84 | End If 85 | If LenB(Key) > Len(Key) * 2 Then 86 | MidB$(Key, Len(Key) + 1, 1) = MidB$(Key, LenB(Key), 1) 87 | End If 88 | Key = MidB$(Key, 1, LenB(Key) \ 2 + LenB(Key) Mod 2) 89 | ReduceKey = noANSI 90 | End Function 91 | Private Function ReduceKey1(Key As String) As Boolean 92 | Dim i As Long, j As Long 93 | If (Len(Key) Mod 2 = 1) Or Key = vbNullString Then Exit Function 94 | For i = 1 To Len(Key) - 1 Step 2 95 | Mid$(Key, i \ 2 + 1, 1) = Chr((Asc(Mid$(Key, i, 1)) And &H78) \ 8 + (Asc(Mid$(Key, i + 1, 1)) And &H78) * 2) 96 | Next i 97 | Key = Mid$(Key, 1, Len(Key) \ 2) 98 | ReduceKey1 = False 99 | End Function 100 | Private Function Bad(ByRef counter As Long, Key As String, item As String) As String 101 | Dim i As Long, j As Long 102 | j = Len(Key) 103 | For i = 1 To Len(item) 104 | Mid$(item, i, 1) = ChrW(AscW(Mid$(item, i, 1)) Xor Asc(Mid$(Key, (counter Mod j) + 1))) 105 | 106 | counter = counter + 1 107 | Next i 108 | 109 | ExpandKey item 110 | Bad = item 111 | End Function 112 | Public Function decryptline(ByVal Data As String, ByVal MasterKey As String, ByRef Start As Long) As String 113 | decryptline = GOOD(Start, MasterKey, Data) 114 | End Function 115 | 116 | Public Function encryptline(ByVal Data As String, ByVal MasterKey As String, ByRef Start As Long) As String 117 | encryptline = Bad(Start, MasterKey, Data) 118 | End Function 119 | Public Function must(sss$) As String 120 | must = decryptline(sss$, "MISTAKE TRY AGAIN", (Len(sss$) / 2) Mod 33) 121 | End Function 122 | Public Function must1(sss$) As String 123 | must1 = encryptline(sss$, "MISTAKE TRY AGAIN", Len(sss$) Mod 33) 124 | End Function 125 | 126 | 127 | 128 | -------------------------------------------------------------------------------- /coder.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "coder" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Attribute VB_Description = "This is the Coder utility" 15 | Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes" 16 | Attribute VB_Ext_KEY = "Top_Level" ,"Yes" 17 | Option Explicit 18 | Private Function GOOD(ByRef counter As Long, ByVal Key As String, ByVal item As String) As String 19 | Dim i As Long, j As Long 20 | j = Len(Key) 21 | If j = 0 Then GOOD = item: Exit Function 22 | 23 | If ReduceKey(item) Then 24 | For i = 1 To Len(item) 25 | ' old function - but needed to stay as is 26 | ' possible problem..decode a greek coded file but Asc() use other than greek language. 27 | ' so a password must be in latin (standard language) to used everywhere. 28 | 29 | Mid$(item, i, 1) = ChrW(AscW(Mid$(item, i, 1)) Xor Asc(Mid$(Key, (counter Mod j) + 1))) 30 | 31 | counter = counter + 1 32 | Next i 33 | Else 34 | For i = 1 To Len(item) 35 | 36 | Mid$(item, i, 1) = Chr(Asc(Mid$(Key, (counter Mod j) + 1, 1)) Xor (Asc(Mid$(item, i, 1)))) 37 | 38 | counter = counter + 1 39 | Next i 40 | End If 41 | GOOD = item 42 | End Function 43 | Private Sub ExpandKey(Key As String) 44 | Dim i As Long, b As Long, k As Long, c As Long, cx1 As Long, c2 As Long, c1 As Long 45 | Dim Pad$ 46 | Randomize 47 | b = Len(Key) 48 | Key = String$(Len(Key), " ") + Key 49 | For i = 1 To Len(Key) - 1 Step 2 50 | k = Int(8 * Rnd) 51 | c = AscW(Mid$(Key, b + i \ 2 + 1, 1)) 52 | c1 = UINT(c And &HF00) + &H4000 53 | c2 = UINT(c And &HF000) \ 8 + &H4000 54 | c = c And &HFF 55 | Mid$(Key, i, 2) = ChrW(c1 + 128 + k + (c And &HF) * 8) + ChrW(c2 + 128 + k + (c And &HF0) / 2) 56 | Next i 57 | 58 | End Sub 59 | Private Function UINT(ByVal a As Long) As Long 60 | Dim b As Integer 61 | b = a And &HFFFF& 62 | If b < 0 Then 63 | UINT = CLng(&H10000 + b) 64 | Else 65 | UINT = CLng(b) 66 | End If 67 | 68 | End Function 69 | Private Function ReduceKey(Key As String) As Boolean 70 | Dim i As Long, j As Long, c1 As Long, c2 As Long, noANSI As Boolean 71 | On Error Resume Next 72 | If (Len(Key) Mod 2 = 1) Or Key = vbNullString Then Exit Function 73 | noANSI = Not ((UINT(AscW(Mid$(Key, 2, 1))) And &H4000) = 0 Or (UINT(AscW(Mid$(Key, i + 1, 1))) And &H4000) = 0) 74 | If noANSI Then 75 | For i = 1 To Len(Key) - 1 Step 2 76 | c2 = UINT(AscW(Mid$(Key, i + 1, 1))) 77 | c1 = UINT(AscW(Mid$(Key, i, 1))) 78 | Mid$(Key, i \ 2 + 1, 1) = ChrW((c1 And &HF00) + (c1 And &H78) \ 8 + (c2 And &H1E00) * 8 + (c2 And &H78) * 2) 79 | Next i 80 | Else 81 | For i = 1 To Len(Key) - 1 Step 2 82 | Mid$(Key, i \ 2 + 1, 1) = Chr((Asc(Mid$(Key, i, 1)) And &H78) \ 8 + (Asc(Mid$(Key, i + 1, 1)) And &H78) * 2) 83 | Next i 84 | End If 85 | If LenB(Key) > Len(Key) * 2 Then 86 | MidB$(Key, Len(Key) + 1, 1) = MidB$(Key, LenB(Key), 1) 87 | End If 88 | Key = MidB$(Key, 1, LenB(Key) \ 2 + LenB(Key) Mod 2) 89 | ReduceKey = noANSI 90 | End Function 91 | Private Function ReduceKey1(Key As String) As Boolean 92 | Dim i As Long, j As Long 93 | If (Len(Key) Mod 2 = 1) Or Key = vbNullString Then Exit Function 94 | For i = 1 To Len(Key) - 1 Step 2 95 | Mid$(Key, i \ 2 + 1, 1) = Chr((Asc(Mid$(Key, i, 1)) And &H78) \ 8 + (Asc(Mid$(Key, i + 1, 1)) And &H78) * 2) 96 | Next i 97 | Key = Mid$(Key, 1, Len(Key) \ 2) 98 | ReduceKey1 = False 99 | End Function 100 | Private Function Bad(ByRef counter As Long, Key As String, item As String) As String 101 | Dim i As Long, j As Long 102 | j = Len(Key) 103 | For i = 1 To Len(item) 104 | Mid$(item, i, 1) = ChrW(AscW(Mid$(item, i, 1)) Xor Asc(Mid$(Key, (counter Mod j) + 1))) 105 | 106 | counter = counter + 1 107 | Next i 108 | 109 | ExpandKey item 110 | Bad = item 111 | End Function 112 | Public Function decryptline(ByVal Data As String, ByVal MasterKey As String, ByRef Start As Long) As String 113 | decryptline = GOOD(Start, MasterKey, Data) 114 | End Function 115 | 116 | Public Function encryptline(ByVal Data As String, ByVal MasterKey As String, ByRef Start As Long) As String 117 | encryptline = Bad(Start, MasterKey, Data) 118 | End Function 119 | Public Function must(sss$) As String 120 | must = decryptline(sss$, "MISTAKE TRY AGAIN", (Len(sss$) / 2) Mod 33) 121 | End Function 122 | Public Function must1(sss$) As String 123 | must1 = encryptline(sss$, "MISTAKE TRY AGAIN", Len(sss$) Mod 33) 124 | End Function 125 | 126 | 127 | 128 | 129 | -------------------------------------------------------------------------------- /utf8/spbuffer.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "SPBuffer" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | ' 16 | 'SPBuffer 17 | '======== 18 | ' 19 | 'A buffer class for use with stream data that arrives in chunks, 20 | 'where the data is to be extracted in "lines" delimited by vbCr 21 | 'sequences or in entirety. 22 | ' 23 | 24 | #Const SPB_DEBUG = False 25 | 26 | Private Const CHUNK_SIZE As Long = 1000 27 | Private Const CHUNK_SOFT_LIMIT As Long = CHUNK_SIZE * 10 28 | 29 | Private Buffer As String 30 | Private CharsInUse As Long 31 | Private mHasLine As Boolean 32 | 33 | Public Sub Append(ByVal Text As String) 34 | Dim TextLen As Long 35 | Dim BufferLen As Long 36 | Dim Temp As String 37 | 38 | TextLen = Len(Text) 39 | If TextLen > 0 Then 40 | BufferLen = Len(Buffer) 41 | Do While TextLen + CharsInUse > BufferLen 42 | BufferLen = BufferLen + CHUNK_SIZE 43 | Loop 44 | If BufferLen > Len(Buffer) Then 45 | Temp = Left$(Buffer, CharsInUse) 46 | Buffer = String$(BufferLen, 0) 47 | Mid$(Buffer, 1) = Temp 48 | End If 49 | Mid$(Buffer, CharsInUse + 1, TextLen) = Text 50 | CharsInUse = CharsInUse + TextLen 51 | mHasLine = mHasLine Or InStr(Text, vbCr) > 0 52 | End If 53 | End Sub 54 | 55 | Public Function Backspace(Optional ByVal Spaces As Long = 1) As Long 56 | If Spaces > CharsInUse Then Spaces = CharsInUse 57 | If Spaces > 0 Then 58 | CharsInUse = CharsInUse - Spaces 59 | If CharsInUse > 0 Then 60 | mHasLine = InStrRev(Buffer, vbCr, CharsInUse) > 0 61 | Else 62 | mHasLine = False 63 | End If 64 | End If 65 | Backspace = Spaces 66 | End Function 67 | 68 | Public Sub Clear() 69 | If Len(Buffer) > CHUNK_SOFT_LIMIT Then 70 | Buffer = String$(CHUNK_SOFT_LIMIT, 0) 71 | End If 72 | CharsInUse = 0 73 | mHasLine = False 74 | End Sub 75 | 76 | Private Sub DeleteChars(ByVal Length As Long) 77 | Dim strRemainder As String 78 | 79 | strRemainder = Mid$(Buffer, Length + 1, _ 80 | CharsInUse - Length) 81 | CharsInUse = Len(strRemainder) 82 | Mid$(Buffer, 1, CharsInUse) = strRemainder 83 | mHasLine = InStr(strRemainder, vbCr) > 0 84 | End Sub 85 | 86 | Public Sub DeleteData(ByVal MaxLen As Long) 87 | If MaxLen > 0 Then 88 | If MaxLen > CharsInUse Then MaxLen = CharsInUse 89 | DeleteChars MaxLen 90 | End If 91 | End Sub 92 | 93 | Public Function GetData(Optional ByVal MaxLen As Long = -1) As String 94 | If MaxLen < 0 Then 95 | GetData = Left$(Buffer, CharsInUse) 96 | Clear 97 | ElseIf MaxLen = 0 Then 98 | GetData = "" 99 | Else 100 | If MaxLen > CharsInUse Then MaxLen = CharsInUse 101 | GetData = Left$(Buffer, MaxLen) 102 | DeleteChars MaxLen 103 | End If 104 | End Function 105 | 106 | Public Function GetLine() As String 107 | 'A "line" is anything delimited by a CR, but also filter 108 | 'out any LF characters for cases where CRLF delimits lines. 109 | 'We see both conventions used in StdIO programs. 110 | Dim lngLineEnd As Long 111 | 112 | If mHasLine Then 113 | If Left$(Buffer, 1) = vbLf Then DeleteChars 1 'LF arrived late. 114 | lngLineEnd = InStr(Buffer, vbCr) 115 | GetLine = Left$(Buffer, lngLineEnd - 1) 116 | DeleteChars lngLineEnd 117 | If CharsInUse > 0 Then 118 | If Left$(Buffer, 1) = vbLf Then DeleteChars 1 'LF on time. 119 | End If 120 | Else 121 | GetLine = "" 122 | End If 123 | End Function 124 | 125 | Public Property Get HasLine() As Boolean 126 | HasLine = mHasLine 127 | End Property 128 | 129 | Public Property Get Length() As Long 130 | Length = CharsInUse 131 | End Property 132 | 133 | Public Sub PeekBuffer(ByRef Data As String) 134 | Data = Left$(Buffer, CharsInUse) 135 | End Sub 136 | 137 | #If SPB_DEBUG Then 138 | Public Property Get PeekDebug() As String 139 | 'MEANT ONLY FOR DEBUGGING. 140 | 'DUMPS BUFFER IN HEX. 141 | Dim CharX As Long 142 | 143 | PeekDebug = "" 144 | For CharX = 1 To CharsInUse 145 | PeekDebug = PeekDebug _ 146 | & Right$("0" & Hex$(Asc(Mid$(Buffer, CharX, 1))), 2) & " " 147 | Next 148 | End Property 149 | #End If 150 | 151 | Private Sub Class_Initialize() 152 | Clear 153 | End Sub -------------------------------------------------------------------------------- /SPBuffer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "SPBuffer" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | ' 16 | 'SPBuffer 17 | '======== 18 | ' 19 | 'A buffer class for use with stream data that arrives in chunks, 20 | 'where the data is to be extracted in "lines" delimited by vbCr 21 | 'sequences or in entirety. 22 | ' 23 | 24 | #Const SPB_DEBUG = False 25 | 26 | Private Const CHUNK_SIZE As Long = 1000 27 | Private Const CHUNK_SOFT_LIMIT As Long = CHUNK_SIZE * 10 28 | 29 | Private Buffer As String 30 | Private CharsInUse As Long 31 | Private mHasLine As Boolean 32 | 33 | Public Sub Append(ByVal Text As String) 34 | Dim TextLen As Long 35 | Dim BufferLen As Long 36 | Dim Temp As String 37 | 38 | TextLen = Len(Text) 39 | If TextLen > 0 Then 40 | BufferLen = Len(Buffer) 41 | Do While TextLen + CharsInUse > BufferLen 42 | BufferLen = BufferLen + CHUNK_SIZE 43 | Loop 44 | If BufferLen > Len(Buffer) Then 45 | Temp = Left$(Buffer, CharsInUse) 46 | Buffer = String$(BufferLen, 0) 47 | Mid$(Buffer, 1) = Temp 48 | End If 49 | Mid$(Buffer, CharsInUse + 1, TextLen) = Text 50 | CharsInUse = CharsInUse + TextLen 51 | mHasLine = mHasLine Or InStr(Text, vbCr) > 0 52 | End If 53 | End Sub 54 | 55 | Public Function Backspace(Optional ByVal Spaces As Long = 1) As Long 56 | If Spaces > CharsInUse Then Spaces = CharsInUse 57 | If Spaces > 0 Then 58 | CharsInUse = CharsInUse - Spaces 59 | If CharsInUse > 0 Then 60 | mHasLine = InStrRev(Buffer, vbCr, CharsInUse) > 0 61 | Else 62 | mHasLine = False 63 | End If 64 | End If 65 | Backspace = Spaces 66 | End Function 67 | 68 | Public Sub Clear() 69 | If Len(Buffer) > CHUNK_SOFT_LIMIT Then 70 | Buffer = String$(CHUNK_SOFT_LIMIT, 0) 71 | End If 72 | CharsInUse = 0 73 | mHasLine = False 74 | End Sub 75 | 76 | Private Sub DeleteChars(ByVal Length As Long) 77 | Dim strRemainder As String 78 | 79 | strRemainder = Mid$(Buffer, Length + 1, _ 80 | CharsInUse - Length) 81 | CharsInUse = Len(strRemainder) 82 | Mid$(Buffer, 1, CharsInUse) = strRemainder 83 | mHasLine = InStr(strRemainder, vbCr) > 0 84 | End Sub 85 | 86 | Public Sub DeleteData(ByVal MaxLen As Long) 87 | If MaxLen > 0 Then 88 | If MaxLen > CharsInUse Then MaxLen = CharsInUse 89 | DeleteChars MaxLen 90 | End If 91 | End Sub 92 | 93 | Public Function GetData(Optional ByVal MaxLen As Long = -1) As String 94 | If MaxLen < 0 Then 95 | GetData = Left$(Buffer, CharsInUse) 96 | Clear 97 | ElseIf MaxLen = 0 Then 98 | GetData = "" 99 | Else 100 | If MaxLen > CharsInUse Then MaxLen = CharsInUse 101 | GetData = Left$(Buffer, MaxLen) 102 | DeleteChars MaxLen 103 | End If 104 | End Function 105 | 106 | Public Function GetLine() As String 107 | 'A "line" is anything delimited by a CR, but also filter 108 | 'out any LF characters for cases where CRLF delimits lines. 109 | 'We see both conventions used in StdIO programs. 110 | Dim lngLineEnd As Long 111 | 112 | If mHasLine Then 113 | If Left$(Buffer, 1) = vbLf Then DeleteChars 1 'LF arrived late. 114 | lngLineEnd = InStr(Buffer, vbCr) 115 | GetLine = Left$(Buffer, lngLineEnd - 1) 116 | DeleteChars lngLineEnd 117 | If CharsInUse > 0 Then 118 | If Left$(Buffer, 1) = vbLf Then DeleteChars 1 'LF on time. 119 | End If 120 | Else 121 | GetLine = "" 122 | End If 123 | End Function 124 | 125 | Public Property Get HasLine() As Boolean 126 | HasLine = mHasLine 127 | End Property 128 | 129 | Public Property Get Length() As Long 130 | Length = CharsInUse 131 | End Property 132 | 133 | Public Sub PeekBuffer(ByRef Data As String) 134 | Data = Left$(Buffer, CharsInUse) 135 | End Sub 136 | 137 | #If SPB_DEBUG Then 138 | Public Property Get PeekDebug() As String 139 | 'MEANT ONLY FOR DEBUGGING. 140 | 'DUMPS BUFFER IN HEX. 141 | Dim CharX As Long 142 | 143 | PeekDebug = "" 144 | For CharX = 1 To CharsInUse 145 | PeekDebug = PeekDebug _ 146 | & Right$("0" & Hex$(Asc(Mid$(Buffer, CharX, 1))), 2) & " " 147 | Next 148 | End Property 149 | #End If 150 | 151 | Private Sub Class_Initialize() 152 | Clear 153 | End Sub 154 | -------------------------------------------------------------------------------- /utf8/enumeration.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "Enumeration" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | Private Declare Function CLSIDFromString Lib "ole32.dll" ( _ 16 | ByVal lpszCLSID As Long, _ 17 | ByRef Clsid As GUID) As Long 18 | Public EnumName As String 19 | Private iGUID As GUID 20 | Public LastGUIDstr As String 21 | Private Type item 22 | Key As String 23 | KeyUCase As String 24 | iValue As Variant 25 | Pad As String 26 | End Type 27 | Public Done As Boolean 28 | Public Index As Long 29 | Private PriveSpace() As item, mInterface As Boolean 30 | Dim MaxSpace As Long 31 | Dim toplim As Long 32 | Private Sub Class_Initialize() 33 | MaxSpace = 20 34 | ReDim PriveSpace(MaxSpace) As item 35 | toplim = -1 36 | End Sub 37 | Property Get Value() As Variant 38 | Done = False 39 | If Index = -1 Then 40 | Else 41 | Done = True 42 | Value = PriveSpace(Index).iValue 43 | 44 | End If 45 | End Property 46 | Property Get PadValue() As String 47 | Done = False 48 | If Index = -1 Then 49 | Else 50 | Done = True 51 | PadValue = PriveSpace(Index).Pad 52 | End If 53 | End Property 54 | 55 | Property Let Guidonce(s As String) 56 | If toplim = -1 Then 57 | mInterface = CLSIDFromString(StrPtr(s), iGUID) = 0 58 | If mInterface Then 59 | LastGUIDstr = s 60 | End If 61 | End If 62 | End Property 63 | Property Get IsInterface() As Boolean 64 | IsInterface = mInterface 65 | End Property 66 | Property Get GuidAddr() As Long 67 | GuidAddr = VarPtr(iGUID) 68 | End Property 69 | 70 | Private Function Malloc() As Long 71 | If toplim + 1 >= MaxSpace Then 72 | MaxSpace = MaxSpace * 2 73 | ReDim Preserve PriveSpace(MaxSpace) As item 74 | End If 75 | toplim = toplim + 1 76 | Malloc = toplim 77 | End Function 78 | Property Get Count() 79 | Count = toplim + 1 80 | End Property 81 | Property Get ZeroValue() 82 | If toplim >= 0 Then ZeroValue = PriveSpace(0).iValue 83 | End Property 84 | 85 | Property Get IsEmpty() 86 | IsEmpty = toplim = -1 87 | End Property 88 | 89 | Public Sub addone(Key As String, nValue As Variant) 90 | Dim a As Long 91 | a = Malloc() 92 | With PriveSpace(a) 93 | .Key = Key 94 | .KeyUCase = myUcase(Key, True) 95 | .iValue = nValue 96 | End With 97 | End Sub 98 | Public Sub addone1(Key As String, nValue As Variant, pd$) 99 | Dim a As Long 100 | a = Malloc() 101 | With PriveSpace(a) 102 | .Key = Key 103 | .KeyUCase = myUcase(Key, True) 104 | .iValue = nValue 105 | .Pad = pd$ 106 | End With 107 | End Sub 108 | Function ExistFromOther(RHS) As Boolean 109 | Dim i As Long 110 | For i = 0 To toplim 111 | If RHS = PriveSpace(i).iValue Then ExistFromOther = True: Exit Function 112 | Next i 113 | End Function 114 | Function ExistFromOther2(useHandler As mHandler) As Boolean 115 | Dim other As Enumeration 116 | Set other = useHandler.objref 117 | other.Index = useHandler.index_start 118 | Dim s$, i As Long 119 | s$ = other.KeyToString 120 | For i = 0 To toplim 121 | If s$ = PriveSpace(i).Key Then ExistFromOther2 = True: useHandler.index_start = i: Exit For 122 | Next i 123 | 124 | End Function 125 | Function SearchSimple(what As String, ByRef ok As Boolean) As Variant 126 | Dim i As Long 127 | For i = 0 To toplim 128 | If what = PriveSpace(i).KeyUCase Then ok = True: SearchSimple = PriveSpace(i).iValue: Index = i: Exit Function 129 | Next i 130 | End Function 131 | Function SearchValue(v As Variant, ByRef ok As Boolean) As Variant 132 | Dim i As Long, mm As mHandler 133 | ok = False 134 | again: 135 | For i = 0 To toplim 136 | If v = PriveSpace(i).iValue Then 137 | ok = True 138 | Set mm = New mHandler 139 | mm.t1 = 4 140 | Set mm.objref = Me 141 | mm.index_cursor = v 142 | mm.index_start = i 143 | mm.sign = 1 144 | Set SearchValue = mm 145 | Exit Function 146 | End If 147 | Next i 148 | If Not ok Then 149 | If MemInt(VarPtr(v)) = vbString Then 150 | v = val(v) 151 | GoTo again 152 | Else 153 | 154 | v = -v 155 | For i = 0 To toplim 156 | If v = PriveSpace(i).iValue Then 157 | ok = True 158 | Set mm = New mHandler 159 | mm.t1 = 4 160 | Set mm.objref = Me 161 | mm.index_cursor = v 162 | mm.index_start = i 163 | mm.sign = -1 164 | Set SearchValue = mm 165 | Exit Function 166 | End If 167 | Next i 168 | End If 169 | End If 170 | Set SearchValue = New mHandler 171 | End Function 172 | Public Property Get KeyToString() As Variant 173 | If Index <> -1 Then KeyToString = PriveSpace(Index).Key 174 | End Property 175 | 176 | Private Sub Class_Terminate() 177 | Erase PriveSpace() 178 | End Sub 179 | 180 | -------------------------------------------------------------------------------- /Enumeration.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "Enumeration" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | Private Declare Function CLSIDFromString Lib "ole32.dll" ( _ 16 | ByVal lpszCLSID As Long, _ 17 | ByRef Clsid As GUID) As Long 18 | Public EnumName As String 19 | Private iGUID As GUID 20 | Public LastGUIDstr As String 21 | Private Type item 22 | Key As String 23 | KeyUCase As String 24 | iValue As Variant 25 | Pad As String 26 | End Type 27 | Public Done As Boolean 28 | Public Index As Long 29 | Private PriveSpace() As item, mInterface As Boolean 30 | Dim MaxSpace As Long 31 | Dim toplim As Long 32 | Private Sub Class_Initialize() 33 | MaxSpace = 20 34 | ReDim PriveSpace(MaxSpace) As item 35 | toplim = -1 36 | End Sub 37 | Property Get Value() As Variant 38 | Done = False 39 | If Index = -1 Then 40 | Else 41 | Done = True 42 | Value = PriveSpace(Index).iValue 43 | 44 | End If 45 | End Property 46 | Property Get PadValue() As String 47 | Done = False 48 | If Index = -1 Then 49 | Else 50 | Done = True 51 | PadValue = PriveSpace(Index).Pad 52 | End If 53 | End Property 54 | 55 | Property Let Guidonce(s As String) 56 | If toplim = -1 Then 57 | mInterface = CLSIDFromString(StrPtr(s), iGUID) = 0 58 | If mInterface Then 59 | LastGUIDstr = s 60 | End If 61 | End If 62 | End Property 63 | Property Get IsInterface() As Boolean 64 | IsInterface = mInterface 65 | End Property 66 | Property Get GuidAddr() As Long 67 | GuidAddr = VarPtr(iGUID) 68 | End Property 69 | 70 | Private Function Malloc() As Long 71 | If toplim + 1 >= MaxSpace Then 72 | MaxSpace = MaxSpace * 2 73 | ReDim Preserve PriveSpace(MaxSpace) As item 74 | End If 75 | toplim = toplim + 1 76 | Malloc = toplim 77 | End Function 78 | Property Get Count() 79 | Count = toplim + 1 80 | End Property 81 | Property Get ZeroValue() 82 | If toplim >= 0 Then ZeroValue = PriveSpace(0).iValue 83 | End Property 84 | 85 | Property Get IsEmpty() 86 | IsEmpty = toplim = -1 87 | End Property 88 | 89 | Public Sub addone(Key As String, nValue As Variant) 90 | Dim a As Long 91 | a = Malloc() 92 | With PriveSpace(a) 93 | .Key = Key 94 | .KeyUCase = myUcase(Key, True) 95 | .iValue = nValue 96 | End With 97 | End Sub 98 | Public Sub addone1(Key As String, nValue As Variant, pd$) 99 | Dim a As Long 100 | a = Malloc() 101 | With PriveSpace(a) 102 | .Key = Key 103 | .KeyUCase = myUcase(Key, True) 104 | .iValue = nValue 105 | .Pad = pd$ 106 | End With 107 | End Sub 108 | Function ExistFromOther(RHS) As Boolean 109 | Dim i As Long 110 | For i = 0 To toplim 111 | If RHS = PriveSpace(i).iValue Then ExistFromOther = True: Exit Function 112 | Next i 113 | End Function 114 | Function ExistFromOther2(useHandler As mHandler) As Boolean 115 | Dim other As Enumeration 116 | Set other = useHandler.objref 117 | other.Index = useHandler.index_start 118 | Dim s$, i As Long 119 | s$ = other.KeyToString 120 | For i = 0 To toplim 121 | If s$ = PriveSpace(i).Key Then ExistFromOther2 = True: useHandler.index_start = i: Exit For 122 | Next i 123 | 124 | End Function 125 | Function SearchSimple(what As String, ByRef ok As Boolean) As Variant 126 | Dim i As Long 127 | For i = 0 To toplim 128 | If what = PriveSpace(i).KeyUCase Then ok = True: SearchSimple = PriveSpace(i).iValue: Index = i: Exit Function 129 | Next i 130 | End Function 131 | Function SearchValue(v As Variant, ByRef ok As Boolean) As Variant 132 | Dim i As Long, mm As mHandler 133 | ok = False 134 | again: 135 | For i = 0 To toplim 136 | If v = PriveSpace(i).iValue Then 137 | ok = True 138 | Set mm = New mHandler 139 | mm.t1 = 4 140 | Set mm.objref = Me 141 | mm.index_cursor = v 142 | mm.index_start = i 143 | mm.sign = 1 144 | Set SearchValue = mm 145 | Exit Function 146 | End If 147 | Next i 148 | If Not ok Then 149 | If MemInt(VarPtr(v)) = vbString Then 150 | v = val(v) 151 | GoTo again 152 | Else 153 | 154 | v = -v 155 | For i = 0 To toplim 156 | If v = PriveSpace(i).iValue Then 157 | ok = True 158 | Set mm = New mHandler 159 | mm.t1 = 4 160 | Set mm.objref = Me 161 | mm.index_cursor = v 162 | mm.index_start = i 163 | mm.sign = -1 164 | Set SearchValue = mm 165 | Exit Function 166 | End If 167 | Next i 168 | End If 169 | End If 170 | Set SearchValue = New mHandler 171 | End Function 172 | Public Property Get KeyToString() As Variant 173 | If Index <> -1 Then KeyToString = PriveSpace(Index).Key 174 | End Property 175 | 176 | Private Sub Class_Terminate() 177 | Erase PriveSpace() 178 | End Sub 179 | 180 | 181 | -------------------------------------------------------------------------------- /M2000.vbw: -------------------------------------------------------------------------------- 1 | gList = 226, 103, 784, 716, , 26, 26, 703, 519, C 2 | AVI = 0, 0, 0, 0, C, 52, 52, 729, 545, C 3 | Form4 = 260, 260, 1302, 909, , 78, 78, 755, 571, C 4 | Form3 = 0, 0, 0, 0, C, 104, 104, 781, 597, C 5 | TweakForm = 26, 26, 844, 426, , 130, 130, 807, 623, C 6 | globalvars = 65, 0, 1287, 578, 7 | helpmod = 0, 0, 0, 0, C 8 | Form2 = 0, 0, 0, 0, C, 156, 156, 833, 649, C 9 | Module6 = 0, 0, 0, 0, C 10 | databaseX = 0, 0, 818, 400, 11 | Module3 = 182, 182, 821, 628, 12 | gpp1 = 104, 104, 953, 700, 13 | AnyPrinter = 0, 0, 0, 0, C 14 | Module5 = 182, 182, 1449, 741, 15 | Module2 = 234, 234, 827, 807, 16 | PicHandler = 26, 26, 585, 519, 17 | Module4 = 78, 78, 1526, 611, 18 | cDIBSection = 208, 208, 1528, 712, 19 | clsProfiler = 0, 0, 0, 0, C 20 | coder = 0, 0, 0, 0, C 21 | counter = 0, 0, 0, 0, C 22 | cRegistry = 0, 0, 0, 0, C 23 | TaskInterface = 0, 0, 0, 0, C 24 | mArray = 156, 156, 1334, 728, 25 | MovieModule = 52, 52, 1415, 480, 26 | mStiva = 156, 156, 1435, 626, 27 | mThreadref = 0, 0, 0, 0, C 28 | MusicBox = 0, 0, 0, 0, C 29 | MyProcess = 52, 52, 1312, 604, 30 | RecordMci = 0, 0, 0, 0, C 31 | TaskBase = 26, 26, 1286, 578, 32 | TaskMaster = 0, 0, 0, 0, C 33 | VarItem = 0, 0, 0, 0, C 34 | mHLSRGB = 0, 0, 0, 0, C 35 | LoadFile = 78, 78, 935, 524, , 182, 182, 859, 675, C 36 | FontDialog = 156, 156, 1447, 715, , 208, 208, 885, 701, C 37 | ColorDialog = 0, 0, 0, 0, C, 0, 0, 677, 493, C 38 | FileSelector = 156, 156, 1354, 689, 39 | Document = 104, 104, 1361, 700, 40 | recDir = 0, 0, 0, 0, C 41 | TextViewer = 52, 52, 1033, 625, 42 | dropdownlist = 0, 0, 0, 0, C 43 | myTextBox = 208, 208, 1329, 786, 44 | myCheckBox = 0, 0, 0, 0, C 45 | myButton = 0, 0, 0, 0, C 46 | InterPress = 0, 0, 0, 0, C 47 | NeoMsgBox = 0, 0, 0, 0, C, 26, 26, 703, 519, C 48 | ExifRead = 0, 0, 0, 0, C 49 | Fcall = 208, 208, 1270, 666, 50 | Group = 156, 156, 1438, 734, 51 | stdCallFunction = 104, 104, 1166, 562, C 52 | mdlIDispatch = 234, 234, 1521, 812, 53 | PropReference = 208, 208, 859, 654, 54 | Module1 = 26, 26, 585, 519, Z 55 | MyPopUp = 156, 156, 1013, 602, , 52, 52, 729, 545, C 56 | Module7 = 182, 182, 741, 675, C 57 | cJpeg = 0, 0, 0, 0, C 58 | Hash = 182, 182, 1512, 761, 59 | sbHash = 0, 0, 0, 0, C 60 | mEvent = 0, 0, 0, 0, C 61 | GuiM2000 = 208, 208, 1189, 781, , 78, 78, 755, 571, C 62 | GuiButton = 0, 0, 0, 0, C 63 | GuiTextBox = 234, 234, 1355, 812, 64 | GuiCheckBox = 0, 0, 0, 0, C 65 | GuiEditBox = 52, 52, 1033, 625, 66 | GuiListBox = 130, 130, 1251, 708, 67 | GuiDropDown = 78, 78, 717, 524, 68 | lambda = 0, 0, 0, 0, C 69 | FastCollection = 52, 52, 1408, 522, 70 | basetask = 208, 208, 1142, 697, 71 | mHandler = 182, 182, 1396, 741, 72 | MemBlock = 52, 52, 1016, 474, 73 | callback = 156, 156, 1277, 734, 74 | CallBack2 = 0, 0, 0, 0, C 75 | ComShinkEvent = 104, 104, 1166, 562, 76 | modObjectExtender = 182, 182, 1163, 755, 77 | modUnregCOM = 104, 104, 923, 550, 78 | Module8 = 0, 0, 0, 0, C 79 | LongHash = 0, 0, 0, 0, C 80 | Constant = 0, 0, 0, 0, C 81 | Module9 = 0, 0, 0, 0, C 82 | idHash = 0, 0, 0, 0, C 83 | clsOSInfo = 52, 52, 909, 498, 84 | Math = 234, 234, 1200, 809, 85 | Form1 = 78, 78, 1408, 657, , 104, 104, 781, 597, C 86 | Form5 = 0, 0, 0, 0, C, 130, 130, 807, 623, C 87 | modGDIPlusResize = 208, 208, 1538, 787, 88 | ThreadsClass = 0, 0, 0, 0, C 89 | Enumeration = 0, 0, 0, 0, C 90 | mStiva2 = 78, 78, 1427, 497, 91 | Mutex = 0, 0, 0, 0, C 92 | Module10 = 26, 26, 952, 599, 93 | safeforms = 0, 0, 0, 0, C 94 | cHttpDownload = 182, 182, 1039, 628, C 95 | cTlsClient = 208, 208, 1065, 654, 96 | GetAdaptsInfo = 208, 208, 1216, 767, 97 | Mk2Base = 0, 0, 0, 0, C 98 | ShellPipe = 0, 0, 0, 0, C 99 | SPBuffer = 0, 0, 0, 0, C 100 | SerialPort = 0, 0, 0, 0, C 101 | MetaDc = 156, 156, 1229, 752, 102 | Module11 = 52, 52, 1214, 710, 103 | cZipArchive = 26, 26, 677, 472, 104 | ZipTool = 0, 0, 0, 0, C 105 | XmlMonoInternal = 78, 78, 1240, 736, 106 | XmlMono = 130, 130, 1308, 702, 107 | XmlNode = 0, 0, 0, 0, C 108 | JsonArray = 0, 0, 0, 0, C 109 | JsonObject = 0, 0, 0, 0, C 110 | mIndexes = 0, 0, 0, 0, C 111 | ErrorBag = 0, 0, 0, 0, C 112 | SinkEvent = 0, 0, 0, 0, C 113 | cTlsSocket = 0, 0, 857, 446, 114 | clsHttpsRequest = 0, 0, 0, 0, C 115 | cAsyncSocket = 26, 26, 883, 472, 116 | GuiImage = 26, 26, 1007, 599, 117 | mdQRCodegen = 130, 130, 1151, 588, 118 | ucPieChart = 182, 182, 1140, 760, C, 156, 156, 833, 649, C 119 | ExtControl = 234, 234, 1215, 807, 120 | ucChartArea = 26, 26, 996, 604, C, 182, 182, 859, 675, C 121 | ctxNineButton = 130, 130, 1405, 708, , 208, 208, 885, 701, C 122 | cNinePatch = 208, 208, 832, 654, 123 | ShapeEx = 26, 26, 984, 604, , 0, 0, 677, 493, C 124 | ucRadialProgress = 52, 52, 1022, 630, , 26, 26, 703, 519, C 125 | RefArray = 130, 130, 949, 576, C 126 | HashList = 26, 26, 993, 602, 127 | iBoxArray = 286, 286, 1578, 859, 128 | ppppLight = 0, 0, 926, 573, 129 | LibMemory = 104, 104, 1123, 619, 130 | cRateLimiter = 0, 0, 624, 446, 131 | ctxWinsock = 52, 52, 1327, 630, , 52, 52, 729, 545, C 132 | mdTlsThunks = 208, 208, 1396, 732, 133 | IControlIndex = 0, 0, 0, 0, C 134 | MATH2 = 26, 26, 650, 472, 135 | BigInteger = 78, 78, 1096, 591, 136 | Module13 = 234, 234, 1354, 892, 137 | tuple = 130, 130, 1082, 665, 138 | ucChartBar = 52, 52, 562, 498, , 0, 0, 752, 578, C 139 | cBarCode = 0, 0, 351, 527, 140 | -------------------------------------------------------------------------------- /utf8/longhash.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "LongHash" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | Private Type item 16 | Key As Long 17 | Container As String 18 | infostr As String 19 | firsthash As Long 20 | lastpos As Long 21 | Pleft As Long ' a list 22 | End Type 23 | ' 24 | Private PriveSpace() As item 25 | Dim MaxSpace As Long 26 | Dim hashlen As Long 27 | Dim lastkey As Long, lastfind As Long 28 | Dim toplim As Long 29 | Private ParentIndex As Long 30 | Public Done As Boolean 31 | Public index As Long 32 | Private Hash() As Long 33 | 34 | Private Sub Class_Initialize() 35 | MaxSpace = 30 36 | ReDim PriveSpace(MaxSpace) As item, Hash(MaxSpace * 2 + 3) 37 | hashlen = MaxSpace * 2 + 3 38 | toplim = -1 39 | End Sub 40 | Public Sub ForceFlush(NewSpace As Long) 41 | MaxSpace = NewSpace 42 | ReDim PriveSpace(MaxSpace) As item, Hash(MaxSpace * 2 + 3) 43 | hashlen = MaxSpace * 2 + 3 44 | toplim = -1 45 | End Sub 46 | 47 | Private Sub ExpandHash() 48 | Dim i As Long 49 | hashlen = hashlen * 2 + 3 50 | 51 | ReDim Hash(hashlen) As Long 52 | For i = 0 To toplim 53 | place HashFunc2(i), i 54 | Next i 55 | End Sub 56 | 57 | 58 | Private Function Malloc() As Long 59 | If toplim + 1 >= MaxSpace Then 60 | '' expand hash 61 | MaxSpace = MaxSpace * 2 62 | ReDim Preserve PriveSpace(MaxSpace) As item 63 | If MaxSpace > hashlen Then ExpandHash 64 | End If 65 | toplim = toplim + 1 66 | Malloc = toplim 67 | End Function 68 | Property Get Count() 69 | Count = toplim + 1 70 | End Property 71 | Private Function Find(Key As Long) As Boolean 72 | Dim k As Long 73 | ParentIndex = -1 74 | Done = False 75 | k = Hash(HashFunc(Key)) - 1 76 | If k >= 0 Then 77 | Do 78 | If PriveSpace(k).Key = Key Then 79 | Find = True: lastfind = Key: index = k: Exit Function 80 | End If 81 | ParentIndex = k 82 | k = PriveSpace(k).Pleft - 1 83 | Loop Until k < 0 84 | End If 85 | End Function 86 | Friend Function ExistKey(Key As Long) As Boolean 87 | Dim k As Long 88 | Done = False 89 | k = Hash(HashFunc(Key)) - 1 90 | If k >= 0 Then 91 | Do 92 | If PriveSpace(k).Key = Key Then ExistKey = True: index = k: Done = True: Exit Function 93 | k = PriveSpace(k).Pleft - 1 94 | Loop Until k < 0 95 | End If 96 | End Function 97 | 98 | Public Property Get Key() As Long 99 | If index > -1 Then 100 | Key = PriveSpace(index).Key 101 | End If 102 | End Property 103 | Public Property Get child() As Boolean 104 | If index > -1 Then 105 | child = Hash(PriveSpace(index).lastpos) - 1 <> index 106 | End If 107 | End Property 108 | Public Property Get HasCollision() As Boolean 109 | If index > -1 Then 110 | HasCollision = (Hash(PriveSpace(index).lastpos) - 1 <> index) Or (PriveSpace(index).Pleft > 0) 111 | End If 112 | End Property 113 | Public Sub AddKey(RHS As Long, Optional aValue As String = vbNullString, Optional aInfo As String = vbNullString) 114 | index = -1 115 | lastkey = RHS 116 | Done = False 117 | ItemCreator lastkey, aValue, aInfo 118 | 119 | End Sub 120 | 121 | Private Sub ItemCreator(Key As Long, storethis As String, andthis As String) 122 | Dim a As Long, first As Long 123 | Done = False 124 | first = HD(Key) 125 | a = Malloc() 126 | With PriveSpace(a) 127 | .Key = Key 128 | .Container = storethis 129 | .infostr = andthis 130 | .firsthash = first 131 | place HashFunc1(first), a 132 | End With 133 | End Sub 134 | Public Sub ItemCreator2(Key As Long, storethis As String) 135 | Dim first As Long 136 | first = HD(Key) 137 | index = Malloc() 138 | With PriveSpace(index) 139 | .Key = Key 140 | .Container = storethis 141 | .firsthash = first 142 | place HashFunc1(first), index 143 | End With 144 | End Sub 145 | 146 | Private Sub place(ByVal b, ByVal a) 147 | Dim k As Long 148 | k = Hash(b) 149 | If Not Hash(b) = a + 1 Then 150 | Hash(b) = a + 1 151 | PriveSpace(a).Pleft = k 152 | End If 153 | PriveSpace(a).lastpos = b 154 | End Sub 155 | Private Function HashFunc2(where As Long) 156 | HashFunc2 = PriveSpace(where).firsthash Mod hashlen 157 | End Function 158 | Public Function HD(ByVal v As Long) As Long 159 | If v = 0 Then v = 1 Else HD = Abs(v) 160 | End Function 161 | Private Function HashFunc1(readyhash) 162 | HashFunc1 = readyhash Mod hashlen 163 | End Function 164 | Private Function HashFunc(a As Long) 165 | HashFunc = HD(a) Mod hashlen 166 | End Function 167 | 168 | Property Get Value() As String 169 | If index = -1 Then 170 | Else 171 | Value = PriveSpace(index).Container 172 | End If 173 | End Property 174 | Property Let ValueStr(RHS As String) 175 | If index = -1 Then 176 | Else 177 | PriveSpace(index).Container = RHS 178 | End If 179 | End Property 180 | 181 | Property Get StrPointer() As Long 182 | If index = -1 Then 183 | Else 184 | StrPointer = StrPtr(PriveSpace(index).Container) 185 | End If 186 | End Property 187 | 188 | Property Get Info() As String 189 | If index = -1 Then 190 | Else 191 | Info = PriveSpace(index).infostr 192 | End If 193 | End Property 194 | Property Get Percent() 195 | Percent = 100 * Count / hashlen 196 | End Property 197 | 198 | -------------------------------------------------------------------------------- /LongHash.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "LongHash" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | Private Type item 16 | Key As Long 17 | Container As String 18 | infostr As String 19 | firsthash As Long 20 | lastpos As Long 21 | Pleft As Long ' a list 22 | End Type 23 | ' 24 | Private PriveSpace() As item 25 | Dim MaxSpace As Long 26 | Dim hashlen As Long 27 | Dim lastkey As Long, lastfind As Long 28 | Dim toplim As Long 29 | Private ParentIndex As Long 30 | Public Done As Boolean 31 | Public index As Long 32 | Private Hash() As Long 33 | 34 | Private Sub Class_Initialize() 35 | MaxSpace = 30 36 | ReDim PriveSpace(MaxSpace) As item, Hash(MaxSpace * 2 + 3) 37 | hashlen = MaxSpace * 2 + 3 38 | toplim = -1 39 | End Sub 40 | Public Sub ForceFlush(NewSpace As Long) 41 | MaxSpace = NewSpace 42 | ReDim PriveSpace(MaxSpace) As item, Hash(MaxSpace * 2 + 3) 43 | hashlen = MaxSpace * 2 + 3 44 | toplim = -1 45 | End Sub 46 | 47 | Private Sub ExpandHash() 48 | Dim i As Long 49 | hashlen = hashlen * 2 + 3 50 | 51 | ReDim Hash(hashlen) As Long 52 | For i = 0 To toplim 53 | place HashFunc2(i), i 54 | Next i 55 | End Sub 56 | 57 | 58 | Private Function Malloc() As Long 59 | If toplim + 1 >= MaxSpace Then 60 | '' expand hash 61 | MaxSpace = MaxSpace * 2 62 | ReDim Preserve PriveSpace(MaxSpace) As item 63 | If MaxSpace > hashlen Then ExpandHash 64 | End If 65 | toplim = toplim + 1 66 | Malloc = toplim 67 | End Function 68 | Property Get Count() 69 | Count = toplim + 1 70 | End Property 71 | Private Function Find(Key As Long) As Boolean 72 | Dim k As Long 73 | ParentIndex = -1 74 | Done = False 75 | k = Hash(HashFunc(Key)) - 1 76 | If k >= 0 Then 77 | Do 78 | If PriveSpace(k).Key = Key Then 79 | Find = True: lastfind = Key: index = k: Exit Function 80 | End If 81 | ParentIndex = k 82 | k = PriveSpace(k).Pleft - 1 83 | Loop Until k < 0 84 | End If 85 | End Function 86 | Friend Function ExistKey(Key As Long) As Boolean 87 | Dim k As Long 88 | Done = False 89 | k = Hash(HashFunc(Key)) - 1 90 | If k >= 0 Then 91 | Do 92 | If PriveSpace(k).Key = Key Then ExistKey = True: index = k: Done = True: Exit Function 93 | k = PriveSpace(k).Pleft - 1 94 | Loop Until k < 0 95 | End If 96 | End Function 97 | 98 | Public Property Get Key() As Long 99 | If index > -1 Then 100 | Key = PriveSpace(index).Key 101 | End If 102 | End Property 103 | Public Property Get child() As Boolean 104 | If index > -1 Then 105 | child = Hash(PriveSpace(index).lastpos) - 1 <> index 106 | End If 107 | End Property 108 | Public Property Get HasCollision() As Boolean 109 | If index > -1 Then 110 | HasCollision = (Hash(PriveSpace(index).lastpos) - 1 <> index) Or (PriveSpace(index).Pleft > 0) 111 | End If 112 | End Property 113 | Public Sub AddKey(RHS As Long, Optional aValue As String = vbNullString, Optional aInfo As String = vbNullString) 114 | index = -1 115 | lastkey = RHS 116 | Done = False 117 | ItemCreator lastkey, aValue, aInfo 118 | 119 | End Sub 120 | 121 | Private Sub ItemCreator(Key As Long, storethis As String, andthis As String) 122 | Dim a As Long, first As Long 123 | Done = False 124 | first = HD(Key) 125 | a = Malloc() 126 | With PriveSpace(a) 127 | .Key = Key 128 | .Container = storethis 129 | .infostr = andthis 130 | .firsthash = first 131 | place HashFunc1(first), a 132 | End With 133 | End Sub 134 | Public Sub ItemCreator2(Key As Long, storethis As String) 135 | Dim first As Long 136 | first = HD(Key) 137 | index = Malloc() 138 | With PriveSpace(index) 139 | .Key = Key 140 | .Container = storethis 141 | .firsthash = first 142 | place HashFunc1(first), index 143 | End With 144 | End Sub 145 | 146 | Private Sub place(ByVal b, ByVal a) 147 | Dim k As Long 148 | k = Hash(b) 149 | If Not Hash(b) = a + 1 Then 150 | Hash(b) = a + 1 151 | PriveSpace(a).Pleft = k 152 | End If 153 | PriveSpace(a).lastpos = b 154 | End Sub 155 | Private Function HashFunc2(where As Long) 156 | HashFunc2 = PriveSpace(where).firsthash Mod hashlen 157 | End Function 158 | Public Function HD(ByVal v As Long) As Long 159 | If v = 0 Then v = 1 Else HD = Abs(v) 160 | End Function 161 | Private Function HashFunc1(readyhash) 162 | HashFunc1 = readyhash Mod hashlen 163 | End Function 164 | Private Function HashFunc(a As Long) 165 | HashFunc = HD(a) Mod hashlen 166 | End Function 167 | 168 | Property Get Value() As String 169 | If index = -1 Then 170 | Else 171 | Value = PriveSpace(index).Container 172 | End If 173 | End Property 174 | Property Let ValueStr(RHS As String) 175 | If index = -1 Then 176 | Else 177 | PriveSpace(index).Container = RHS 178 | End If 179 | End Property 180 | 181 | Property Get StrPointer() As Long 182 | If index = -1 Then 183 | Else 184 | StrPointer = StrPtr(PriveSpace(index).Container) 185 | End If 186 | End Property 187 | 188 | Property Get Info() As String 189 | If index = -1 Then 190 | Else 191 | Info = PriveSpace(index).infostr 192 | End If 193 | End Property 194 | Property Get Percent() 195 | Percent = 100 * Count / hashlen 196 | End Property 197 | 198 | 199 | -------------------------------------------------------------------------------- /utf8/propreference.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "PropReference" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | Dim ObjectRef As Long 16 | Dim vtref As Long 17 | Dim mIndex As Variant 18 | Public UseIndex As Boolean 19 | Dim Init As Boolean 20 | Dim IamMethod As Boolean 21 | Dim hardlink As Object, useobj As Boolean 22 | Private mLastObj As Object 23 | Public arr As Boolean 24 | Dim oEnum As IUnknown 25 | Private IndexList As mIndexes 26 | Private IndexNew As Boolean 27 | Function IsObj() 28 | IsObj = useobj 29 | End Function 30 | Property Get ObjectType() As String 31 | On Error Resume Next 32 | If Not hardlink Is Nothing Then 33 | ObjectType = "*" + Typename(ObjectRef) 34 | Else 35 | ObjectType = "[" + Typename(var(ObjectRef)) + "]" 36 | End If 37 | End Property 38 | Sub Construct(ref As Long, vtrefnumber As Long, Optional indirect As Boolean = False) 39 | If useobj Then Exit Sub 40 | Init = True 41 | 42 | ObjectRef = ref 43 | If indirect Then 44 | vtref = -vtrefnumber 45 | Else 46 | vtref = vtrefnumber 47 | End If 48 | End Sub 49 | Sub ConstructObj(obj As Object, vtrefnumber As Long) 50 | Init = True 51 | Set hardlink = obj 52 | useobj = True 53 | 'ObjectRef = ref 54 | vtref = vtrefnumber 55 | End Sub 56 | Public Property Get lastobj() As Object 57 | Set lastobj = mLastObj 58 | End Property 59 | Public Property Get lastobjfinal() As Object 60 | Set lastobjfinal = mLastObj 61 | Set mLastObj = Nothing 62 | End Property 63 | Public Sub clearlastobject() 64 | Set mLastObj = Nothing 65 | End Sub 66 | Public Property Get Value() As Variant 67 | Dim v 68 | Dim RETVAR As Variant, retvar2, obj As Object 69 | Dim check As Boolean 70 | Set mLastObj = Nothing 71 | If Init Then 72 | If UseIndex Then 73 | If Not IndexNew Then 74 | Value = 0 75 | Set mLastObj = Me 76 | Exit Property 77 | ElseIf useobj Then 78 | IndexNew = False 79 | Value = ReadPropIndexObj(hardlink, vtref, mIndex) 80 | Else 81 | IndexNew = False 82 | Value = ReadPropIndex(ObjectRef, vtref, mIndex, check, RETVAR) 83 | If check And IsObject(RETVAR) Then 84 | On Error Resume Next 85 | Set obj = RETVAR 86 | If ReadOneParameter(obj, (0), vbNullString, retvar2) Then 87 | Value = retvar2 88 | Else 89 | Set mLastObj = RETVAR 90 | End If 91 | 92 | End If 93 | End If 94 | 95 | Else 96 | 97 | 98 | If useobj Then 99 | If ReadPropObj(hardlink, vtref, RETVAR) Then 100 | If IsObject(RETVAR) Then 101 | Value = 0 102 | Set mLastObj = RETVAR 103 | 104 | Else 105 | Value = RETVAR 106 | End If 107 | End If 108 | Else 109 | If ReadProp(ObjectRef, vtref, RETVAR) Then 110 | If IsObject(RETVAR) Then 111 | Value = 0 112 | Set mLastObj = RETVAR 113 | 114 | Else 115 | On Error Resume Next 116 | If TypeOf RETVAR Is IUnknown Then 117 | Value = 0 118 | Set mLastObj = RETVAR: Exit Property 119 | End If 120 | Err.Clear 121 | Value = RETVAR 122 | End If 123 | End If 124 | End If 125 | End If 126 | Else 127 | ' ?????????? 128 | 129 | End If 130 | 'If Not IsObject(Value) Then Debug.Print Value 131 | End Property 132 | Public Property Let Value(vNewValue As Variant) 133 | If Init Then 134 | If Not UseIndex Then 135 | If useobj Then 136 | WritePropObj hardlink, vtref, vNewValue 137 | Else 138 | WriteProp ObjectRef, vtref, vNewValue 139 | End If 140 | ElseIf Not IndexNew Then 141 | MyEr "Missing index", "Έχασα τον δείκτη" 142 | Exit Property 143 | ElseIf useobj Then 144 | IndexNew = False 145 | WritePropIndexObj hardlink, vtref, vNewValue, mIndex 146 | Else 147 | IndexNew = False 148 | WritePropIndex ObjectRef, vtref, vNewValue, mIndex 149 | End If 150 | End If 151 | 152 | End Property 153 | Public Property Let ValueStr(s As String) 154 | Dim vNewValue 155 | vNewValue = vbNullString 156 | SwapString2Variant s, vNewValue 157 | If Init Then 158 | If Not UseIndex Then 159 | If useobj Then 160 | WritePropObj hardlink, vtref, vNewValue 161 | Else 162 | WriteProp ObjectRef, vtref, vNewValue 163 | End If 164 | ElseIf Not IndexNew Then 165 | ' do nothing 166 | MyEr "Missing index", "Έχασα τον δείκτη" 167 | Exit Property 168 | ElseIf useobj Then 169 | IndexNew = False 170 | WritePropIndexObj hardlink, vtref, vNewValue, mIndex 171 | Else 172 | IndexNew = False 173 | WritePropIndex ObjectRef, vtref, vNewValue, mIndex 174 | End If 175 | End If 176 | 177 | 178 | End Property 179 | Public Property Get isMethod() As Boolean 180 | isMethod = IamMethod 181 | End Property 182 | 183 | Public Property Let isMethod(ByVal vNewValue As Boolean) 184 | IamMethod = vNewValue 185 | End Property 186 | 187 | Private Sub Class_Terminate() 188 | Set hardlink = Nothing 189 | End Sub 190 | Public Sub IndexOpt() 191 | IndexNew = True 192 | mIndex = 0 193 | OptVariant mIndex 194 | End Sub 195 | Public Property Get Index() As Variant 196 | Index = mIndex 197 | End Property 198 | Public Sub ArrayIndex(ParamArray RHS()) 199 | 'IndexNew = True 200 | mIndex = RHS 201 | End Sub 202 | 203 | Public Property Let Index(ByVal RHS As Variant) 204 | IndexNew = True 205 | mIndex = RHS 206 | End Property 207 | Friend Sub PushIndexes(idx As mIndexes) 208 | If idx Is Nothing Then Exit Sub 209 | IndexNew = True 210 | UseIndex = True 211 | If IndexList Is Nothing Then 212 | If idx.Count = 1 Then 213 | idx.Dump 0, mIndex 214 | Else 215 | idx.GetArr mIndex 216 | End If 217 | End If 218 | End Sub 219 | Sub IndexAgain() 220 | IndexNew = True 221 | End Sub -------------------------------------------------------------------------------- /utf8/musicbox.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "MusicBox" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements TaskInterface 16 | Private instrum As Long 17 | Private octava As Integer 18 | Private Channel As Long 19 | Private volume As Long 20 | Private lNote As Integer 21 | Private mNote As Integer 22 | Private m_duration As Long, m_now As Long 23 | Dim jobnameID As Long 24 | Dim metronome As Long 25 | Dim mybusy As Boolean 26 | Private myBase As TaskInterface 27 | 'Private Declare Function timeGetTime Lib "kernel32.dll" Alias "GetTickCount" () As Long 28 | Private Declare Function timeGetTime Lib "winmm.dll" () As Long 29 | Private myProcess As basetask 30 | 31 | Private Sub Class_Terminate() 32 | Dim midimsg As String 33 | TaskMaster.MusicTaskNum = TaskMaster.MusicTaskNum - 1 34 | If mNote > 0 Then 35 | midimsg = &H80 + (mNote * &H100) + Channel 36 | midiOutShortMsg hmidi, midimsg 37 | End If 38 | End Sub 39 | 40 | Private Property Get TaskInterface_Process() As basetask 41 | Set TaskInterface_Process = myProcess 42 | End Property 43 | Private Property Set TaskInterface_Process(aProcess As basetask) 44 | Set myProcess = aProcess 45 | Set myProcess.Process = myBase 46 | End Property 47 | Private Property Let TaskInterface_ID(ByVal RHS As Long) 48 | If RHS = Channel + 1 Then 49 | myBase.Done = True 50 | End If 51 | End Property 52 | 53 | Private Property Get TaskInterface_ID() As Long 54 | TaskInterface_ID = Channel + 1 55 | End Property 56 | 57 | Private Property Let TaskInterface_interval(ByVal RHS As Currency) 58 | m_duration = Signed(RHS) 59 | End Property 60 | 61 | Private Property Get TaskInterface_interval() As Currency 62 | TaskInterface_interval = m_duration 63 | End Property 64 | 65 | ' IMPLEMENTED PROPERTIES 66 | 67 | Private Property Set TaskInterface_Owner(RHS As Object) 68 | ' Usage: Private Property Set TaskInterface_Owner(RHS As Form) 69 | 70 | 'Validating type 71 | ' If TypeOf RHS Is Form Then 72 | Set myBase.Owner = RHS 73 | ' Else 74 | ' Error tmTypeMisMatch 75 | 'End If 76 | End Property 77 | 78 | 79 | ' IMPLEMENTED METHODS 80 | 81 | Private Sub TaskInterface_Parameters(ParamArray Values() As Variant) 82 | '' Usage: Private Sub TaskInterface_Parameters(Color As Long, Count As Long) 83 | On Error GoTo poulos 84 | ' Verifing parameter count 85 | If UBound(Values) = 1 Then 86 | 87 | On Error Resume Next 88 | jobnameID = CLng(Values(0)) ' this is the channel name 89 | instrum = CLng(Values(1)) 90 | Channel = jobnameID - 1 91 | volume = 127 92 | m_duration = 0& 93 | 94 | If Err.Number > 0 Then 95 | On Error GoTo 0 96 | 97 | End If 98 | On Error GoTo 0 99 | Dim midimsg As Long 100 | instrument instrum, Channel 101 | Else 102 | poulos: 103 | 104 | End If 105 | 106 | End Sub 107 | 108 | 109 | Private Function TaskInterface_Tick() As Boolean 110 | Dim midimsg As Long 111 | If mute Or UnsignedSub(timeGetTime, m_now) >= m_duration Then 112 | TaskInterface_Tick = True 113 | If mNote > 0 Then 114 | midimsg = &H80 + (mNote * &H100) + Channel 115 | midiOutShortMsg hmidi, midimsg 116 | End If 117 | 118 | Dim BE As Long 119 | 120 | If PlayTuneMIDI(voices(Channel), octava, lNote, BE, volume) And Not mute Then 121 | If volume > 127 Then volume = 127 122 | If volume < 1 Then volume = 1 123 | If lNote = 24 Then 124 | 125 | mNote = -1 126 | Else 127 | mNote = 0 128 | End If 129 | 130 | If BE < 1 Then BE = 1 131 | If BE > 6 Then BE = 6 132 | m_now = timeGetTime 133 | m_duration = Signed(BEATS(Channel) / 2# ^ (BE - 1)) 134 | If mNote <> -1 Then 135 | mNote = GetNote(octava, lNote \ 2) 136 | midimsg = &H90 + (mNote * &H100) + (volume * &H10000) + Channel 137 | midiOutShortMsg hmidi, midimsg 138 | End If 139 | 140 | Else 141 | mNote = 0 142 | myBase.Done = True 143 | End If 144 | 145 | 146 | End If 147 | 'Form1.OwnEvet = jobnameID 148 | End Function 149 | 150 | 151 | 152 | ' DELEGATED PROPERTIES 153 | 154 | 155 | 156 | Private Property Let TaskInterface_Done(ByVal RHS As Boolean) 157 | myBase.Done = RHS 158 | End Property 159 | 160 | Private Property Get TaskInterface_Done() As Boolean 161 | TaskInterface_Done = myBase.Done 162 | End Property 163 | 164 | 165 | Private Property Get TaskInterface_Owner() As Object 166 | Set TaskInterface_Owner = myBase.Owner 167 | End Property 168 | 169 | Public Property Let TaskInterface_Priority(ByVal Value As PriorityLevel) 170 | myBase.Priority = Value 171 | End Property 172 | 173 | Public Property Get TaskInterface_Priority() As PriorityLevel 174 | TaskInterface_Priority = myBase.Priority 175 | End Property 176 | Private Property Let TaskInterface_busy(ByVal RHS As Boolean) 177 | mybusy = RHS 178 | End Property 179 | 180 | Private Property Get TaskInterface_busy() As Boolean 181 | TaskInterface_busy = mybusy 182 | End Property 183 | Public Property Get TaskInterface_CodeData() As String 184 | TaskInterface_CodeData = vbNullString 185 | End Property 186 | ' DELEGATED METHODS 187 | 188 | Private Sub TaskInterface_Dispose(ByVal Action As DisposeAction) 189 | If myBase Is Nothing Then Exit Sub 190 | myBase.Dispose Action 191 | Set myBase = Nothing 192 | End Sub 193 | 194 | 195 | 196 | ' PRIVATE ROUTINES 197 | 198 | Private Sub Class_Initialize() 199 | Set myBase = New TaskBase 200 | octava = 4 201 | volume = 127 202 | End Sub 203 | 204 | 205 | 206 | -------------------------------------------------------------------------------- /ucRadialProgress.ctl: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.UserControl ucRadialProgress 3 | CanGetFocus = 0 'False 4 | ClientHeight = 2010 5 | ClientLeft = 0 6 | ClientTop = 0 7 | ClientWidth = 2160 8 | ScaleHeight = 2010 9 | ScaleWidth = 2160 10 | Windowless = -1 'True 11 | End 12 | Attribute VB_Name = "ucRadialProgress" 13 | Attribute VB_GlobalNameSpace = False 14 | Attribute VB_Creatable = True 15 | Attribute VB_PredeclaredId = False 16 | Attribute VB_Exposed = False 17 | Option Explicit 'simple, minimal (DPI-aware) implementation of a "pure GDI-based" circular Progress-Control 18 | 'Olaf Schmidt, in May 2020 19 | 20 | Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC&, ByVal nIndex&) As Long 21 | Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC&, ByVal nStretchMode&) As Long 22 | Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC&, ByVal X&, ByVal Y&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long 23 | Private Declare Function MoveTo Lib "gdi32" Alias "MoveToEx" (ByVal hDC&, ByVal X&, ByVal Y&, Optional ByVal lpPoint As Long) As Long 24 | Private Declare Function LineTo Lib "gdi32" (ByVal hDC&, ByVal X&, ByVal Y&) As Long 25 | Private Declare Function TextOutW Lib "gdi32" (ByVal hDC&, ByVal X&, ByVal Y&, ByVal lpString&, ByVal nCount&) As Long 26 | 27 | Private mPercVal#, mBB As VB.PictureBox, NumElm&, GapRatio!, InnerRadiusPerc!, TopColor&, BottomColor& 28 | 29 | Private Sub UserControl_Initialize() 30 | ClipBehavior = 0: BackStyle = 0: FillStyle = 1 'ensure transparent behaviour 31 | NumElm = 20: GapRatio = 0.15: InnerRadiusPerc = 0.75 'initialize a few internal "math-vars" 32 | TopColor = &HAA00&: BottomColor = 0 ' vbWhite: FontName = "Arial" 'plus a few "formatting-vars" 33 | End Sub 34 | 35 | Public Sub ChangeDefaults(NumElements, StripeTopColor, Optional ByVal ElementGapRatio# = 0.15, Optional ByVal InnerRadiusRatio# = 0.75, Optional StripeBottomColor, Optional FontName, Optional TextColor) 36 | NumElm = NumElements: TopColor = mycolor(StripeTopColor): GapRatio = ElementGapRatio: InnerRadiusPerc = InnerRadiusRatio 37 | If Not IsMissing(StripeBottomColor) Then BottomColor = mycolor(StripeBottomColor) 38 | If Not IsMissing(FontName) Then UserControl.FontName = FontName 39 | If Not IsMissing(TextColor) Then UserControl.ForeColor = mycolor(TextColor) 40 | UserControl.Refresh 41 | End Sub 42 | 43 | Public Property Get Value() As Long 44 | Value = mPercVal * 100 45 | End Property 46 | Public Property Let Value(ByVal RHS As Long) 47 | If RHS < 0 Then RHS = 0 Else If RHS > 100 Then RHS = 100 48 | mPercVal = RHS / 100: UserControl.Refresh 49 | End Property 50 | 51 | Public Sub Refresh() 52 | UserControl.Refresh 53 | End Sub 54 | 55 | Private Sub UserControl_HitTest(X As Single, Y As Single, HitResult As Integer) 56 | If UserControl.enabled Then HitResult = vbHitResultHit 57 | End Sub 58 | Property Get enabled() As Boolean 59 | enabled = UserControl.enabled 60 | End Property 61 | Property Let enabled(ByVal bValue As Boolean) 62 | If UserControl.enabled <> bValue Then 63 | UserControl.enabled = bValue 64 | End If 65 | PropertyChanged 66 | End Property 67 | Private Sub UserControl_Show() 68 | If Not (Ambient.UserMode And mBB Is Nothing) Then Exit Sub 69 | Set mBB = Parent.Controls.Add("VB.PictureBox", "HIDE_" & ObjPtr(Me)) 70 | mBB.BorderStyle = 0: mBB.AutoRedraw = True: mBB.ScaleMode = vbPixels: mBB.enabled = False 71 | mBB.Visible = False 72 | 73 | End Sub 74 | 75 | Private Sub UserControl_Paint() 76 | Const D2R# = 1.74532925199433E-02, sc& = 6 77 | Static a&, Cs#, Sn#, x1&(720), y1&(720), x2&(720), y2&(720) 'statics, to avoid re-allocs 78 | ScaleMode = vbPixels 79 | Dim cx#: cx = ScaleWidth / 2 80 | Dim cy#: cy = ScaleHeight / 2 81 | Dim r1#: r1 = IIf(cx < cy, cx, cy) - GetDeviceCaps(hDC, 88) / 96 82 | Dim R2#: R2 = r1 * InnerRadiusPerc 83 | Dim sL$: sL = Format$(mPercVal, "0%") 84 | 85 | FontSize = R2 * 0.4 / (GetDeviceCaps(hDC, 88) / 96) 86 | TextOutW hDC, cx - TextWidth(sL) * 0.48, cy - TextHeight(sL) * 0.5, StrPtr(sL), Len(sL) 87 | If mBB Is Nothing Then Circle (cx, cy), r1 - 1, TopColor: Exit Sub 88 | If mBB.Width <> ScaleX(cx * 2 * sc, 3, Parent.ScaleMode) Or mBB.Height <> ScaleY(cy * 2 * sc, 3, Parent.ScaleMode) Then _ 89 | mBB.move 0, 0, ScaleX(cx * 2 * sc, 3, Parent.ScaleMode), ScaleY(cy * 2 * sc, 3, Parent.ScaleMode) 90 | mBB.DrawWidth = sc * 0.018 * Atn(1) * r1 91 | 92 | StretchBlt mBB.hDC, 0, 0, cx * 2 * sc, cy * 2 * sc, hDC, 0, 0, cx * 2, cy * 2, vbSrcCopy 93 | For a = 0 To 720 - 1 94 | Cs = Cos((a / 2 - 90 + GapRatio * 180 / NumElm) * D2R) 95 | Sn = Sin((a / 2 - 90 + GapRatio * 180 / NumElm) * D2R) 96 | x1(a) = sc * (cx + r1 * Cs): y1(a) = sc * (cy + r1 * Sn) 97 | x2(a) = sc * (cx + R2 * Cs): y2(a) = sc * (cy + R2 * Sn) 98 | Next 99 | 100 | mBB.ForeColor = TopColor 'first draw the circular strip up to the current Perc-Value 101 | For a = 0 To mPercVal * 720 - 1 102 | If (a Mod 720 / NumElm) < 720 / NumElm * (1 - GapRatio) Then _ 103 | MoveTo mBB.hDC, x2(a), y2(a): LineTo mBB.hDC, x1(a), y1(a) 104 | Next 105 | mBB.ForeColor = BottomColor 'and the remaining percent-circle with the bottom-color 106 | For a = a To 720 - 1 107 | If (a Mod 720 / NumElm) < 720 / NumElm * (1 - GapRatio) Then _ 108 | MoveTo mBB.hDC, x2(a), y2(a): LineTo mBB.hDC, x1(a), y1(a) 109 | Next 110 | SetStretchBltMode hDC, 4 '<- ensures good HalfTone-quality for the StretchBlt-call below 111 | StretchBlt hDC, 0, 0, cx * 2, cy * 2, mBB.hDC, 0, 0, cx * 2 * sc, cy * 2 * sc, vbSrcCopy 112 | End Sub 113 | -------------------------------------------------------------------------------- /utf8/iboxarray.cls.utf8.txt: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "iBoxArray" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | ' Public myarrbase As Long 15 | 16 | Public Property Get CodeName() As String 17 | 18 | End Property 19 | 20 | Public Property Let CodeName(vNewValue As String) 21 | 22 | End Property 23 | 24 | Public Property Get item(curitem As Long) As Variant 25 | 26 | End Property 27 | 28 | Public Property Let item(curitem As Long, vNewValue As Variant) 29 | 30 | End Property 31 | 32 | Public Property Set item(curitem As Long, vNewValue As Variant) 33 | 34 | End Property 35 | Public Property Get Arr() As Boolean 36 | 37 | End Property 38 | 39 | Public Property Let Arr(ByVal vNewValue As Boolean) 40 | 41 | End Property 42 | 43 | Public Property Get GroupRef() As Object 44 | 45 | 46 | End Property 47 | 48 | Public Property Set GroupRef(vNewValue As Object) 49 | 50 | End Property 51 | 52 | Public Property Get refgroup() As Object 53 | 54 | End Property 55 | 56 | Public Property Set refgroup(ByVal vNewValue As Object) 57 | 58 | End Property 59 | Property Get IsEmpty() As Variant 60 | 61 | End Property 62 | Public Property Get IhaveClass() As Boolean 63 | 64 | End Property 65 | 66 | Public Property Let IhaveClass(ByVal vNewValue As Boolean) 67 | 68 | 69 | End Property 70 | Public Property Get itemObject(curitem As Long) As Variant 71 | 72 | End Property 73 | Public Property Get ItemType(curitem) As String 74 | 75 | End Property 76 | Public Property Get arrname() As String 77 | 78 | End Property 79 | 80 | Public Property Let arrname(ByVal vNewValue As String) 81 | 82 | End Property 83 | 84 | Public Property Get Final() As Boolean 85 | 86 | End Property 87 | 88 | Public Property Let Final(ByVal vNewValue As Boolean) 89 | 90 | End Property 91 | 92 | Public Property Get common() As Boolean 93 | 94 | End Property 95 | 96 | Public Property Let common(ByVal vNewValue As Boolean) 97 | 98 | End Property 99 | Public Sub PushDim(nDim As Long, Optional limBase As Variant) 100 | 101 | End Sub 102 | 103 | Public Sub PushEnd(Optional thisarr) 104 | 105 | End Sub 106 | Public Sub PushProp(a As Variant) 107 | 108 | End Sub 109 | Function IsObjAt(curitem As Long, peekvalue) As Boolean 110 | 111 | End Function 112 | 113 | 114 | Public Property Get myarrbase() As Long 115 | 116 | End Property 117 | 118 | Public Property Let myarrbase(ByVal vNewValue As Long) 119 | 120 | End Property 121 | 122 | Public Function SerialItem(item As Variant, cursor As Long, Command As Long) As Boolean 123 | ' 124 | End Function 125 | 126 | Public Property Get Count() As Long 127 | 128 | End Property 129 | 130 | Public Function MyIsNumeric(v As Variant) As Boolean 131 | 132 | End Function 133 | 134 | Public Function MyIsObject(v As Variant) As Boolean 135 | 136 | End Function 137 | 138 | Public Function IsEnum2(curitem As Long, p As Variant) As Boolean 139 | 140 | End Function 141 | 142 | Public Function ItemIsObject(curitem) As Boolean 143 | 144 | End Function 145 | 146 | Public Function IsStringItem(curitem As Long) As Variant 147 | 148 | End Function 149 | 150 | Public Function itemnumeric(curitem As Long) As Variant 151 | 152 | End Function 153 | 154 | Public Sub SortDesTuple(Optional Low As Long = -1, Optional high As Long = -1) 155 | 156 | End Sub 157 | 158 | Public Sub SortTuple(Optional Low As Long = -1, Optional high As Long = -1) 159 | 160 | End Sub 161 | 162 | Public Function EmptyArraySameType() As Object 163 | 164 | End Function 165 | 166 | Public Sub CopyArraySlice(K As iBoxArray, fromS As Long, toS As Long) 167 | 168 | End Sub 169 | 170 | Public Sub CopyArraySliceFast(K As iBoxArray, fromS As Long, toS As Long) 171 | 172 | End Sub 173 | 174 | Public Sub CopyArray(K As iBoxArray) 175 | 176 | End Sub 177 | 178 | Public Function IsObj() As Boolean 179 | 180 | End Function 181 | 182 | Public Property Get Index() As Long 183 | 184 | End Property 185 | 186 | Public Property Let Index(ByVal vNewValue As Long) 187 | 188 | End Property 189 | 190 | Public Property Get Value() As Variant 191 | 192 | End Property 193 | 194 | Public Sub AppendArray(K As iBoxArray) 195 | 196 | End Sub 197 | 198 | Public Sub CopyArrayRevFast(K As iBoxArray) 199 | 200 | End Sub 201 | 202 | Public Sub CopyArrayRev(K As iBoxArray) 203 | 204 | End Sub 205 | 206 | Public Property Get MyTypeToBe() As Integer 207 | 208 | End Property 209 | 210 | 211 | Public Function GetCopy() As Variant() 212 | 213 | End Function 214 | 215 | Public Sub processAppend(m As Object) 216 | 217 | End Sub 218 | 219 | Public Function GetUDTValue(ByVal p As Long, Name$, Optional ndx) 220 | 221 | End Function 222 | 223 | Public Property Get ItemTypeNum(curitem) As Integer 224 | 225 | End Property 226 | Public Sub SwapItem(curitem As Long, thisvariant) 227 | 228 | End Sub 229 | Public Function UpperMonoLimit() 230 | 231 | End Function 232 | Public Function PlaceValue2UDTArray(p As Long, Name$, v, Index As Long) As Boolean 233 | 234 | End Function 235 | Public Function PlaceValue2UDT(p As Long, Name$, v) As Boolean 236 | 237 | End Function 238 | Public Sub GetPorp(aProp As PropReference, curitem As Long) 239 | 240 | End Sub 241 | Public Property Let ItemStr(curitem As Long, item As String) 242 | 243 | End Property 244 | Public Function IsEnum(p As Variant) As Boolean 245 | 246 | End Function 247 | Public Sub Neg(v As Long) 248 | 249 | End Sub 250 | Public Property Get ArrPtr() As Long 251 | 252 | End Property 253 | Public Property Get itemPtr(curitem As Long) As Long 254 | 255 | End Property 256 | 257 | Public Function bareteamgroup() As Object 258 | 259 | End Function 260 | Public Sub StartResize() 261 | 262 | End Sub -------------------------------------------------------------------------------- /MusicBox.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "MusicBox" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements TaskInterface 16 | Private instrum As Long 17 | Private octava As Integer 18 | Private Channel As Long 19 | Private volume As Long 20 | Private lNote As Integer 21 | Private mNote As Integer 22 | Private m_duration As Long, m_now As Long 23 | Dim jobnameID As Long 24 | Dim metronome As Long 25 | Dim mybusy As Boolean 26 | Private myBase As TaskInterface 27 | 'Private Declare Function timeGetTime Lib "kernel32.dll" Alias "GetTickCount" () As Long 28 | Private Declare Function timeGetTime Lib "winmm.dll" () As Long 29 | Private myProcess As basetask 30 | 31 | Private Sub Class_Terminate() 32 | Dim midimsg As String 33 | TaskMaster.MusicTaskNum = TaskMaster.MusicTaskNum - 1 34 | If mNote > 0 Then 35 | midimsg = &H80 + (mNote * &H100) + Channel 36 | midiOutShortMsg hmidi, midimsg 37 | End If 38 | End Sub 39 | 40 | Private Property Get TaskInterface_Process() As basetask 41 | Set TaskInterface_Process = myProcess 42 | End Property 43 | Private Property Set TaskInterface_Process(aProcess As basetask) 44 | Set myProcess = aProcess 45 | Set myProcess.Process = myBase 46 | End Property 47 | Private Property Let TaskInterface_ID(ByVal RHS As Long) 48 | If RHS = Channel + 1 Then 49 | myBase.Done = True 50 | End If 51 | End Property 52 | 53 | Private Property Get TaskInterface_ID() As Long 54 | TaskInterface_ID = Channel + 1 55 | End Property 56 | 57 | Private Property Let TaskInterface_interval(ByVal RHS As Currency) 58 | m_duration = Signed(RHS) 59 | End Property 60 | 61 | Private Property Get TaskInterface_interval() As Currency 62 | TaskInterface_interval = m_duration 63 | End Property 64 | 65 | ' IMPLEMENTED PROPERTIES 66 | 67 | Private Property Set TaskInterface_Owner(RHS As Object) 68 | ' Usage: Private Property Set TaskInterface_Owner(RHS As Form) 69 | 70 | 'Validating type 71 | ' If TypeOf RHS Is Form Then 72 | Set myBase.Owner = RHS 73 | ' Else 74 | ' Error tmTypeMisMatch 75 | 'End If 76 | End Property 77 | 78 | 79 | ' IMPLEMENTED METHODS 80 | 81 | Private Sub TaskInterface_Parameters(ParamArray Values() As Variant) 82 | '' Usage: Private Sub TaskInterface_Parameters(Color As Long, Count As Long) 83 | On Error GoTo poulos 84 | ' Verifing parameter count 85 | If UBound(Values) = 1 Then 86 | 87 | On Error Resume Next 88 | jobnameID = CLng(Values(0)) ' this is the channel name 89 | instrum = CLng(Values(1)) 90 | Channel = jobnameID - 1 91 | volume = 127 92 | m_duration = 0& 93 | 94 | If Err.Number > 0 Then 95 | On Error GoTo 0 96 | 97 | End If 98 | On Error GoTo 0 99 | Dim midimsg As Long 100 | instrument instrum, Channel 101 | Else 102 | poulos: 103 | 104 | End If 105 | 106 | End Sub 107 | 108 | 109 | Private Function TaskInterface_Tick() As Boolean 110 | Dim midimsg As Long 111 | If mute Or UnsignedSub(timeGetTime, m_now) >= m_duration Then 112 | TaskInterface_Tick = True 113 | If mNote > 0 Then 114 | midimsg = &H80 + (mNote * &H100) + Channel 115 | midiOutShortMsg hmidi, midimsg 116 | End If 117 | 118 | Dim BE As Long 119 | 120 | If PlayTuneMIDI(voices(Channel), octava, lNote, BE, volume) And Not mute Then 121 | If volume > 127 Then volume = 127 122 | If volume < 1 Then volume = 1 123 | If lNote = 24 Then 124 | 125 | mNote = -1 126 | Else 127 | mNote = 0 128 | End If 129 | 130 | If BE < 1 Then BE = 1 131 | If BE > 6 Then BE = 6 132 | m_now = timeGetTime 133 | m_duration = Signed(BEATS(Channel) / 2# ^ (BE - 1)) 134 | If mNote <> -1 Then 135 | mNote = GetNote(octava, lNote \ 2) 136 | midimsg = &H90 + (mNote * &H100) + (volume * &H10000) + Channel 137 | midiOutShortMsg hmidi, midimsg 138 | End If 139 | 140 | Else 141 | mNote = 0 142 | myBase.Done = True 143 | End If 144 | 145 | 146 | End If 147 | 'Form1.OwnEvet = jobnameID 148 | End Function 149 | 150 | 151 | 152 | ' DELEGATED PROPERTIES 153 | 154 | 155 | 156 | Private Property Let TaskInterface_Done(ByVal RHS As Boolean) 157 | myBase.Done = RHS 158 | End Property 159 | 160 | Private Property Get TaskInterface_Done() As Boolean 161 | TaskInterface_Done = myBase.Done 162 | End Property 163 | 164 | 165 | Private Property Get TaskInterface_Owner() As Object 166 | Set TaskInterface_Owner = myBase.Owner 167 | End Property 168 | 169 | Public Property Let TaskInterface_Priority(ByVal Value As PriorityLevel) 170 | myBase.Priority = Value 171 | End Property 172 | 173 | Public Property Get TaskInterface_Priority() As PriorityLevel 174 | TaskInterface_Priority = myBase.Priority 175 | End Property 176 | Private Property Let TaskInterface_busy(ByVal RHS As Boolean) 177 | mybusy = RHS 178 | End Property 179 | 180 | Private Property Get TaskInterface_busy() As Boolean 181 | TaskInterface_busy = mybusy 182 | End Property 183 | Public Property Get TaskInterface_CodeData() As String 184 | TaskInterface_CodeData = vbNullString 185 | End Property 186 | ' DELEGATED METHODS 187 | 188 | Private Sub TaskInterface_Dispose(ByVal Action As DisposeAction) 189 | If myBase Is Nothing Then Exit Sub 190 | myBase.Dispose Action 191 | Set myBase = Nothing 192 | End Sub 193 | 194 | 195 | 196 | ' PRIVATE ROUTINES 197 | 198 | Private Sub Class_Initialize() 199 | Set myBase = New TaskBase 200 | octava = 4 201 | volume = 127 202 | End Sub 203 | 204 | 205 | 206 | 207 | -------------------------------------------------------------------------------- /utf8/servermod.bas.utf8.txt: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ServerMod" 2 | Public Function CallEventFromSocketNow(sck As Server, a As mEvent, aString$, vrs()) As Boolean 3 | Dim tr As Boolean, extr As Boolean, olescok As Boolean 4 | olescok = escok 5 | escok = False 6 | CallEventFromSocketNow = True 7 | extr = extreme 8 | extreme = True 9 | tr = trace 10 | If Rnd * 100 > 3 Then trace = False 11 | Dim n$, f$, F1$, bb As mStiva, oldbstack As mStiva, nowtotal As Long 12 | Dim bstack As basetask 13 | Set bstack = New basetask 14 | Set bstack.Owner = Form1.DIS 15 | Set bstack.StaticCollection = EventStaticCollection 16 | bstack.IamAnEvent = True 17 | Dim i As Long 18 | If a Is Nothing Then GoTo conthere0 19 | i = a.VarIndex 20 | F1$ = sck.modulename 21 | Set oldbstack = bstack.soros 22 | Dim j As Long, k As Long, s1$, klm As Long, s2$ 23 | Dim ohere$ 24 | ohere$ = here$ 25 | here$ = "EV" + CStr(i) 26 | If a.enabled Then 27 | a.ReadVar 0, n$, f$ 28 | If f$ <> "" Then 29 | Set bb = New mStiva 30 | Set bstack.Sorosref = bb 31 | PushStage bstack, False 32 | For k = LBound(vrs()) To UBound(vrs()) - 1 33 | If VarType(vrs(k)) = vbString Then 34 | globalvarGroup "EV" + CStr(i + k) + "$", vrs(k) 35 | bb.DataStr here$ + "." + "EV" + CStr(i + k) + "$" 36 | Else 37 | globalvarGroup "EV" + CStr(i + k), vrs(k) 38 | bb.DataStr here$ + "." + "EV" + CStr(i + k) 39 | End If 40 | Next k 41 | bb.DataObj sck 42 | FastPureLabel aString$, f$, , , , , False 43 | n$ = Mid$(aString$, Len(f$) + 1) 44 | If Len(n$) > 0 Then 45 | n$ = Left$(n$, Len(n$) - 1) 46 | If n$ <> "" Then n$ = "Push " + n$ + vbCrLf 47 | End If 48 | If F1$ <> "" Then f$ = myUcase(F1$ + "." + f$ + ")", True) Else f$ = myUcase(f$ + ")", True) 49 | If Not GetSub(f$, klm) Then PopStage bstack: bb.Flush: CallEventFromSocketNow = False: GoTo conthere 50 | s1$ = sbf(klm).sb 51 | If Left$(s1$, 10) = "'11001EDIT" Then 52 | SetNextLine s1$ 53 | End If 54 | If F1$ <> "" Then s1$ = n$ + "Module " + F1$ + vbCrLf + sbf(klm).sb Else s1$ = n$ + sbf(klm).sb 55 | Dim nn As Long 56 | 57 | If Execute(bstack, s1$, False, False) = 0 Then 58 | MyEr "Problem in Event " + aString$, "Πρόβλημα στο γεγονός " + aString$ 59 | PopStage bstack 60 | bb.Flush 61 | GoTo conthere 62 | End If 63 | here$ = "EV" + CStr(i) 64 | For k = LBound(vrs()) To UBound(vrs()) - 1 65 | If VarType(vrs(k)) = vbString Then 66 | GetlocalVar "EV" + CStr(i + k) + "$", j 67 | vrs(k) = var(j) 68 | Else 69 | GetlocalVar "EV" + CStr(i + k), j 70 | vrs(k) = var(j) 71 | End If 72 | Next k 73 | PopStage bstack 74 | bb.Flush 75 | End If 76 | End If 77 | conthere: 78 | Set bstack.Sorosref = oldbstack 79 | here$ = ohere$ 80 | conthere0: 81 | Set oldbstack = Nothing 82 | Set bb = Nothing 83 | If tr Then trace = tr 84 | extreme = extr 85 | escok = olescok 86 | End Function 87 | Public Function CallEventFromSocketOne(sck As Server, a As mEvent, aString$) As Boolean 88 | Dim tr As Boolean, extr As Boolean, olescok As Boolean 89 | CallEventFromSocketOne = True 90 | olescok = escok 91 | escok = False 92 | tr = trace 93 | extr = extreme 94 | extreme = True 95 | If Rnd * 100 > 3 Then trace = False 96 | Dim n$, f$, F1$, bb As mStiva, uIndex As Long 97 | Dim bstack As basetask 98 | Set bstack = New basetask 99 | Set bstack.Owner = Form1.DIS 100 | Set bstack.StaticCollection = EventStaticCollection 101 | bstack.IamAnEvent = True 102 | Dim i As Long 103 | If a Is Nothing Then GoTo conthere0 104 | i = a.VarIndex 105 | uIndex = sck.index 106 | If uIndex >= 0 Then 107 | bstack.soros.DataVal CDbl(uIndex) 108 | uIndex = 1 109 | End If 110 | uIndex = uIndex + 1 111 | F1$ = sck.modulename 112 | bstack.soros.DataObj sck 113 | 114 | Dim j As Long, k As Long, s1$, klm As Long, s2$ 115 | Dim ohere$ 116 | ohere$ = here$ 117 | here$ = "EV" + CStr(i) 118 | If a.enabled Then 119 | PushStage bstack, False 120 | FastPureLabel aString$, f$, , , , , False 121 | n$ = Mid$(aString$, Len(f$) + 1) 122 | n$ = Left$(n$, Len(n$) - 1) 123 | If n$ <> "" Then 124 | If uIndex > 0 Then 125 | n$ = "Data " + n$ + " : ShiftBack Stack.Size" + Str(1 - uIndex) + "," + Str$(uIndex) + vbCrLf 126 | Else 127 | n$ = "Data " + n$ + " : ShiftBack Stack.Size" + vbCrLf 128 | End If 129 | End If 130 | If F1$ <> "" Then f$ = myUcase(F1$ + "." + f$ + ")", True) Else f$ = myUcase(f$ + ")", True) 131 | If Not GetSub(f$, klm) Then 132 | PopStage bstack: CallEventFromSocketOne = False: GoTo conthere 133 | End If 134 | s1$ = sbf(klm).sb 135 | If Left$(s1$, 10) = "'11001EDIT" Then 136 | SetNextLine s1$ 137 | End If 138 | If F1$ <> "" Then s1$ = n$ + "Module " + F1$ + vbCrLf + sbf(klm).sb Else s1$ = n$ + sbf(klm).sb 139 | If Execute(bstack, s1$, False, False) = 0 Then 140 | If F1$ = vbNullString Then 141 | MyEr "Problem in Event " + aString$, "Πρόβλημα στο γεγονός " + aString$ 142 | Else 143 | MyEr "Problem in Event " + aString$ + " in module " + F1$, "Πρόβλημα στο γεγονός " + aString$ + " στο τμήμα " + F1$ 144 | End If 145 | bstack.soros.Flush 146 | PopStage bstack 147 | GoTo conthere 148 | End If 149 | PopStage bstack 150 | End If 151 | conthere: 152 | Set bstack = Nothing 153 | here$ = ohere$ 154 | conthere0: 155 | If tr Then trace = tr 156 | extreme = extr 157 | escok = olescok 158 | End Function --------------------------------------------------------------------------------