├── Post.ctx ├── send.ico ├── newToot.frx ├── loginform.frx ├── msw.fbp.vbw ├── msw.fbp.vbp ├── README.md ├── modConfig.bas ├── Post.ctl ├── modURLUtils.bas ├── msw.fbp.PDM ├── modWinInet.bas ├── loginform.frm ├── newToot.frm ├── main.frm ├── LICENSE └── JsonBag.cls /Post.ctx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/meyskens/mastodon-for-workgroups/HEAD/Post.ctx -------------------------------------------------------------------------------- /send.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/meyskens/mastodon-for-workgroups/HEAD/send.ico -------------------------------------------------------------------------------- /newToot.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/meyskens/mastodon-for-workgroups/HEAD/newToot.frx -------------------------------------------------------------------------------- /loginform.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/meyskens/mastodon-for-workgroups/HEAD/loginform.frx -------------------------------------------------------------------------------- /msw.fbp.vbw: -------------------------------------------------------------------------------- 1 | main = 18, 75, 643, 601, , 44, 44, 563, 484, C 2 | JsonBag = 0, 0, 0, 0, C 3 | newToot = -25, 65, 653, 623, C, 89, 62, 608, 502, C 4 | loginform = 132, 132, 651, 572, C, 110, 110, 629, 550, C 5 | modWinInet = 22, 22, 681, 530, C 6 | frmHttpQuery = 69, 87, 731, 580, C, 110, 110, 636, 550, C 7 | Post = 0, 0, 0, 0, C, 198, 198, 654, 638, C 8 | modConfig = 31, 63, 708, 607, C 9 | Module1 = 118, 97, 644, 537, CI 10 | -------------------------------------------------------------------------------- /msw.fbp.vbp: -------------------------------------------------------------------------------- 1 | Type=Exe 2 | Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\SYSTEM\StdOle2.Tlb#OLE Automation 3 | Form=main.frm 4 | Class=JsonBag; JsonBag.cls 5 | Form=newToot.frm 6 | Form=loginform.frm 7 | Module=modWinInet; modWinInet.bas 8 | Object={6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0; COMCTL32.OCX 9 | Form=..\..\..\samples\techart\tech\vb\vbhttp\HTTP.Frm 10 | UserControl=Post.ctl 11 | Module=modConfig; modConfig.bas 12 | Module=Module1; modURLUtils.bas 13 | IconForm="main" 14 | Startup="main" 15 | HelpFile="" 16 | Title="mastodon" 17 | ExeName32="mastodon311.exe" 18 | Path32=".." 19 | Command32="" 20 | Name="MFW" 21 | HelpContextID="0" 22 | CompatibleMode="0" 23 | MajorVer=1 24 | MinorVer=0 25 | RevisionVer=0 26 | AutoIncrementVer=0 27 | ServerSupportFiles=0 28 | VersionCompanyName="Katholieke Hogeschool Kempen" 29 | VersionProductName="Mastodon 3.11 For Workgroups" 30 | CompilationType=0 31 | OptimizationType=1 32 | FavorPentiumPro(tm)=0 33 | CodeViewDebugInfo=0 34 | NoAliasing=0 35 | BoundsCheck=0 36 | OverflowCheck=0 37 | FlPointCheck=0 38 | FDIVCheck=0 39 | UnroundedFP=0 40 | StartMode=0 41 | Unattended=0 42 | Retained=0 43 | ThreadPerObject=0 44 | MaxNumberOfThreads=1 45 | DebugStartupOption=0 46 | 47 | [MS Transaction Server] 48 | AutoRefresh=1 49 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Mastodon 3.11 For Workgroups 2 | 3 | This project is a Mastodon client written in Visual Basic 6. It works on Windows 95 and higher (Windows 10/11 ~~untested~~ [confirmed to work](https://mastodon.lol/@autistic_enby/109378329066875960) but... why?). 4 | 5 | This project is in very early stages! Use at own risk. Contributions very welcome! (If you cannot use Git email me for an address to which you can mail your patches on floppy disk). 6 | 7 | What works: 8 | 9 | - Sending a toot 10 | - Loading 20 posts of your home timeline 11 | 12 | What is planned soon: 13 | 14 | - Image support 15 | - Avatars 16 | - Boosts and likes 17 | - Replies 18 | - Refreshing toots without crashing 19 | 20 | What I can use help on: 21 | 22 | - Tabs for different timelines 23 | - Better errorhandling 24 | - More things... 25 | 26 | 27 | ## Shut up and take my floppy 28 | 29 | If you are in no mood to install VB6 I understand. There is an installer [under releases](https://github.com/meyskens/mastodon-for-workgroups/releases/download/alpha-1/mfw-windows.9x.zip) 30 | 31 | ## What do I need? 32 | 33 | You need a HTTPS to HTTP proxy, one that preferably also converts UTF-8 to Windows encoding. I use [WebOne](https://github.com/atauenis/webone) for this. 34 | As this project sends your personal token, always host the proxy yourself. 35 | 36 | Once you set the proxy as your system proxy in Internet Explorer it will work. Press the "refresh" button to log in to your mastodon instance. 37 | 38 | ## Demos 39 | 40 | - [Reading posts](https://blahaj.social/@maartje/109372878061833398) 41 | - [Posting a toot](https://blahaj.social/@maartje/109376527177239374) 42 | 43 | ## Why the name? 44 | 45 | In need of a good name I got reminded of [this joke](https://mastodon.technology/@rysiek/108341299588619079) which relied on the fact that Mastodon v3.x is a thing. 46 | -------------------------------------------------------------------------------- /modConfig.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "modConfig" 2 | '--------for INI file read/write 3 | Private Declare Function GetPrivateProfileSection Lib "kernel32" Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long 4 | Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long 5 | Private Declare Function WritePrivateProfileSection Lib "kernel32" Alias "WritePrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpString As String, ByVal lpFileName As String) As Long 6 | Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long 7 | '------------------- 8 | 9 | Private Function GetPath() As String 10 | Dim path As String 11 | 12 | path = App.path 13 | If Right$(path, 1) = "\" Then ' fix for A:\ path 14 | path = Left(path, Len(path) - 1) 15 | End If 16 | 17 | GetPath = path & "\mastodon.ini" 18 | End Function 19 | 20 | 'reads ini string 21 | Public Function ReadIni(Section As String, Key As String) As String 22 | Dim RetVal As String * 255, v As Long 23 | v = GetPrivateProfileString(Section, Key, "", RetVal, 255, GetPath()) 24 | ReadIni = Left(RetVal, v) 25 | End Function 26 | 27 | 'reads ini section 28 | Public Function ReadIniSection(Section As String) As String 29 | Dim RetVal As String * 255, v As Long 30 | v = GetPrivateProfileSection(Section, RetVal, 255, GetPath()) 31 | ReadIniSection = Left(RetVal, v - 1) 32 | End Function 33 | 34 | 'writes ini 35 | Public Sub WriteIni(Section As String, Key As String, Value As String) 36 | WritePrivateProfileString Section, Key, Value, GetPath() 37 | End Sub 38 | 39 | 'writes ini section 40 | Public Sub WriteIniSection(Section As String, Value As String) 41 | WritePrivateProfileSection Section, Value, GetPath() 42 | End Sub 43 | 44 | Public Function GetInstance() As String 45 | GetInstance = ReadIni("auth", "instance") 46 | End Function 47 | 48 | Public Function GetToken() As String 49 | GetToken = ReadIni("auth", "token") 50 | End Function 51 | -------------------------------------------------------------------------------- /Post.ctl: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.UserControl Post 3 | ClientHeight = 1365 4 | ClientLeft = 0 5 | ClientTop = 0 6 | ClientWidth = 4215 7 | ScaleHeight = 1365 8 | ScaleWidth = 4215 9 | Begin VB.CommandButton Boost 10 | Caption = "Boost" 11 | Height = 255 12 | Left = 120 13 | TabIndex = 2 14 | Top = 1080 15 | Width = 1455 16 | End 17 | Begin VB.CommandButton Favorite 18 | Caption = "Favorite" 19 | Height = 255 20 | Left = 1680 21 | MaskColor = &H0080FFFF& 22 | TabIndex = 1 23 | Top = 1080 24 | Width = 1455 25 | End 26 | Begin VB.Label ContentLabel 27 | Caption = "Content" 28 | Height = 615 29 | Left = 600 30 | TabIndex = 3 31 | Top = 360 32 | Width = 3495 33 | End 34 | Begin VB.Label UsernameLabel 35 | Caption = "Username" 36 | DataField = "pUsername" 37 | BeginProperty Font 38 | Name = "MS Sans Serif" 39 | Size = 8.25 40 | Charset = 0 41 | Weight = 700 42 | Underline = 0 'False 43 | Italic = 0 'False 44 | Strikethrough = 0 'False 45 | EndProperty 46 | Height = 255 47 | Left = 600 48 | TabIndex = 0 49 | Top = 120 50 | Width = 3255 51 | End 52 | Begin VB.Image Image1 53 | Height = 420 54 | Left = 120 55 | Picture = "Post.ctx":0000 56 | Stretch = -1 'True 57 | Top = 120 58 | Width = 420 59 | End 60 | End 61 | Attribute VB_Name = "Post" 62 | Attribute VB_GlobalNameSpace = False 63 | Attribute VB_Creatable = True 64 | Attribute VB_PredeclaredId = False 65 | Attribute VB_Exposed = False 66 | 67 | Private pUsername As String 68 | Private pContent As String 69 | 70 | Public Property Get Username() As String 71 | Username = pUsername 72 | End Property 73 | 74 | Public Property Let Username(ByVal NewValue As String) 75 | pUsername = NewValue 76 | UsernameLabel.Caption = pUsername 77 | PropertyChanged "Username" 78 | End Property 79 | 80 | Public Property Get content() As String 81 | content = pContent 82 | End Property 83 | 84 | Public Property Let content(ByVal NewValue As String) 85 | pContent = NewValue 86 | ContentLabel.Caption = pContent 87 | PropertyChanged "Content" 88 | End Property 89 | 90 | Private Sub Command1_Click() 91 | 92 | End Sub 93 | 94 | Private Sub UserControl_Initialize() 95 | ContentLabel.Caption = pContent 96 | UsernameLabel.Caption = pUsername 97 | End Sub 98 | 99 | -------------------------------------------------------------------------------- /modURLUtils.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Module1" 2 | Option Explicit 3 | '========== 4 | 'URLUtility 5 | '========== 6 | ' 7 | 'Adding the URLUtility class to a VB6 project produces a predeclared 8 | 'global object named URLUtility to your program. You can call methods 9 | 'on this object to URLDecode and URLEncode String values. 10 | ' 11 | ' 12 | 'Note the hack implemented here for "+ encoding" of spaces in the query 13 | 'portion of a URL. By rights everything following the ? or # in a URL 14 | 'should be passed literally. Encoding/decoding this string is NOT part 15 | 'of the URL encode/decode process, but is part of building and parsing 16 | 'the parameter string. 17 | ' 18 | 'As a result, the API calls used here do not process the query portion 19 | 'of the URL, assuming this has already been done/will be done later as 20 | 'required. The hack used here implements a common substitution of 21 | 'spaces by "+" characters after converting any "+" characters to "%2B" 22 | 'sequences. 23 | ' 24 | 25 | Private Const E_POINTER As Long = &H80004003 26 | Private Const S_OK As Long = 0 27 | Private Const INTERNET_MAX_URL_LENGTH As Long = 2048 28 | Private Const URL_ESCAPE_PERCENT As Long = &H1000& 29 | 30 | Private Declare Function UrlEscape Lib "shlwapi" Alias "UrlEscapeA" ( _ 31 | ByVal pszURL As String, _ 32 | ByVal pszEscaped As String, _ 33 | ByRef pcchEscaped As Long, _ 34 | ByVal dwFlags As Long) As Long 35 | 36 | Private Declare Function UrlUnescape Lib "shlwapi" Alias "UrlUnescapeA" ( _ 37 | ByVal pszURL As String, _ 38 | ByVal pszUnescaped As String, _ 39 | ByRef pcchUnescaped As Long, _ 40 | ByVal dwFlags As Long) As Long 41 | 42 | Public Function URLDecode( _ 43 | ByVal URL As String, _ 44 | Optional ByVal PlusSpace As Boolean = True) As String 45 | 46 | Dim cchUnescaped As Long 47 | Dim HRESULT As Long 48 | 49 | If PlusSpace Then URL = Replace$(URL, "+", " ") 50 | cchUnescaped = Len(URL) 51 | URLDecode = String$(cchUnescaped, 0) 52 | HRESULT = UrlUnescape(URL, URLDecode, cchUnescaped, 0) 53 | If HRESULT = E_POINTER Then 54 | URLDecode = String$(cchUnescaped, 0) 55 | HRESULT = UrlUnescape(URL, URLDecode, cchUnescaped, 0) 56 | End If 57 | 58 | If HRESULT <> S_OK Then 59 | Err.Raise Err.LastDllError, "URLUtility.URLDecode", _ 60 | "System error" 61 | End If 62 | 63 | URLDecode = Left$(URLDecode, cchUnescaped) 64 | End Function 65 | 66 | Public Function URLEncode( _ 67 | ByVal URL As String, _ 68 | Optional ByVal SpacePlus As Boolean = True) As String 69 | 70 | Dim cchEscaped As Long 71 | Dim HRESULT As Long 72 | 73 | If Len(URL) > INTERNET_MAX_URL_LENGTH Then 74 | Err.Raise &H8004D700, "URLUtility.URLEncode", _ 75 | "URL parameter too long" 76 | End If 77 | 78 | cchEscaped = Len(URL) * 1.5 79 | URLEncode = String$(cchEscaped, 0) 80 | HRESULT = UrlEscape(URL, URLEncode, cchEscaped, URL_ESCAPE_PERCENT) 81 | If HRESULT = E_POINTER Then 82 | URLEncode = String$(cchEscaped, 0) 83 | HRESULT = UrlEscape(URL, URLEncode, cchEscaped, URL_ESCAPE_PERCENT) 84 | End If 85 | 86 | If HRESULT <> S_OK Then 87 | Err.Raise Err.LastDllError, "URLUtility.URLEncode", _ 88 | "System error" 89 | End If 90 | 91 | URLEncode = Left$(URLEncode, cchEscaped) 92 | If SpacePlus Then 93 | URLEncode = Replace$(URLEncode, "+", "%2B") 94 | URLEncode = Replace$(URLEncode, " ", "+") 95 | End If 96 | End Function 97 | 98 | 99 | 100 | -------------------------------------------------------------------------------- /msw.fbp.PDM: -------------------------------------------------------------------------------- 1 | [Root] 2 | Most Recent Package=Standard Setup Package 1 3 | 4 | 5 | [Package|Standard Setup Package 1|Root] 6 | SubWizProgID=PDWizard.SetupPkgSubWiz 7 | BuildFolder=C:\WINDOWS\DESKTOP\mfw\Package 8 | 9 | [Package|Standard Setup Package 1|Configure DAO ISAMs] 10 | Applicable=No 11 | 12 | [Package|Standard Setup Package 1|Configure DAO ODBC] 13 | JetWorkspace= 14 | ODBCDirect= 15 | 16 | [Package|Standard Setup Package 1|Files Found] 17 | 18 | [Package|Standard Setup Package 1|Files Released] 19 | 20 | [Package|Standard Setup Package 1|Missing Dependency Information] 21 | C:\WINDOWS\SYSTEM\WININET.DLL= 22 | C:\WINDOWS\SYSTEM\SHLWAPI.DLL= 23 | 24 | [Package|Standard Setup Package 1|Out-of-Date Dependency Information] 25 | 26 | [Package|Standard Setup Package 1|Files Added] 27 | 28 | [Package|Standard Setup Package 1|Files Removed] 29 | 30 | [Package|Standard Setup Package 1|Files In Project] 31 | C:\WINDOWS\DESKTOP\mastodon311.exe=Yes 32 | C:\WINDOWS\SYSTEM\MSVBVM60.DLL=Yes 33 | C:\WINDOWS\SYSTEM\OLEAUT32.DLL=Yes 34 | C:\WINDOWS\SYSTEM\OLEPRO32.DLL=Yes 35 | C:\WINDOWS\SYSTEM\ASYCFILT.DLL=Yes 36 | C:\WINDOWS\SYSTEM\STDOLE2.TLB=Yes 37 | C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\Redist\COMCAT.DLL=Yes 38 | C:\WINDOWS\SYSTEM\SHLWAPI.DLL=Yes 39 | C:\WINDOWS\SYSTEM\WININET.DLL=Yes 40 | C:\WINDOWS\SYSTEM\COMCTL32.OCX=Yes 41 | C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\SETUP.EXE=Yes 42 | C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\SETUP1.EXE=Yes 43 | C:\WINDOWS\SYSTEM\VB6STKIT.DLL=Yes 44 | C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\ST6UNST.EXE=Yes 45 | 46 | [Package|Standard Setup Package 1|Configure Registry Files] 47 | Applicable=No 48 | 49 | [Package|Standard Setup Package 1|Configure Remote Servers] 50 | Applicable=No 51 | 52 | [Package|Standard Setup Package 1|Install Locations] 53 | C:\WINDOWS\DESKTOP\mastodon311.exe=$(AppPath) 54 | C:\WINDOWS\SYSTEM\MSVBVM60.DLL=$(WinSysPathSysFile) 55 | C:\WINDOWS\SYSTEM\OLEAUT32.DLL=$(WinSysPathSysFile) 56 | C:\WINDOWS\SYSTEM\OLEPRO32.DLL=$(WinSysPathSysFile) 57 | C:\WINDOWS\SYSTEM\ASYCFILT.DLL=$(WinSysPathSysFile) 58 | C:\WINDOWS\SYSTEM\STDOLE2.TLB=$(WinSysPathSysFile) 59 | C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\Redist\COMCAT.DLL=$(WinSysPathSysFile) 60 | C:\WINDOWS\SYSTEM\SHLWAPI.DLL=$(WinSysPath) 61 | C:\WINDOWS\SYSTEM\WININET.DLL=$(WinSysPath) 62 | C:\WINDOWS\SYSTEM\COMCTL32.OCX=$(WinSysPath) 63 | C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\SETUP.EXE=$(AppPath) 64 | C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\SETUP1.EXE=$(WinPath) 65 | C:\WINDOWS\SYSTEM\VB6STKIT.DLL=$(WinSysPathSysFile) 66 | C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\ST6UNST.EXE=$(WinPath) 67 | 68 | [Package|Standard Setup Package 1|Configure Shared Files] 69 | Applicable=Yes 70 | C:\WINDOWS\DESKTOP\mastodon311.exe=No 71 | 72 | [Package|Standard Setup Package 1|Distribution] 73 | Type=multi 74 | Size=1.44 MB 75 | Title=Mastodon 3.11 For Workgroups 76 | 77 | [Package|Standard Setup Package 1|IconGroups] 78 | Group0=Mastodon 3.11 For Workgroups 79 | PrivateGroup0=True 80 | Parent0=$(Programs) 81 | 82 | [Package|Standard Setup Package 1|Mastodon 3.11 For Workgroups] 83 | Icon1=mastodon311.exe 84 | Title1=Mastodon 3.11 For Workgroups 85 | StartIn1=$(AppPath) 86 | Key1=Icon1 87 | 88 | [Package|Standard Setup Package 1|Package] 89 | PackageFolder=C:\WINDOWS\DESKTOP\mfw\Package 90 | ProjectFolder=C:\WINDOWS\DESKTOP\mfw 91 | ServerSideCab= 92 | File1=C:\WINDOWS\DESKTOP\mfw\Package\setup.exe 93 | File2=C:\WINDOWS\DESKTOP\mfw\Package\Setup.Lst 94 | File3=C:\WINDOWS\DESKTOP\mfw\Package\mastod1.CAB 95 | File4=C:\WINDOWS\DESKTOP\mfw\Package\mastod2.CAB 96 | Handler1=PDWizard.FloppyDplySubWiz 97 | Handler2=PDWizard.FolderDplySubWiz 98 | Handler3=PDWizard.WebPostDplySubWiz 99 | -------------------------------------------------------------------------------- /modWinInet.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "modWinInet" 2 | Option Explicit 3 | 4 | ' Initializes an application's use of the Win32 Internet functions 5 | Public Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _ 6 | (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _ 7 | ByVal sProxyBypass As String, ByVal lFlags As Long) As Long 8 | 9 | ' User agent constant. 10 | Public Const scUserAgent = "Mastodon for Workgroups/1.0" 11 | 12 | ' Use registry access settings. 13 | Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0 14 | 15 | ' Opens a HTTP session for a given site. 16 | Public Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _ 17 | (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, _ 18 | ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, _ 19 | ByVal lFlags As Long, ByVal lContext As Long) As Long 20 | 21 | ' Number of the TCP/IP port on the server to connect to. 22 | Public Const INTERNET_DEFAULT_FTP_PORT = 21 23 | Public Const INTERNET_DEFAULT_GOPHER_PORT = 70 24 | Public Const INTERNET_DEFAULT_HTTP_PORT = 80 25 | Public Const INTERNET_DEFAULT_HTTPS_PORT = 443 26 | Public Const INTERNET_DEFAULT_SOCKS_PORT = 1080 27 | 28 | ' Type of service to access. 29 | Public Const INTERNET_SERVICE_FTP = 1 30 | Public Const INTERNET_SERVICE_GOPHER = 2 31 | Public Const INTERNET_SERVICE_HTTP = 3 32 | 33 | ' Opens an HTTP request handle. 34 | Public Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" _ 35 | (ByVal hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As String, ByVal sVersion As String, _ 36 | ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long 37 | 38 | ' Brings the data across the wire even if it locally cached. 39 | Public Const INTERNET_FLAG_RELOAD = &H80000000 40 | 41 | ' Sends the specified request to the HTTP server. 42 | Public Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" (ByVal _ 43 | hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, sOptional As _ 44 | Any, ByVal lOptionalLength As Long) As Integer 45 | 46 | ' Queries for information about an HTTP request. 47 | Public Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" _ 48 | (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As Any, _ 49 | ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer 50 | 51 | ' The possible values for the lInfoLevel parameter include: 52 | Public Const HTTP_QUERY_CONTENT_TYPE = 1 53 | Public Const HTTP_QUERY_CONTENT_LENGTH = 5 54 | Public Const HTTP_QUERY_EXPIRES = 10 55 | Public Const HTTP_QUERY_LAST_MODIFIED = 11 56 | Public Const HTTP_QUERY_PRAGMA = 17 57 | Public Const HTTP_QUERY_VERSION = 18 58 | Public Const HTTP_QUERY_STATUS_CODE = 19 59 | Public Const HTTP_QUERY_STATUS_TEXT = 20 60 | Public Const HTTP_QUERY_RAW_HEADERS = 21 61 | Public Const HTTP_QUERY_RAW_HEADERS_CRLF = 22 62 | Public Const HTTP_QUERY_FORWARDED = 30 63 | Public Const HTTP_QUERY_SERVER = 37 64 | Public Const HTTP_QUERY_USER_AGENT = 39 65 | Public Const HTTP_QUERY_SET_COOKIE = 43 66 | Public Const HTTP_QUERY_REQUEST_METHOD = 45 67 | 68 | ' Add this flag to the about flags to get request header. 69 | Public Const HTTP_QUERY_FLAG_REQUEST_HEADERS = &H80000000 70 | 71 | ' Reads data from a handle opened by the HttpOpenRequest function. 72 | Public Declare Function InternetReadFile Lib "wininet.dll" _ 73 | (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _ 74 | lNumberOfBytesRead As Long) As Integer 75 | 76 | ' Closes a single Internet handle or a subtree of Internet handles. 77 | Public Declare Function InternetCloseHandle Lib "wininet.dll" _ 78 | (ByVal hInet As Long) As Integer 79 | 80 | ' Queries an Internet option on the specified handle 81 | Public Declare Function InternetQueryOption Lib "wininet.dll" Alias "InternetQueryOptionA" _ 82 | (ByVal hInternet As Long, ByVal lOption As Long, ByRef sBuffer As Any, ByRef lBufferLength As Long) As Integer 83 | 84 | ' Returns the version number of Wininet.dll. 85 | Public Const INTERNET_OPTION_VERSION = 40 86 | 87 | ' Contains the version number of the DLL that contains the Windows Internet 88 | ' functions (Wininet.dll). This structure is used when passing the 89 | ' INTERNET_OPTION_VERSION flag to the InternetQueryOption function. 90 | Public Type tWinInetDLLVersion 91 | lMajorVersion As Long 92 | lMinorVersion As Long 93 | End Type 94 | 95 | ' Adds one or more HTTP request headers to the HTTP request handle. 96 | Public Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias "HttpAddRequestHeadersA" _ 97 | (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, _ 98 | ByVal lModifiers As Long) As Integer 99 | 100 | ' Flags to modify the semantics of this function. Can be a combination of these values: 101 | 102 | ' Adds the header only if it does not already exist; otherwise, an error is returned. 103 | Public Const HTTP_ADDREQ_FLAG_ADD_IF_NEW = &H10000000 104 | 105 | ' Adds the header if it does not exist. Used with REPLACE. 106 | Public Const HTTP_ADDREQ_FLAG_ADD = &H20000000 107 | 108 | ' Replaces or removes a header. If the header value is empty and the header is found, 109 | ' it is removed. If not empty, the header value is replaced 110 | Public Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000 111 | 112 | 113 | -------------------------------------------------------------------------------- /loginform.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form loginform 3 | ClientHeight = 3615 4 | ClientLeft = 60 5 | ClientTop = 345 6 | ClientWidth = 4680 7 | LinkTopic = "Form1" 8 | ScaleHeight = 3615 9 | ScaleWidth = 4680 10 | StartUpPosition = 3 'Windows Default 11 | Begin VB.CommandButton cancelbt 12 | Caption = "Cancel" 13 | BeginProperty Font 14 | Name = "Times New Roman" 15 | Size = 9 16 | Charset = 0 17 | Weight = 400 18 | Underline = 0 'False 19 | Italic = 0 'False 20 | Strikethrough = 0 'False 21 | EndProperty 22 | Height = 375 23 | Left = 120 24 | TabIndex = 6 25 | Top = 3120 26 | Width = 1575 27 | End 28 | Begin VB.CommandButton Command1 29 | Caption = "Save and continue" 30 | Default = -1 'True 31 | BeginProperty Font 32 | Name = "Times New Roman" 33 | Size = 9 34 | Charset = 0 35 | Weight = 400 36 | Underline = 0 'False 37 | Italic = 0 'False 38 | Strikethrough = 0 'False 39 | EndProperty 40 | Height = 375 41 | Left = 3000 42 | TabIndex = 5 43 | Top = 3120 44 | Width = 1575 45 | End 46 | Begin VB.Frame Frame2 47 | Caption = "API token" 48 | BeginProperty Font 49 | Name = "Times New Roman" 50 | Size = 9 51 | Charset = 0 52 | Weight = 400 53 | Underline = 0 'False 54 | Italic = 0 'False 55 | Strikethrough = 0 'False 56 | EndProperty 57 | Height = 615 58 | Left = 120 59 | TabIndex = 3 60 | Top = 1560 61 | Width = 4455 62 | Begin VB.TextBox token 63 | BeginProperty Font 64 | Name = "Times New Roman" 65 | Size = 9 66 | Charset = 0 67 | Weight = 400 68 | Underline = 0 'False 69 | Italic = 0 'False 70 | Strikethrough = 0 'False 71 | EndProperty 72 | Height = 285 73 | Left = 120 74 | TabIndex = 4 75 | Top = 240 76 | Width = 4215 77 | End 78 | End 79 | Begin VB.Frame Frame1 80 | Caption = "Instance (eg. blahaj.social)" 81 | BeginProperty Font 82 | Name = "Times New Roman" 83 | Size = 9 84 | Charset = 0 85 | Weight = 400 86 | Underline = 0 'False 87 | Italic = 0 'False 88 | Strikethrough = 0 'False 89 | EndProperty 90 | Height = 615 91 | Left = 120 92 | TabIndex = 1 93 | Top = 720 94 | Width = 4455 95 | Begin VB.TextBox instance 96 | BeginProperty Font 97 | Name = "Times New Roman" 98 | Size = 9 99 | Charset = 0 100 | Weight = 400 101 | Underline = 0 'False 102 | Italic = 0 'False 103 | Strikethrough = 0 'False 104 | EndProperty 105 | Height = 285 106 | Left = 120 107 | TabIndex = 2 108 | Top = 240 109 | Width = 4215 110 | End 111 | End 112 | Begin VB.Label tokenNotice 113 | Caption = $"loginform.frx":0000 114 | Height = 615 115 | Left = 240 116 | TabIndex = 7 117 | Top = 2280 118 | Width = 4215 119 | End 120 | Begin VB.Label Label1 121 | Caption = "Welcome to Mastodon 3.11 for workgroups. Please sign in with your Fediverse ID first:" 122 | BeginProperty Font 123 | Name = "Times New Roman" 124 | Size = 9 125 | Charset = 0 126 | Weight = 400 127 | Underline = 0 'False 128 | Italic = 0 'False 129 | Strikethrough = 0 'False 130 | EndProperty 131 | Height = 495 132 | Left = 120 133 | TabIndex = 0 134 | Top = 120 135 | Width = 4455 136 | End 137 | End 138 | Attribute VB_Name = "loginform" 139 | Attribute VB_GlobalNameSpace = False 140 | Attribute VB_Creatable = False 141 | Attribute VB_PredeclaredId = True 142 | Attribute VB_Exposed = False 143 | Dim file_token As Integer 144 | Dim file_instance As Integer 145 | Dim path, token_path As String, instance_path As String 146 | 147 | Private Sub cancelbt_Click() 148 | main.Show 149 | Unload loginform 150 | End Sub 151 | 152 | Private Sub Command1_Click() 153 | WriteIni "auth", "instance", instance.Text 154 | WriteIni "auth", "token", token.Text 155 | 156 | main.Show 157 | Unload loginform 158 | End Sub 159 | 160 | 161 | -------------------------------------------------------------------------------- /newToot.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form newToot 3 | Caption = "New Toot" 4 | ClientHeight = 2970 5 | ClientLeft = 60 6 | ClientTop = 345 7 | ClientWidth = 4680 8 | LinkTopic = "Form1" 9 | ScaleHeight = 2970 10 | ScaleWidth = 4680 11 | StartUpPosition = 3 'Windows Default 12 | Begin VB.ComboBox Visibility 13 | Height = 315 14 | ItemData = "newToot.frx":0000 15 | Left = 1680 16 | List = "newToot.frx":0002 17 | TabIndex = 3 18 | Text = "Visibiliy" 19 | Top = 2520 20 | Width = 1335 21 | End 22 | Begin VB.CommandButton SendToot 23 | Caption = "Toot!" 24 | DragIcon = "newToot.frx":0004 25 | Enabled = 0 'False 26 | BeginProperty Font 27 | Name = "Arial" 28 | Size = 9 29 | Charset = 0 30 | Weight = 400 31 | Underline = 0 'False 32 | Italic = 0 'False 33 | Strikethrough = 0 'False 34 | EndProperty 35 | Height = 375 36 | Left = 3120 37 | MouseIcon = "newToot.frx":030E 38 | Picture = "newToot.frx":0618 39 | TabIndex = 1 40 | ToolTipText = "Send a post to your Mastodon account" 41 | Top = 2520 42 | Width = 1455 43 | End 44 | Begin VB.TextBox Content 45 | BeginProperty Font 46 | Name = "Arial" 47 | Size = 9 48 | Charset = 0 49 | Weight = 400 50 | Underline = 0 'False 51 | Italic = 0 'False 52 | Strikethrough = 0 'False 53 | EndProperty 54 | Height = 2295 55 | Left = 120 56 | MultiLine = -1 'True 57 | TabIndex = 0 58 | Top = 120 59 | Width = 4455 60 | End 61 | Begin VB.Label CharsLeft 62 | Caption = "0 / 500" 63 | ForeColor = &H80000008& 64 | Height = 255 65 | Left = 120 66 | TabIndex = 2 67 | Top = 2640 68 | Width = 1215 69 | End 70 | End 71 | Attribute VB_Name = "newToot" 72 | Attribute VB_GlobalNameSpace = False 73 | Attribute VB_Creatable = False 74 | Attribute VB_PredeclaredId = True 75 | Attribute VB_Exposed = False 76 | Private Sub Form_Load() 77 | Visibility.AddItem "public" 78 | Visibility.AddItem "unlisted" 79 | Visibility.AddItem "private" 80 | Visibility.Text = Visibility.List(0) ' Display first item. 81 | 82 | End Sub 83 | 84 | Private Sub SendToot_Click() 85 | Dim hInternetSession As Long 86 | Dim hInternetConnect As Long 87 | Dim hHttpOpenRequest As Long 88 | Dim sBuffer As String 89 | Dim sReadBuffer As String * 2048 90 | Dim lNumberOfBytesRead As Long 91 | Dim scUserAgent As String 92 | Dim bDoLoop As Boolean 93 | 94 | SendToot.Enabled = False 95 | Screen.MousePointer = vbHourglass 96 | 97 | hInternetSession = InternetOpen(scUserAgent, _ 98 | INTERNET_OPEN_TYPE_PRECONFIG, _ 99 | vbNullString, _ 100 | vbNullString, _ 101 | 0) 102 | hInternetConnect = InternetConnect(hInternetSession, _ 103 | GetInstance(), _ 104 | INTERNET_DEFAULT_HTTP_PORT, _ 105 | vbNullString, _ 106 | vbNullString, _ 107 | INTERNET_SERVICE_HTTP, _ 108 | 0, _ 109 | 0) 110 | 111 | hHttpOpenRequest = HttpOpenRequest(hInternetConnect, _ 112 | "POST", _ 113 | "/api/v1/statuses", _ 114 | "HTTP/1.1", _ 115 | vbNullString, _ 116 | 0, _ 117 | INTERNET_FLAG_RELOAD, _ 118 | 0) 119 | Dim authHeader As String 120 | authHeader = "Authorization: Bearer " & GetToken() & vbCrLf 121 | HttpAddRequestHeaders hHttpOpenRequest, _ 122 | authHeader, _ 123 | Len(authHeader), _ 124 | HTTP_ADDREQ_FLAG_ADD 125 | 126 | Dim contentType As String 127 | contentType = "Content-Type: application/x-www-form-urlencoded" 128 | HttpAddRequestHeaders hHttpOpenRequest, _ 129 | contentType, _ 130 | Len(contentType), _ 131 | HTTP_ADDREQ_FLAG_ADD 132 | 133 | Dim formData As String 134 | formData = "status=" & URLEncode(Content.Text) & "&visibility=" & Visibility.Text 135 | 136 | HttpSendRequest hHttpOpenRequest, vbNullString, 0, ByVal formData, Len(formData) 137 | 138 | bDoLoop = True 139 | While bDoLoop 140 | sReadBuffer = vbNullString 141 | bDoLoop = InternetReadFile(hHttpOpenRequest, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead) 142 | sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead) 143 | If Not CBool(lNumberOfBytesRead) Then bDoLoop = False 144 | Wend 145 | 146 | InternetCloseHandle (hInternetSession) 147 | Screen.MousePointer = vbDefault 148 | Unload Me 149 | End Sub 150 | 151 | Private Sub Content_Change() 152 | CharsLeft.Caption = Len(Content.Text) & " / 500" 153 | 154 | If Len(Content.Text) > 500 Then 155 | CharsLeft.ForeColor = &HFF& 156 | SendToot.Enabled = False 157 | Else 158 | CharsLeft.ForeColor = vbWindowText 159 | If Len(Content.Text) > 0 Then 160 | SendToot.Enabled = True 161 | Else 162 | SendToot.Enabled = False 163 | End If 164 | End If 165 | End Sub 166 | 167 | -------------------------------------------------------------------------------- /main.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX" 3 | Begin VB.Form main 4 | Caption = "Mastodon 3.11 for Workgroups" 5 | ClientHeight = 5445 6 | ClientLeft = 60 7 | ClientTop = 345 8 | ClientWidth = 4710 9 | BeginProperty Font 10 | Name = "Times New Roman" 11 | Size = 9 12 | Charset = 0 13 | Weight = 400 14 | Underline = 0 'False 15 | Italic = 0 'False 16 | Strikethrough = 0 'False 17 | EndProperty 18 | LinkTopic = "Form1" 19 | ScaleHeight = 5445 20 | ScaleWidth = 4710 21 | StartUpPosition = 3 'Windows Default 22 | Begin MFW.Post Post1 23 | Height = 1455 24 | Left = 120 25 | TabIndex = 6 26 | Top = 1800 27 | Width = 4215 28 | _ExtentX = 5953 29 | _ExtentY = 2566 30 | End 31 | Begin VB.VScrollBar VScroll1 32 | Height = 3495 33 | Left = 4440 34 | TabIndex = 5 35 | Top = 1680 36 | Width = 255 37 | End 38 | Begin ComctlLib.StatusBar StatusBar 39 | Align = 2 'Align Bottom 40 | Height = 255 41 | Left = 0 42 | TabIndex = 4 43 | Top = 5190 44 | Width = 4710 45 | _ExtentX = 8308 46 | _ExtentY = 450 47 | SimpleText = "" 48 | _Version = 327682 49 | BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7} 50 | NumPanels = 1 51 | BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7} 52 | TextSave = "" 53 | Key = "" 54 | Object.Tag = "" 55 | EndProperty 56 | EndProperty 57 | End 58 | Begin VB.CommandButton refreshbt 59 | Caption = "Refresh" 60 | Height = 375 61 | Left = 240 62 | TabIndex = 2 63 | Top = 720 64 | Width = 4215 65 | End 66 | Begin VB.Frame buttonframe 67 | Height = 1575 68 | Left = 120 69 | TabIndex = 0 70 | Top = 0 71 | Width = 4455 72 | Begin VB.CommandButton debug 73 | Caption = "HTTP Debug" 74 | Height = 255 75 | Left = 960 76 | TabIndex = 3 77 | Top = 1200 78 | Width = 2655 79 | End 80 | Begin VB.CommandButton addbt 81 | Caption = "New Toot" 82 | Height = 375 83 | Left = 120 84 | TabIndex = 1 85 | Top = 240 86 | Width = 4215 87 | End 88 | End 89 | End 90 | Attribute VB_Name = "main" 91 | Attribute VB_GlobalNameSpace = False 92 | Attribute VB_Creatable = False 93 | Attribute VB_PredeclaredId = True 94 | Attribute VB_Exposed = False 95 | ' Mastodon 3.11 for Workgroups the Windows 9x Mastodon Client 96 | ' Copyright 2022 Maartje Eyskens 97 | ' inspired by awsom, the vb6 mastodon client: reds, 2018 98 | 99 | Option Explicit 100 | Dim statusPanel As Panel ' status panel 101 | Dim posts() As Object ' list of rendered posts 102 | Dim oldScrollValue As Integer ' make scrolling work 103 | 104 | Private Sub SetStatus(status As String) 105 | statusPanel.Text = status 106 | End Sub 107 | 108 | Private Sub addbt_Click() 109 | newToot.Show 110 | End Sub 111 | 112 | Private Function cleanStatus(ByVal Content As String) As String 113 | Content = Replace(Content, "

", "") 114 | Content = Replace(Content, "

", "") 115 | cleanStatus = Content 116 | End Function 117 | 118 | 119 | Private Function loadTimeline() As JsonBag 120 | Dim hInternetSession As Long 121 | Dim hInternetConnect As Long 122 | Dim hHttpOpenRequest As Long 123 | Dim sBuffer As String 124 | Dim sReadBuffer As String * 2048 125 | Dim lNumberOfBytesRead As Long 126 | Dim scUserAgent As String 127 | Dim bDoLoop As Boolean 128 | 129 | SetStatus "Opening connection..." 130 | 131 | hInternetSession = InternetOpen(scUserAgent, _ 132 | INTERNET_OPEN_TYPE_PRECONFIG, _ 133 | vbNullString, _ 134 | vbNullString, _ 135 | 0) 136 | hInternetConnect = InternetConnect(hInternetSession, _ 137 | GetInstance(), _ 138 | INTERNET_DEFAULT_HTTP_PORT, _ 139 | vbNullString, _ 140 | vbNullString, _ 141 | INTERNET_SERVICE_HTTP, _ 142 | 0, _ 143 | 0) 144 | SetStatus "Sending request..." 145 | hHttpOpenRequest = HttpOpenRequest(hInternetConnect, _ 146 | "GET", _ 147 | "/api/v1/timelines/home", _ 148 | "HTTP/1.1", _ 149 | vbNullString, _ 150 | 0, _ 151 | INTERNET_FLAG_RELOAD, _ 152 | 0) 153 | Dim authHeader As String 154 | authHeader = "Authorization: Bearer " & GetToken() & vbCrLf 155 | 156 | HttpAddRequestHeaders hHttpOpenRequest, _ 157 | authHeader, _ 158 | Len(authHeader), _ 159 | HTTP_ADDREQ_FLAG_ADD 160 | HttpSendRequest hHttpOpenRequest, vbNullString, 0, 0, 0 161 | 162 | SetStatus "Reading data..." 163 | bDoLoop = True 164 | While bDoLoop 165 | sReadBuffer = vbNullString 166 | bDoLoop = InternetReadFile(hHttpOpenRequest, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead) 167 | sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead) 168 | If Not CBool(lNumberOfBytesRead) Then bDoLoop = False 169 | Wend 170 | 171 | SetStatus "Parsing data..." 172 | 173 | Dim JB 174 | Set JB = New JsonBag 175 | JB.JSON = sBuffer 176 | InternetCloseHandle (hInternetSession) 177 | 178 | SetStatus "Rendering..." 179 | 180 | Dim counter As Integer 181 | counter = 1 182 | While JB.Count >= counter And counter <= 20 183 | ' MsgBox JB.Item(counter).Item("content"), vbInformation, "Mastodon 3.11 for Workgroups" 184 | ReDim Preserve posts(counter) 185 | Set posts(counter) = Controls.Add("MFW.Post", "dynpost" & counter) 186 | posts(counter).Width = 4215 187 | posts(counter).Top = 1800 + 1455 * (counter - 1) 188 | posts(counter).Left = 120 189 | posts(counter).Height = 1455 190 | posts(counter).Visible = True 191 | posts(counter).Username = JB.Item(counter).Item("account").Item("acct") 192 | posts(counter).Content = cleanStatus(JB.Item(counter).Item("content")) 193 | 194 | counter = counter + 1 195 | Wend 196 | 197 | SetStatus "Cuddle a Blahaj" 198 | 199 | End Function 200 | 201 | Private Sub debug_Click() 202 | frmHttpQuery.Show 203 | End Sub 204 | 205 | Private Sub refreshbt_Click() 206 | Screen.MousePointer = vbHourglass 207 | VScroll1.Value = 0 208 | 209 | If GetInstance() <> "" Then 210 | loadTimeline 211 | Else 212 | loginform.Show 213 | main.Hide 214 | End If 215 | 216 | Screen.MousePointer = vbDefault 217 | End Sub 218 | 219 | Private Sub Form_Load() 220 | Post1.Visible = False ' post1 is used to demo in the form editor 221 | StatusBar.Panels.Clear ' clear default panels 222 | Set statusPanel = StatusBar.Panels.Add() 223 | 224 | With VScroll1 ' set up scrollbad TODO: make math better 225 | .Min = 0 226 | .Max = 20000 227 | .SmallChange = Screen.TwipsPerPixelY * 10 228 | .LargeChange = .SmallChange 229 | End With 230 | End Sub 231 | 232 | 233 | Private Sub VScroll1_Change() 234 | Dim eachctl As Control 235 | For Each eachctl In Me.Controls 236 | If TypeOf eachctl Is Post Then 237 | eachctl.Top = eachctl.Top + oldScrollValue - VScroll1.Value 238 | End If 239 | Next 240 | oldScrollValue = VScroll1.Value 241 | 242 | 243 | End Sub 244 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /JsonBag.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 = "JsonBag" 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 | 'Not a real (fractional) number, but Major.Minor integers: 17 | Private Const CLASS_VERSION As String = "2.5" 18 | 19 | 'LICENSE: 20 | ' 21 | 'JsonBag Class (JsonBag.cls) 22 | ' 23 | 'Version 2.5 24 | ' 25 | 'A parser/serializer class for JSON data interchange written in Visual 26 | 'Basic 6.0 (some versions usable in Office VBA with little or no 27 | 'modification). 28 | ' 29 | ' 30 | 'Copyright 2013, 2014, 2015, 2016 Robert D. Riemersma, Jr. 31 | ' 32 | 'Licensed under the Apache License, Version 2.0 (the "License"); 33 | 'you may not use this file except in compliance with the License. 34 | 'You may obtain a copy of the License at 35 | ' 36 | ' http://www.apache.org/licenses/LICENSE-2.0 37 | ' 38 | 'Unless required by applicable law or agreed to in writing, software 39 | 'distributed under the License is distributed on an "AS IS" BASIS, 40 | 'WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 41 | 'See the License for the specific language governing permissions and 42 | 'limitations under the License. 43 | 44 | 'True for faster parsing at some loss of functionality. Comment out to 45 | 'default to False or the value specified via the Project Properties Make 46 | 'tab or VB6.EXE batch compile command line: 47 | 48 | '#Const NO_DEEPCOPY_WHITESPACE = True 49 | 50 | 'Character constants. 51 | Private Const LBRACE As String = "{" 52 | Private Const RBRACE As String = "}" 53 | Private Const LBRACKET As String = "[" 54 | Private Const RBRACKET As String = "]" 55 | Private Const COLON As String = ":" 56 | Private Const COMMA As String = "," 57 | Private Const BLANKSPACE As String = " " 58 | Private Const QUOTE As String = """" 59 | Private Const PLUS As String = "+" 60 | Private Const MINUS As String = "-" 61 | Private Const RADIXPOINT As String = "." 'Always a period since we're locale-blind. 62 | Private Const JSON_EXP As String = "e" 63 | Private Const ZERO As String = "0" 64 | Private Const NINE As String = "9" 65 | Private Const REVSOLIDUS As String = "\" 66 | 67 | Private Const WHITE_SPACE As String = vbTab & vbLf & vbCr & " " 68 | 69 | 'CLng(AscW()) And &HFFFF& (i.e. AscW() promoted to Long without sign extension) value constants. 70 | Private Const LBRACE_W As Long = &H7B& 71 | Private Const RBRACE_W As Long = &H7D& 72 | Private Const LBRACKET_W As Long = &H5B& 73 | Private Const RBRACKET_W As Long = &H5D& 74 | Private Const COLON_W As Long = &H3A& 75 | Private Const COMMA_W As Long = &H2C& 76 | Private Const NULL_W As Long = 0 77 | Private Const BLANKSPACE_W As Long = &H20& 78 | Private Const QUOTE_W As Long = &H22& 79 | Private Const PLUS_W As Long = &H2B& 80 | Private Const MINUS_W As Long = &H2D& 81 | Private Const RADIXPOINT_W As Long = &H2E& 'Always a period since we're locale-blind. 82 | Private Const JSON_EXP_W As Long = &H65& 83 | Private Const ZERO_W As Long = &H30& 84 | Private Const NINE_W As Long = &H39& 85 | Private Const REVSOLIDUS_W As Long = &H5C& 86 | 87 | Private Const S_OK As Long = 0 88 | Private Const VARIANT_ALPHABOOL As Long = &H2& 89 | Private Const LOCALE_INVARIANT As Long = 127& 'Used to do VT conversions with the invariant locale. 90 | 91 | #If Vba7 Then 92 | 'In VB6 and VBA6 many of these declarations will be marked in error by the IDE, but 93 | 'the compiler will never see them so you can ignore the error color (typically red): 94 | Private Declare PtrSafe Function HashData Lib "shlwapi" ( _ 95 | ByVal pbData As LongPtr, _ 96 | ByVal cbData As Long, _ 97 | ByVal pbHash As LongPtr, _ 98 | ByVal cbHash As Long) As Long 99 | 100 | Private Declare PtrSafe Function StrSpn Lib "shlwapi" Alias "StrSpnW" ( _ 101 | ByVal psz As LongPtr, _ 102 | ByVal pszSet As LongPtr) As Long 103 | 104 | Private PtrWhiteSpace As LongPtr 105 | 106 | Private Declare PtrSafe Function VariantChangeTypeEx Lib "oleaut32" ( _ 107 | ByRef vargDest As Variant, _ 108 | ByRef varSrc As Variant, _ 109 | ByVal lcid As Long, _ 110 | ByVal wFlags As Integer, _ 111 | ByVal vt As VbVarType) As Long 112 | #Else 113 | Private Declare Function HashData Lib "shlwapi" ( _ 114 | ByVal pbData As Long, _ 115 | ByVal cbData As Long, _ 116 | ByVal pbHash As Long, _ 117 | ByVal cbHash As Long) As Long 118 | 119 | Private Declare Function StrSpn Lib "shlwapi" Alias "StrSpnW" ( _ 120 | ByVal psz As Long, _ 121 | ByVal pszSet As Long) As Long 122 | 123 | Private PtrWhiteSpace As Long 124 | 125 | Private Declare Function VariantChangeTypeEx Lib "oleaut32" ( _ 126 | ByRef vargDest As Variant, _ 127 | ByRef varSrc As Variant, _ 128 | ByVal lcid As Long, _ 129 | ByVal wFlags As Integer, _ 130 | ByVal vt As VbVarType) As Long 131 | #End If 132 | 133 | Private TypeNameOfMe As String 'Used in raising exceptions. 134 | Private Names As Collection 135 | Private Values As Collection 136 | Private CursorIn As Long 'Scan position within JSON input string. 137 | Private LengthIn As Long 'Length of JSON input string. 138 | Private TextOut As String 'Buffer to build JSON output string in. 139 | Private CursorOut As Long 'Append position within JSON output string. 140 | Private NumberType As VbVarType 141 | Private PrefixedKey As String 'Side effect of ExistsStr() calls, used internally for optimization. 142 | 143 | Private mIsArray As Boolean 144 | Private mDecimalMode As Boolean 145 | Private mWhitespace As Boolean 'True to use indenting and newlines on JSON Get. 146 | Private mWhitespaceIndent As Integer 'Number of spaces per level for whitespace indenting. 147 | Private mWhitespaceNewLine As String 148 | 149 | '=== Public Properties ================================================================= 150 | 151 | Public Property Get CloneItem(ByVal Key As Variant) As Variant 152 | Attribute CloneItem.VB_Description = "Retrieve a clone of an Item by Key or Index, change or add a new Item that is a clone of the passed Item." 153 | 'Similar to the Item property but accepts/returns deep-copied 154 | 'clones instead of references to child object ("objects" and 155 | '"arrays"). 156 | ' 157 | 'For symmatry non-JsonBag simple values are just copied as with 158 | 'the item property. 159 | 160 | If IsNull(Key) Then Error9904 161 | If VarType(Key) = vbString Then 162 | If mIsArray Then Error9908 163 | 164 | If ExistsStr(Key) Then 165 | If IsObject(Values.Item(PrefixedKey)) Then 166 | Set CloneItem = Values.Item(PrefixedKey).Clone() 167 | Else 168 | CloneItem = Values.Item(PrefixedKey) 169 | End If 170 | Else 171 | Error990C 172 | End If 173 | Else 174 | If IsObject(Values.Item(Key)) Then 175 | Set CloneItem = Values.Item(Key).Clone() 176 | Else 177 | CloneItem = Values.Item(Key) 178 | End If 179 | End If 180 | End Property 181 | 182 | Public Property Let CloneItem(Optional ByVal Key As Variant, ByVal RHS As Variant) 183 | 'Add new Item or change existing Item's value to a deep-copy clone 184 | 'of RHS. 185 | 186 | If IsMissing(Key) Then Key = Null 187 | 188 | If IsObject(RHS) Then 189 | If Not TypeOf RHS Is JsonBag Then Error990D 190 | 191 | Item(Key) = RHS.Clone() 192 | Else 193 | Item(Key) = RHS 194 | End If 195 | End Property 196 | 197 | Public Property Set CloneItem(Optional ByVal Key As Variant, ByVal RHS As Variant) 198 | 'This is just an alias for Let since we don't have to do anything 199 | 'different. 200 | ' 201 | 'This allows either Let or Set to be used by client logic. 202 | 203 | If IsMissing(Key) Then Key = Null 204 | 205 | CloneItem(Key) = RHS 206 | End Property 207 | 208 | Public Property Get Count() As Long 209 | Attribute Count.VB_Description = "Count of Items in the list." 210 | Count = Values.Count 211 | End Property 212 | 213 | Public Property Get DecimalMode() As Boolean 214 | Attribute DecimalMode.VB_Description = "Causes numbers to be parsed and stored as Decimal type instead of Double." 215 | DecimalMode = mDecimalMode 216 | End Property 217 | 218 | Public Property Let DecimalMode(ByVal RHS As Boolean) 219 | Dim Item As Variant 220 | 221 | mDecimalMode = RHS 222 | If mDecimalMode Then 223 | NumberType = vbDecimal 224 | Else 225 | NumberType = vbDouble 226 | End If 227 | For Each Item In Values 228 | If TypeOf Item Is JsonBag Then 229 | Item.DecimalMode = mDecimalMode 230 | End If 231 | Next 232 | End Property 233 | 234 | Public Property Let IsArray(ByVal RHS As Boolean) 235 | If Values.Count > 0 Then 236 | Err.Raise &H80049900, TypeNameOfMe, "Cannot change IsArray setting after items have been added" 237 | Else 238 | mIsArray = RHS 239 | End If 240 | End Property 241 | 242 | Public Property Get IsArray() As Boolean 243 | Attribute IsArray.VB_Description = "True if this object is a JSON array instead of a JSON object. Must be set before first item is added." 244 | IsArray = mIsArray 245 | End Property 246 | 247 | 'Default property. 248 | Public Property Get Item(ByVal Key As Variant) As Variant 249 | Attribute Item.VB_Description = "Retrieve an Item by Key or Index, change or add a new Item." 250 | Attribute Item.VB_UserMemId = 0 251 | 'Retrieval works either by key or index for "objects" but only 252 | 'by index for "arrays." 253 | 254 | If IsNull(Key) Then Error9904 255 | If VarType(Key) = vbString Then 256 | If mIsArray Then Error9908 257 | 258 | If ExistsStr(Key) Then 259 | If IsObject(Values.Item(PrefixedKey)) Then 260 | Set Item = Values.Item(PrefixedKey) 261 | Else 262 | Item = Values.Item(PrefixedKey) 263 | End If 264 | Else 265 | Error990C 266 | End If 267 | Else 268 | If IsObject(Values.Item(Key)) Then 269 | Set Item = Values.Item(Key) 270 | Else 271 | Item = Values.Item(Key) 272 | End If 273 | End If 274 | End Property 275 | 276 | Public Property Let Item(Optional ByVal Key As Variant, ByVal RHS As Variant) 277 | 'Add new Item or change existing Item's value. 278 | ' 279 | 'When IsArray = True: 280 | ' 281 | ' Pass a Null as Key to add a new item at the end of the "array." 282 | ' 283 | ' Pass an index (Long) as Key to assign a new value to an 284 | ' existing Item. However if the index is greater than .Count 285 | ' the value is added as a new entry at the end of the "array." 286 | ' 287 | 'When IsArray = False (i.e. a JSON "object"): 288 | ' 289 | ' Pass a name (String) as Key. If the named Item exists its 290 | ' value is updated. If it does not exist a new Item is added. 291 | ' 292 | 'Item reassignment for existing items (assign new value) is 293 | 'implemented as remove and re-add. This means changing the value 294 | 'of an "object's" Item moves it to the end of the list. 295 | 296 | If IsMissing(Key) Then Key = Null 297 | 298 | If IsObject(RHS) Then 299 | If Not TypeOf RHS Is JsonBag Then Error990D 300 | End If 301 | 302 | With Values 303 | If mIsArray Then 304 | If VarType(Key) = vbString Then Error990E 305 | 306 | If IsNull(Key) Then 307 | .Add RHS 'Add at end. 308 | Names.Add .Count, CStr(.Count) 309 | Else 310 | If Key > .Count Then 311 | .Add RHS 'Add at end. 312 | Names.Add .Count, CStr(.Count) 313 | Else 314 | .Remove Key 315 | If Key > .Count Then 316 | .Add RHS 'Add at end. 317 | Else 318 | .Add RHS, , Key 'Insert into position. 319 | End If 320 | End If 321 | End If 322 | Else 323 | If VarType(Key) <> vbString Then Error9910 324 | 325 | If ExistsStr(Key) Then 326 | .Remove PrefixedKey 327 | .Add RHS, PrefixedKey 328 | Names.Remove PrefixedKey 329 | Else 330 | .Add RHS, PrefixedKey 331 | End If 332 | 'Add Name. 333 | Names.Add Key, PrefixedKey 334 | End If 335 | End With 336 | End Property 337 | 338 | Public Property Set Item(Optional ByVal Key As Variant, ByVal RHS As Variant) 339 | 'This is just an alias for Let since we don't have to do anything 340 | 'different. 341 | ' 342 | 'This allows either Let or Set to be used by client logic. 343 | 344 | If IsMissing(Key) Then Key = Null 345 | 346 | Item(Key) = RHS 347 | End Property 348 | 349 | Public Property Get ItemIsJSON(ByVal Key As Variant) As Boolean 350 | Attribute ItemIsJSON.VB_Description = "Reports True if an item is a JSON ""array"" or ""object"" and False if a simple value." 351 | 'Reports True if an item is a JSON "array" or "object" and False 352 | 'if a simple value. 353 | 354 | If IsNull(Key) Then Error9904 355 | If VarType(Key) = vbString Then 356 | If mIsArray Then Error9908 357 | 358 | If ExistsStr(Key) Then 359 | ItemIsJSON = IsObject(Values.Item(PrefixedKey)) 360 | Else 361 | Error990C 362 | End If 363 | Else 364 | ItemIsJSON = IsObject(Values.Item(Key)) 365 | End If 366 | End Property 367 | 368 | Public Property Get ItemJSON(ByVal Key As Variant) As String 369 | 'Retrieval works either by key or index for "objects" but only 370 | 'by index for "arrays." 371 | 372 | If IsNull(Key) Then Error9904 373 | If VarType(Key) = vbString Then 374 | If mIsArray Then Error9908 375 | 376 | If ExistsStr(Key) Then 377 | If IsObject(Values.Item(PrefixedKey)) Then 378 | ItemJSON = Values.Item(PrefixedKey).JSON 379 | Else 380 | Error990A 381 | End If 382 | Else 383 | Error990C 384 | End If 385 | Else 386 | If IsObject(Values.Item(Key)) Then 387 | ItemJSON = Values.Item(Key).JSON 388 | Else 389 | Error990A 390 | End If 391 | End If 392 | End Property 393 | 394 | Public Property Let ItemJSON(Optional ByVal Key As Variant, ByVal RHS As String) 395 | Attribute ItemJSON.VB_Description = "Retrieve a JsonBag Item's JSON by Key or Index, change or add a new Item via JSON text." 396 | 'Add new Item or change existing Item's value to parsed JSON "array" 397 | 'or "object." 398 | 399 | Dim JsonBag As JsonBag 400 | 401 | If IsMissing(Key) Then Key = Null 402 | 403 | Set JsonBag = New JsonBag 404 | With JsonBag 405 | .DecimalMode = mDecimalMode 406 | #If Not NO_DEEPCOPY_WHITESPACE Then 407 | .Whitespace = mWhitespace 408 | .WhitespaceIndent = mWhitespaceIndent 409 | .WhitespaceNewLine = mWhitespaceNewLine 410 | #End If 411 | .JSON = RHS 412 | End With 413 | Item(Key) = JsonBag 414 | End Property 415 | 416 | Public Property Get JSON() As String 417 | Attribute JSON.VB_Description = "A string representing the serialized contents of the object." 418 | CursorOut = 1 419 | SerializeItem vbNullString, Me 420 | JSON = Left$(TextOut, CursorOut - 1) 421 | 422 | 'Clear for next reuse. Do it here to reclaim space. 423 | TextOut = vbNullString 424 | End Property 425 | 426 | Public Property Let JSON(ByRef RHS As String) 427 | Clear 428 | 429 | CursorIn = 1 430 | LengthIn = Len(RHS) 431 | 432 | SkipWhitespace RHS 433 | 434 | Select Case Mid$(RHS, CursorIn, 1) 435 | Case LBRACE 436 | CursorIn = CursorIn + 1 437 | mIsArray = False 438 | ParseObject RHS, CursorIn, Len(RHS) 439 | Case LBRACKET 440 | CursorIn = CursorIn + 1 441 | mIsArray = True 442 | ParseArray RHS, CursorIn, Len(RHS) 443 | Case Else 444 | Error99A0 "either " & LBRACE & " or " & LBRACKET, CursorIn 445 | End Select 446 | End Property 447 | 448 | Public Property Get Name(ByVal Index As Long) As Variant 449 | Attribute Name.VB_Description = "Retrieves list Item Name by Index." 450 | If mIsArray Then 451 | Name = Index 452 | Else 453 | Name = Names.Item(Index) 454 | End If 455 | End Property 456 | 457 | Public Property Get Version() As String() 458 | Attribute Version.VB_Description = "Returns the Class version as a two-element String array." 459 | Version = Split(CLASS_VERSION, ".") 460 | End Property 461 | 462 | Public Property Get Whitespace() As Boolean 463 | Whitespace = mWhitespace 464 | End Property 465 | 466 | Public Property Let Whitespace(ByVal RHS As Boolean) 467 | Dim Item As Variant 468 | 469 | mWhitespace = RHS 470 | For Each Item In Values 471 | If TypeOf Item Is JsonBag Then 472 | Item.Whitespace = mWhitespace 473 | End If 474 | Next 475 | End Property 476 | 477 | Public Property Get WhitespaceIndent() As Integer 478 | WhitespaceIndent = mWhitespaceIndent 479 | End Property 480 | 481 | Public Property Let WhitespaceIndent(ByVal RHS As Integer) 482 | Dim Item As Variant 483 | 484 | If 1 > RHS Or RHS > 32 Then Err.Raise 380 'Invalid property value. 485 | 486 | mWhitespaceIndent = RHS 487 | For Each Item In Values 488 | If TypeOf Item Is JsonBag Then 489 | Item.WhitespaceIndent = mWhitespaceIndent 490 | End If 491 | Next 492 | End Property 493 | 494 | Public Property Get WhitespaceNewLine() As String 495 | WhitespaceNewLine = mWhitespaceNewLine 496 | End Property 497 | 498 | Public Property Let WhitespaceNewLine(ByVal RHS As String) 499 | Dim Item As Variant 500 | 501 | If Len(RHS) = 0 Then Err.Raise 380 'Invalid property value. 502 | 503 | mWhitespaceNewLine = RHS 504 | For Each Item In Values 505 | If TypeOf Item Is JsonBag Then 506 | Item.WhitespaceNewLine = mWhitespaceNewLine 507 | End If 508 | Next 509 | End Property 510 | 511 | '=== Public Methods ==================================================================== 512 | 513 | Public Function AddNewArray(Optional ByVal Key As Variant) As JsonBag 514 | Attribute AddNewArray.VB_Description = "Create new ""array"" type Item and add it to the list, returning a reference to it." 515 | If IsMissing(Key) Then Key = Null 516 | 517 | Set AddNewArray = New JsonBag 518 | With AddNewArray 519 | .DecimalMode = mDecimalMode 520 | .IsArray = True 521 | #If Not NO_DEEPCOPY_WHITESPACE Then 522 | .Whitespace = mWhitespace 523 | .WhitespaceIndent = mWhitespaceIndent 524 | .WhitespaceNewLine = mWhitespaceNewLine 525 | #End If 526 | End With 527 | Set Item(Key) = AddNewArray 528 | End Function 529 | 530 | Public Function AddNewObject(Optional ByVal Key As Variant) As JsonBag 531 | Attribute AddNewObject.VB_Description = "Create new ""object"" type Item and add it to the list, returning a reference to it." 532 | If IsMissing(Key) Then Key = Null 533 | 534 | Set AddNewObject = New JsonBag 535 | With AddNewObject 536 | .DecimalMode = mDecimalMode 537 | #If Not NO_DEEPCOPY_WHITESPACE Then 538 | .Whitespace = mWhitespace 539 | .WhitespaceIndent = mWhitespaceIndent 540 | .WhitespaceNewLine = mWhitespaceNewLine 541 | #End If 542 | End With 543 | Set Item(Key) = AddNewObject 544 | End Function 545 | 546 | Public Sub Clear() 547 | Attribute Clear.VB_Description = "Clears all data and sets IsArray to False." 548 | Set Names = New Collection 549 | Set Values = New Collection 550 | IsArray = False 551 | End Sub 552 | 553 | Public Function Clone() As JsonBag 554 | Attribute Clone.VB_Description = "Returns a deep-copy clione of the JsonBag instance." 555 | Dim I As Long 556 | 557 | Set Clone = New JsonBag 558 | With Clone 559 | .DecimalMode = DecimalMode 560 | #If Not NO_DEEPCOPY_WHITESPACE Then 561 | .Whitespace = Whitespace 562 | .WhitespaceIndent = WhitespaceIndent 563 | .WhitespaceNewLine = WhitespaceNewLine 564 | #End If 565 | If IsArray Then 566 | .IsArray = True 567 | For I = 1 To Count 568 | .Item(I) = CloneItem(I) 569 | Next 570 | Else 571 | For I = 1 To Count 572 | .Item(Name(I)) = CloneItem(I) 573 | Next 574 | End If 575 | End With 576 | End Function 577 | 578 | Public Function Exists(ByVal Key As Variant) As Boolean 579 | Attribute Exists.VB_Description = "Returns True if item specified by Key or Index is present." 580 | Dim Hash As Long 581 | Dim PrefixedKey As String 582 | Dim Name As String 583 | 584 | If VarType(Key) = vbString Then 585 | HashData StrPtr(Key), Len(Key) * 2, VarPtr(Hash), 4 586 | PrefixedKey = Right$("0000000" & Hex$(Hash), 8) & Key 587 | On Error Resume Next 588 | Name = Names.Item(PrefixedKey) 589 | Else 590 | On Error Resume Next 591 | Name = Names.Item(Key) 592 | End If 593 | Exists = Err.Number = 0 594 | Err.Clear 595 | End Function 596 | 597 | 'Marked as hidden and ProcedureID = -4 598 | Public Function NewEnum() As IUnknown 599 | Attribute NewEnum.VB_Description = "Iterates over the Item names." 600 | Attribute NewEnum.VB_UserMemId = -4 601 | Attribute NewEnum.VB_MemberFlags = "40" 602 | Set NewEnum = Values.[_NewEnum] 603 | End Function 604 | 605 | Public Sub Remove(ByVal Key As Variant) 606 | Attribute Remove.VB_Description = "Removes Item specified by Key or Index." 607 | 'Allow remove by Key or Index (only by Index for arrays). If the item 608 | 'does not exist return silently. 609 | 610 | Dim I As Long 611 | 612 | If VarType(Key) = vbString Then 613 | If mIsArray Then Err.Raise &H8004991C, TypeNameOfMe, "Must remove by index for arrays" 614 | 615 | If ExistsStr(Key) Then 616 | Names.Remove PrefixedKey 617 | Values.Remove PrefixedKey 618 | End If 619 | Else 620 | If 1 <= Key And Key <= Values.Count Then 621 | Values.Remove Key 622 | If IsArray Then 623 | For I = Names.Count To Key Step -1 624 | Names.Remove I 625 | Next 626 | For I = Key To Values.Count 627 | Names.Add I, CStr(I) 628 | Next 629 | Else 630 | Names.Remove Key 631 | End If 632 | End If 633 | End If 634 | End Sub 635 | 636 | '=== Friend Methods (do not call from client logic) ==================================== 637 | 638 | Friend Sub ParseArray( _ 639 | ByRef Text As String, _ 640 | ByRef StartCursor As Long, _ 641 | ByVal TextLength As Long) 642 | 'This call is made within the context of the instance at hand. 643 | 644 | Dim ArrayValue As Variant 645 | Dim FoundValue As Boolean 646 | 647 | CursorIn = StartCursor 648 | LengthIn = TextLength 649 | 650 | Do 651 | SkipWhitespace Text 652 | Select Case CLng(AscW(Mid$(Text, CursorIn, 1))) And &HFFFF& 653 | Case COMMA_W 654 | If Not FoundValue Then 655 | Err.Raise &H80049920, TypeNameOfMe, "Empty value at character " & CStr(CursorIn - 1) 656 | End If 657 | CursorIn = CursorIn + 1 658 | FoundValue = False 659 | Case RBRACKET_W 660 | CursorIn = CursorIn + 1 661 | Exit Do 662 | Case Else 663 | ParseValue Text, ArrayValue 664 | Values.Add ArrayValue 665 | Names.Add Values.Count 666 | FoundValue = True 667 | End Select 668 | Loop 669 | StartCursor = CursorIn 670 | End Sub 671 | 672 | Friend Sub ParseObject( _ 673 | ByRef Text As String, _ 674 | ByRef StartCursor As Long, _ 675 | ByVal TextLength As Long) 676 | 'This call is made within the context of the instance at hand. 677 | 678 | Dim ItemName As String 679 | Dim Value As Variant 680 | Dim FoundValue As Boolean 681 | 682 | CursorIn = StartCursor 683 | LengthIn = TextLength 684 | 685 | Do 686 | SkipWhitespace Text 687 | Select Case CLng(AscW(Mid$(Text, CursorIn, 1))) And &HFFFF& 688 | Case QUOTE_W 689 | CursorIn = CursorIn + 1 690 | ItemName = ParseName(Text) 691 | ParseValue Text, Value 692 | Item(ItemName) = Value 693 | FoundValue = True 694 | Case COMMA_W 695 | If Not FoundValue Then 696 | Err.Raise &H80049920, TypeNameOfMe, "Empty value at character " & CStr(CursorIn - 1) 697 | End If 698 | CursorIn = CursorIn + 1 699 | FoundValue = False 700 | Case RBRACE_W 701 | CursorIn = CursorIn + 1 702 | Exit Do 703 | Case Else 704 | Error99A0 ", or }", CursorIn - 1 705 | End Select 706 | Loop 707 | StartCursor = CursorIn 708 | End Sub 709 | 710 | '=== Private Methods =================================================================== 711 | 712 | Private Sub Cat(ByRef NewText As String) 713 | Const TEXT_CHUNK As Long = 512 'Allocation size for destination buffer Text. 714 | Dim LenNew As Long 715 | 716 | LenNew = Len(NewText) 717 | If LenNew > 0 Then 718 | If CursorOut + LenNew - 1 > Len(TextOut) Then 719 | If LenNew > TEXT_CHUNK Then 720 | TextOut = TextOut & Space$(LenNew + TEXT_CHUNK) 721 | Else 722 | TextOut = TextOut & Space$(TEXT_CHUNK) 723 | End If 724 | End If 725 | Mid$(TextOut, CursorOut, LenNew) = NewText 726 | CursorOut = CursorOut + LenNew 727 | End If 728 | End Sub 729 | 730 | Private Sub Error9904() 731 | Err.Raise &H80049904, TypeNameOfMe, "Key must be provided, a String or an index" 732 | End Sub 733 | 734 | Private Sub Error9908() 735 | Err.Raise &H80049908, TypeNameOfMe, "Array values can only be acessed by index" 736 | End Sub 737 | 738 | Private Sub Error990A() 739 | Err.Raise &H8004990A, TypeNameOfMe, "Simple Item cannot be retrieved as JSON text" 740 | End Sub 741 | 742 | Private Sub Error990C() 743 | Err.Raise &H8004990C, TypeNameOfMe, "Requested Item by key doesn't exist (case mismatch?)" 744 | End Sub 745 | 746 | Private Sub Error990D() 747 | Err.Raise &H8004990D, TypeNameOfMe, "JsonBag does not support VB6 Objects" 748 | End Sub 749 | 750 | Private Sub Error990E() 751 | Err.Raise &H8004990E, TypeNameOfMe, "Array values can only be changed by index or added via Null" 752 | End Sub 753 | 754 | Private Sub Error9910() 755 | Err.Raise &H80049910, TypeNameOfMe, "Object values can only be changed or added by key not by index" 756 | End Sub 757 | 758 | Private Sub Error99A0(ByVal Symbol As String, ByVal Position As Long) 759 | Err.Raise &H800499A0, TypeNameOfMe, "Expected " & Symbol & " at character " & CStr(Position) 760 | End Sub 761 | 762 | Private Sub Error99B0(ByVal Position As Long) 763 | Err.Raise &H800499B0, TypeNameOfMe, "Bad string character escape at character " & CStr(Position) 764 | End Sub 765 | 766 | Private Function ExistsStr(ByVal Key As String) As Boolean 767 | 'Used internally where Key will always be a String. 768 | Dim Hash As Long 769 | Dim Name As String 770 | 771 | HashData StrPtr(Key), Len(Key) * 2, VarPtr(Hash), 4 772 | PrefixedKey = Right$("0000000" & Hex$(Hash), 8) & Key 'Sets global PrefixedKey as side-effect! 773 | On Error Resume Next 774 | Name = Names.Item(PrefixedKey) 775 | ExistsStr = Err.Number = 0 776 | Err.Clear 777 | End Function 778 | 779 | Private Function ParseName(ByRef Text As String) As String 780 | ParseName = ParseString(Text) 781 | 782 | SkipWhitespace Text 783 | If Mid$(Text, CursorIn, 1) <> COLON Then 784 | Error99A0 COLON, CursorIn 785 | End If 786 | CursorIn = CursorIn + 1 787 | End Function 788 | 789 | Private Function ParseNumber(ByRef Text As String) As Variant 790 | Const BUILD_CHUNK As Long = 16 791 | Dim SaveCursor As Long 792 | Dim BuildString As String 793 | Dim BuildCursor As Long 794 | Dim Char As String 795 | Dim CharW As Long 796 | Dim GotDecPoint As Boolean 797 | Dim GotExpSign As Boolean 798 | 799 | SaveCursor = CursorIn 'Saved for "bad number format" error. 800 | BuildString = Space$(BUILD_CHUNK) 801 | 802 | 'We know 1st char has been validated by the caller. 803 | BuildCursor = 1 804 | Mid$(BuildString, 1, 1) = Mid$(Text, CursorIn, 1) 805 | 806 | For CursorIn = CursorIn + 1 To LengthIn 807 | Char = LCase$(Mid$(Text, CursorIn, 1)) 808 | CharW = CLng(AscW(Char)) And &HFFFF& 809 | Select Case CharW 810 | Case ZERO_W To NINE_W 811 | 'Do nothing. 812 | Case RADIXPOINT_W 813 | If GotDecPoint Then 814 | Err.Raise &H80049924, TypeNameOfMe, "Second decimal point at character " & CStr(CursorIn) 815 | End If 816 | If Mid$(BuildString, BuildCursor, 1) = MINUS Then 817 | Err.Raise &H80049928, TypeNameOfMe, "Digit expected at character " & CStr(CursorIn) 818 | End If 819 | GotDecPoint = True 820 | Case JSON_EXP_W 821 | CursorIn = CursorIn + 1 822 | Exit For 823 | Case Else 824 | Exit For 825 | End Select 826 | BuildCursor = BuildCursor + 1 827 | If BuildCursor > Len(BuildString) Then BuildString = BuildString & Space$(BUILD_CHUNK) 828 | Mid$(BuildString, BuildCursor, 1) = Char 829 | Next 830 | 831 | If CharW = JSON_EXP_W Then 832 | BuildCursor = BuildCursor + 1 833 | If BuildCursor > Len(BuildString) Then BuildString = BuildString & Space$(BUILD_CHUNK) 834 | Mid$(BuildString, BuildCursor, 1) = Char 835 | 836 | For CursorIn = CursorIn To LengthIn 837 | Char = Mid$(Text, CursorIn, 1) 838 | Select Case CLng(AscW(Char)) And &HFFFF& 839 | Case ZERO_W To NINE_W 840 | 'Do nothing. 841 | Case PLUS_W, MINUS_W 842 | If GotExpSign Then 843 | Err.Raise &H8004992C, TypeNameOfMe, "Second exponent sign at character " & CStr(CursorIn) 844 | End If 845 | GotExpSign = True 846 | Case Else 847 | Exit For 848 | End Select 849 | BuildCursor = BuildCursor + 1 850 | If BuildCursor > Len(BuildString) Then BuildString = BuildString & Space$(BUILD_CHUNK) 851 | Mid$(BuildString, BuildCursor, 1) = Char 852 | Next 853 | End If 854 | 855 | If CursorIn > LengthIn Then 856 | Err.Raise &H80049930, TypeNameOfMe, "Ran off end of JSON text while parsing a number" 857 | End If 858 | 859 | ParseNumber = Left$(BuildString, BuildCursor) 860 | If VariantChangeTypeEx(ParseNumber, ParseNumber, LOCALE_INVARIANT, 0, NumberType) <> S_OK Then 861 | Err.Raise &H80049934, TypeNameOfMe, "Number overflow or parse error at character " & CStr(SaveCursor) 862 | End If 863 | End Function 864 | 865 | Private Function ParseString(ByRef Text As String) As String 866 | Const BUILD_CHUNK As Long = 32 867 | Dim LenParseString As Long 868 | Dim BuildCursor As Long 869 | Dim Char As String 870 | Dim CharW As Long 871 | 872 | ParseString = Space$(BUILD_CHUNK) 873 | LenParseString = BUILD_CHUNK 874 | 875 | For CursorIn = CursorIn To LengthIn 876 | Char = Mid$(Text, CursorIn, 1) 877 | CharW = CLng(AscW(Char)) And &HFFFF& 878 | Select Case CharW 879 | Case QUOTE_W 880 | CursorIn = CursorIn + 1 881 | ParseString = Left$(ParseString, BuildCursor) 882 | Exit Function 'Normal exit here -------------------------------------- 883 | Case REVSOLIDUS_W 884 | CursorIn = CursorIn + 1 885 | If CursorIn > LengthIn Then 886 | Error99B0 CursorIn 887 | End If 888 | Char = LCase$(Mid$(Text, CursorIn, 1)) 'Recognize uppercased escape symbols. 889 | Select Case Char 890 | Case QUOTE, REVSOLIDUS, "/" 891 | 'Do nothing. 892 | Case "b" 893 | Char = vbBack 894 | Case "f" 895 | Char = vbFormFeed 896 | Case "n" 897 | Char = vbLf 898 | Case "r" 899 | Char = vbCr 900 | Case "t" 901 | Char = vbTab 902 | Case "u" 903 | CursorIn = CursorIn + 1 904 | If LengthIn - CursorIn < 3 Then 905 | Error99B0 CursorIn 906 | End If 907 | On Error Resume Next 908 | Char = ChrW$(CLng("&H0" & Mid$(Text, CursorIn, 4))) 909 | If Err Then 910 | On Error GoTo 0 911 | Error99B0 CursorIn 912 | End If 913 | On Error GoTo 0 914 | CursorIn = CursorIn + 3 'Not + 4 because For loop will increment again. 915 | Case Else 916 | Error99B0 CursorIn 917 | End Select 918 | Case Is >= BLANKSPACE_W 919 | 'Do nothing, i.e. fall through passing Char unchanged. 920 | Case Else 921 | Err.Raise &H80049938, _ 922 | TypeNameOfMe, _ 923 | "Invalid string character (hex " & Right$("000" & Hex$(CharW), 4) & ") at " _ 924 | & CStr(CursorIn) 925 | End Select 926 | BuildCursor = BuildCursor + 1 927 | If BuildCursor > LenParseString Then 928 | ParseString = ParseString & Space$(BUILD_CHUNK) 929 | LenParseString = LenParseString + BUILD_CHUNK 930 | End If 931 | Mid$(ParseString, BuildCursor, 1) = Char 932 | Next 933 | 934 | Error99A0 QUOTE, LengthIn + 1 935 | End Function 936 | 937 | Private Sub ParseValue(ByRef Text As String, ByRef Value As Variant) 938 | Dim SubBag As JsonBag 939 | Dim Token As String 940 | 941 | SkipWhitespace Text 942 | Select Case CLng(AscW(Mid$(Text, CursorIn, 1))) And &HFFFF& 943 | Case MINUS_W, ZERO_W To NINE_W 944 | Value = ParseNumber(Text) 945 | Case QUOTE_W 946 | CursorIn = CursorIn + 1 947 | Value = ParseString(Text) 948 | Case LBRACE_W 949 | CursorIn = CursorIn + 1 950 | Set SubBag = New JsonBag 951 | With SubBag 952 | .DecimalMode = mDecimalMode 953 | .IsArray = False 954 | .ParseObject Text, CursorIn, LengthIn 955 | #If Not NO_DEEPCOPY_WHITESPACE Then 956 | .Whitespace = mWhitespace 957 | .WhitespaceIndent = mWhitespaceIndent 958 | .WhitespaceNewLine = mWhitespaceNewLine 959 | #End If 960 | End With 961 | Set Value = SubBag 962 | Case LBRACKET_W 963 | CursorIn = CursorIn + 1 964 | Set SubBag = New JsonBag 965 | With SubBag 966 | .DecimalMode = mDecimalMode 967 | .IsArray = True 968 | .ParseArray Text, CursorIn, LengthIn 969 | #If Not NO_DEEPCOPY_WHITESPACE Then 970 | .Whitespace = mWhitespace 971 | .WhitespaceIndent = mWhitespaceIndent 972 | .WhitespaceNewLine = mWhitespaceNewLine 973 | #End If 974 | End With 975 | Set Value = SubBag 976 | Case Else 977 | If Mid$(Text, CursorIn, 1) = COLON Then 978 | Err.Raise &H800499C0, TypeNameOfMe, "Unexpected "":"" at character " & CStr(CursorIn) 979 | Else 980 | 'Special value tokens. 981 | Token = LCase$(Mid$(Text, CursorIn, 4)) 982 | If Token = "null" Then 983 | Value = Null 984 | CursorIn = CursorIn + 4 985 | ElseIf Token = "true" Then 986 | Value = True 987 | CursorIn = CursorIn + 4 988 | Else 989 | Token = LCase$(Mid$(Text, CursorIn, 5)) 990 | If Token = "false" Then 991 | Value = False 992 | CursorIn = CursorIn + 5 993 | Else 994 | Err.Raise &H8004993C, TypeNameOfMe, "Bad value at character " & CStr(CursorIn) 995 | End If 996 | End If 997 | End If 998 | End Select 999 | End Sub 1000 | 1001 | Private Sub SerializeItem( _ 1002 | ByVal ItemName As String, _ 1003 | ByRef Item As Variant, _ 1004 | Optional ByVal Level As Integer) 1005 | 'For outer level call set CursorOut = 1 before calling. For outer level call 1006 | 'or array calls pass vbNullString as ItemName for "anonymity." 1007 | 1008 | Const TEXT_CHUNK As Long = 64 1009 | Dim Indent As String 1010 | Dim Anonymous As Boolean 1011 | Dim Name As Variant 1012 | Dim ItemIndex As Long 1013 | Dim TempItem As Variant 1014 | Dim ItemBag As JsonBag 1015 | Dim SubBag As JsonBag 1016 | Dim ItemText As String 1017 | Dim ArrayItem As Variant 1018 | 1019 | If mWhitespace Then 1020 | Indent = Space$(mWhitespaceIndent * Level) 1021 | End If 1022 | 1023 | Anonymous = StrPtr(ItemName) = 0 'Check for vbNullString. 1024 | If Not Anonymous Then 1025 | 'Not vbNullString so we have a named Item. 1026 | If mWhitespace Then Cat Indent 1027 | Cat SerializeString(ItemName) & COLON 1028 | End If 1029 | 1030 | Select Case VarType(Item) 1031 | Case vbEmpty, vbNull 'vbEmpty case should actually never occur. 1032 | If mWhitespace And Anonymous Then Cat Indent 1033 | Cat "null" 1034 | Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal, vbByte, vbBoolean 1035 | If mWhitespace And Anonymous Then Cat Indent 1036 | If VariantChangeTypeEx(TempItem, _ 1037 | Item, _ 1038 | LOCALE_INVARIANT, _ 1039 | VARIANT_ALPHABOOL, _ 1040 | vbString) <> S_OK Then 1041 | Err.Raise &H80049940, TypeNameOfMe, "Item """ & ItemName & """ value " & CStr(Item) & " failed to serialize" 1042 | End If 1043 | Cat LCase$(TempItem) 'Convert to lowercase "true" and "false" and "1.234e34" and such. 1044 | Case vbString 1045 | If mWhitespace And Anonymous Then Cat Indent 1046 | Cat SerializeString(Item) 1047 | Case vbObject 1048 | Set ItemBag = Item 1049 | If ItemBag.IsArray Then 1050 | If mWhitespace And Anonymous Then Cat Indent 1051 | Cat LBRACKET 1052 | If ItemBag.Count < 1 Then 1053 | Cat RBRACKET 1054 | Else 1055 | If mWhitespace Then Cat mWhitespaceNewLine 1056 | With ItemBag 1057 | For ItemIndex = 1 To .Count 1058 | If IsObject(.Item(ItemIndex)) Then 1059 | Set TempItem = .Item(ItemIndex) 1060 | Else 1061 | TempItem = .Item(ItemIndex) 1062 | End If 1063 | SerializeItem vbNullString, TempItem, Level + 1 1064 | Cat COMMA 1065 | If mWhitespace Then Cat mWhitespaceNewLine 1066 | Next 1067 | End With 1068 | If mWhitespace Then 1069 | CursorOut = CursorOut - 3 1070 | Cat mWhitespaceNewLine & Indent & RBRACKET 1071 | Else 1072 | Mid$(TextOut, CursorOut - 1) = RBRACKET 1073 | End If 1074 | End If 1075 | Else 1076 | If mWhitespace And Anonymous Then Cat Indent 1077 | Cat LBRACE 1078 | If ItemBag.Count < 1 Then 1079 | Cat RBRACE 1080 | Else 1081 | If mWhitespace Then Cat mWhitespaceNewLine 1082 | With ItemBag 1083 | For ItemIndex = 1 To .Count 1084 | If IsObject(.Item(ItemIndex)) Then 1085 | Set TempItem = .Item(ItemIndex) 1086 | Else 1087 | TempItem = .Item(ItemIndex) 1088 | End If 1089 | SerializeItem .Name(ItemIndex), TempItem, Level + 1 1090 | Cat COMMA 1091 | If mWhitespace Then Cat mWhitespaceNewLine 1092 | Next 1093 | End With 1094 | If mWhitespace Then 1095 | CursorOut = CursorOut - 3 1096 | Cat mWhitespaceNewLine & Indent & RBRACE 1097 | Else 1098 | Mid$(TextOut, CursorOut - 1) = RBRACE 1099 | End If 1100 | End If 1101 | End If 1102 | Case Else 1103 | Err.Raise &H80049944, TypeNameOfMe, """Item " & ItemName & """ unknown/unsupported type = " & CStr(VarType(Item)) 1104 | End Select 1105 | End Sub 1106 | 1107 | Private Function SerializeString(ByVal Text As String) As String 1108 | Dim BuildString As String 1109 | Dim BuildCursor As Long 1110 | Dim TextCursor As Long 1111 | Dim Char As String 1112 | Dim CharW As Long 1113 | 1114 | BuildString = Space$(3 * Len(Text) \ 2) 1115 | BuildCursor = 1 1116 | StringCat BuildString, BuildCursor, QUOTE 1117 | For TextCursor = 1 To Len(Text) 1118 | Char = Mid$(Text, TextCursor, 1) 1119 | Select Case Char 1120 | Case QUOTE, REVSOLIDUS 1121 | StringCat BuildString, BuildCursor, REVSOLIDUS & Char 1122 | Case vbBack 1123 | StringCat BuildString, BuildCursor, REVSOLIDUS & "b" 1124 | Case vbFormFeed 1125 | StringCat BuildString, BuildCursor, REVSOLIDUS & "f" 1126 | Case vbLf 1127 | StringCat BuildString, BuildCursor, REVSOLIDUS & "n" 1128 | Case vbCr 1129 | StringCat BuildString, BuildCursor, REVSOLIDUS & "r" 1130 | Case vbTab 1131 | StringCat BuildString, BuildCursor, REVSOLIDUS & "t" 1132 | Case " " To "!", "#" To LBRACKET, RBRACKET To "~" 1133 | StringCat BuildString, BuildCursor, Char 1134 | Case Else 1135 | CharW = CLng(AscW(Char)) And &HFFFF& 1136 | Select Case CharW 1137 | Case 0& To &H1F&, &H7F& To &H9F&, &H34F&, &H200B& To &H200F&, _ 1138 | &H2028& To &H202E&, &H2060&, &HFE01& To &HFE0F&, _ 1139 | &HFEFF&, &HFFFD&, &HD800& To &HDFFF& 1140 | StringCat BuildString, BuildCursor, _ 1141 | REVSOLIDUS & "u" & Right$("000" & Hex$(CharW), 4) 1142 | Case Else 1143 | StringCat BuildString, BuildCursor, Char 1144 | End Select 1145 | End Select 1146 | Next 1147 | StringCat BuildString, BuildCursor, QUOTE 1148 | SerializeString = Left$(BuildString, BuildCursor - 1) 1149 | End Function 1150 | 1151 | Private Sub SkipWhitespace(ByRef Text As String) 1152 | 'Original code: 1153 | #If Win64 Then 1154 | CursorIn = CursorIn + StrSpn(StrPtr(Text) + 2 * (CursorIn - 1), PtrWhiteSpace) 1155 | #Else 1156 | 'Now make sure we do an "unsigned add" in case we're in a LARGEADDRESSAWARE program: 1157 | CursorIn = CursorIn _ 1158 | + StrSpn((StrPtr(Text) Xor &H80000000) + 2 * (CursorIn - 1) Xor &H80000000, _ 1159 | PtrWhiteSpace) 1160 | #End If 1161 | End Sub 1162 | 1163 | Private Sub StringCat(ByRef TextOut As String, ByRef CursorOut, ByRef NewText As String) 1164 | Const TEXT_CHUNK As Long = 64 'Allocation size for destination buffer Text. 1165 | Dim LenNew As Long 1166 | 1167 | LenNew = Len(NewText) 1168 | If LenNew > 0 Then 1169 | If CursorOut + LenNew - 1 > Len(TextOut) Then 1170 | If LenNew > TEXT_CHUNK Then 1171 | TextOut = TextOut & Space$(LenNew + TEXT_CHUNK) 1172 | Else 1173 | TextOut = TextOut & Space$(TEXT_CHUNK) 1174 | End If 1175 | End If 1176 | Mid$(TextOut, CursorOut, LenNew) = NewText 1177 | CursorOut = CursorOut + LenNew 1178 | End If 1179 | End Sub 1180 | 1181 | '=== Private Events ==================================================================== 1182 | 1183 | Private Sub Class_Initialize() 1184 | TypeNameOfMe = TypeName(Me) 1185 | PtrWhiteSpace = StrPtr(WHITE_SPACE) 1186 | Clear 'Creates Collections. 1187 | DecimalMode = False 'Default 1188 | Whitespace = False 'Default 1189 | WhitespaceIndent = 4 'Default. 1190 | WhitespaceNewLine = vbNewLine 'Default. 1191 | End Sub 1192 | --------------------------------------------------------------------------------