From 6a17972679c634e65d3c0dd7c29d6b226dce3394 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Fri, 17 Mar 2023 22:16:23 -0400 Subject: [PATCH 01/28] Remove superfluous ^ --- lib/linguist/heuristics.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 147b2c4635..0deacc0403 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -91,7 +91,7 @@ disambiguations: - language: FreeBasic pattern: '^[ \t]*#(?:define|endif|endmacro|ifn?def|if|include|lang|macro)\s' - language: BASIC - pattern: '^\A\s*\d+' + pattern: '\A\s*\d+' - extensions: ['.bb'] rules: - language: BlitzBasic From 04322cd2babf6203ea5ed1726fd92d8a0b0f8386 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Fri, 17 Mar 2023 23:24:02 -0400 Subject: [PATCH 02/28] Add .bas to Visual Basic 6.0 --- lib/linguist/heuristics.yml | 16 ++++++++++++++++ lib/linguist/languages.yml | 1 + test/test_heuristics.rb | 3 ++- 3 files changed, 19 insertions(+), 1 deletion(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 0deacc0403..36068c6c25 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -92,6 +92,12 @@ disambiguations: pattern: '^[ \t]*#(?:define|endif|endmacro|ifn?def|if|include|lang|macro)\s' - language: BASIC pattern: '\A\s*\d+' + - language: VBA + and: + - named_pattern: vb-module + - named_pattern: vba + - language: Visual Basic 6.0 + named_pattern: vb-module - extensions: ['.bb'] rules: - language: BlitzBasic @@ -838,5 +844,15 @@ named_patterns: - '^\s*package\s+[^\W\d]\w*(?:::\w+)*\s*(?:[;{]|\sv?\d)' - '[\s$][^\W\d]\w*(?::\w+)*->[a-zA-Z_\[({]' raku: '^\s*(?:use\s+v6\b|\bmodule\b|\b(?:my\s+)?class\b)' + vba: + - '^\s*#If\s+(:?VBA7|Win64)' + - '^\s*Declare\s+PtrSafe\s+(?:Sub|Function)' + - '^\s*Dim\s+[0-9a-zA-Z_]*\s+As\s+(?:LongPtr|LongLong)' + - '\sVBA.(?:vb|[A-Z])' + - '\s(?:Excel.[a-zA-Z]|ThisWorkbook|ActiveWorkbook|ActiveSheet|ActiveChart|ActiveCell|WorksheetFunction)' + - '\s(?:Word.[a-zA-Z]|ActiveDocument)' + - '\s(?:PowerPoint.[a-zA-Z]|ActivePresentation)' + - '\s(?:Outlook.[a-zA-Z]|ActiveExplorer|ActiveInspector)' vb-class: '^\s*VERSION\s+[0-9]\.[0-9]\s+CLASS' vb-form: '^\s*VERSION\s+[0-9]\.[0-9]{2}' + vb-module: '^\s*Attribute\s+VB_Name\s+=\s+' diff --git a/lib/linguist/languages.yml b/lib/linguist/languages.yml index b9139595b4..956a6de93c 100644 --- a/lib/linguist/languages.yml +++ b/lib/linguist/languages.yml @@ -7262,6 +7262,7 @@ Visual Basic 6.0: type: programming color: "#2c6353" extensions: + - ".bas" - ".cls" - ".ctl" - ".Dsr" diff --git a/test/test_heuristics.rb b/test/test_heuristics.rb index c8f51086c0..3830df0b8f 100755 --- a/test/test_heuristics.rb +++ b/test/test_heuristics.rb @@ -267,7 +267,8 @@ def test_bas_by_heuristics assert_heuristics({ "FreeBasic" => all_fixtures("FreeBasic", "*.bas"), "BASIC" => all_fixtures("BASIC", "*.bas"), - nil => all_fixtures("VBA", "*.bas") + "VBA" => all_fixtures("VBA", "*.bas"), + "Visual Basic 6.0" => all_fixtures("Visual Basic 6.0", "*.bas") }) end From 9599bc6ea04cd89a155bf93c43583eb236bf6ee9 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sat, 18 Mar 2023 00:03:37 -0400 Subject: [PATCH 03/28] Add samples --- samples/VBA/JsonConverter.bas | 1123 +++++++++++++ samples/Visual Basic 6.0/mdTlsNative.bas | 1943 ++++++++++++++++++++++ samples/Visual Basic 6.0/modLoader.bas | 1128 +++++++++++++ 3 files changed, 4194 insertions(+) create mode 100644 samples/VBA/JsonConverter.bas create mode 100644 samples/Visual Basic 6.0/mdTlsNative.bas create mode 100644 samples/Visual Basic 6.0/modLoader.bas diff --git a/samples/VBA/JsonConverter.bas b/samples/VBA/JsonConverter.bas new file mode 100644 index 0000000000..876b86501b --- /dev/null +++ b/samples/VBA/JsonConverter.bas @@ -0,0 +1,1123 @@ +Attribute VB_Name = "JsonConverter" +'' +' VBA-JSON v2.3.1 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON +' +' JSON Converter for VBA +' +' Errors: +' 10001 - JSON parse error +' +' @class JsonConverter +' @author tim.hall.engr@gmail.com +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +' +' Based originally on vba-json (with extensive changes) +' BSD license included below +' +' JSONLib, http://code.google.com/p/vba-json/ +' +' Copyright (c) 2013, Ryo Yokoyama +' All rights reserved. +' +' Redistribution and use in source and binary forms, with or without +' modification, are permitted provided that the following conditions are met: +' * Redistributions of source code must retain the above copyright +' notice, this list of conditions and the following disclaimer. +' * Redistributions in binary form must reproduce the above copyright +' notice, this list of conditions and the following disclaimer in the +' documentation and/or other materials provided with the distribution. +' * Neither the name of the nor the +' names of its contributors may be used to endorse or promote products +' derived from this software without specific prior written permission. +' +' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +' DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +Option Explicit + +' === VBA-UTC Headers +#If Mac Then + +#If VBA7 Then + +' 64-bit Mac (2016) +Private Declare PtrSafe Function utc_popen Lib "/usr/lib/libc.dylib" Alias "popen" _ + (ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr +Private Declare PtrSafe Function utc_pclose Lib "/usr/lib/libc.dylib" Alias "pclose" _ + (ByVal utc_File As LongPtr) As LongPtr +Private Declare PtrSafe Function utc_fread Lib "/usr/lib/libc.dylib" Alias "fread" _ + (ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr +Private Declare PtrSafe Function utc_feof Lib "/usr/lib/libc.dylib" Alias "feof" _ + (ByVal utc_File As LongPtr) As LongPtr + +#Else + +' 32-bit Mac +Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _ + (ByVal utc_Command As String, ByVal utc_Mode As String) As Long +Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _ + (ByVal utc_File As Long) As Long +Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _ + (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long +Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _ + (ByVal utc_File As Long) As Long + +#End If + +#ElseIf VBA7 Then + +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx +Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long +Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long +Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long + +#Else + +Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long +Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long +Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long + +#End If + +#If Mac Then + +#If VBA7 Then +Private Type utc_ShellResult + utc_Output As String + utc_ExitCode As LongPtr +End Type + +#Else + +Private Type utc_ShellResult + utc_Output As String + utc_ExitCode As Long +End Type + +#End If + +#Else + +Private Type utc_SYSTEMTIME + utc_wYear As Integer + utc_wMonth As Integer + utc_wDayOfWeek As Integer + utc_wDay As Integer + utc_wHour As Integer + utc_wMinute As Integer + utc_wSecond As Integer + utc_wMilliseconds As Integer +End Type + +Private Type utc_TIME_ZONE_INFORMATION + utc_Bias As Long + utc_StandardName(0 To 31) As Integer + utc_StandardDate As utc_SYSTEMTIME + utc_StandardBias As Long + utc_DaylightName(0 To 31) As Integer + utc_DaylightDate As utc_SYSTEMTIME + utc_DaylightBias As Long +End Type + +#End If +' === End VBA-UTC + +Private Type json_Options + ' VBA only stores 15 significant digits, so any numbers larger than that are truncated + ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits + ' See: http://support.microsoft.com/kb/269370 + ' + ' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits + ' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True` + UseDoubleForLargeNumbers As Boolean + + ' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys + AllowUnquotedKeys As Boolean + + ' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson + EscapeSolidus As Boolean +End Type +Public JsonOptions As json_Options + +' ============================================= ' +' Public Methods +' ============================================= ' + +'' +' Convert JSON string to object (Dictionary/Collection) +' +' @method ParseJson +' @param {String} json_String +' @return {Object} (Dictionary or Collection) +' @throws 10001 - JSON parse error +'' +Public Function ParseJson(ByVal JsonString As String) As Object + Dim json_Index As Long + json_Index = 1 + + ' Remove vbCr, vbLf, and vbTab from json_String + JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "") + + json_SkipSpaces JsonString, json_Index + Select Case VBA.Mid$(JsonString, json_Index, 1) + Case "{" + Set ParseJson = json_ParseObject(JsonString, json_Index) + Case "[" + Set ParseJson = json_ParseArray(JsonString, json_Index) + Case Else + ' Error: Invalid JSON string + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['") + End Select +End Function + +'' +' Convert object (Dictionary/Collection/Array) to JSON +' +' @method ConvertToJson +' @param {Variant} JsonValue (Dictionary, Collection, or Array) +' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string +' @return {String} +'' +Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + Dim json_Index As Long + Dim json_LBound As Long + Dim json_UBound As Long + Dim json_IsFirstItem As Boolean + Dim json_Index2D As Long + Dim json_LBound2D As Long + Dim json_UBound2D As Long + Dim json_IsFirstItem2D As Boolean + Dim json_Key As Variant + Dim json_Value As Variant + Dim json_DateStr As String + Dim json_Converted As String + Dim json_SkipItem As Boolean + Dim json_PrettyPrint As Boolean + Dim json_Indentation As String + Dim json_InnerIndentation As String + + json_LBound = -1 + json_UBound = -1 + json_IsFirstItem = True + json_LBound2D = -1 + json_UBound2D = -1 + json_IsFirstItem2D = True + json_PrettyPrint = Not IsMissing(Whitespace) + + Select Case VBA.VarType(JsonValue) + Case VBA.vbNull + ConvertToJson = "null" + Case VBA.vbDate + ' Date + json_DateStr = ConvertToIso(VBA.CDate(JsonValue)) + + ConvertToJson = """" & json_DateStr & """" + Case VBA.vbString + ' String (or large number encoded as string) + If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then + ConvertToJson = JsonValue + Else + ConvertToJson = """" & json_Encode(JsonValue) & """" + End If + Case VBA.vbBoolean + If JsonValue Then + ConvertToJson = "true" + Else + ConvertToJson = "false" + End If + Case VBA.vbArray To VBA.vbArray + VBA.vbByte + If json_PrettyPrint Then + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) + json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace) + Else + json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) + json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace) + End If + End If + + ' Array + json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength + + On Error Resume Next + + json_LBound = LBound(JsonValue, 1) + json_UBound = UBound(JsonValue, 1) + json_LBound2D = LBound(JsonValue, 2) + json_UBound2D = UBound(JsonValue, 2) + + If json_LBound >= 0 And json_UBound >= 0 Then + For json_Index = json_LBound To json_UBound + If json_IsFirstItem Then + json_IsFirstItem = False + Else + ' Append comma to previous line + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + If json_LBound2D >= 0 And json_UBound2D >= 0 Then + ' 2D Array + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + End If + json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength + + For json_Index2D = json_LBound2D To json_UBound2D + If json_IsFirstItem2D Then + json_IsFirstItem2D = False + Else + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_InnerIndentation & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + Next json_Index2D + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + End If + + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + json_IsFirstItem2D = True + Else + ' 1D Array + json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(JsonValue(json_Index)) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + End If + Next json_Index + End If + + On Error GoTo 0 + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + + ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) + + ' Dictionary or Collection + Case VBA.vbObject + If json_PrettyPrint Then + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) + Else + json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) + End If + End If + + ' Dictionary + If VBA.TypeName(JsonValue) = "Dictionary" Then + json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength + For Each json_Key In JsonValue.Keys + ' For Objects, undefined (Empty/Nothing) is not added to object + json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1) + If json_Converted = "" Then + json_SkipItem = json_IsUndefined(JsonValue(json_Key)) + Else + json_SkipItem = False + End If + + If Not json_SkipItem Then + If json_IsFirstItem Then + json_IsFirstItem = False + Else + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted + Else + json_Converted = """" & json_Key & """:" & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + End If + Next json_Key + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength + + ' Collection + ElseIf VBA.TypeName(JsonValue) = "Collection" Then + json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength + For Each json_Value In JsonValue + If json_IsFirstItem Then + json_IsFirstItem = False + Else + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(json_Value) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + Next json_Value + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + End If + + ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) + Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal + ' Number (use decimals for numbers) + ConvertToJson = VBA.Replace(JsonValue, ",", ".") + Case Else + ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType + ' Use VBA's built-in to-string + On Error Resume Next + ConvertToJson = JsonValue + On Error GoTo 0 + End Select +End Function + +' ============================================= ' +' Private Functions +' ============================================= ' + +Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary + Dim json_Key As String + Dim json_NextChar As String + + Set json_ParseObject = New Dictionary + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> "{" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'") + Else + json_Index = json_Index + 1 + + Do + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) = "}" Then + json_Index = json_Index + 1 + Exit Function + ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then + json_Index = json_Index + 1 + json_SkipSpaces json_String, json_Index + End If + + json_Key = json_ParseKey(json_String, json_Index) + json_NextChar = json_Peek(json_String, json_Index) + If json_NextChar = "[" Or json_NextChar = "{" Then + Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) + Else + json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) + End If + Loop + End If +End Function + +Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection + Set json_ParseArray = New Collection + + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> "[" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['") + Else + json_Index = json_Index + 1 + + Do + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) = "]" Then + json_Index = json_Index + 1 + Exit Function + ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then + json_Index = json_Index + 1 + json_SkipSpaces json_String, json_Index + End If + + json_ParseArray.Add json_ParseValue(json_String, json_Index) + Loop + End If +End Function + +Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant + json_SkipSpaces json_String, json_Index + Select Case VBA.Mid$(json_String, json_Index, 1) + Case "{" + Set json_ParseValue = json_ParseObject(json_String, json_Index) + Case "[" + Set json_ParseValue = json_ParseArray(json_String, json_Index) + Case """", "'" + json_ParseValue = json_ParseString(json_String, json_Index) + Case Else + If VBA.Mid$(json_String, json_Index, 4) = "true" Then + json_ParseValue = True + json_Index = json_Index + 4 + ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then + json_ParseValue = False + json_Index = json_Index + 5 + ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then + json_ParseValue = Null + json_Index = json_Index + 4 + ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then + json_ParseValue = json_ParseNumber(json_String, json_Index) + Else + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['") + End If + End Select +End Function + +Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String + Dim json_Quote As String + Dim json_Char As String + Dim json_Code As String + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + + json_SkipSpaces json_String, json_Index + + ' Store opening quote to look for matching closing quote + json_Quote = VBA.Mid$(json_String, json_Index, 1) + json_Index = json_Index + 1 + + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + + Select Case json_Char + Case "\" + ' Escaped string, \\, or \/ + json_Index = json_Index + 1 + json_Char = VBA.Mid$(json_String, json_Index, 1) + + Select Case json_Char + Case """", "\", "/", "'" + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "b" + json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "f" + json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "n" + json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "r" + json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "t" + json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "u" + ' Unicode character escape (e.g. \u00a9 = Copyright) + json_Index = json_Index + 1 + json_Code = VBA.Mid$(json_String, json_Index, 4) + json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength + json_Index = json_Index + 4 + End Select + Case json_Quote + json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition) + json_Index = json_Index + 1 + Exit Function + Case Else + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + End Select + Loop +End Function + +Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant + Dim json_Char As String + Dim json_Value As String + Dim json_IsLargeNumber As Boolean + + json_SkipSpaces json_String, json_Index + + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + + If VBA.InStr("+-0123456789.eE", json_Char) Then + ' Unlikely to have massive number, so use simple append rather than buffer here + json_Value = json_Value & json_Char + json_Index = json_Index + 1 + Else + ' Excel only stores 15 significant digits, so any numbers larger than that are truncated + ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits + ' See: http://support.microsoft.com/kb/269370 + ' + ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number + ' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16) + json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16) + If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then + json_ParseNumber = json_Value + Else + ' VBA.Val does not use regional settings, so guard for comma is not needed + json_ParseNumber = VBA.Val(json_Value) + End If + Exit Function + End If + Loop +End Function + +Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String + ' Parse key with single or double quotes + If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then + json_ParseKey = json_ParseString(json_String, json_Index) + ElseIf JsonOptions.AllowUnquotedKeys Then + Dim json_Char As String + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + If (json_Char <> " ") And (json_Char <> ":") Then + json_ParseKey = json_ParseKey & json_Char + json_Index = json_Index + 1 + Else + Exit Do + End If + Loop + Else + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''") + End If + + ' Check for colon and skip if present or throw if not present + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> ":" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'") + Else + json_Index = json_Index + 1 + End If +End Function + +Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean + ' Empty / Nothing -> undefined + Select Case VBA.VarType(json_Value) + Case VBA.vbEmpty + json_IsUndefined = True + Case VBA.vbObject + Select Case VBA.TypeName(json_Value) + Case "Empty", "Nothing" + json_IsUndefined = True + End Select + End Select +End Function + +Private Function json_Encode(ByVal json_Text As Variant) As String + ' Reference: http://www.ietf.org/rfc/rfc4627.txt + ' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab + Dim json_Index As Long + Dim json_Char As String + Dim json_AscCode As Long + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + + For json_Index = 1 To VBA.Len(json_Text) + json_Char = VBA.Mid$(json_Text, json_Index, 1) + json_AscCode = VBA.AscW(json_Char) + + ' When AscW returns a negative number, it returns the twos complement form of that number. + ' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result. + ' https://support.microsoft.com/en-us/kb/272138 + If json_AscCode < 0 Then + json_AscCode = json_AscCode + 65536 + End If + + ' From spec, ", \, and control characters must be escaped (solidus is optional) + + Select Case json_AscCode + Case 34 + ' " -> 34 -> \" + json_Char = "\""" + Case 92 + ' \ -> 92 -> \\ + json_Char = "\\" + Case 47 + ' / -> 47 -> \/ (optional) + If JsonOptions.EscapeSolidus Then + json_Char = "\/" + End If + Case 8 + ' backspace -> 8 -> \b + json_Char = "\b" + Case 12 + ' form feed -> 12 -> \f + json_Char = "\f" + Case 10 + ' line feed -> 10 -> \n + json_Char = "\n" + Case 13 + ' carriage return -> 13 -> \r + json_Char = "\r" + Case 9 + ' tab -> 9 -> \t + json_Char = "\t" + Case 0 To 31, 127 To 65535 + ' Non-ascii characters -> convert to 4-digit hex + json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4) + End Select + + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength + Next json_Index + + json_Encode = json_BufferToString(json_Buffer, json_BufferPosition) +End Function + +Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String + ' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef) + json_SkipSpaces json_String, json_Index + json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters) +End Function + +Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long) + ' Increment index to skip over spaces + Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " " + json_Index = json_Index + 1 + Loop +End Sub + +Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean + ' Check if the given string is considered a "large number" + ' (See json_ParseNumber) + + Dim json_Length As Long + Dim json_CharIndex As Long + json_Length = VBA.Len(json_String) + + ' Length with be at least 16 characters and assume will be less than 100 characters + If json_Length >= 16 And json_Length <= 100 Then + Dim json_CharCode As String + + json_StringIsLargeNumber = True + + For json_CharIndex = 1 To json_Length + json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1)) + Select Case json_CharCode + ' Look for .|0-9|E|e + Case 46, 48 To 57, 69, 101 + ' Continue through characters + Case Else + json_StringIsLargeNumber = False + Exit Function + End Select + Next json_CharIndex + End If +End Function + +Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, ErrorMessage As String) + ' Provide detailed parse error message, including details of where and what occurred + ' + ' Example: + ' Error parsing JSON: + ' {"abcde":True} + ' ^ + ' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '[' + + Dim json_StartIndex As Long + Dim json_StopIndex As Long + + ' Include 10 characters before and after error (if possible) + json_StartIndex = json_Index - 10 + json_StopIndex = json_Index + 10 + If json_StartIndex <= 0 Then + json_StartIndex = 1 + End If + If json_StopIndex > VBA.Len(json_String) Then + json_StopIndex = VBA.Len(json_String) + End If + + json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _ + VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _ + VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _ + ErrorMessage +End Function + +Private Sub json_BufferAppend(ByRef json_Buffer As String, _ + ByRef json_Append As Variant, _ + ByRef json_BufferPosition As Long, _ + ByRef json_BufferLength As Long) + ' VBA can be slow to append strings due to allocating a new string for each append + ' Instead of using the traditional append, allocate a large empty string and then copy string at append position + ' + ' Example: + ' Buffer: "abc " + ' Append: "def" + ' Buffer Position: 3 + ' Buffer Length: 5 + ' + ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer + ' Buffer: "abc " + ' Buffer Length: 10 + ' + ' Put "def" into buffer at position 3 (0-based) + ' Buffer: "abcdef " + ' + ' Approach based on cStringBuilder from vbAccelerator + ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp + ' + ' and clsStringAppend from Philip Swannell + ' https://github.com/VBA-tools/VBA-JSON/pull/82 + + Dim json_AppendLength As Long + Dim json_LengthPlusPosition As Long + + json_AppendLength = VBA.Len(json_Append) + json_LengthPlusPosition = json_AppendLength + json_BufferPosition + + If json_LengthPlusPosition > json_BufferLength Then + ' Appending would overflow buffer, add chunk + ' (double buffer length or append length, whichever is bigger) + Dim json_AddedLength As Long + json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength) + + json_Buffer = json_Buffer & VBA.Space$(json_AddedLength) + json_BufferLength = json_BufferLength + json_AddedLength + End If + + ' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error: + ' Function call on left-hand side of assignment must return Variant or Object + Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append) + json_BufferPosition = json_BufferPosition + json_AppendLength +End Sub + +Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String + If json_BufferPosition > 0 Then + json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition) + End If +End Function + +'' +' VBA-UTC v1.0.6 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter +' +' UTC/ISO 8601 Converter for VBA +' +' Errors: +' 10011 - UTC parsing error +' 10012 - UTC conversion error +' 10013 - ISO 8601 parsing error +' 10014 - ISO 8601 conversion error +' +' @module UtcConverter +' @author tim.hall.engr@gmail.com +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' + +' (Declarations moved to top) + +' ============================================= ' +' Public Methods +' ============================================= ' + +'' +' Parse UTC date to local date +' +' @method ParseUtc +' @param {Date} UtcDate +' @return {Date} Local date +' @throws 10011 - UTC parsing error +'' +Public Function ParseUtc(utc_UtcDate As Date) As Date + On Error GoTo utc_ErrorHandling + +#If Mac Then + ParseUtc = utc_ConvertDate(utc_UtcDate) +#Else + Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION + Dim utc_LocalDate As utc_SYSTEMTIME + + utc_GetTimeZoneInformation utc_TimeZoneInfo + utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate + + ParseUtc = utc_SystemTimeToDate(utc_LocalDate) +#End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description +End Function + +'' +' Convert local date to UTC date +' +' @method ConvertToUrc +' @param {Date} utc_LocalDate +' @return {Date} UTC date +' @throws 10012 - UTC conversion error +'' +Public Function ConvertToUtc(utc_LocalDate As Date) As Date + On Error GoTo utc_ErrorHandling + +#If Mac Then + ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True) +#Else + Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION + Dim utc_UtcDate As utc_SYSTEMTIME + + utc_GetTimeZoneInformation utc_TimeZoneInfo + utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate + + ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate) +#End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description +End Function + +'' +' Parse ISO 8601 date string to local date +' +' @method ParseIso +' @param {Date} utc_IsoString +' @return {Date} Local date +' @throws 10013 - ISO 8601 parsing error +'' +Public Function ParseIso(utc_IsoString As String) As Date + On Error GoTo utc_ErrorHandling + + Dim utc_Parts() As String + Dim utc_DateParts() As String + Dim utc_TimeParts() As String + Dim utc_OffsetIndex As Long + Dim utc_HasOffset As Boolean + Dim utc_NegativeOffset As Boolean + Dim utc_OffsetParts() As String + Dim utc_Offset As Date + + utc_Parts = VBA.Split(utc_IsoString, "T") + utc_DateParts = VBA.Split(utc_Parts(0), "-") + ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2))) + + If UBound(utc_Parts) > 0 Then + If VBA.InStr(utc_Parts(1), "Z") Then + utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":") + Else + utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+") + If utc_OffsetIndex = 0 Then + utc_NegativeOffset = True + utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-") + End If + + If utc_OffsetIndex > 0 Then + utc_HasOffset = True + utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":") + utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":") + + Select Case UBound(utc_OffsetParts) + Case 0 + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0) + Case 1 + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0) + Case 2 + ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2)))) + End Select + + If utc_NegativeOffset Then: utc_Offset = -utc_Offset + Else + utc_TimeParts = VBA.Split(utc_Parts(1), ":") + End If + End If + + Select Case UBound(utc_TimeParts) + Case 0 + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0) + Case 1 + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0) + Case 2 + ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2)))) + End Select + + ParseIso = ParseUtc(ParseIso) + + If utc_HasOffset Then + ParseIso = ParseIso - utc_Offset + End If + End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description +End Function + +'' +' Convert local date to ISO 8601 string +' +' @method ConvertToIso +' @param {Date} utc_LocalDate +' @return {Date} ISO 8601 string +' @throws 10014 - ISO 8601 conversion error +'' +Public Function ConvertToIso(utc_LocalDate As Date) As String + On Error GoTo utc_ErrorHandling + + ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z") + + Exit Function + +utc_ErrorHandling: + Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description +End Function + +' ============================================= ' +' Private Functions +' ============================================= ' + +#If Mac Then + +Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date + Dim utc_ShellCommand As String + Dim utc_Result As utc_ShellResult + Dim utc_Parts() As String + Dim utc_DateParts() As String + Dim utc_TimeParts() As String + + If utc_ConvertToUtc Then + utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _ + "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _ + " +'%s'` +'%Y-%m-%d %H:%M:%S'" + Else + utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _ + "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _ + "+'%Y-%m-%d %H:%M:%S'" + End If + + utc_Result = utc_ExecuteInShell(utc_ShellCommand) + + If utc_Result.utc_Output = "" Then + Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed" + Else + utc_Parts = Split(utc_Result.utc_Output, " ") + utc_DateParts = Split(utc_Parts(0), "-") + utc_TimeParts = Split(utc_Parts(1), ":") + + utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _ + TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2)) + End If +End Function + +Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult +#If VBA7 Then + Dim utc_File As LongPtr + Dim utc_Read As LongPtr +#Else + Dim utc_File As Long + Dim utc_Read As Long +#End If + + Dim utc_Chunk As String + + On Error GoTo utc_ErrorHandling + utc_File = utc_popen(utc_ShellCommand, "r") + + If utc_File = 0 Then: Exit Function + + Do While utc_feof(utc_File) = 0 + utc_Chunk = VBA.Space$(50) + utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File)) + If utc_Read > 0 Then + utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read)) + utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk + End If + Loop + +utc_ErrorHandling: + utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File)) +End Function + +#Else + +Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME + utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value) + utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value) + utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value) + utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value) + utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value) + utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value) + utc_DateToSystemTime.utc_wMilliseconds = 0 +End Function + +Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date + utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _ + TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond) +End Function + +#End If diff --git a/samples/Visual Basic 6.0/mdTlsNative.bas b/samples/Visual Basic 6.0/mdTlsNative.bas new file mode 100644 index 0000000000..2923c9e3e7 --- /dev/null +++ b/samples/Visual Basic 6.0/mdTlsNative.bas @@ -0,0 +1,1943 @@ +Attribute VB_Name = "mdTlsNative" +'========================================================================= +' +' VbAsyncSocket Project (c) 2018-2022 by wqweto@gmail.com +' +' Simple and thin WinSock API wrappers for VB6 +' +' This project is licensed under the terms of the MIT license +' See the LICENSE file in the project root for more information +' +'========================================================================= +Option Explicit +DefObj A-Z +Private Const MODULE_NAME As String = "mdTlsNative" + +#Const ImplTlsServer = (ASYNCSOCKET_NO_TLSSERVER = 0) +#Const ImplUseShared = (ASYNCSOCKET_USE_SHARED <> 0) +#Const ImplUseDebugLog = (USE_DEBUG_LOG <> 0) +#Const ImplCaptureTraffic = CLng(ASYNCSOCKET_CAPTURE_TRAFFIC) '--- bitmask: 1 - traffic + +'========================================================================= +' API +'========================================================================= + +'--- for VirtualProtect +Private Const PAGE_EXECUTE_READWRITE As Long = &H40 +'--- for AcquireCredentialsHandle +Private Const UNISP_NAME As String = "Microsoft Unified Security Protocol Provider" +Private Const SECPKG_CRED_INBOUND As Long = 1 +Private Const SECPKG_CRED_OUTBOUND As Long = 2 +Private Const SCHANNEL_CRED_VERSION As Long = 4 +Private Const SCH_CREDENTIALS_VERSION As Long = 5 +Private Const SP_PROT_TLS1_0 As Long = &H40 Or &H80 +Private Const SP_PROT_TLS1_1 As Long = &H100 Or &H200 +Private Const SP_PROT_TLS1_2 As Long = &H400 Or &H800 +Private Const SP_PROT_TLS1_3 As Long = &H1000 Or &H2000 +Private Const SCH_CRED_MANUAL_CRED_VALIDATION As Long = 8 +Private Const SCH_CRED_NO_DEFAULT_CREDS As Long = &H10 +Private Const SCH_CRED_REVOCATION_CHECK_CHAIN_EXCLUDE_ROOT As Long = &H400 +Private Const SCH_USE_STRONG_CRYPTO As Long = &H400000 +'-- for InitializeSecurityContext +Private Const ISC_REQ_REPLAY_DETECT As Long = &H4 +Private Const ISC_REQ_SEQUENCE_DETECT As Long = &H8 +Private Const ISC_REQ_CONFIDENTIALITY As Long = &H10 +Private Const ISC_REQ_USE_SUPPLIED_CREDS As Long = &H80 +Private Const ISC_REQ_ALLOCATE_MEMORY As Long = &H100 +Private Const ISC_REQ_EXTENDED_ERROR As Long = &H4000 +Private Const ISC_REQ_STREAM As Long = &H8000& +Private Const SECURITY_NATIVE_DREP As Long = &H10 +'--- for ApiSecBuffer.BufferType +Private Const SECBUFFER_EMPTY As Long = 0 ' Undefined, replaced by provider +Private Const SECBUFFER_DATA As Long = 1 ' Packet data +Private Const SECBUFFER_TOKEN As Long = 2 ' Security token +Private Const SECBUFFER_EXTRA As Long = 5 ' Extra data +Private Const SECBUFFER_STREAM_TRAILER As Long = 6 ' Security Trailer +Private Const SECBUFFER_STREAM_HEADER As Long = 7 ' Security Header +Private Const SECBUFFER_ALERT As Long = 17 +Private Const SECBUFFER_APPLICATION_PROTOCOLS As Long = 18 +Private Const SECBUFFER_VERSION As Long = 0 +'--- SSPI/Schannel retvals +Private Const SEC_E_OK As Long = 0 +Private Const SEC_I_CONTINUE_NEEDED As Long = &H90312 +Private Const SEC_I_CONTEXT_EXPIRED As Long = &H90317 +Private Const SEC_I_INCOMPLETE_CREDENTIALS As Long = &H90320 +Private Const SEC_I_RENEGOTIATE As Long = &H90321 +Private Const SEC_E_INVALID_HANDLE As Long = &H80090301 +Private Const SEC_E_INCOMPLETE_MESSAGE As Long = &H80090318 +Private Const SEC_E_CERT_UNKNOWN As Long = &H80090327 +'--- for QueryContextAttributes +Private Const SECPKG_ATTR_STREAM_SIZES As Long = 4 +Private Const SECPKG_ATTR_REMOTE_CERT_CONTEXT As Long = &H53 +Private Const SECPKG_ATTR_ISSUER_LIST_EX As Long = &H59 +Private Const SECPKG_ATTR_CONNECTION_INFO As Long = &H5A +Private Const SECPKG_ATTR_CIPHER_INFO As Long = &H64 +Private Const SECPKG_ATTR_APPLICATION_PROTOCOL As Long = 35 +'--- for ApplyControlToken +Private Const SCHANNEL_SHUTDOWN As Long = 1 ' gracefully close down a connection +'--- for CryptDecodeObjectEx +Private Const X509_ASN_ENCODING As Long = 1 +Private Const PKCS_7_ASN_ENCODING As Long = &H10000 +Private Const PKCS_RSA_PRIVATE_KEY As Long = 43 +Private Const PKCS_PRIVATE_KEY_INFO As Long = 44 +Private Const X509_ECC_PRIVATE_KEY As Long = 82 +Private Const CRYPT_DECODE_NOCOPY_FLAG As Long = &H1 +Private Const CRYPT_DECODE_ALLOC_FLAG As Long = &H8000 +Private Const ERROR_FILE_NOT_FOUND As Long = 2 +'--- for CertOpenStore +Private Const CERT_STORE_PROV_MEMORY As Long = 2 +Private Const CERT_STORE_CREATE_NEW_FLAG As Long = &H2000 +'--- for CertAddEncodedCertificateToStore +Private Const CERT_STORE_ADD_USE_EXISTING As Long = 2 +'--- for CryptAcquireContext +Private Const PROV_RSA_FULL As Long = 1 +Private Const CRYPT_NEWKEYSET As Long = &H8 +Private Const CRYPT_DELETEKEYSET As Long = &H10 +Private Const AT_KEYEXCHANGE As Long = 1 +'--- for CertGetCertificateContextProperty +Private Const CERT_KEY_PROV_INFO_PROP_ID As Long = 2 +Private Const CERT_OCSP_RESPONSE_PROP_ID As Long = 70 +'--- for ALPN +Private Const SecApplicationProtocolNegotiationExt_ALPN As Long = 2 +Private Const SecApplicationProtocolNegotiationStatus_Success As Long = 1 +'--- OIDs +Private Const szOID_RSA_RSA As String = "1.2.840.113549.1.1.1" +Private Const szOID_ECC_PUBLIC_KEY As String = "1.2.840.10045.2.1" +Private Const szOID_ECC_CURVE_P256 As String = "1.2.840.10045.3.1.7" +Private Const szOID_ECC_CURVE_P384 As String = "1.3.132.0.34" +Private Const szOID_ECC_CURVE_P521 As String = "1.3.132.0.35" +'--- NCrypt +Private Const BCRYPT_ECDSA_PRIVATE_P256_MAGIC As Long = &H32534345 +Private Const BCRYPT_ECDSA_PRIVATE_P384_MAGIC As Long = &H34534345 +Private Const BCRYPT_ECDSA_PRIVATE_P521_MAGIC As Long = &H36534345 +Private Const MS_KEY_STORAGE_PROVIDER As String = "Microsoft Software Key Storage Provider" +Private Const NCRYPTBUFFER_PKCS_KEY_NAME As Long = 45 +Private Const NCRYPT_OVERWRITE_KEY_FLAG As Long = &H80 + +Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) +Private Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long +Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, ByRef lpflOldProtect As Long) As Long +Private Declare Function vbaObjSetAddref Lib "msvbvm60" Alias "__vbaObjSetAddref" (oDest As Any, ByVal lSrcPtr As Long) As Long +Private Declare Function lstrlenA Lib "kernel32" (ByVal lpStr As Long) As Long +Private Declare Function lstrlenW Lib "kernel32" (ByVal lpStr As Long) As Long +Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long +Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageW" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As Long, ByVal nSize As Long, ByVal Args As Long) As Long +'--- msvbvm60 +Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long +'--- version +Private Declare Function GetFileVersionInfo Lib "version" Alias "GetFileVersionInfoW" (ByVal lptstrFilename As Long, ByVal dwHandle As Long, ByVal dwLen As Long, lpData As Any) As Long +Private Declare Function VerQueryValue Lib "version" Alias "VerQueryValueW" (pBlock As Any, ByVal lpSubBlock As Long, lpBuffer As Any, puLen As Long) As Long +'--- security +Private Declare Function AcquireCredentialsHandle Lib "security" Alias "AcquireCredentialsHandleW" (ByVal pszPrincipal As Long, ByVal pszPackage As Long, ByVal fCredentialUse As Long, ByVal pvLogonId As Long, pAuthData As Any, ByVal pGetKeyFn As Long, ByVal pvGetKeyArgument As Long, phCredential As Currency, ByVal ptsExpiry As Long) As Long +Private Declare Function FreeCredentialsHandle Lib "security" (phContext As Currency) As Long +Private Declare Function AcceptSecurityContext Lib "security" (phCredential As Currency, ByVal phContext As Long, pInput As Any, ByVal fContextReq As Long, ByVal TargetDataRep As Long, phNewContext As Currency, pOutput As Any, pfContextAttr As Long, ByVal ptsExpiry As Long) As Long +Private Declare Function InitializeSecurityContext Lib "security" Alias "InitializeSecurityContextW" (phCredential As Currency, ByVal phContext As Long, ByVal pszTargetName As Long, ByVal fContextReq As Long, ByVal Reserved1 As Long, ByVal TargetDataRep As Long, pInput As Any, ByVal Reserved2 As Long, phNewContext As Currency, pOutput As Any, pfContextAttr As Long, ByVal ptsExpiry As Long) As Long +Private Declare Function DeleteSecurityContext Lib "security" (phContext As Currency) As Long +Private Declare Function FreeContextBuffer Lib "security" (ByVal pvContextBuffer As Long) As Long +Private Declare Function QueryContextAttributes Lib "security" Alias "QueryContextAttributesW" (phContext As Currency, ByVal ulAttribute As Long, pBuffer As Any) As Long +Private Declare Function DecryptMessage Lib "security" (phContext As Currency, pMessage As Any, ByVal MessageSeqNo As Long, ByVal pfQOP As Long) As Long +Private Declare Function EncryptMessage Lib "security" (phContext As Currency, ByVal fQOP As Long, pMessage As Any, ByVal MessageSeqNo As Long) As Long +Private Declare Function ApplyControlToken Lib "security" (phContext As Currency, pInput As Any) As Long +'--- crypt32 +Private Declare Function CryptDecodeObjectEx Lib "crypt32" (ByVal dwCertEncodingType As Long, ByVal lpszStructType As Any, pbEncoded As Any, ByVal cbEncoded As Long, ByVal dwFlags As Long, ByVal pDecodePara As Long, pvStructInfo As Any, pcbStructInfo As Long) As Long +Private Declare Function CertOpenStore Lib "crypt32" (ByVal lpszStoreProvider As Long, ByVal dwEncodingType As Long, ByVal hCryptProv As Long, ByVal dwFlags As Long, ByVal pvPara As Long) As Long +Private Declare Function CertCloseStore Lib "crypt32" (ByVal hCertStore As Long, ByVal dwFlags As Long) As Long +Private Declare Function CertAddEncodedCertificateToStore Lib "crypt32" (ByVal hCertStore As Long, ByVal dwCertEncodingType As Long, pbCertEncoded As Any, ByVal cbCertEncoded As Long, ByVal dwAddDisposition As Long, ByVal ppCertContext As Long) As Long +Private Declare Function CertSetCertificateContextProperty Lib "crypt32" (ByVal pCertContext As Long, ByVal dwPropId As Long, ByVal dwFlags As Long, pvData As Any) As Long +Private Declare Function CertFreeCertificateContext Lib "crypt32" (ByVal pCertContext As Long) As Long +Private Declare Function CertEnumCertificatesInStore Lib "crypt32" (ByVal hCertStore As Long, ByVal pPrevCertContext As Long) As Long +Private Declare Function CertGetCertificateContextProperty Lib "crypt32" (ByVal pCertContext As Long, ByVal dwPropId As Long, pvData As Any, pcbData As Long) As Long +Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, pcbBinary As Long, Optional ByVal pdwSkip As Long, Optional ByVal pdwFlags As Long) As Long +'--- advapi32 +Private Declare Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextW" (phProv As Long, ByVal pszContainer As Long, ByVal pszProvider As Long, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long +Private Declare Function CryptReleaseContext Lib "advapi32" (ByVal hProv As Long, ByVal dwFlags As Long) As Long +Private Declare Function CryptImportKey Lib "advapi32" (ByVal hProv As Long, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As Long, ByVal dwFlags As Long, phKey As Long) As Long +Private Declare Function CryptDestroyKey Lib "advapi32" (ByVal hKey As Long) As Long +Private Declare Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength As Long) As Long +'--- ncrypt +Private Declare Function NCryptOpenStorageProvider Lib "ncrypt" (phProvider As Long, ByVal pszProviderName As Long, ByVal dwFlags As Long) As Long +Private Declare Function NCryptImportKey Lib "ncrypt" (ByVal hProvider As Long, ByVal hImportKey As Long, ByVal pszBlobType As Long, pParameterList As Any, phKey As Long, pbData As Any, ByVal cbData As Long, ByVal dwFlags As Long) As Long +Private Declare Function NCryptFreeObject Lib "ncrypt" (ByVal hObject As Long) As Long + +Private Type SCHANNEL_CRED + dwVersion As Long + cCreds As Long + paCred As Long + hRootStore As Long + cMappers As Long + aphMappers As Long + cSupportedAlgs As Long + palgSupportedAlgs As Long + grbitEnabledProtocols As Long + dwMinimumCipherStrength As Long + dwMaximumCipherStrength As Long + dwSessionLifespan As Long + dwFlags As Long + dwCredFormat As Long +End Type + +Private Type SCH_CREDENTIALS + dwVersion As Long + dwCredFormat As Long + cCreds As Long + paCred As Long + hRootStore As Long + cMappers As Long + aphMappers As Long + dwSessionLifespan As Long + dwFlags As Long + cTlsParameters As Long + pTlsParameters As Long +End Type + +Private Type TLS_PARAMETERS + cAlpnIds As Long + rgstrAlpnIds As Long + grbitDisabledProtocols As Long + cDisabledCrypto As Long + pDisabledCrypto As Long + dwFlags As Long +End Type + +Private Type ApiSecBuffer + cbBuffer As Long + BufferType As Long + pvBuffer As Long +End Type + +Private Type ApiSecBufferDesc + ulVersion As Long + cBuffers As Long + pBuffers As Long +End Type + +Private Type ApiSecPkgContext_StreamSizes + cbHeader As Long + cbTrailer As Long + cbMaximumMessage As Long + cBuffers As Long + cbBlockSize As Long +End Type + +Private Type CRYPT_KEY_PROV_INFO + pwszContainerName As Long + pwszProvName As Long + dwProvType As Long + dwFlags As Long + cProvParam As Long + rgProvParam As Long + dwKeySpec As Long +End Type + +Private Type BCRYPT_ECCKEY_BLOB + dwMagic As Long + cbKey As Long + Buffer(0 To 1000) As Byte +End Type + +Private Type CRYPT_DATA_BLOB + cbData As Long + pbData As Long +End Type + +Private Type CRYPT_BIT_BLOB + cbData As Long + pbData As Long + cUnusedBits As Long +End Type + +Private Type CRYPT_ALGORITHM_IDENTIFIER + pszObjId As Long + Parameters As CRYPT_DATA_BLOB +End Type + +Private Type CERT_PUBLIC_KEY_INFO + Algorithm As CRYPT_ALGORITHM_IDENTIFIER + PublicKey As CRYPT_BIT_BLOB +End Type + +Private Type CRYPT_ECC_PRIVATE_KEY_INFO + dwVersion As Long + PrivateKey As CRYPT_DATA_BLOB + szCurveOid As Long + PublicKey As CRYPT_DATA_BLOB +End Type + +Private Type CRYPT_PRIVATE_KEY_INFO + dwVersion As Long + Algorithm As CRYPT_ALGORITHM_IDENTIFIER + PrivateKey As CRYPT_DATA_BLOB + pAttributes As Long +End Type + +Private Type CERT_CONTEXT + dwCertEncodingType As Long + pbCertEncoded As Long + cbCertEncoded As Long + pCertInfo As Long + hCertStore As Long +End Type + +Private Type SecPkgContext_IssuerListInfoEx + aIssuers As Long + cIssuers As Long +End Type + +Private Type SecPkgContext_ConnectionInfo + dwProtocol As Long + aiCipher As Long + dwCipherStrength As Long + aiHash As Long + dwHashStrength As Long + aiExch As Long + dwExchStrength As Long +End Type + +Private Const SZ_ALG_MAX_SIZE As Long = 64 +Private Type SecPkgContext_CipherInfo + dwVersion As Long + dwProtocol As Long + dwCipherSuite As Long + dwBaseCipherSuite As Long + szCipherSuite(0 To SZ_ALG_MAX_SIZE - 1) As Integer + szCipher(0 To SZ_ALG_MAX_SIZE - 1) As Integer + dwCipherLen As Long + dwCipherBlockLen As Long + szHash(0 To SZ_ALG_MAX_SIZE - 1) As Integer + dwHashLen As Long + szExchange(0 To SZ_ALG_MAX_SIZE - 1) As Integer + dwMinExchangeLen As Long + dwMaxExchangeLen As Long + szCertificate(0 To SZ_ALG_MAX_SIZE - 1) As Integer + dwKeyType As Long +End Type + +Private Const MAX_PROTOCOL_ID_SIZE As Long = &HFF& +Private Type SecPkgContext_ApplicationProtocol + ProtoNegoStatus As Long + ProtoNegoExt As Long + ProtocolIdSize As Byte + ProtocolId(0 To MAX_PROTOCOL_ID_SIZE) As Byte +End Type + +'========================================================================= +' Constants and member variables +'========================================================================= + +Private Const STR_VL_ALERTS As String = "0|Close notify|10|Unexpected message|20|Bad record mac|21|Decryption failed|22|Record overflow|30|Decompression failure|40|Handshake failure|41|No certificate|42|Bad certificate|43|Unsupported certificate|44|Certificate revoked|45|Certificate expired|46|Certificate unknown|47|Illegal parameter|48|Unknown certificate authority|50|Decode error|51|Decrypt error|70|Protocol version|71|Insufficient security|80|Internal error|90|User canceled|100|No renegotiation|109|Missing extension|110|Unsupported expension|112|Unrecognized name|116|Certificate required|120|No application protocol" +Private Const STR_UNKNOWN As String = "Unknown (%1)" +Private Const STR_FORMAT_ALERT As String = "%1." +'--- errors +Private Const ERR_UNEXPECTED_RESULT As String = "Unexpected result from %1 (%2)" +Private Const ERR_CONNECTION_CLOSED As String = "Connection closed" +Private Const ERR_UNKNOWN_ECC_PRIVKEY As String = "Unknown ECC private key (%1)" +Private Const ERR_UNKNOWN_PUBKEY As String = "Unknown public key (%1)" +Private Const ERR_NO_SERVER_COMPILED As String = "Server-side TLS not compiled (ASYNCSOCKET_NO_TLSSERVER = 1)" +'--- numeric +Private Const TLS_CONTENT_TYPE_ALERT As Long = 21 +Private Const LNG_FACILITY_WIN32 As Long = &H80070000 + +Private Enum UcsTlsLocalFeaturesEnum '--- bitmask + ucsTlsSupportTls10 = 2 ^ 0 + ucsTlsSupportTls11 = 2 ^ 1 + ucsTlsSupportTls12 = 2 ^ 2 + ucsTlsSupportTls13 = 2 ^ 3 + ucsTlsIgnoreServerCertificateErrors = 2 ^ 4 + ucsTlsSupportAll = ucsTlsSupportTls10 Or ucsTlsSupportTls11 Or ucsTlsSupportTls12 Or ucsTlsSupportTls13 +End Enum + +Private Enum UcsTlsStatesEnum + ucsTlsStateNew = 0 + ucsTlsStateClosed = 1 + ucsTlsStateHandshakeStart = 2 + ucsTlsStatePostHandshake = 8 + ucsTlsStateShutdown = 9 +End Enum + +Private Enum UcsTlsAlertDescriptionsEnum + uscTlsAlertCloseNotify = 0 + uscTlsAlertUnexpectedMessage = 10 + uscTlsAlertBadRecordMac = 20 + uscTlsAlertHandshakeFailure = 40 + uscTlsAlertBadCertificate = 42 + uscTlsAlertCertificateRevoked = 44 + uscTlsAlertCertificateExpired = 45 + uscTlsAlertCertificateUnknown = 46 + uscTlsAlertIllegalParameter = 47 + uscTlsAlertUnknownCa = 48 + uscTlsAlertDecodeError = 50 + uscTlsAlertDecryptError = 51 + uscTlsAlertProtocolVersion = 70 + uscTlsAlertInternalError = 80 + uscTlsAlertUserCanceled = 90 + uscTlsAlertMissingExtension = 109 + uscTlsAlertUnrecognizedName = 112 + uscTlsAlertCertificateRequired = 116 + uscTlsAlertNoApplicationProtocol = 120 +End Enum + +#If Not ImplUseShared Then +Private Enum UcsOsVersionEnum + ucsOsvNt4 = 400 + ucsOsvWin98 = 410 + ucsOsvWin2000 = 500 + ucsOsvXp = 501 + ucsOsvVista = 600 + ucsOsvWin7 = 601 + ucsOsvWin8 = 602 + [ucsOsvWin8.1] = 603 + ucsOsvWin10 = 1000 +End Enum +#End If + +Public Type UcsTlsContext + '--- config + IsServer As Boolean + RemoteHostName As String + LocalFeatures As UcsTlsLocalFeaturesEnum + ClientCertCallback As Long + AlpnProtocols As String + '--- state + State As UcsTlsStatesEnum + LastErrNumber As Long + LastError As String + LastErrSource As String + LastAlertCode As UcsTlsAlertDescriptionsEnum + AlpnNegotiated As String + SniRequested As String + '--- handshake + LocalCertificates As Collection + LocalPrivateKey As Collection + RemoteCertificates As Collection + RemoteCertStatuses As Collection + '--- SSPI + ContextReq As Long + hTlsCredentials As Currency + hTlsContext As Currency + TlsSizes As ApiSecPkgContext_StreamSizes + InDesc As ApiSecBufferDesc + InBuffers() As ApiSecBuffer + OutDesc As ApiSecBufferDesc + OutBuffers() As ApiSecBuffer + '--- I/O buffers + RecvBuffer() As Byte + RecvPos As Long +#If ImplCaptureTraffic <> 0 Then + TrafficDump As Collection +#End If +End Type + +Private Type UcsKeyInfo + AlgoObjId As String + KeyBlob() As Byte + BitLen As Long +End Type + +Public g_oRequestSocket As Object + +'========================================================================= +' Error handling +'========================================================================= + +Private Sub ErrRaise(ByVal Number As Long, Optional Source As Variant, Optional Description As Variant) + Err.Raise Number, Source, Description +End Sub + +'========================================================================= +' Properties +'========================================================================= + +Public Property Get TlsIsClosed(uCtx As UcsTlsContext) As Boolean + TlsIsClosed = (uCtx.State = ucsTlsStateClosed) +End Property + +Public Property Get TlsIsStarted(uCtx As UcsTlsContext) As Boolean + TlsIsStarted = (uCtx.State > ucsTlsStateClosed) +End Property + +Public Property Get TlsIsReady(uCtx As UcsTlsContext) As Boolean + TlsIsReady = (uCtx.State >= ucsTlsStatePostHandshake) +End Property + +Public Property Get TlsIsShutdown(uCtx As UcsTlsContext) As Boolean + TlsIsShutdown = (uCtx.State = ucsTlsStateShutdown) +End Property + +'========================================================================= +' TLS support +'========================================================================= + +Public Function TlsInitClient( _ + uCtx As UcsTlsContext, _ + Optional RemoteHostName As String, _ + Optional ByVal LocalFeatures As Long = ucsTlsSupportAll, _ + Optional ClientCertCallback As Object, _ + Optional AlpnProtocols As String) As Boolean + Dim uEmpty As UcsTlsContext + + On Error GoTo EH + With uEmpty + pvTlsClearLastError uEmpty + .State = ucsTlsStateHandshakeStart + .RemoteHostName = RemoteHostName + .LocalFeatures = LocalFeatures + .ClientCertCallback = ObjPtr(ClientCertCallback) + If RealOsVersion >= [ucsOsvWin8.1] Then + .AlpnProtocols = AlpnProtocols + End If + #If ImplCaptureTraffic <> 0 Then + Set .TrafficDump = New Collection + #End If + End With + uCtx = uEmpty + '--- success + TlsInitClient = True + Exit Function +EH: + pvTlsSetLastError uCtx, Err.Number, Err.Source, Err.Description +End Function + +Public Function TlsInitServer( _ + uCtx As UcsTlsContext, _ + Optional RemoteHostName As String, _ + Optional Certificates As Collection, _ + Optional PrivateKey As Collection, _ + Optional AlpnProtocols As String, _ + Optional ByVal LocalFeatures As Long = ucsTlsSupportAll) As Boolean +#If Not ImplTlsServer Then + ErrRaise vbObjectError, , ERR_NO_SERVER_COMPILED +#Else + Dim uEmpty As UcsTlsContext + + On Error GoTo EH + With uEmpty + pvTlsClearLastError uEmpty + .IsServer = True + .State = ucsTlsStateHandshakeStart + .RemoteHostName = RemoteHostName + .LocalFeatures = LocalFeatures + Set .LocalCertificates = Certificates + Set .LocalPrivateKey = PrivateKey + If RealOsVersion >= [ucsOsvWin8.1] Then + .AlpnProtocols = AlpnProtocols + End If + #If ImplCaptureTraffic <> 0 Then + Set .TrafficDump = New Collection + #End If + End With + uCtx = uEmpty + '--- success + TlsInitServer = True + Exit Function +EH: + pvTlsSetLastError uCtx, Err.Number, Err.Source, Err.Description +#End If +End Function + +Public Function TlsTerminate(uCtx As UcsTlsContext) + With uCtx + .State = ucsTlsStateClosed + If .hTlsContext <> 0 Then + Call DeleteSecurityContext(.hTlsContext) + .hTlsContext = 0 + End If + If .hTlsCredentials <> 0 Then + Call FreeCredentialsHandle(.hTlsCredentials) + .hTlsCredentials = 0 + End If + End With +End Function + +Public Function TlsHandshake(uCtx As UcsTlsContext, baInput() As Byte, ByVal lSize As Long, baOutput() As Byte, lOutputPos As Long) As Boolean + Const FUNC_NAME As String = "TlsHandshake" + Dim uCred As SCHANNEL_CRED + Dim uNewCred As SCH_CREDENTIALS + Dim uNewParams As TLS_PARAMETERS + Dim lContextAttr As Long + Dim hResult As Long + Dim lIdx As Long + Dim lPtr As Long + Dim oCallback As Object + Dim sKeyName As String + Dim pCertContext As Long + Dim aCred(0 To 0) As Long + Dim uIssuerInfo As SecPkgContext_IssuerListInfoEx + Dim uIssuerList() As CRYPT_DATA_BLOB + Dim cIssuers As Collection + Dim baCaDn() As Byte + Dim uCertContext As CERT_CONTEXT + Dim sApiSource As String + Dim uConnInfo As SecPkgContext_ConnectionInfo + Dim uCipherInfo As SecPkgContext_CipherInfo + Dim baAlpnBuffer() As Byte + Dim uAppProtocol As SecPkgContext_ApplicationProtocol + + On Error GoTo EH + With uCtx + If .State = ucsTlsStateClosed Then + pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME, ERR_CONNECTION_CLOSED + GoTo QH + End If + pvTlsClearLastError uCtx + If .ContextReq = 0 Then + .ContextReq = .ContextReq Or ISC_REQ_REPLAY_DETECT ' Detect replayed messages that have been encoded by using the EncryptMessage or MakeSignature functions. + .ContextReq = .ContextReq Or ISC_REQ_SEQUENCE_DETECT ' Detect messages received out of sequence. + .ContextReq = .ContextReq Or ISC_REQ_CONFIDENTIALITY ' Encrypt messages by using the EncryptMessage function. + .ContextReq = .ContextReq Or ISC_REQ_ALLOCATE_MEMORY ' The security package allocates output buffers for you. When you have finished using the output buffers, free them by calling the FreeContextBuffer function. + .ContextReq = .ContextReq Or ISC_REQ_EXTENDED_ERROR ' When errors occur, the remote party will be notified. + .ContextReq = .ContextReq Or ISC_REQ_STREAM ' Support a stream-oriented connection. + End If + If lSize < 0 Then + lSize = pvArraySize(baInput) + End If + If lSize > 0 Then + .RecvPos = pvWriteBuffer(.RecvBuffer, .RecvPos, VarPtr(baInput(0)), lSize) + End If + '--- note: doesn't work for encrypted alerts + If lSize = 7 Then + If baInput(0) = TLS_CONTENT_TYPE_ALERT Then + .LastAlertCode = baInput(6) + End If + End If +RetryCredentials: + If .hTlsCredentials = 0 Then + uCred.dwVersion = SCHANNEL_CRED_VERSION + uCred.grbitEnabledProtocols = IIf((.LocalFeatures And ucsTlsSupportTls10) <> 0, SP_PROT_TLS1_0, 0) Or _ + IIf((.LocalFeatures And ucsTlsSupportTls11) <> 0, SP_PROT_TLS1_1, 0) Or _ + IIf((.LocalFeatures And ucsTlsSupportTls12) <> 0, SP_PROT_TLS1_2, 0) + uCred.dwFlags = uCred.dwFlags Or SCH_CRED_MANUAL_CRED_VALIDATION ' Prevent Schannel from validating the received server certificate chain. + uCred.dwFlags = uCred.dwFlags Or SCH_CRED_NO_DEFAULT_CREDS ' Prevent Schannel from attempting to automatically supply a certificate chain for client authentication. + uCred.dwFlags = uCred.dwFlags Or SCH_CRED_REVOCATION_CHECK_CHAIN_EXCLUDE_ROOT ' Force TLS certificate status request extension (commonly known as OCSP stapling) to be sent on Vista or later + If pvCollectionCount(.LocalCertificates) > 0 Then + If pvTlsImportToCertStore(.LocalCertificates, .LocalPrivateKey, sKeyName, pCertContext) And pCertContext <> 0 Then + aCred(uCred.cCreds) = pCertContext + uCred.cCreds = uCred.cCreds + 1 + uCred.paCred = VarPtr(aCred(0)) + .ContextReq = .ContextReq Or ISC_REQ_USE_SUPPLIED_CREDS ' Schannel must not attempt to supply credentials for the client automatically. + End If + End If + If RealOsVersion(BuildNo:=lIdx) = ucsOsvWin10 And lIdx >= 20348 Then '--- 20348 = Windows Server 2022 + '--- use new credentials struct for TLS 1.3 support + uNewCred.dwVersion = SCH_CREDENTIALS_VERSION + uNewCred.cCreds = uCred.cCreds + uNewCred.paCred = uCred.paCred + uNewCred.dwFlags = uCred.dwFlags Or SCH_USE_STRONG_CRYPTO + uNewCred.cTlsParameters = 1 + uNewCred.pTlsParameters = VarPtr(uNewParams) + uNewParams.grbitDisabledProtocols = Not (uCred.grbitEnabledProtocols Or _ + IIf((.LocalFeatures And ucsTlsSupportTls13) <> 0, SP_PROT_TLS1_3, 0)) + hResult = AcquireCredentialsHandle(0, StrPtr(UNISP_NAME), IIf(.IsServer, SECPKG_CRED_INBOUND, SECPKG_CRED_OUTBOUND), 0, uNewCred, 0, 0, .hTlsCredentials, 0) + Else + hResult = -1 + End If + If hResult < 0 Then + hResult = AcquireCredentialsHandle(0, StrPtr(UNISP_NAME), IIf(.IsServer, SECPKG_CRED_INBOUND, SECPKG_CRED_OUTBOUND), 0, uCred, 0, 0, .hTlsCredentials, 0) + End If + If hResult < 0 Then + pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "AcquireCredentialsHandle", AlertCode:=.LastAlertCode + GoTo QH + End If + If pCertContext <> 0 Then + Call CertFreeCertificateContext(pCertContext) + pCertContext = 0 + End If + End If + If .hTlsContext = 0 Then + pvInitSecDesc .InDesc, 3, .InBuffers + pvInitSecDesc .OutDesc, 3, .OutBuffers + #If ImplTlsServer Then + If .IsServer Then + pvTlsParseHandshakeClientHello uCtx, baInput, 0 + End If + #End If + If LenB(.AlpnProtocols) <> 0 Then + pvTlsBuildAlpnBuffer baAlpnBuffer, 0, .AlpnProtocols + End If + End If + Do + If .RecvPos > 0 Then + #If (ImplCaptureTraffic And 1) <> 0 Then + .TrafficDump.Add FUNC_NAME & ".Input" & vbCrLf & TlsDesignDumpArray(.RecvBuffer, 0, .RecvPos) + #End If + pvInitSecBuffer .InBuffers(0), SECBUFFER_TOKEN, VarPtr(.RecvBuffer(0)), .RecvPos + lPtr = VarPtr(.InDesc) + Else + lPtr = 0 + End If + If pvArraySize(baAlpnBuffer) > 0 Then + pvInitSecBuffer .InBuffers(IIf(lPtr <> 0, 1, 0)), SECBUFFER_APPLICATION_PROTOCOLS, VarPtr(baAlpnBuffer(0)), UBound(baAlpnBuffer) + 1 + lPtr = VarPtr(.InDesc) + End If + #If ImplTlsServer Then + If .IsServer Then + hResult = AcceptSecurityContext(.hTlsCredentials, IIf(.hTlsContext <> 0, VarPtr(.hTlsContext), 0), ByVal lPtr, .ContextReq, _ + SECURITY_NATIVE_DREP, .hTlsContext, .OutDesc, lContextAttr, 0) + sApiSource = "AcceptSecurityContext" + Else + #End If + hResult = InitializeSecurityContext(.hTlsCredentials, IIf(.hTlsContext <> 0, VarPtr(.hTlsContext), 0), StrPtr(.RemoteHostName), .ContextReq, 0, _ + SECURITY_NATIVE_DREP, ByVal lPtr, 0, .hTlsContext, .OutDesc, lContextAttr, 0) + sApiSource = "InitializeSecurityContext" + #If ImplTlsServer Then + End If + #End If + If hResult = SEC_E_INCOMPLETE_MESSAGE Then + pvInitSecBuffer .InBuffers(1), SECBUFFER_EMPTY + Exit Do + ElseIf hResult < 0 Then + pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & sApiSource, AlertCode:=.LastAlertCode + '--- treat as warnings TLS1_ALERT_BAD_CERTIFICATE, TLS1_ALERT_UNSUPPORTED_CERT and TLS1_ALERT_CERTIFICATE_UNKNOWN + If hResult = SEC_E_CERT_UNKNOWN Then + TlsHandshake = True + End If + GoTo QH + Else + .RecvPos = 0 + For lIdx = 1 To UBound(.InBuffers) + With .InBuffers(lIdx) + If .cbBuffer > 0 Then + Select Case .BufferType + Case SECBUFFER_EXTRA + lPtr = .pvBuffer + If lPtr = 0 Then + lPtr = VarPtr(uCtx.RecvBuffer(uCtx.InBuffers(0).cbBuffer - .cbBuffer)) + End If + uCtx.RecvPos = pvWriteBuffer(uCtx.RecvBuffer, uCtx.RecvPos, lPtr, .cbBuffer) + Case SECBUFFER_ALERT + #If ImplUseDebugLog Then + DebugLog MODULE_NAME, FUNC_NAME, "InBuffers, SECBUFFER_ALERT:" & vbCrLf & TlsDesignDumpMemory(.pvBuffer, .cbBuffer), vbLogEventTypeWarning + #End If + Case Else + #If ImplUseDebugLog Then + DebugLog MODULE_NAME, FUNC_NAME, ".BufferType(" & lIdx & ")=" & .BufferType + #End If + End Select + End If + End With + pvInitSecBuffer .InBuffers(lIdx), SECBUFFER_EMPTY + Next + Erase baAlpnBuffer + For lIdx = 0 To UBound(.OutBuffers) + With .OutBuffers(lIdx) + If .cbBuffer > 0 Then + Select Case .BufferType + Case SECBUFFER_TOKEN + lOutputPos = pvWriteBuffer(baOutput, lOutputPos, .pvBuffer, .cbBuffer) + #If (ImplCaptureTraffic And 1) <> 0 Then + uCtx.TrafficDump.Add FUNC_NAME & ".Output" & vbCrLf & TlsDesignDumpMemory(.pvBuffer, .cbBuffer) + #End If + Case SECBUFFER_ALERT + #If ImplUseDebugLog Then + DebugLog MODULE_NAME, FUNC_NAME, "OutBuffers, SECBUFFER_ALERT:" & vbCrLf & TlsDesignDumpMemory(.pvBuffer, .cbBuffer), vbLogEventTypeWarning + #End If + End Select + If .pvBuffer <> 0 Then + Call FreeContextBuffer(.pvBuffer) + Debug.Assert Err.LastDllError = 0 + End If + End If + End With + pvInitSecBuffer .OutBuffers(lIdx), SECBUFFER_EMPTY + Next + Select Case hResult + Case SEC_I_CONTINUE_NEEDED + '--- do nothing + Case SEC_E_OK + hResult = QueryContextAttributes(.hTlsContext, SECPKG_ATTR_STREAM_SIZES, .TlsSizes) + If hResult < 0 Then + pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "QueryContextAttributes(SECPKG_ATTR_STREAM_SIZES)", AlertCode:=.LastAlertCode + GoTo QH + End If + pvInitSecDesc .InDesc, .TlsSizes.cBuffers, .InBuffers + pvInitSecDesc .OutDesc, .TlsSizes.cBuffers, .OutBuffers + If QueryContextAttributes(.hTlsContext, SECPKG_ATTR_REMOTE_CERT_CONTEXT, pCertContext) = 0 And pCertContext <> 0 Then + Call CopyMemory(uCertContext, ByVal pCertContext, Len(uCertContext)) + If Not pvTlsExportFromCertStore(uCertContext.hCertStore, .RemoteCertificates, .RemoteCertStatuses) Then + GoTo QH + End If + Call CertFreeCertificateContext(pCertContext) + pCertContext = 0 + End If + If LenB(.AlpnProtocols) <> 0 Then + .AlpnNegotiated = vbNullString + If QueryContextAttributes(.hTlsContext, SECPKG_ATTR_APPLICATION_PROTOCOL, uAppProtocol) = 0 Then + If uAppProtocol.ProtoNegoStatus = SecApplicationProtocolNegotiationStatus_Success Then + uAppProtocol.ProtocolId(uAppProtocol.ProtocolIdSize) = 0 + .AlpnNegotiated = pvToStringA(VarPtr(uAppProtocol.ProtocolId(0))) + End If + End If + End If + #If ImplUseDebugLog Then + If QueryContextAttributes(.hTlsContext, SECPKG_ATTR_CIPHER_INFO, uCipherInfo) = 0 Then + DebugLog MODULE_NAME, FUNC_NAME, "Using " & pvToStringW(VarPtr(uCipherInfo.szCipherSuite(0))) & " (&H" & Hex$(uCipherInfo.dwCipherSuite) & ") from " & .RemoteHostName + End If + If QueryContextAttributes(.hTlsContext, SECPKG_ATTR_CONNECTION_INFO, uConnInfo) = 0 Then + DebugLog MODULE_NAME, FUNC_NAME, pvTlsGetAlgName(uConnInfo.dwProtocol) & " using " & _ + pvTlsGetAlgName(uConnInfo.aiCipher) & " cipher with " & _ + pvTlsGetAlgName(uConnInfo.aiHash) & " hash and " & _ + pvTlsGetAlgName(uConnInfo.aiExch) & " key-exchange" & _ + IIf(LenB(.AlpnNegotiated) <> 0, " over " & .AlpnNegotiated & " (ALPN)", vbNullString) & _ + IIf(LenB(.SniRequested) <> 0, " for " & .SniRequested & " (SNI)", vbNullString) + End If + #End If + .State = ucsTlsStatePostHandshake + Exit Do + Case SEC_I_INCOMPLETE_CREDENTIALS + If .ClientCertCallback <> 0 Then + hResult = QueryContextAttributes(.hTlsContext, SECPKG_ATTR_ISSUER_LIST_EX, uIssuerInfo) + If hResult < 0 Then + pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "QueryContextAttributes(SECPKG_ATTR_ISSUER_LIST_EX)", AlertCode:=.LastAlertCode + GoTo QH + End If + Set cIssuers = New Collection + If uIssuerInfo.cIssuers > 0 Then + ReDim uIssuerList(0 To uIssuerInfo.cIssuers - 1) As CRYPT_DATA_BLOB + Debug.Assert uIssuerInfo.aIssuers <> 0 + Call CopyMemory(uIssuerList(0), ByVal uIssuerInfo.aIssuers, uIssuerInfo.cIssuers * Len(uIssuerList(0))) + For lIdx = 0 To UBound(uIssuerList) + pvWriteBuffer baCaDn, 0, uIssuerList(lIdx).pbData, uIssuerList(lIdx).cbData + pvArrayReallocate baCaDn, uIssuerList(lIdx).cbData, FUNC_NAME & ".baCaDn" + cIssuers.Add baCaDn + Next + End If + Call vbaObjSetAddref(oCallback, .ClientCertCallback) + If oCallback.FireOnCertificate(cIssuers) Then + Call FreeCredentialsHandle(.hTlsCredentials) + .hTlsCredentials = 0 + End If + ElseIf (.ContextReq And ISC_REQ_USE_SUPPLIED_CREDS) = 0 Then + .ContextReq = .ContextReq Or ISC_REQ_USE_SUPPLIED_CREDS + End If + GoTo RetryCredentials + Case SEC_I_CONTEXT_EXPIRED + .State = ucsTlsStateShutdown + Exit Do + Case Else + pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME & vbCrLf & sApiSource, _ + Replace(Replace(ERR_UNEXPECTED_RESULT, "%1", sApiSource), "%2", "&H" & Hex$(hResult)), AlertCode:=.LastAlertCode + GoTo QH + End Select + If .RecvPos = 0 Then + Exit Do + End If + End If + Loop + End With + '--- success + TlsHandshake = True +QH: + If pCertContext <> 0 Then + Call CertFreeCertificateContext(pCertContext) + End If + If LenB(sKeyName) Then + Call CryptAcquireContext(0, StrPtr(sKeyName), 0, PROV_RSA_FULL, CRYPT_DELETEKEYSET) + End If + Exit Function +EH: + pvTlsSetLastError uCtx, Err.Number, Err.Source, Err.Description + Resume QH +End Function + +Public Function TlsReceive(uCtx As UcsTlsContext, baInput() As Byte, ByVal lSize As Long, baPlainText() As Byte, lPos As Long, baOutput() As Byte, lOutputPos As Long) As Boolean + Const FUNC_NAME As String = "TlsReceive" + Dim hResult As Long + Dim lIdx As Long + Dim lPtr As Long + Dim baEmpty() As Byte + + On Error GoTo EH + With uCtx + If .State = ucsTlsStateClosed Then + pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME, ERR_CONNECTION_CLOSED + GoTo QH + End If + pvTlsClearLastError uCtx + If lSize < 0 Then + lSize = pvArraySize(baInput) + End If + If lSize > 0 Then + .RecvPos = pvWriteBuffer(.RecvBuffer, .RecvPos, VarPtr(baInput(0)), lSize) + End If + Do + If .RecvPos > 0 Then + lPtr = VarPtr(.RecvBuffer(0)) + #If (ImplCaptureTraffic And 1) <> 0 Then + .TrafficDump.Add FUNC_NAME & ".Input" & vbCrLf & TlsDesignDumpArray(.RecvBuffer, 0, .RecvPos) + #End If + Else + lPtr = VarPtr(.RecvPos) + End If + pvInitSecBuffer .InBuffers(0), SECBUFFER_DATA, lPtr, .RecvPos + hResult = DecryptMessage(.hTlsContext, .InDesc, 0, 0) + If hResult = SEC_E_INCOMPLETE_MESSAGE Then + pvInitSecBuffer .InBuffers(1), SECBUFFER_EMPTY + Exit Do + ElseIf hResult = SEC_E_INVALID_HANDLE And .RecvPos = 0 Then + '--- session on hTlsContext already closed so don't call pvTlsSetLastError + Exit Do + ElseIf hResult < 0 Then + pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "DecryptMessage" + GoTo QH + End If + .RecvPos = 0 + For lIdx = 1 To UBound(.InBuffers) + With .InBuffers(lIdx) + If .cbBuffer > 0 Then + Select Case .BufferType + Case SECBUFFER_DATA + lPos = pvWriteBuffer(baPlainText, lPos, .pvBuffer, .cbBuffer) + Case SECBUFFER_EXTRA + lPtr = .pvBuffer + If lPtr = 0 Then + lPtr = VarPtr(uCtx.RecvBuffer(uCtx.InBuffers(0).cbBuffer - .cbBuffer)) + End If + uCtx.RecvPos = pvWriteBuffer(uCtx.RecvBuffer, uCtx.RecvPos, lPtr, .cbBuffer) + Case SECBUFFER_ALERT + #If ImplUseDebugLog Then + DebugLog MODULE_NAME, FUNC_NAME, "InBuffers, SECBUFFER_ALERT:" & vbCrLf & TlsDesignDumpMemory(.pvBuffer, .cbBuffer), vbLogEventTypeWarning + #End If + Case SECBUFFER_STREAM_HEADER, SECBUFFER_STREAM_TRAILER + '--- do nothing + Case Else + #If ImplUseDebugLog Then + DebugLog MODULE_NAME, FUNC_NAME, ".BufferType(" & lIdx & ")=" & .BufferType + #End If + End Select + End If + End With + pvInitSecBuffer .InBuffers(lIdx), SECBUFFER_EMPTY + Next + Select Case hResult + Case SEC_E_OK + '--- do nothing + Case SEC_I_RENEGOTIATE + .State = ucsTlsStateHandshakeStart + '--- .RecvBuffer is populated already + If Not TlsHandshake(uCtx, baEmpty, 0, baOutput, lOutputPos) Then + GoTo QH + End If + Case SEC_I_CONTEXT_EXPIRED + .State = ucsTlsStateShutdown + Exit Do + Case Else + pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "DecryptMessage", _ + Replace(Replace(ERR_UNEXPECTED_RESULT, "%1", "DecryptMessage"), "%2", "&H" & Hex$(hResult)) + GoTo QH + End Select + If .RecvPos = 0 Then + Exit Do + End If + Loop + End With + '--- success + TlsReceive = True +QH: + Exit Function +EH: + pvTlsSetLastError uCtx, Err.Number, Err.Source, Err.Description + Resume QH +End Function + +Public Function TlsSend(uCtx As UcsTlsContext, baPlainText() As Byte, ByVal lSize As Long, baOutput() As Byte, lOutputPos As Long) As Boolean + Const FUNC_NAME As String = "TlsSend" + Dim hResult As Long + Dim lBufPos As Long + Dim lBufSize As Long + Dim lPos As Long + Dim lIdx As Long + + On Error GoTo EH + With uCtx + If .State = ucsTlsStateClosed Then + pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME, ERR_CONNECTION_CLOSED + GoTo QH + End If + pvTlsClearLastError uCtx + '--- figure out upper bound of total output and reserve space in baOutput + lIdx = (lSize + .TlsSizes.cbMaximumMessage - 1) \ .TlsSizes.cbMaximumMessage + pvWriteReserved baOutput, lOutputPos, .TlsSizes.cbHeader * lIdx + lSize + .TlsSizes.cbTrailer * lIdx + For lPos = 0 To lSize - 1 Step .TlsSizes.cbMaximumMessage + lBufPos = lOutputPos + lBufSize = lSize - lPos + If lBufSize > .TlsSizes.cbMaximumMessage Then + lBufSize = .TlsSizes.cbMaximumMessage + End If + pvWriteReserved baOutput, lOutputPos, .TlsSizes.cbHeader + lBufSize + .TlsSizes.cbTrailer + pvInitSecBuffer .InBuffers(0), SECBUFFER_STREAM_HEADER, VarPtr(baOutput(lBufPos)), .TlsSizes.cbHeader + lBufPos = lBufPos + .TlsSizes.cbHeader + Debug.Assert UBound(baPlainText) + 1 >= lPos + lBufSize + Call CopyMemory(baOutput(lBufPos), baPlainText(lPos), lBufSize) + pvInitSecBuffer .InBuffers(1), SECBUFFER_DATA, VarPtr(baOutput(lBufPos)), lBufSize + lBufPos = lBufPos + lBufSize + pvInitSecBuffer .InBuffers(2), SECBUFFER_STREAM_TRAILER, VarPtr(baOutput(lBufPos)), .TlsSizes.cbTrailer + For lIdx = 3 To UBound(.InBuffers) + pvInitSecBuffer .InBuffers(lIdx), SECBUFFER_EMPTY + Next + hResult = EncryptMessage(.hTlsContext, 0, .InDesc, 0) + If hResult < 0 Then + pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "EncryptMessage" + GoTo QH + End If + #If (ImplCaptureTraffic And 1) <> 0 Then + .TrafficDump.Add FUNC_NAME & ".Output" & vbCrLf & TlsDesignDumpArray(baOutput, lOutputPos, .InBuffers(0).cbBuffer + .InBuffers(1).cbBuffer + .InBuffers(2).cbBuffer) + #End If + '--- note: use cbBuffer's as returned by EncryptMessage because trailing MAC might be trimmed (shorter than initial .TlsSizes.cbTrailer) + lOutputPos = lOutputPos + .InBuffers(0).cbBuffer + .InBuffers(1).cbBuffer + .InBuffers(2).cbBuffer + For lIdx = 1 To UBound(.InBuffers) + With .InBuffers(lIdx) + If .cbBuffer > 0 Then + Select Case .BufferType + Case SECBUFFER_ALERT + #If ImplUseDebugLog Then + DebugLog MODULE_NAME, FUNC_NAME, "InBuffers, SECBUFFER_ALERT:" & vbCrLf & TlsDesignDumpMemory(.pvBuffer, .cbBuffer), vbLogEventTypeWarning + #End If + Case SECBUFFER_DATA, SECBUFFER_STREAM_HEADER, SECBUFFER_STREAM_TRAILER + '--- do nothing + Case Else + #If ImplUseDebugLog Then + DebugLog MODULE_NAME, FUNC_NAME, ".BufferType(" & lIdx & ")=" & .BufferType + #End If + End Select + End If + End With + pvInitSecBuffer .InBuffers(lIdx), SECBUFFER_EMPTY + Next + Select Case hResult + Case SEC_E_OK + '--- do nothing + Case Else + pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "EncryptMessage", _ + Replace(Replace(ERR_UNEXPECTED_RESULT, "%1", "EncryptMessage"), "%2", "&H" & Hex$(hResult)) + GoTo QH + End Select + Next + End With + '--- success + TlsSend = True +QH: + Exit Function +EH: + pvTlsSetLastError uCtx, Err.Number, Err.Source, Err.Description + Resume QH +End Function + +Public Function TlsShutdown(uCtx As UcsTlsContext, baOutput() As Byte, lPos As Long) As Boolean + Const FUNC_NAME As String = "pvTlsShutdown" + Dim lType As Long + Dim hResult As Long + Dim lIdx As Long + Dim sApiSource As String + Dim lContextAttr As Long + + On Error GoTo QH + With uCtx + If .State = ucsTlsStateClosed Or .State = ucsTlsStateShutdown Then + '--- success + TlsShutdown = True + GoTo QH + End If + lType = SCHANNEL_SHUTDOWN + pvInitSecBuffer .InBuffers(0), SECBUFFER_TOKEN, VarPtr(lType), 4 + '--- note: passing more than one input buffer fails w/ SEC_E_INVALID_TOKEN (&H80090308) + .InDesc.cBuffers = 1 + hResult = ApplyControlToken(.hTlsContext, .InDesc) + .InDesc.cBuffers = .TlsSizes.cBuffers + If hResult < 0 Then + pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "ApplyControlToken" + GoTo QH + End If + pvInitSecBuffer .OutBuffers(0), SECBUFFER_TOKEN + For lIdx = 1 To UBound(.OutBuffers) + pvInitSecBuffer .OutBuffers(lIdx), SECBUFFER_EMPTY + Next + #If ImplTlsServer Then + If .IsServer Then + hResult = AcceptSecurityContext(.hTlsCredentials, VarPtr(.hTlsContext), ByVal 0, .ContextReq, _ + SECURITY_NATIVE_DREP, .hTlsContext, .OutDesc, lContextAttr, 0) + sApiSource = "AcceptSecurityContext" + Else + #End If + hResult = InitializeSecurityContext(.hTlsCredentials, VarPtr(.hTlsContext), StrPtr(.RemoteHostName), .ContextReq, 0, _ + SECURITY_NATIVE_DREP, ByVal 0, 0, .hTlsContext, .OutDesc, lContextAttr, 0) + sApiSource = "InitializeSecurityContext" + #If ImplTlsServer Then + End If + #End If + If hResult < 0 Then + pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & sApiSource + GoTo QH + End If + For lIdx = 0 To UBound(.OutBuffers) + With .OutBuffers(lIdx) + If .BufferType = SECBUFFER_TOKEN And .cbBuffer > 0 Then + #If (ImplCaptureTraffic And 1) <> 0 Then + uCtx.TrafficDump.Add FUNC_NAME & ".Output" & vbCrLf & TlsDesignDumpMemory(.pvBuffer, .cbBuffer) + #End If + lPos = pvWriteBuffer(baOutput, lPos, .pvBuffer, .cbBuffer) + End If + If .pvBuffer <> 0 Then + Call FreeContextBuffer(.pvBuffer) + Debug.Assert Err.LastDllError = 0 + .pvBuffer = 0 + End If + End With + Next + .State = ucsTlsStateShutdown + End With + '--- success + TlsShutdown = True +QH: + Exit Function +EH: + pvTlsSetLastError uCtx, Err.Number, Err.Source, Err.Description + Resume QH +End Function + +Public Function TlsGetLastError(uCtx As UcsTlsContext, Optional LastErrNumber As Long, Optional LastErrSource As String) As String + LastErrNumber = uCtx.LastErrNumber + LastErrSource = uCtx.LastErrSource + TlsGetLastError = uCtx.LastError + If uCtx.LastAlertCode <> -1 Then + TlsGetLastError = IIf(LenB(TlsGetLastError) <> 0, TlsGetLastError & ". ", vbNullString) & Replace(STR_FORMAT_ALERT, "%1", pvTlsGetLastAlert(uCtx)) + End If +End Function + +Private Sub pvTlsClearLastError(uCtx As UcsTlsContext) + With uCtx + .LastErrNumber = 0 + .LastErrSource = vbNullString + .LastError = vbNullString + .LastAlertCode = 0 + End With +End Sub + +Private Sub pvTlsSetLastError( _ + uCtx As UcsTlsContext, _ + Optional ByVal ErrNumber As Long, _ + Optional ErrSource As String, _ + Optional ErrDescription As String, _ + Optional ByVal AlertCode As Long = -1) + Const FUNC_NAME As String = "pvTlsSetLastError" + + With uCtx + .LastErrNumber = ErrNumber + .LastErrSource = ErrSource + .LastAlertCode = AlertCode + If ErrNumber <> 0 And LenB(ErrDescription) = 0 Then + uCtx.LastError = GetSystemMessage(ErrNumber) + If LenB(.LastError) = 0 Then + .LastError = "Error &H" & Hex$(ErrNumber) + End If + Else + .LastError = ErrDescription + End If + If Right$(.LastError, 2) = vbCrLf Then + .LastError = Left$(.LastError, Len(.LastError) - 2) + End If + If Right$(.LastError, 1) = "." Then + .LastError = Left$(.LastError, Len(.LastError) - 1) + End If + If Left$(.LastError, 16) = "Automation error" Then + .LastError = Mid$(.LastError, 17) + End If + If .LastErrNumber <> 0 Then + .State = ucsTlsStateClosed + End If + #If ImplCaptureTraffic <> 0 Then + Clipboard.Clear + Clipboard.SetText TlsConcatCollection(.TrafficDump, vbCrLf) + #If ImplUseDebugLog Then + DebugLog MODULE_NAME, FUNC_NAME, "Traffic dump copied to clipboard" + #End If + #End If + End With +End Sub + +Private Function pvTlsGetLastAlert(uCtx As UcsTlsContext, Optional AlertCode As Long) As String + Static vTexts As Variant + + AlertCode = uCtx.LastAlertCode + If AlertCode >= 0 Then + If IsEmpty(vTexts) Then + vTexts = SplitOrReindex(STR_VL_ALERTS, "|") + End If + If AlertCode <= UBound(vTexts) Then + pvTlsGetLastAlert = vTexts(AlertCode) + End If + If LenB(pvTlsGetLastAlert) = 0 Then + pvTlsGetLastAlert = Replace(STR_UNKNOWN, "%1", AlertCode) + End If + End If +End Function + +#If ImplUseDebugLog Then +Private Function pvTlsGetAlgName(ByVal lAlgId As Long) As String + Select Case lAlgId + Case &H20& + pvTlsGetAlgName = "SSL3_CLIENT" + Case &H80& + pvTlsGetAlgName = "TLS1_0_CLIENT" + Case &H200& + pvTlsGetAlgName = "TLS1_1_CLIENT" + Case &H800& + pvTlsGetAlgName = "TLS1_2_CLIENT" + Case &H2000& + pvTlsGetAlgName = "TLS1_3_CLIENT" + Case &H10& + pvTlsGetAlgName = "SSL3_SERVER" + Case &H40& + pvTlsGetAlgName = "TLS1_0_SERVER" + Case &H100& + pvTlsGetAlgName = "TLS1_1_SERVER" + Case &H400& + pvTlsGetAlgName = "TLS1_2_SERVER" + Case &H1000 + pvTlsGetAlgName = "TLS1_3_SERVER" + Case &H6602& + pvTlsGetAlgName = "RC2" + Case &H6801& + pvTlsGetAlgName = "RC4" + Case &H6601& + pvTlsGetAlgName = "DES" + Case &H6603& + pvTlsGetAlgName = "3DES" + Case &H660E& + pvTlsGetAlgName = "AES_128" + Case &H660F& + pvTlsGetAlgName = "AES_192" + Case &H6610& + pvTlsGetAlgName = "AES_256" + Case &H8001& + pvTlsGetAlgName = "MD2" + Case &H8003& + pvTlsGetAlgName = "MD5" + Case &H8004& + pvTlsGetAlgName = "SHA1" + Case &H800C& + pvTlsGetAlgName = "SHA_256" + Case &H800D& + pvTlsGetAlgName = "SHA_384" + Case &H800E& + pvTlsGetAlgName = "SHA_512" + Case &HA400& + pvTlsGetAlgName = "RSA_KEYX" + Case &H2400& + pvTlsGetAlgName = "RSA_SIGN" + Case &HAA02& + pvTlsGetAlgName = "DH_EPHEM" + Case &HAA05& + pvTlsGetAlgName = "ECDH" + Case &HAE06& + pvTlsGetAlgName = "ECDH_EPHEM" + Case Else + pvTlsGetAlgName = "&H" & Hex$(lAlgId) + End Select +End Function +#End If + +Private Function pvTlsBuildAlpnBuffer(baOutput() As Byte, ByVal lPos As Long, sAlpnProtocols As String) As Long + Dim vElem As Variant + Dim sProtocol As String + Dim lSize As Long + + lPos = pvWriteReserved(baOutput, 0, 4) + lPos = pvWriteBuffer(baOutput, lPos, VarPtr(SecApplicationProtocolNegotiationExt_ALPN), 4) + lPos = pvWriteReserved(baOutput, lPos, 2) + For Each vElem In Split(sAlpnProtocols, "|") + vElem = Left$(vElem, 255) + lSize = Len(vElem) + lPos = pvWriteBuffer(baOutput, lPos, VarPtr(lSize), 1) + sProtocol = StrConv(vElem, vbFromUnicode) + lPos = pvWriteBuffer(baOutput, lPos, StrPtr(sProtocol), Len(vElem)) + Next + pvWriteBuffer baOutput, 8, VarPtr(lPos - 10), 2 + pvWriteBuffer baOutput, 0, VarPtr(lPos - 4), 4 + pvTlsBuildAlpnBuffer = lPos +End Function + +Private Function pvTlsParseHandshakeClientHello(uCtx As UcsTlsContext, baInput() As Byte, ByVal lPos As Long) As Long + Const TLS_CONTENT_TYPE_HANDSHAKE As Long = 22 + Const TLS_HANDSHAKE_TYPE_CLIENT_HELLO As Long = 1 + Dim lValue As Long + Dim lSize As Long + Dim lEnd As Long + Dim baTemp() As Byte + Dim lExtType As Long + Dim lExtSize As Long + Dim lNamePos As Long + Dim lNameType As Long + Dim lNameSize As Long + + lPos = pvReadLong(baInput, lPos, lValue) '--- content type + If lValue <> TLS_CONTENT_TYPE_HANDSHAKE Then + GoTo QH + End If + lPos = pvReadLong(baInput, lPos, lValue, Size:=2) '--- protocol version + lPos = lPos + 2 '--- skip handshake message size + lPos = pvReadLong(baInput, lPos, lValue) '--- handshake type + If lValue <> TLS_HANDSHAKE_TYPE_CLIENT_HELLO Then + GoTo QH + End If + lPos = lPos + 3 '--- skip size of client hello + lPos = lPos + 2 '--- skip Client Version + lPos = lPos + 32 '--- skip Client Random + lPos = pvReadLong(baInput, lPos, lSize, Size:=1) '--- skip Session ID + lPos = lPos + lSize + lPos = pvReadLong(baInput, lPos, lSize, Size:=2) '--- skip Cipher Suites + lPos = lPos + lSize + lPos = pvReadLong(baInput, lPos, lSize, Size:=1) '--- skip Compression Methods + lPos = lPos + lSize + lPos = pvReadLong(baInput, lPos, lSize, Size:=2) '--- size of Extensions + lEnd = lPos + lSize + Do While lPos < lEnd And lPos <= UBound(baInput) + lPos = pvReadLong(baInput, lPos, lExtType, Size:=2) + lPos = pvReadLong(baInput, lPos, lExtSize, Size:=2) + Select Case lExtType + Case 0 '--- Extension -- Server Name + lNamePos = pvReadLong(baInput, lPos, lValue, Size:=2) + Do While lNamePos < lPos + lValue + lNamePos = pvReadLong(baInput, lNamePos, lNameType, Size:=1) + lNamePos = pvReadLong(baInput, lNamePos, lNameSize, Size:=2) + If lNameType = 0 Then '--- FQDN + lNamePos = pvReadArray(baInput, lNamePos, baTemp, lNameSize) + uCtx.SniRequested = StrConv(baTemp, vbUnicode) + Else + lNamePos = lNamePos + lNameSize + End If + Loop + End Select + lPos = lPos + lExtSize + Loop +QH: + pvTlsParseHandshakeClientHello = lPos +End Function + +Private Function pvTlsImportToCertStore(cCerts As Collection, cPrivKey As Collection, sOutKeyName As String, pOutCertContext As Long) As Boolean + Const FUNC_NAME As String = "pvTlsImportToCertStore" + Const IDX_KEYNAME As Long = 1 + Const IDX_PROVNAME As Long = 2 + Const IDX_PROVTYPE As Long = 3 + Const IDX_KEYSPEC As Long = 4 + Dim hCertStore As Long + Dim lIdx As Long + Dim baCert() As Byte + Dim pCertContext As Long + Dim baPrivKey() As Byte + Dim sProvName As String + Dim sKeyName As String + Dim hProv As Long + Dim hKey As Long + Dim lPtr As Long + Dim uPrivKeyInfo As UcsKeyInfo + Dim uPublicKeyInfo As CERT_PUBLIC_KEY_INFO + Dim uProvInfo As CRYPT_KEY_PROV_INFO + Dim uEccBlob As BCRYPT_ECCKEY_BLOB + Dim lBlobSize As Long + Dim hNProv As Long + Dim hNKey As Long + Dim uDesc As ApiSecBufferDesc + Dim uBuffers() As ApiSecBuffer + Dim hResult As Long + Dim sApiSource As String + + '--- load server X.509 certificates to an in-memory certificate store + hCertStore = CertOpenStore(CERT_STORE_PROV_MEMORY, 0, 0, CERT_STORE_CREATE_NEW_FLAG, 0) + If hCertStore = 0 Then + hResult = Err.LastDllError + sApiSource = "CertOpenStore" + GoTo QH + End If + For lIdx = 1 To pvCollectionCount(cCerts) + baCert = cCerts.Item(lIdx) + If CertAddEncodedCertificateToStore(hCertStore, X509_ASN_ENCODING, baCert(0), UBound(baCert) + 1, CERT_STORE_ADD_USE_EXISTING, IIf(lIdx = 1, VarPtr(pCertContext), 0)) = 0 Then + hResult = Err.LastDllError + sApiSource = "CertAddEncodedCertificateToStore" + GoTo QH + End If + Next + If pCertContext <> 0 Then + If cPrivKey.Count > 1 Then + With cPrivKey + sKeyName = .Item(IDX_KEYNAME) + sProvName = .Item(IDX_PROVNAME) + uProvInfo.pwszContainerName = StrPtr(sKeyName) + uProvInfo.pwszProvName = StrPtr(sProvName) + If .Count > IDX_PROVNAME Then + uProvInfo.dwProvType = .Item(IDX_PROVTYPE) + uProvInfo.dwKeySpec = .Item(IDX_KEYSPEC) + End If + End With + ElseIf SearchCollection(cPrivKey, 1, RetVal:=baPrivKey) Then + sKeyName = "VbAsyncSocket" & pvGetRandomString() + If Not pvAsn1DecodePrivateKey(baPrivKey, uPrivKeyInfo) Then + GoTo QH + End If + Call CopyMemory(lPtr, ByVal UnsignedAdd(pCertContext, 12), 4) '--- dereference pCertContext->pCertInfo + lPtr = UnsignedAdd(lPtr, 56) '--- &pCertContext->pCertInfo->SubjectPublicKeyInfo + Call CopyMemory(uPublicKeyInfo, ByVal lPtr, Len(uPublicKeyInfo)) + Select Case pvToStringA(uPublicKeyInfo.Algorithm.pszObjId) + Case szOID_RSA_RSA + uProvInfo.pwszContainerName = StrPtr(sKeyName) + uProvInfo.dwProvType = PROV_RSA_FULL + uProvInfo.dwKeySpec = AT_KEYEXCHANGE + If CryptAcquireContext(hProv, uProvInfo.pwszContainerName, uProvInfo.pwszProvName, uProvInfo.dwProvType, uProvInfo.dwFlags) = 0 Then + If CryptAcquireContext(hProv, uProvInfo.pwszContainerName, uProvInfo.pwszProvName, uProvInfo.dwProvType, uProvInfo.dwFlags Or CRYPT_NEWKEYSET) = 0 Then + hResult = Err.LastDllError + sApiSource = "CryptAcquireContext" + GoTo QH + End If + sOutKeyName = sKeyName + End If + If CryptImportKey(hProv, uPrivKeyInfo.KeyBlob(0), UBound(uPrivKeyInfo.KeyBlob) + 1, 0, 0, hKey) = 0 Then + hResult = Err.LastDllError + sApiSource = "CryptImportKey" + GoTo QH + End If + Case szOID_ECC_PUBLIC_KEY + Select Case uPrivKeyInfo.AlgoObjId + Case szOID_ECC_CURVE_P256 + uEccBlob.dwMagic = BCRYPT_ECDSA_PRIVATE_P256_MAGIC + Case szOID_ECC_CURVE_P384 + uEccBlob.dwMagic = BCRYPT_ECDSA_PRIVATE_P384_MAGIC + Case szOID_ECC_CURVE_P521 + uEccBlob.dwMagic = BCRYPT_ECDSA_PRIVATE_P521_MAGIC + Case Else + ErrRaise vbObjectError, , Replace(ERR_UNKNOWN_ECC_PRIVKEY, "%1", uPrivKeyInfo.AlgoObjId) + End Select + lBlobSize = uPublicKeyInfo.PublicKey.cbData - 1 + uEccBlob.cbKey = UBound(uPrivKeyInfo.KeyBlob) + 1 + Call CopyMemory(uEccBlob.Buffer(0), ByVal UnsignedAdd(uPublicKeyInfo.PublicKey.pbData, 1), lBlobSize) + Call CopyMemory(uEccBlob.Buffer(lBlobSize), uPrivKeyInfo.KeyBlob(0), uEccBlob.cbKey) + lBlobSize = 8 + lBlobSize + uEccBlob.cbKey + '--- import key + uProvInfo.pwszContainerName = StrPtr(sKeyName) + uProvInfo.pwszProvName = StrPtr(MS_KEY_STORAGE_PROVIDER) + hResult = NCryptOpenStorageProvider(hNProv, uProvInfo.pwszProvName, 0) + If hResult < 0 Then + sApiSource = "NCryptOpenStorageProvider" + GoTo QH + End If + pvInitSecDesc uDesc, 1, uBuffers + pvInitSecBuffer uBuffers(0), NCRYPTBUFFER_PKCS_KEY_NAME, StrPtr(sKeyName), LenB(sKeyName) + 2 + hResult = NCryptImportKey(hNProv, 0, StrPtr("ECCPRIVATEBLOB"), uDesc, hNKey, uEccBlob, lBlobSize, NCRYPT_OVERWRITE_KEY_FLAG) + If hResult < 0 Then + sApiSource = "NCryptImportKey" + GoTo QH + End If + Case Else + ErrRaise vbObjectError, , Replace(ERR_UNKNOWN_PUBKEY, "%1", pvToStringA(uPublicKeyInfo.Algorithm.pszObjId)) + End Select + End If + If CertSetCertificateContextProperty(pCertContext, CERT_KEY_PROV_INFO_PROP_ID, 0, uProvInfo) = 0 Then + hResult = Err.LastDllError + sApiSource = "CertSetCertificateContextProperty" + GoTo QH + End If + pOutCertContext = pCertContext + pCertContext = 0 + End If + '--- success + pvTlsImportToCertStore = True +QH: + If hNKey <> 0 Then + Call NCryptFreeObject(hNKey) + End If + If hNProv <> 0 Then + Call NCryptFreeObject(hNProv) + End If + If hKey <> 0 Then + Call CryptDestroyKey(hKey) + End If + If hProv <> 0 Then + Call CryptReleaseContext(hProv, 0) + End If + If pCertContext <> 0 Then + Call CertFreeCertificateContext(pCertContext) + End If + If hCertStore <> 0 Then + Call CertCloseStore(hCertStore, 0) + End If + If LenB(sApiSource) <> 0 Then + ErrRaise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), FUNC_NAME & "." & sApiSource + End If +End Function + +Private Function pvTlsExportFromCertStore(ByVal hCertStore As Long, cCerts As Collection, cStatuses As Collection) As Boolean + Const FUNC_NAME As String = "pvTlsExportFromCertStore" + Dim uCertContext As CERT_CONTEXT + Dim baCert() As Byte + Dim pCertContext As Long + Dim lSize As Long + Dim hResult As Long + Dim sApiSource As String + + '--- export server X.509 certificates from certificate store + Set cCerts = New Collection + Set cStatuses = New Collection + Do + pCertContext = CertEnumCertificatesInStore(hCertStore, pCertContext) + If pCertContext = 0 Then + Exit Do + End If + Call CopyMemory(uCertContext, ByVal pCertContext, Len(uCertContext)) + pvWriteBuffer baCert, 0, uCertContext.pbCertEncoded, uCertContext.cbCertEncoded + pvArrayReallocate baCert, uCertContext.cbCertEncoded, FUNC_NAME & ".baCert" + cCerts.Add baCert + '--- collect OCSP response + If CertGetCertificateContextProperty(pCertContext, CERT_OCSP_RESPONSE_PROP_ID, ByVal 0, lSize) <> 0 And lSize > 0 Then + pvArrayReallocate baCert, lSize, FUNC_NAME & ".baCert" + If CertGetCertificateContextProperty(pCertContext, CERT_OCSP_RESPONSE_PROP_ID, baCert(0), lSize) = 0 Then + hResult = Err.LastDllError + sApiSource = "CertGetCertificateContextProperty" + GoTo QH + End If + cStatuses.Add baCert + End If + Loop + '--- success + pvTlsExportFromCertStore = True +QH: + If LenB(sApiSource) <> 0 Then + ErrRaise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), FUNC_NAME & "." & sApiSource + End If +End Function + +Private Function pvAsn1DecodePrivateKey(baPrivKey() As Byte, uRetVal As UcsKeyInfo) As Boolean + Const FUNC_NAME As String = "pvAsn1DecodePrivateKey" + Dim lPkiPtr As Long + Dim uPrivKey As CRYPT_PRIVATE_KEY_INFO + Dim lKeyPtr As Long + Dim lKeySize As Long + Dim lSize As Long + Dim uEccKeyInfo As CRYPT_ECC_PRIVATE_KEY_INFO + Dim hResult As Long + Dim sApiSource As String + + If CryptDecodeObjectEx(X509_ASN_ENCODING Or PKCS_7_ASN_ENCODING, PKCS_PRIVATE_KEY_INFO, baPrivKey(0), UBound(baPrivKey) + 1, CRYPT_DECODE_ALLOC_FLAG Or CRYPT_DECODE_NOCOPY_FLAG, 0, lPkiPtr, 0) <> 0 Then + Debug.Assert lPkiPtr <> 0 + Call CopyMemory(uPrivKey, ByVal lPkiPtr, Len(uPrivKey)) + If CryptDecodeObjectEx(X509_ASN_ENCODING Or PKCS_7_ASN_ENCODING, PKCS_RSA_PRIVATE_KEY, ByVal uPrivKey.PrivateKey.pbData, uPrivKey.PrivateKey.cbData, CRYPT_DECODE_ALLOC_FLAG Or CRYPT_DECODE_NOCOPY_FLAG, 0, lKeyPtr, lKeySize) = 0 Then + hResult = Err.LastDllError + sApiSource = "CryptDecodeObjectEx(PKCS_RSA_PRIVATE_KEY)" + GoTo QH + End If + uRetVal.AlgoObjId = pvToStringA(uPrivKey.Algorithm.pszObjId) + GoTo DecodeRsa + ElseIf CryptDecodeObjectEx(X509_ASN_ENCODING Or PKCS_7_ASN_ENCODING, PKCS_RSA_PRIVATE_KEY, baPrivKey(0), UBound(baPrivKey) + 1, CRYPT_DECODE_ALLOC_FLAG Or CRYPT_DECODE_NOCOPY_FLAG, 0, lKeyPtr, lKeySize) <> 0 Then + uRetVal.AlgoObjId = szOID_RSA_RSA +DecodeRsa: + pvArrayAllocate uRetVal.KeyBlob, lKeySize, FUNC_NAME & ".uRetVal.KeyBlob" + Debug.Assert lKeyPtr <> 0 + Call CopyMemory(uRetVal.KeyBlob(0), ByVal lKeyPtr, lKeySize) + Debug.Assert UBound(uRetVal.KeyBlob) + 1 >= 16 + Call CopyMemory(uRetVal.BitLen, uRetVal.KeyBlob(12), 4) + ElseIf CryptDecodeObjectEx(X509_ASN_ENCODING Or PKCS_7_ASN_ENCODING, X509_ECC_PRIVATE_KEY, baPrivKey(0), UBound(baPrivKey) + 1, CRYPT_DECODE_ALLOC_FLAG Or CRYPT_DECODE_NOCOPY_FLAG, 0, lKeyPtr, 0) <> 0 Then + Debug.Assert lKeyPtr <> 0 + Call CopyMemory(uEccKeyInfo, ByVal lKeyPtr, Len(uEccKeyInfo)) + uRetVal.AlgoObjId = pvToStringA(uEccKeyInfo.szCurveOid) + pvArrayAllocate uRetVal.KeyBlob, uEccKeyInfo.PrivateKey.cbData, FUNC_NAME & ".uRetVal.KeyBlob" + Debug.Assert uEccKeyInfo.PrivateKey.pbData <> 0 + Call CopyMemory(uRetVal.KeyBlob(0), ByVal uEccKeyInfo.PrivateKey.pbData, uEccKeyInfo.PrivateKey.cbData) + ElseIf Err.LastDllError = ERROR_FILE_NOT_FOUND Then + '--- no X509_ECC_PRIVATE_KEY struct type on NT4 -> decode in a wildly speculative way + Call CopyMemory(lSize, baPrivKey(6), 1) + If 7 + lSize <= UBound(baPrivKey) Then + uRetVal.AlgoObjId = szOID_ECC_CURVE_P256 + pvArrayAllocate uRetVal.KeyBlob, lSize, FUNC_NAME & ".uRetVal.KeyBlob" + Call CopyMemory(uRetVal.KeyBlob(0), baPrivKey(7), lSize) + Else + hResult = ERROR_FILE_NOT_FOUND + sApiSource = "CryptDecodeObjectEx(X509_ECC_PRIVATE_KEY)" + GoTo QH + End If + Else + hResult = Err.LastDllError + sApiSource = "CryptDecodeObjectEx(X509_ECC_PRIVATE_KEY)" + GoTo QH + End If + '--- success + pvAsn1DecodePrivateKey = True +QH: + If lKeyPtr <> 0 Then + Call LocalFree(lKeyPtr) + End If + If lPkiPtr <> 0 Then + Call LocalFree(lPkiPtr) + End If + If LenB(sApiSource) <> 0 Then + ErrRaise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), FUNC_NAME & "." & sApiSource + End If +End Function + +Private Sub pvArrayAllocate(baRetVal() As Byte, ByVal lSize As Long, sFuncName As String) + If lSize > 0 Then + ReDim baRetVal(0 To lSize - 1) As Byte + Else + baRetVal = vbNullString + End If + Debug.Assert RedimStats(MODULE_NAME & "." & sFuncName, lSize) +End Sub + +Private Sub pvArrayReallocate(baArray() As Byte, ByVal lSize As Long, sFuncName As String) + If lSize > 0 Then + ReDim Preserve baArray(0 To lSize - 1) As Byte + Else + baArray = vbNullString + End If + Debug.Assert RedimStats(MODULE_NAME & "." & sFuncName, lSize) +End Sub + +Private Property Get pvArraySize(baArray() As Byte) As Long + Dim lPtr As Long + + '--- peek long at ArrPtr(baArray) + Call CopyMemory(lPtr, ByVal ArrPtr(baArray), 4) + If lPtr <> 0 Then + pvArraySize = UBound(baArray) + 1 + End If +End Property + +Private Function pvWriteReserved(baBuffer() As Byte, ByVal lPos As Long, ByVal lSize As Long) As Long + pvWriteReserved = pvWriteBuffer(baBuffer, lPos, 0, lSize) +End Function + +Private Function pvWriteBuffer(baBuffer() As Byte, ByVal lPos As Long, ByVal lPtr As Long, ByVal lSize As Long) As Long + Const FUNC_NAME As String = "pvWriteBuffer" + Dim lBufPtr As Long + + '--- peek long at ArrPtr(baBuffer) + Call CopyMemory(lBufPtr, ByVal ArrPtr(baBuffer), 4) + If lBufPtr = 0 Then + pvArrayAllocate baBuffer, lPos + lSize, FUNC_NAME & ".baBuffer" + ElseIf UBound(baBuffer) < lPos + lSize - 1 Then + pvArrayReallocate baBuffer, lPos + lSize, FUNC_NAME & ".baRetVal" + End If + If lSize > 0 And lPtr <> 0 Then + Debug.Assert IsBadReadPtr(lPtr, lSize) = 0 + Call CopyMemory(baBuffer(lPos), ByVal lPtr, lSize) + End If + pvWriteBuffer = lPos + lSize +End Function + +Private Function pvReadLong(baBuffer() As Byte, ByVal lPos As Long, lValue As Long, Optional ByVal Size As Long = 1) As Long + Static baTemp(0 To 3) As Byte + + If lPos + Size <= pvArraySize(baBuffer) Then + If Size <= 1 Then + lValue = baBuffer(lPos) + Else + baTemp(Size - 1) = baBuffer(lPos + 0) + baTemp(Size - 2) = baBuffer(lPos + 1) + If Size >= 3 Then baTemp(Size - 3) = baBuffer(lPos + 2) + If Size >= 4 Then baTemp(Size - 4) = baBuffer(lPos + 3) + Call CopyMemory(lValue, baTemp(0), Size) + End If + Else + lValue = 0 + End If + pvReadLong = lPos + Size +End Function + +Private Function pvReadArray(baBuffer() As Byte, ByVal lPos As Long, baDest() As Byte, ByVal lSize As Long) As Long + Const FUNC_NAME As String = "pvReadArray" + + If lSize < 0 Then + lSize = pvArraySize(baBuffer) - lPos + End If + If lSize > 0 Then + pvArrayAllocate baDest, lSize, FUNC_NAME & ".baDest" + If lPos + lSize <= pvArraySize(baBuffer) Then + Call CopyMemory(baDest(0), baBuffer(lPos), lSize) + ElseIf lPos < pvArraySize(baBuffer) Then + Call CopyMemory(baDest(0), baBuffer(lPos), pvArraySize(baBuffer) - lPos) + End If + Else + Erase baDest + End If + pvReadArray = lPos + lSize +End Function + +'= Schannel buffers helpers ============================================== + +Private Sub pvInitSecDesc(uDesc As ApiSecBufferDesc, ByVal lCount As Long, uBuffers() As ApiSecBuffer) + ReDim uBuffers(0 To lCount - 1) + With uDesc + .ulVersion = SECBUFFER_VERSION + .cBuffers = lCount + .pBuffers = VarPtr(uBuffers(0)) + End With +End Sub + +Private Sub pvInitSecBuffer(uBuffer As ApiSecBuffer, ByVal lType As Long, Optional ByVal lPtr As Long, Optional ByVal lSize As Long) + With uBuffer + .BufferType = lType + .pvBuffer = lPtr + .cbBuffer = lSize + End With +End Sub + +Private Function pvToStringA(ByVal lPtr As Long) As String + If lPtr <> 0 Then + pvToStringA = String$(lstrlenA(lPtr), 0) + Call CopyMemory(ByVal pvToStringA, ByVal lPtr, Len(pvToStringA)) + End If +End Function + +#If ImplUseDebugLog Then +Private Function pvToStringW(ByVal lPtr As Long) As String + If lPtr <> 0 Then + pvToStringW = String$(lstrlenW(lPtr), 0) + Call CopyMemory(ByVal StrPtr(pvToStringW), ByVal lPtr, LenB(pvToStringW)) + End If +End Function +#End If + +Private Function pvCollectionCount(oCol As Collection) As Long + If Not oCol Is Nothing Then + pvCollectionCount = oCol.Count + End If +End Function + +Private Function pvGetRandomString(Optional Size As Long = 16, Optional Delimiter As String) As String + Dim baBuffer() As Byte + Dim aText() As String + Dim lIdx As Long + + ReDim baBuffer(0 To Size - 1) As Byte + Call RtlGenRandom(baBuffer(0), Size) + ReDim aText(0 To UBound(baBuffer)) As String + For lIdx = 0 To UBound(baBuffer) + aText(lIdx) = Right$("0" & Hex$(baBuffer(lIdx)), 2) + Next + pvGetRandomString = LCase$(Join(aText, Delimiter)) +End Function + +#If Not ImplUseShared Then +Public Function RedimStats(sFuncName As String, ByVal lSize As Long) As Boolean + #If sFuncName And lSize Then + #End If + RedimStats = True +End Function + +Public Sub RemoveCollection(ByVal oCol As Collection, Index As Variant) + If Not oCol Is Nothing Then + pvCallCollectionRemove oCol, Index + End If +End Sub + +Public Function SearchCollection(ByVal oCol As Collection, Index As Variant, Optional RetVal As Variant) As Boolean + Dim vItem As Variant + + If oCol Is Nothing Then + GoTo QH + ElseIf pvCallCollectionItem(oCol, Index, vItem) < 0 Then + GoTo QH + End If + If IsObject(vItem) Then + Set RetVal = vItem + Else + RetVal = vItem + End If + '--- success + SearchCollection = True +QH: +End Function + +Private Function pvCallCollectionItem(ByVal oCol As Collection, Index As Variant, Optional RetVal As Variant) As Long + Const IDX_COLLECTION_ITEM As Long = 7 + + pvPatchMethodTrampoline AddressOf mdTlsNative.pvCallCollectionItem, IDX_COLLECTION_ITEM + pvCallCollectionItem = pvCallCollectionItem(oCol, Index, RetVal) +End Function + +Private Function pvCallCollectionRemove(ByVal oCol As Collection, Index As Variant) As Long + Const IDX_COLLECTION_REMOVE As Long = 10 + + pvPatchMethodTrampoline AddressOf mdTlsNative.pvCallCollectionRemove, IDX_COLLECTION_REMOVE + pvCallCollectionRemove = pvCallCollectionRemove(oCol, Index) +End Function + +Private Function pvPatchMethodTrampoline(ByVal Pfn As Long, ByVal lMethodIdx As Long) As Boolean + Dim bInIDE As Boolean + + Debug.Assert pvSetTrue(bInIDE) + If bInIDE Then + '--- note: IDE is not large-address aware + Call CopyMemory(Pfn, ByVal Pfn + &H16, 4) + Else + Call VirtualProtect(Pfn, 12, PAGE_EXECUTE_READWRITE, 0) + End If + ' 0: 8B 44 24 04 mov eax,dword ptr [esp+4] + ' 4: 8B 00 mov eax,dword ptr [eax] + ' 6: FF A0 00 00 00 00 jmp dword ptr [eax+lMethodIdx*4] + Call CopyMemory(ByVal Pfn, -684575231150992.4725@, 8) + Call CopyMemory(ByVal (Pfn Xor &H80000000) + 8 Xor &H80000000, lMethodIdx * 4, 4) + '--- success + pvPatchMethodTrampoline = True +End Function + +Private Function pvSetTrue(bValue As Boolean) As Boolean + #If TWINBASIC = 0 Then + bValue = True + #End If + pvSetTrue = True +End Function + +Public Function FromBase64Array(sText As String) As Byte() + Const CRYPT_STRING_BASE64 As Long = 1 + Dim lSize As Long + Dim baOutput() As Byte + + On Error GoTo EH + lSize = Len(sText) + 1 + ReDim baOutput(0 To lSize - 1) As Byte + If CryptStringToBinary(StrPtr(sText), Len(sText), CRYPT_STRING_BASE64, VarPtr(baOutput(0)), lSize) <> 0 Then + If lSize > 0 Then + ReDim Preserve baOutput(0 To lSize - 1) As Byte + FromBase64Array = baOutput + Else + FromBase64Array = vbNullString + End If + Exit Function + End If +EH: + With CreateObject("MSXML2.DOMDocument").createElement("dummy") + .DataType = "bin.base64" + .Text = sText + If IsArray(.NodeTypedValue) Then + FromBase64Array = .NodeTypedValue + Else + FromBase64Array = vbNullString + End If + End With +End Function + +Private Function UnsignedAdd(ByVal lUnsignedPtr As Long, ByVal lSignedOffset As Long) As Long + '--- note: safely add *signed* offset to *unsigned* ptr for *unsigned* retval w/o overflow in LARGEADDRESSAWARE processes + UnsignedAdd = ((lUnsignedPtr Xor &H80000000) + lSignedOffset) Xor &H80000000 +End Function + +Private Function SplitOrReindex(Expression As String, Delimiter As String) As Variant + Dim vResult As Variant + Dim vTemp As Variant + Dim lIdx As Long + Dim lSize As Long + + vResult = Split(Expression, Delimiter) + '--- check if reindex needed + If IsNumeric(vResult(0)) Then + vTemp = vResult + For lIdx = 0 To UBound(vTemp) Step 2 + If lSize < vTemp(lIdx) Then + lSize = vTemp(lIdx) + End If + Next + ReDim vResult(0 To lSize) As Variant + Debug.Assert RedimStats(MODULE_NAME & ".SplitOrReindex.vResult", 0) + For lIdx = 0 To UBound(vTemp) Step 2 + vResult(vTemp(lIdx)) = vTemp(lIdx + 1) + Next + SplitOrReindex = vResult + End If +End Function + +Private Property Get RealOsVersion(Optional BuildNo As Long) As UcsOsVersionEnum + Static lVersion As Long + Static lBuildNo As Long + Dim baBuffer() As Byte + Dim lPtr As Long + Dim lSize As Long + Dim aVer(0 To 9) As Integer + + If lVersion = 0 Then + ReDim baBuffer(0 To 8192) As Byte + Call GetFileVersionInfo(StrPtr("kernel32.dll"), 0, UBound(baBuffer), baBuffer(0)) + Call VerQueryValue(baBuffer(0), StrPtr("\"), lPtr, lSize) + Call CopyMemory(aVer(0), ByVal lPtr, 20) + lVersion = aVer(9) * 100 + aVer(8) + lBuildNo = aVer(7) + End If + RealOsVersion = lVersion + BuildNo = lBuildNo +End Property + +Private Function GetSystemMessage(ByVal lLastDllError As Long) As String + Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000 + Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200 + Dim lSize As Long + + GetSystemMessage = String$(2000, 0) + lSize = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, lLastDllError, 0, StrPtr(GetSystemMessage), Len(GetSystemMessage), 0) + GetSystemMessage = Left$(GetSystemMessage, lSize) +End Function +#End If ' Not ImplUseShared + +Public Function TlsDesignDumpArray(baData() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As String + If Size < 0 Then + Size = UBound(baData) + 1 - Pos + End If + If Size > 0 Then + TlsDesignDumpArray = TlsDesignDumpMemory(VarPtr(baData(Pos)), Size) + End If +End Function + +Public Function TlsDesignDumpMemory(ByVal lPtr As Long, ByVal lSize As Long) As String + Dim lIdx As Long + Dim sHex As String + Dim sChar As String + Dim lValue As Long + Dim aResult() As String + + ReDim aResult(0 To (lSize + 15) \ 16) As String + Debug.Assert RedimStats("TlsDesignDumpMemory.aResult", UBound(aResult) + 1) + For lIdx = 0 To ((lSize + 15) \ 16) * 16 + If lIdx < lSize Then + If IsBadReadPtr(lPtr, 1) = 0 Then + Call CopyMemory(lValue, ByVal lPtr, 1) + sHex = sHex & Right$("0" & Hex$(lValue), 2) & " " + If lValue >= 32 Then + sChar = sChar & Chr$(lValue) + Else + sChar = sChar & "." + End If + Else + sHex = sHex & "?? " + sChar = sChar & "." + End If + Else + sHex = sHex & " " + End If + If ((lIdx + 1) Mod 4) = 0 Then + sHex = sHex & " " + End If + If ((lIdx + 1) Mod 16) = 0 Then + aResult(lIdx \ 16) = Right$("000" & Hex$(lIdx - 15), 4) & " - " & sHex & sChar + sHex = vbNullString + sChar = vbNullString + End If + lPtr = (lPtr Xor &H80000000) + 1 Xor &H80000000 + Next + TlsDesignDumpMemory = Join(aResult, vbCrLf) +End Function + +#If ImplCaptureTraffic <> 0 Then +Public Function TlsConcatCollection(oCol As Collection, Optional Separator As String = vbCrLf) As String + Dim lSize As Long + Dim vElem As Variant + + For Each vElem In oCol + lSize = lSize + Len(vElem) + Len(Separator) + Next + If lSize > 0 Then + TlsConcatCollection = String$(lSize - Len(Separator), 0) + lSize = 1 + For Each vElem In oCol + If lSize <= Len(TlsConcatCollection) Then + Mid$(TlsConcatCollection, lSize, Len(vElem) + Len(Separator)) = vElem & Separator + End If + lSize = lSize + Len(vElem) + Len(Separator) + Next + End If +End Function +#End If ' ImplCaptureTraffic + diff --git a/samples/Visual Basic 6.0/modLoader.bas b/samples/Visual Basic 6.0/modLoader.bas new file mode 100644 index 0000000000..77b0b40dd9 --- /dev/null +++ b/samples/Visual Basic 6.0/modLoader.bas @@ -0,0 +1,1128 @@ +Attribute VB_Name = "modLoader" +'[modLoader.bas] + +' // modLoader.bas - EXE (VB6) loader from memory +' // Krivous Anatoly Anatolevich (The trick), 2016 + +Option Explicit + +Public Enum MessagesID + MID_ERRORLOADINGCONST = 100 ' // Errors + MID_ERRORREADINGPROJECT = 101 ' + MID_ERRORCOPYINGFILE = 102 ' + MID_ERRORWIN32 = 103 ' + MID_ERROREXECUTELINE = 104 ' + MID_ERRORSTARTUPEXE = 105 ' + Project = 200 ' // Project resource ID + API_LIB_KERNEL32 = 300 ' // Library names + API_LIB_NTDLL = 350 ' + API_LIB_USER32 = 400 ' + MSG_LOADER_ERROR = 500 +End Enum + +Private Enum ERROR_MESSAGES + EM_NO_ERRORS + EM_UNABLE_TO_GET_NT_HEADERS + EM_INVALID_DATA_DIRECTORY + EM_UNABLE_TO_ALLOCATE_MEMORY + EM_UNABLE_TO_PROTECT_MEMORY + EM_LOADLIBRARY_FAILED + EM_PROCESS_INFORMATION_NOT_FOUND + EM_END +End Enum + +Private Type IMAGE_DOS_HEADER + e_magic_e_cblp As Long + e_cp As Integer + e_crlc As Integer + e_cparhdr As Integer + e_minalloc As Integer + e_maxalloc As Integer + e_ss As Integer + e_sp As Integer + e_csum As Integer + e_ip As Integer + e_cs As Integer + e_lfarlc As Integer + e_ovno As Integer + e_res(0 To 3) As Integer + e_oemid As Integer + e_oeminfo As Integer + e_res2(0 To 9) As Integer + e_lfanew As Long +End Type +Private Type IMAGE_DATA_DIRECTORY + VirtualAddress As Long + Size As Long +End Type +Private Type IMAGE_OPTIONAL_HEADER + Magic As Integer + MajorLinkerVersion As Byte + MinorLinkerVersion As Byte + SizeOfCode As Long + SizeOfInitializedData As Long + SizeOfUnitializedData As Long + AddressOfEntryPoint As Long + BaseOfCode As Long + BaseOfData As Long + ImageBase As Long + SectionAlignment As Long + FileAlignment As Long + MajorOperatingSystemVersion As Integer + MinorOperatingSystemVersion As Integer + MajorImageVersion As Integer + MinorImageVersion As Integer + MajorSubsystemVersion As Integer + MinorSubsystemVersion As Integer + W32VersionValue As Long + SizeOfImage As Long + SizeOfHeaders As Long + CheckSum As Long + SubSystem As Integer + DllCharacteristics As Integer + SizeOfStackReserve As Long + SizeOfStackCommit As Long + SizeOfHeapReserve As Long + SizeOfHeapCommit As Long + LoaderFlags As Long + NumberOfRvaAndSizes As Long + DataDirectory(15) As IMAGE_DATA_DIRECTORY +End Type +Private Type IMAGE_FILE_HEADER + Machine As Integer + NumberOfSections As Integer + TimeDateStamp As Long + PointerToSymbolTable As Long + NumberOfSymbols As Long + SizeOfOptionalHeader As Integer + Characteristics As Integer +End Type +Private Type IMAGE_NT_HEADERS + Signature As Long + FileHeader As IMAGE_FILE_HEADER + OptionalHeader As IMAGE_OPTIONAL_HEADER +End Type +Private Type IMAGE_SECTION_HEADER + SectionName(1) As Long + VirtualSize As Long + VirtualAddress As Long + SizeOfRawData As Long + PointerToRawData As Long + PointerToRelocations As Long + PointerToLinenumbers As Long + NumberOfRelocations As Integer + NumberOfLinenumbers As Integer + Characteristics As Long +End Type +Private Type IMAGE_IMPORT_DESCRIPTOR + Characteristics As Long + TimeDateStamp As Long + ForwarderChain As Long + pName As Long + FirstThunk As Long +End Type + +Private Type IMAGE_BASE_RELOCATION + VirtualAddress As Long + SizeOfBlock As Long +End Type + +Private Type UNICODE_STRING + Length As Integer + MaxLength As Integer + lpBuffer As Long +End Type +Private Type PROCESS_BASIC_INFORMATION + ExitStatus As Long + PebBaseAddress As Long + AffinityMask As Long + BasePriority As Long + UniqueProcessId As Long + InheritedFromUniqueProcessId As Long +End Type +Public Type LIST_ENTRY + Flink As Long + Blink As Long +End Type +Public Type PEB_LDR_DATA + Length As Long + Initialized As Long + SsHandle As Long + InLoadOrderModuleList As LIST_ENTRY + InMemoryOrderModuleList As LIST_ENTRY + InInitializationOrderModuleList As LIST_ENTRY +End Type +Public Type LDR_MODULE + InLoadOrderModuleList As LIST_ENTRY + InMemoryOrderModuleList As LIST_ENTRY + InInitOrderModuleList As LIST_ENTRY + BaseAddress As Long + EntryPoint As Long + SizeOfImage As Long + FullDllName As UNICODE_STRING + BaseDllName As UNICODE_STRING + Flags As Long + LoadCount As Integer + TlsIndex As Integer + HashTableEntry As LIST_ENTRY + TimeDateStamp As Long +End Type + +Private Type PEB + NotUsed As Long + Mutant As Long + ImageBaseAddress As Long + LoaderData As Long ' // Pointer to PEB_LDR_DATA + ProcessParameters As Long + ' // .... +End Type + +Private Const IMAGE_FILE_MACHINE_I386 As Long = &H14C +Private Const IMAGE_DOS_SIGNATURE As Long = &H5A4D +Private Const IMAGE_NT_SIGNATURE As Long = &H4550& +Private Const IMAGE_NT_OPTIONAL_HDR32_MAGIC As Long = &H10B& +Private Const IMAGE_FILE_RELOCS_STRIPPED As Long = &H1 +Private Const IMAGE_FILE_EXECUTABLE_IMAGE As Long = &H2 +Private Const IMAGE_FILE_32BIT_MACHINE As Long = &H100 +Private Const IMAGE_DIRECTORY_ENTRY_IMPORT As Long = 1 +Private Const IMAGE_DIRECTORY_ENTRY_BASERELOC As Long = 5 +Private Const IMAGE_SCN_MEM_EXECUTE As Long = &H20000000 +Private Const IMAGE_SCN_MEM_READ As Long = &H40000000 +Private Const IMAGE_SCN_MEM_WRITE As Long = &H80000000 +Private Const IMAGE_REL_BASED_HIGHLOW As Long = 3 +Private Const HEAP_NO_SERIALIZE As Long = &H1 +Private Const STATUS_SUCCESS As Long = 0 +Private Const STATUS_INFO_LENGTH_MISMATCH As Long = &HC0000004 +Private Const ProcessBasicInformation As Long = 0 + +'Private Declare Function SysAllocStringByteLen Lib "oleaut32.dll" (ByVal pszStrPtr As Long, ByVal length As Long) As Long + + +' // Obtain string from resource (it should be less or equal MAX_PATH) +Public Function ResGetString( _ + ByVal id As MessagesID) As Long + + Dim hInstance As Long + + ResGetString = llib.SysAllocStringLen(0, MAX_PATH) + + If ResGetString Then + + hInstance = llib.GetModuleHandle(ByVal 0&) + + If llib.LoadString(hInstance, id, ResGetString, MAX_PATH) = 0 Then llib.SysFreeString ResGetString: ResGetString = 0: Exit Function + If llib.SysReAllocString(ResGetString, ResGetString) = 0 Then llib.SysFreeString ResGetString: ResGetString = 0: Exit Function + + End If + + 'Dbg "ID: " & ID & ", Result: " & GetString + +End Function + +' // Run exe from project in memory +Public Function RunExeFromMemory(pFileInMemory As Long, dwSize As Long) As Boolean + Dim pFileData As Long + + ' // Alloc memory within top memory addresses + pFileData = llib.VirtualAlloc(ByVal 0&, dwSize, MEM_TOP_DOWN Or MEM_COMMIT, PAGE_READWRITE) + If pFileData = 0 Then Exit Function + + ' // Copy raw exe file to this memory + llib.CopyMemory ByVal pFileData, ByVal pFileInMemory, dwSize + + ' // Free decompressed project data + 'HeapFree GetProcessHeap(), HEAP_NO_SERIALIZE, pProjectData + 'pProjectData = 0 + + Dbg "pFileData = " & pFileData + + ' // Run exe from memory + RunExeFromMemory = RunExeFromMemoryEx(pFileData, True) + + ' ---------------------------------------------------- + ' // An error occurs + ' // Clean memory + + llib.VirtualFree ByVal pFileData, 0, MEM_RELEASE + +End Function + +' // Run EXE file by memory address +Private Function RunExeFromMemoryEx( _ + ByVal pExeData As Long, _ + ByVal IgnoreError As Boolean) As Boolean + Dim Length As Long: Dim pCode As Long + Dim pszMsg As Long: Dim pMsgTable As Long + Dim Index As Long: Dim pCurMsg As Long + + ' // Get size of shellcode + Length = GetAddr(AddressOf ENDSHELLLOADER) - GetAddr(AddressOf BEGINSHELLLOADER) + + ' // Alloc memory within top addresses + pCode = llib.VirtualAlloc(ByVal 0&, Length, MEM_TOP_DOWN Or MEM_COMMIT, PAGE_EXECUTE_READWRITE) + + ' // Copy shellcode to allocated memory + llib.CopyMemory ByVal pCode, ByVal GetAddr(AddressOf BEGINSHELLLOADER), Length + + Dbg "pCode = " & pCode + + Dbg "InitShellLoader" + + ' // Initialization of shellcode + If Not InitShellLoader(pCode) Then GoTo CleanUp + + Dbg "Splice" + + ' // Splice CallLoader function in order to call shellcode + Splice AddressOf CallLoader, pCode + GetAddr(AddressOf LoadExeFromMemory) - GetAddr(AddressOf BEGINSHELLLOADER) + + ' // Check ignore errors + If Not IgnoreError Then + + Dbg "VirtualAlloc" + + ' // Alloc memory for messages table + pMsgTable = llib.VirtualAlloc(ByVal 0&, 1024, MEM_TOP_DOWN Or MEM_COMMIT, PAGE_READWRITE) + If pMsgTable = 0 Then GoTo CleanUp + + ' // Skip pointers + pCurMsg = pMsgTable + EM_END * 4 + + For Index = 0 To EM_END - 1 + + Dbg "GetString" & Index + + ' // Load message string + pszMsg = ResGetString(MSG_LOADER_ERROR + Index) + If pszMsg = 0 Then GoTo CleanUp + + Length = llib.SysStringLen(pszMsg) + + llib.lstrcpyn ByVal pCurMsg, ByVal pszMsg, Length + 1 + + ' // Store pointer + llib.CopyMemory ByVal pMsgTable + Index * 4, pCurMsg, Len(pCurMsg) + + ' // Next message offset + pCurMsg = pCurMsg + (Length + 1) * 2 + + llib.SysFreeString pszMsg + + Next + + End If + + Dbg "CallLoader: pExeData = " & CStr(pExeData) + + ' // Call shellcode + CallLoader pExeData, pCode, pMsgTable + +CleanUp: + + If pMsgTable Then + llib.VirtualFree ByVal pMsgTable, 0, MEM_RELEASE + End If + + If pCode Then + llib.VirtualFree ByVal pCode, 0, MEM_RELEASE + End If + +End Function + +' // Shellcode initialization +Private Function InitShellLoader( _ + ByVal pShellCode As Long) As Boolean + Dim hLib As Long: Dim sName As Long + Dim sFunc As Long: Dim lpAddr As Long + Dim libIdx As Long: Dim fncIdx As Long + Dim libName As MessagesID ': Dim fncName As MessagesID + Dim fncSpc As Long: Dim splAddr As Long + + ' // +----------------------------------------------------------------+ + ' // | Fixing of API addresses | + ' // +----------------------------------------------------------------+ + ' // | In order to call api function from shellcode i use splicing of | + ' // | our VB functions and redirect call to corresponding api. | + ' // | I did same in the code that injects to other process. | + ' // +----------------------------------------------------------------+ + + splAddr = GetAddr(AddressOf tVirtualAlloc) - GetAddr(AddressOf BEGINSHELLLOADER) + pShellCode + + ' // Get size in bytes between stub functions + fncSpc = GetAddr(AddressOf tVirtualProtect) - GetAddr(AddressOf tVirtualAlloc) + + ' // Use 3 library: kernel32, ntdll user32 + For libIdx = 0 To 2 + + ' // Get number of imported functions depending on library + Select Case libIdx + Case 0: libName = API_LIB_KERNEL32: fncIdx = 13 + Case 1: libName = API_LIB_NTDLL: fncIdx = 1 + Case 2: libName = API_LIB_USER32: fncIdx = 1 + End Select + + ' // Get library name from resources + sName = ResGetString(libName): If sName = 0 Then Exit Function + + Dbg "Get module handle" + + ' // Get module handle + hLib = llib.GetModuleHandle(ByVal sName): If hLib = 0 Then Exit Function + llib.SysFreeString sName + + ' // Go thru functions + Do While fncIdx + + libName = libName + 1 + ' // Get function name + sName = ResGetString(libName): If sName = 0 Then Exit Function + + ' // Because of GetProcAddress works with ANSI string translate it to ANSI + sFunc = ToAnsi(sName): If sFunc = 0 Then Exit Function + + ' // Get function address + lpAddr = llib.GetProcAddress(hLib, sFunc) + llib.SysFreeString sName: llib.SysFreeString sFunc + + Dbg "Addr of function: " & libName & " is " & lpAddr + + ' // Error + If lpAddr = 0 Then Exit Function + + ' // Splice stub + Splice splAddr, lpAddr + + ' // Next stub + splAddr = splAddr + fncSpc + fncIdx = fncIdx - 1 + + Loop + + Next + + Dbg "Modify CallByPointer" + + ' // Modify CallByPointer + lpAddr = GetAddr(AddressOf CallByPointer) - GetAddr(AddressOf BEGINSHELLLOADER) + pShellCode + + ' // pop eax - 0x58 + ' // pop ecx - 0x59 + ' // push eax - 0x50 + ' // jmp ecx - 0xFFE1 + + llib.CopyMemory ByVal lpAddr, &HFF505958, 4 + llib.CopyMemory ByVal lpAddr + 4, &HE1, 1 + + ' // Success + InitShellLoader = True + +End Function + +' // Splice function +Private Sub Splice( _ + ByVal Func As Long, _ + ByVal NewAddr As Long) + ' // Set memory permissions + llib.VirtualProtect ByVal Func, 5, PAGE_EXECUTE_READWRITE, 0 + llib.CopyMemory ByVal Func, &HE9, 1 ' // JMP + llib.CopyMemory ByVal Func + 1, NewAddr - Func - 5, 4 ' // Relative address +End Sub + +' // Unicode->Ansi +Private Function ToAnsi( _ + ByVal s As Long) As Long + Dim Size As Long + + ' // Get string size + Size = llib.SysStringLen(s) + + ' // Alloc memory for ansi string + ToAnsi = llib.SysAllocStringByteLen(0, Size) + + ' // Translate + llib.WideCharToMultiByte CP_ACP, 0, s, Size, ToAnsi, Size, 0, 0 + +End Function + +' // Stub for calling shellcode +Private Function CallLoader( _ + ByVal Pointer As Long, _ + ByVal MyBaseAddress As Long, _ + ByVal ErrMsgTable As Long) As Boolean + CallLoader = 1 +End Function + +' // Begin of shellcode +Private Function BEGINSHELLLOADER() As Integer: End Function + +' // Parse exe in memory +Private Function LoadExeFromMemory( _ + ByVal pRawData As Long, _ + ByVal pMyBaseAddress As Long, _ + ByVal pErrMsgTable As Long) As Boolean + Dim NtHdr As IMAGE_NT_HEADERS + Dim pBase As Long + 'Dim Index As Long + Dim iError As ERROR_MESSAGES + 'Dim pszMsg As Long + + ' // Get IMAGE_NT_HEADERS + If GetImageNtHeaders(pRawData, NtHdr) = 0 Then + iError = EM_UNABLE_TO_GET_NT_HEADERS + EndProcess pErrMsgTable, iError + Exit Function + End If + + ' // Check flags + If NtHdr.FileHeader.Machine <> IMAGE_FILE_MACHINE_I386 Or _ + (NtHdr.FileHeader.Characteristics And IMAGE_FILE_EXECUTABLE_IMAGE) = 0 Or _ + (NtHdr.FileHeader.Characteristics And IMAGE_FILE_32BIT_MACHINE) = 0 Then Exit Function + + ' // Release main EXE memory. After that main exe is unloaded from memory. + 'llib.ZwUnmapViewOfSection llib.GetCurrentProcess(), llib.GetModuleHandle(ByVal 0&) + + ' // Reserve memory for EXE + iError = ReserveMemory(pRawData, pBase) + If iError Then + EndProcess pErrMsgTable, iError + Exit Function + End If + + ' // Place data + iError = ProcessSectionsAndHeaders(pRawData, pBase) + If iError Then + EndProcess pErrMsgTable, iError + Exit Function + End If + + ' // Update new base address + iError = UpdateNewBaseAddress(pBase) + If iError Then + EndProcess pErrMsgTable, iError + Exit Function + End If + + ' // Import table processing + iError = ProcessImportTable(pBase) + If iError Then + EndProcess pErrMsgTable, iError + Exit Function + End If + + ' // Relocations processing + iError = ProcessRelocations(pBase) + If iError Then + EndProcess pErrMsgTable, iError + Exit Function + End If + + ' // Set the memory attributes + iError = SetMemoryPermissions(pBase) + If iError Then + EndProcess pErrMsgTable, iError + Exit Function + End If + + ' // Release error message table + If pErrMsgTable Then + tVirtualFree pErrMsgTable, 0, MEM_RELEASE + End If + + ' // Call entry point + CallByPointer NtHdr.OptionalHeader.AddressOfEntryPoint + pBase + + ' // End process + EndProcess + +End Function + +' // Update new base address +Private Function UpdateNewBaseAddress( _ + ByVal pBase As Long) As ERROR_MESSAGES + Dim pPBI As Long: Dim PBIlen As Long + Dim PBI As PROCESS_BASIC_INFORMATION: Dim cPEB As PEB + Dim ntstat As Long + Dim ldrData As PEB_LDR_DATA + Dim ldrMod As LDR_MODULE + + ntstat = tNtQueryInformationProcess(tGetCurrentProcess(), ProcessBasicInformation, IntPtr(PBI.ExitStatus), Len(PBI), PBIlen) + + Do While ntstat = STATUS_INFO_LENGTH_MISMATCH + + PBIlen = PBIlen * 2 + + If pPBI Then + tHeapFree tGetProcessHeap(), HEAP_NO_SERIALIZE, pPBI + End If + + pPBI = tHeapAlloc(tGetProcessHeap(), HEAP_NO_SERIALIZE, PBIlen) + ntstat = tNtQueryInformationProcess(tGetCurrentProcess(), ProcessBasicInformation, pPBI, PBIlen, PBIlen) + + Loop + + If ntstat <> STATUS_SUCCESS Then + UpdateNewBaseAddress = EM_PROCESS_INFORMATION_NOT_FOUND + GoTo CleanUp + End If + + If pPBI Then + ' // Copy to PROCESS_BASIC_INFORMATION + tCopyMemory IntPtr(PBI.ExitStatus), pPBI, Len(PBI) + End If + + ' // Get PEB + tCopyMemory IntPtr(cPEB.NotUsed), PBI.PebBaseAddress, Len(cPEB) + + ' // Modify image base + cPEB.ImageBaseAddress = pBase + + ' // Restore PEB + tCopyMemory PBI.PebBaseAddress, IntPtr(cPEB.NotUsed), Len(cPEB) + + ' // Fix base address in PEB_LDR_DATA list + tCopyMemory IntPtr(ldrData.Length), cPEB.LoaderData, Len(ldrData) + + ' // Get first element + tCopyMemory IntPtr(ldrMod.InLoadOrderModuleList.Flink), ldrData.InLoadOrderModuleList.Flink, Len(ldrMod) + + ' // Fix base + ldrMod.BaseAddress = pBase + + ' // Restore + tCopyMemory ldrData.InLoadOrderModuleList.Flink, IntPtr(ldrMod.InLoadOrderModuleList.Flink), Len(ldrMod) + +CleanUp: + + ' // Free memory + If pPBI Then + tHeapFree tGetProcessHeap(), HEAP_NO_SERIALIZE, pPBI + End If + +End Function + +' // Set memory permissions +Private Function SetMemoryPermissions( _ + ByVal pBase As Long) As ERROR_MESSAGES + Dim iSec As Long: Dim pNtHdr As Long + Dim NtHdr As IMAGE_NT_HEADERS: Dim sec As IMAGE_SECTION_HEADER + Dim Attr As MEMPROTECT: Dim pSec As Long + Dim ret As Long + + pNtHdr = GetImageNtHeaders(pBase, NtHdr) + If pNtHdr = 0 Then + SetMemoryPermissions = EM_UNABLE_TO_GET_NT_HEADERS + Exit Function + End If + + ' // Get address of first section header + pSec = pNtHdr + 4 + Len(NtHdr.FileHeader) + NtHdr.FileHeader.SizeOfOptionalHeader + + ' // Go thru section headers + For iSec = 0 To NtHdr.FileHeader.NumberOfSections - 1 + + ' // Copy section descriptor + tCopyMemory IntPtr(sec.SectionName(0)), pSec, Len(sec) + + ' // Get type + If sec.Characteristics And IMAGE_SCN_MEM_EXECUTE Then + If sec.Characteristics And IMAGE_SCN_MEM_READ Then + If sec.Characteristics And IMAGE_SCN_MEM_WRITE Then + Attr = PAGE_EXECUTE_READWRITE + Else + Attr = PAGE_EXECUTE_READ + End If + Else + If sec.Characteristics And IMAGE_SCN_MEM_WRITE Then + Attr = PAGE_EXECUTE_WRITECOPY + Else + Attr = PAGE_EXECUTE + End If + End If + Else + If sec.Characteristics And IMAGE_SCN_MEM_READ Then + If sec.Characteristics And IMAGE_SCN_MEM_WRITE Then + Attr = PAGE_READWRITE + Else + Attr = PAGE_READONLY + End If + Else + If sec.Characteristics And IMAGE_SCN_MEM_WRITE Then + Attr = PAGE_WRITECOPY + Else + Attr = PAGE_NOACCESS + End If + End If + End If + + ' // Set memory permissions + If tVirtualProtect(sec.VirtualAddress + pBase, sec.VirtualSize, Attr, IntPtr(ret)) = 0 Then + SetMemoryPermissions = EM_UNABLE_TO_PROTECT_MEMORY + Exit Function + End If + + ' // Next section + pSec = pSec + Len(sec) + + Next + +End Function + +' // Process import table +Private Function ProcessImportTable( _ + ByVal pBase As Long) As ERROR_MESSAGES + Dim NtHdr As IMAGE_NT_HEADERS: Dim datDirectory As IMAGE_DATA_DIRECTORY + Dim dsc As IMAGE_IMPORT_DESCRIPTOR: Dim hLib As Long + Dim thnk As Long: Dim Addr As Long + Dim fnc As Long: Dim pData As Long + + If GetImageNtHeaders(pBase, NtHdr) = 0 Then + ProcessImportTable = EM_UNABLE_TO_GET_NT_HEADERS + Exit Function + End If + + ' // Import table processing + If NtHdr.OptionalHeader.NumberOfRvaAndSizes > 1 Then + + If GetDataDirectory(pBase, IMAGE_DIRECTORY_ENTRY_IMPORT, datDirectory) = 0 Then + ProcessImportTable = EM_INVALID_DATA_DIRECTORY + Exit Function + End If + + ' // If import table exists + If datDirectory.Size > 0 And datDirectory.VirtualAddress > 0 Then + + ' // Copy import descriptor + pData = datDirectory.VirtualAddress + pBase + tCopyMemory IntPtr(dsc.Characteristics), pData, Len(dsc) + + ' // Go thru all descriptors + Do Until dsc.Characteristics = 0 And _ + dsc.FirstThunk = 0 And _ + dsc.ForwarderChain = 0 And _ + dsc.pName = 0 And _ + dsc.TimeDateStamp = 0 + + If dsc.pName > 0 Then + + ' // Load needed library + hLib = tLoadLibrary(dsc.pName + pBase) + + If hLib = 0 Then + ProcessImportTable = EM_LOADLIBRARY_FAILED + Exit Function + End If + + If dsc.Characteristics Then fnc = dsc.Characteristics + pBase Else fnc = dsc.FirstThunk + pBase + + ' // Go to names table + tCopyMemory IntPtr(thnk), fnc, 4 + + ' // Go thru names table + Do While thnk + + ' // Check import type + If thnk < 0 Then + ' // By ordinal + Addr = tGetProcAddress(hLib, thnk And &HFFFF&) + Else + ' // By name + Addr = tGetProcAddress(hLib, thnk + 2 + pBase) + End If + + ' // Next function + fnc = fnc + 4 + tCopyMemory IntPtr(thnk), fnc, 4 + tCopyMemory dsc.FirstThunk + pBase, IntPtr(Addr), 4 + dsc.FirstThunk = dsc.FirstThunk + 4 + + Loop + + End If + + ' // Next descriptor + pData = pData + Len(dsc) + tCopyMemory IntPtr(dsc.Characteristics), pData, Len(dsc) + + Loop + + End If + + End If + +End Function + +' // Process relocations +Private Function ProcessRelocations( _ + ByVal pBase As Long) As ERROR_MESSAGES + Dim NtHdr As IMAGE_NT_HEADERS: Dim datDirectory As IMAGE_DATA_DIRECTORY + Dim relBase As IMAGE_BASE_RELOCATION: Dim entriesCount As Long + Dim relType As Long: Dim dwAddress As Long + Dim dwOrig As Long: Dim pRelBase As Long + Dim delta As Long: Dim pData As Long + + ' // Check if module has not been loaded to image base value + If GetImageNtHeaders(pBase, NtHdr) = 0 Then + ProcessRelocations = EM_UNABLE_TO_GET_NT_HEADERS + Exit Function + End If + + delta = pBase - NtHdr.OptionalHeader.ImageBase + + ' // Process relocations + If delta Then + + ' // Get address of relocation table + If GetDataDirectory(pBase, IMAGE_DIRECTORY_ENTRY_BASERELOC, datDirectory) = 0 Then + ProcessRelocations = EM_INVALID_DATA_DIRECTORY + Exit Function + End If + + If datDirectory.Size > 0 And datDirectory.VirtualAddress > 0 Then + + ' // Copy relocation base + pRelBase = datDirectory.VirtualAddress + pBase + tCopyMemory IntPtr(relBase.VirtualAddress), pRelBase, Len(relBase) + + Do While relBase.VirtualAddress + + ' // To first reloc chunk + pData = pRelBase + Len(relBase) + + entriesCount = (relBase.SizeOfBlock - Len(relBase)) \ 2 + + Do While entriesCount > 0 + + tCopyMemory IntPtr(relType), pData, 2 + + Select Case (relType \ 4096) And &HF + Case IMAGE_REL_BASED_HIGHLOW + + ' // Calculate address + dwAddress = relBase.VirtualAddress + (relType And &HFFF&) + pBase + + ' // Get original address + tCopyMemory IntPtr(dwOrig), dwAddress, Len(dwOrig) + + ' // Add delta + dwOrig = dwOrig + delta + + ' // Save + tCopyMemory dwAddress, IntPtr(dwOrig), Len(dwOrig) + + End Select + + pData = pData + 2 + entriesCount = entriesCount - 1 + + Loop + + ' // Next relocation base + pRelBase = pRelBase + relBase.SizeOfBlock + tCopyMemory IntPtr(relBase.VirtualAddress), pRelBase, Len(relBase) + + Loop + + End If + + End If + +End Function + +' // Reserve memory for EXE +Private Function ReserveMemory( _ + ByVal pRawExeData As Long, _ + ByRef pBase As Long) As ERROR_MESSAGES + Dim NtHdr As IMAGE_NT_HEADERS + Dim pLocBase As Long + + If GetImageNtHeaders(pRawExeData, NtHdr) = 0 Then + ReserveMemory = EM_UNABLE_TO_GET_NT_HEADERS + Exit Function + End If + + ' // Reserve memory for EXE + pLocBase = tVirtualAlloc(ByVal NtHdr.OptionalHeader.ImageBase, _ + NtHdr.OptionalHeader.SizeOfImage, _ + MEM_RESERVE, PAGE_EXECUTE_READWRITE) + If pLocBase = 0 Then + + ' // If relocation information not found error + If NtHdr.FileHeader.Characteristics And IMAGE_FILE_RELOCS_STRIPPED Then + + ReserveMemory = EM_UNABLE_TO_ALLOCATE_MEMORY + Exit Function + + Else + ' // Reserve memory in other region + pLocBase = tVirtualAlloc(ByVal 0&, NtHdr.OptionalHeader.SizeOfImage, _ + MEM_RESERVE, PAGE_EXECUTE_READWRITE) + + If pLocBase = 0 Then + + ReserveMemory = EM_UNABLE_TO_ALLOCATE_MEMORY + Exit Function + + End If + + End If + + End If + + pBase = pLocBase + +End Function + +' // Allocate memory for sections and copy them data to there +Private Function ProcessSectionsAndHeaders( _ + ByVal pRawExeData As Long, _ + ByVal pBase As Long) As ERROR_MESSAGES + + Dim iSec As Long + Dim pNtHdr As Long + Dim NtHdr As IMAGE_NT_HEADERS + Dim sec As IMAGE_SECTION_HEADER + Dim lpSec As Long + Dim pData As Long + + pNtHdr = GetImageNtHeaders(pRawExeData, NtHdr) + If pNtHdr = 0 Then + ProcessSectionsAndHeaders = EM_UNABLE_TO_GET_NT_HEADERS + Exit Function + End If + + ' // Alloc memory for headers + pData = tVirtualAlloc(ByVal pBase, NtHdr.OptionalHeader.SizeOfHeaders, MEM_COMMIT, PAGE_READWRITE) + If pData = 0 Then + ProcessSectionsAndHeaders = EM_UNABLE_TO_ALLOCATE_MEMORY + Exit Function + End If + + ' // Copy headers + tCopyMemory pData, pRawExeData, NtHdr.OptionalHeader.SizeOfHeaders + + ' // Get address of beginnig of sections headers + pData = pNtHdr + Len(NtHdr.Signature) + Len(NtHdr.FileHeader) + NtHdr.FileHeader.SizeOfOptionalHeader + + ' // Go thru sections + For iSec = 0 To NtHdr.FileHeader.NumberOfSections - 1 + + ' // Copy section descriptor + tCopyMemory IntPtr(sec.SectionName(0)), pData, Len(sec) + + ' // Alloc memory for section + lpSec = tVirtualAlloc(sec.VirtualAddress + pBase, sec.VirtualSize, MEM_COMMIT, PAGE_READWRITE) + If lpSec = 0 Then + ProcessSectionsAndHeaders = EM_UNABLE_TO_ALLOCATE_MEMORY + Exit Function + End If + + ' If there is initialized data + If sec.SizeOfRawData Then + + ' // Take into account file alignment + If sec.SizeOfRawData > sec.VirtualSize Then sec.SizeOfRawData = sec.VirtualSize + + ' // Copy initialized data to section + tCopyMemory lpSec, pRawExeData + sec.PointerToRawData, sec.SizeOfRawData + lpSec = lpSec + sec.SizeOfRawData + sec.VirtualSize = sec.VirtualSize - sec.SizeOfRawData + + End If + + ' // Fill remain part with zero + tFillMemory lpSec, sec.VirtualSize, 0 + + ' // Next section + pData = pData + Len(sec) + + Next + +End Function + +' // Get NT headers and return its address +Private Function GetImageNtHeaders( _ + ByVal pBase As Long, _ + ByRef pNtHeaders As IMAGE_NT_HEADERS) As Long + Dim dosHdr As IMAGE_DOS_HEADER + Dim NtHdr As IMAGE_NT_HEADERS + Dim pNtHdr As Long + + ' // Get DOS header + tCopyMemory IntPtr(dosHdr.e_magic_e_cblp), pBase, Len(dosHdr) + + ' // Check MZ signature and alignment + If (dosHdr.e_magic_e_cblp And &HFFFF&) <> IMAGE_DOS_SIGNATURE Or _ + (dosHdr.e_lfanew And &H3) <> 0 Then + Exit Function + End If + + ' // Get pointer to NT headers + pNtHdr = pBase + dosHdr.e_lfanew + + ' // Get NT headers + tCopyMemory IntPtr(NtHdr.Signature), pNtHdr, Len(NtHdr) + + ' // Check NT signature + If (NtHdr.Signature <> IMAGE_NT_SIGNATURE) Or _ + NtHdr.OptionalHeader.Magic <> IMAGE_NT_OPTIONAL_HDR32_MAGIC Or _ + NtHdr.FileHeader.SizeOfOptionalHeader <> Len(NtHdr.OptionalHeader) Then + Exit Function + End If + + tCopyMemory IntPtr(pNtHeaders.Signature), IntPtr(NtHdr.Signature), Len(NtHdr) + GetImageNtHeaders = pNtHdr + +End Function + +' // Get data directory and return its data +Private Function GetDataDirectory( _ + ByVal pBase As Long, _ + ByVal lIndex As Long, _ + ByRef pDirectory As IMAGE_DATA_DIRECTORY) As Long + Dim NtHdr As IMAGE_NT_HEADERS + Dim pNtHdr As Long + + + ' // Get NT headers + pNtHdr = GetImageNtHeaders(pBase, NtHdr) + If pNtHdr = 0 Then + Exit Function + End If + + ' // Check directory index + If lIndex < 0 Or lIndex >= NtHdr.OptionalHeader.NumberOfRvaAndSizes Then + Exit Function + End If + + ' // Copy directory data + tCopyMemory IntPtr(pDirectory.VirtualAddress), IntPtr(NtHdr.OptionalHeader.DataDirectory(lIndex).VirtualAddress), Len(pDirectory) + GetDataDirectory = pNtHdr + Len(NtHdr.Signature) + Len(NtHdr.FileHeader) + &H60 + lIndex * Len(pDirectory) + +End Function + +' // Error message +Private Sub EndProcess( _ + Optional ByVal pMsgTable As Long = 0, _ + Optional ByVal lMsgNumber As Long = 0) + + Dim pszMsg As Long + + If pMsgTable Then + ' // Get message offset + tCopyMemory IntPtr(pszMsg), pMsgTable + lMsgNumber * 4, 4 + ' // Show message box + tMessageBox 0, pszMsg, 0, MB_ICONERROR + + End If + + tExitProcess 0 + +End Sub + +' // Call function by pointer +Private Sub CallByPointer( _ + ByVal pFuncAddress As Long) + +End Sub + +' // Stubs for API calling +Private Function tVirtualAlloc( _ + ByVal lpAddress As Long, _ + ByVal dwSize As Long, _ + ByVal flAllocationType As ALLOCATIONTYPE, _ + ByVal flProtect As MEMPROTECT) As Long + tVirtualAlloc = 2 +End Function +Private Function tVirtualProtect( _ + ByVal lpAddress As Long, _ + ByVal dwSize As Long, _ + ByVal flNewProtect As MEMPROTECT, _ + ByVal flOldProtect As MEMPROTECT) As Long + tVirtualProtect = 3 +End Function +Private Function tVirtualFree( _ + ByVal lpAddress As Long, _ + ByVal dwSize As Long, _ + ByVal dwFreeType As FREETYPE) As Long + tVirtualFree = 4 +End Function +Private Function tCopyMemory( _ + ByVal lpDst As Long, _ + ByVal lpSrc As Long, _ + ByVal Size As Long) As Long + tCopyMemory = 5 +End Function +Private Function tFillMemory( _ + ByVal lpDst As Long, _ + ByVal dwSize As Long, _ + ByVal Char As Byte) As Long + tFillMemory = 6 +End Function +Private Function tlstrcpyn( _ + ByRef lpString1 As Long, _ + ByRef lpString2 As Long, _ + ByVal iMaxLength As Long) As Long + tlstrcpyn = 7 +End Function +Private Function tLoadLibrary( _ + ByVal lpFileName As Long) As Long + tLoadLibrary = 8 +End Function +Private Function tGetProcAddress( _ + ByVal hModule As Long, _ + ByVal lpProcName As Long) As Long + tGetProcAddress = 9 +End Function +Private Function tExitProcess( _ + ByVal uExitCode As Long) As Long + tExitProcess = 10 +End Function +Private Function tHeapAlloc( _ + ByVal hHeap As Long, _ + ByVal dwFlags As Long, _ + ByVal dwBytes As Long) As Long + tHeapAlloc = 11 +End Function +Private Function tHeapFree( _ + ByVal hHeap As Long, _ + ByVal dwFlags As Long, _ + ByVal lpMem As Long) As Long + tHeapFree = 12 +End Function +Private Function tGetProcessHeap() As Long + tGetProcessHeap = 13 +End Function +Private Function tGetCurrentProcess() As Long + tGetCurrentProcess = 14 +End Function +Private Function tNtQueryInformationProcess( _ + ByVal ProcessHandle As Long, _ + ByVal InformationClass As Long, _ + ByVal ProcessInformation As Long, _ + ByVal ProcessInformationLength As Long, _ + ByRef ReturnLength As Long) As Long + tNtQueryInformationProcess = 16 +End Function +Private Function tMessageBox( _ + ByVal hwnd As Long, _ + ByVal lpText As Long, _ + ByVal lpCaption As Long, _ + ByVal uType As MESSAGEBOXCONSTANTS) As MESSAGEBOXRETURN + tMessageBox = 17 +End Function + +' // VarPtr analog +Private Function IntPtr( _ + ByRef Value As Long) As Long + IntPtr = tlstrcpyn(Value, 0, 0) +End Function + +' // Get AddressOf +Private Function GetAddr( _ + ByVal Addr As Long) As Long + GetAddr = Addr: Exit Function +End Function + +' // End of shellcode +Private Function ENDSHELLLOADER() As Long: End Function + From 067c499d07dd8d645e35e3eeb1cd8354562f05db Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sat, 18 Mar 2023 00:30:40 -0400 Subject: [PATCH 04/28] Adjust order + fix heuristic --- lib/linguist/heuristics.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 36068c6c25..703c22f492 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -844,15 +844,15 @@ named_patterns: - '^\s*package\s+[^\W\d]\w*(?:::\w+)*\s*(?:[;{]|\sv?\d)' - '[\s$][^\W\d]\w*(?::\w+)*->[a-zA-Z_\[({]' raku: '^\s*(?:use\s+v6\b|\bmodule\b|\b(?:my\s+)?class\b)' + vb-class: '^\s*VERSION\s+[0-9]\.[0-9]\s+CLASS' + vb-form: '^\s*VERSION\s+[0-9]\.[0-9]{2}' + vb-module: '^\s*Attribute\s+VB_Name\s+=\s+' vba: - '^\s*#If\s+(:?VBA7|Win64)' - - '^\s*Declare\s+PtrSafe\s+(?:Sub|Function)' + - '^\s*(?:Public|Private)?\s+Declare\s+PtrSafe\s+(?:Sub|Function)' - '^\s*Dim\s+[0-9a-zA-Z_]*\s+As\s+(?:LongPtr|LongLong)' - '\sVBA.(?:vb|[A-Z])' - '\s(?:Excel.[a-zA-Z]|ThisWorkbook|ActiveWorkbook|ActiveSheet|ActiveChart|ActiveCell|WorksheetFunction)' - '\s(?:Word.[a-zA-Z]|ActiveDocument)' - '\s(?:PowerPoint.[a-zA-Z]|ActivePresentation)' - - '\s(?:Outlook.[a-zA-Z]|ActiveExplorer|ActiveInspector)' - vb-class: '^\s*VERSION\s+[0-9]\.[0-9]\s+CLASS' - vb-form: '^\s*VERSION\s+[0-9]\.[0-9]{2}' - vb-module: '^\s*Attribute\s+VB_Name\s+=\s+' + - '\s(?:Outlook.[a-zA-Z]|ActiveExplorer|ActiveInspector)' \ No newline at end of file From f2549fb15a82b515a1fb60043b775bf6e6ee7027 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Mon, 20 Mar 2023 21:35:06 -0400 Subject: [PATCH 05/28] Edit heuristics --- lib/linguist/heuristics.yml | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 703c22f492..e87bfb8ef0 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -848,11 +848,17 @@ named_patterns: vb-form: '^\s*VERSION\s+[0-9]\.[0-9]{2}' vb-module: '^\s*Attribute\s+VB_Name\s+=\s+' vba: - - '^\s*#If\s+(:?VBA7|Win64)' - - '^\s*(?:Public|Private)?\s+Declare\s+PtrSafe\s+(?:Sub|Function)' - - '^\s*Dim\s+[0-9a-zA-Z_]*\s+As\s+(?:LongPtr|LongLong)' - - '\sVBA.(?:vb|[A-Z])' - - '\s(?:Excel.[a-zA-Z]|ThisWorkbook|ActiveWorkbook|ActiveSheet|ActiveChart|ActiveCell|WorksheetFunction)' - - '\s(?:Word.[a-zA-Z]|ActiveDocument)' - - '\s(?:PowerPoint.[a-zA-Z]|ActivePresentation)' - - '\s(?:Outlook.[a-zA-Z]|ActiveExplorer|ActiveInspector)' \ No newline at end of file + # VBA7 new 64-bit features (https://learn.microsoft.com/en-us/office/vba/language/concepts/getting-started/64-bit-visual-basic-for-applications-overview) + - '^\s*(?:Public|Private)?\s+Declare\s+PtrSafe\s+(?:Sub|Function)\b' + - '^\s*#If\s(:?VBA7|Win64)\b' + - '^\s*Dim\s[0-9a-zA-Z_]*\sAs\s(?:LongPtr|LongLong)\b' + # Top module declarations unique to VBA + - '^\s*Option\sPrivate\sModule\b' + - '^\s*Option\sCompare\sDatabase\b' + # Libraries/Objects preloaded with VBA + - '(?:\s|\()(?:VBA|Access|Excel|Outlook|PowerPoint|Visio|Word)\.\w+' # VBA Libraries invocation + - '\b(?:ThisDrawing|AcadObject)\b' # AutoCAD + - '\b(?:ThisWorkbook|ActiveWorkbook|ActiveSheet|ActiveChart|ActiveCell|Range\("[0-9a-zA-Z:]*"\)|WorksheetFunction)\b' # Excel + - '\b(?:ActiveExplorer|ActiveInspector)\b' # Outlook + - '\b(?:ActiveWindow\.Presentation|ActivePresentation)\b' # PowerPoint + - '\b(?:ActiveDocument|Selection\.Find|Selection\.Paragraphs)\b' # Word From 45eb74171c176020d1d6f13cc7763e507b6efb6d Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 2 Apr 2023 14:44:18 -0400 Subject: [PATCH 06/28] Seperate Range Object to seperate line --- lib/linguist/heuristics.yml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index e87bfb8ef0..704baeabfe 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -857,8 +857,9 @@ named_patterns: - '^\s*Option\sCompare\sDatabase\b' # Libraries/Objects preloaded with VBA - '(?:\s|\()(?:VBA|Access|Excel|Outlook|PowerPoint|Visio|Word)\.\w+' # VBA Libraries invocation - - '\b(?:ThisDrawing|AcadObject)\b' # AutoCAD - - '\b(?:ThisWorkbook|ActiveWorkbook|ActiveSheet|ActiveChart|ActiveCell|Range\("[0-9a-zA-Z:]*"\)|WorksheetFunction)\b' # Excel - - '\b(?:ActiveExplorer|ActiveInspector)\b' # Outlook - - '\b(?:ActiveWindow\.Presentation|ActivePresentation)\b' # PowerPoint - - '\b(?:ActiveDocument|Selection\.Find|Selection\.Paragraphs)\b' # Word + - '\b(?:ThisDrawing|AcadObject)\b' # AutoCAD Objects + - '\b(?:ThisWorkbook|ActiveWorkbook|ActiveSheet|ActiveChart|ActiveCell|WorksheetFunction)\b' # Excel Objects + - '\bRange\("(?:[a-zA-Z]+\d+|[a-zA-Z]+\d+:[a-zA-Z]+\d+|[a-zA-Z]+:[a-zA-Z]+|\d+:\d+)"\)' # Excel range + - '\b(?:ActiveExplorer|ActiveInspector)\b' # Outlook Objects + - '\b(?:ActiveWindow\.Presentation|ActivePresentation)\b' # PowerPoint Objects + - '\b(?:ActiveDocument|Selection\.Find|Selection\.Paragraphs)\b' # Word Objects From 77f439b795c6c728a3c66908bd9aad9a86d19d0c Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 2 Apr 2023 22:55:29 -0400 Subject: [PATCH 07/28] Replace FreeBasic Sample --- samples/FreeBasic/Plasma Generation.bas | 125 --------- samples/FreeBasic/ir.bas | 326 ++++++++++++++++++++++++ 2 files changed, 326 insertions(+), 125 deletions(-) delete mode 100644 samples/FreeBasic/Plasma Generation.bas create mode 100644 samples/FreeBasic/ir.bas diff --git a/samples/FreeBasic/Plasma Generation.bas b/samples/FreeBasic/Plasma Generation.bas deleted file mode 100644 index 0273ae94a4..0000000000 --- a/samples/FreeBasic/Plasma Generation.bas +++ /dev/null @@ -1,125 +0,0 @@ -'+++++ IMPORTANT +++++ -' - The only reason this -' code doesnt generate -' plasma instantaneously -' is because it draws -' each iteration instead -' of the final product. -' It looks cooler this -' way : ) - - -Dim Shared As Integer Grad(0 To 255) - - -'+=============================================================+ -Sub Rainbow() - Dim As Integer i, b, badd, g, gadd, r, radd, rx, gx, bx - rx = 2 - gx = -2 - bx = -2 - b=Int(Rnd * 256):badd= bx - g=Int(Rnd * 256):gadd= gx - r=Int(Rnd * 256):radd= rx - For i = 0 To 255 - b += badd - g += gadd - r += radd - If b < 0 Then badd = -bx: b = 0 - If b > 255 Then badd = bx: b = 255 - If g < 0 Then gadd = -gx: g = 0 - If g > 255 Then gadd = gx: g = 255 - If r > 255 Then radd = -rx: r = 255 - If r < 0 Then radd = rx: r = 0 - Grad(i) = RGB(r,g,b) - Next i -End Sub -'+==============+MAKE THIS WHATEVER YOU WANT : )+==============+ - - -Rainbow - - -Sub GenPlasma(byval w as integer, byval h as integer, _ - byval crnr1 as integer, byval crnr2 as integer, _ - byval crnr3 as integer, byval crnr4 as integer, _ - byval rough as integer, byval iter as integer, _ - byval prs as double) - Dim as double prex, prey, d1, d2, d3, d4, hr, fv, Image(0 to w,0 to h) - hr = rough * 2 - prex = w / 2: prey = h / 2 - Image(0,0)=crnr1 - Image(w,0)=crnr2: d1 = (crnr1+crnr2) / 2: Image(prex,0)=d1 - Image(w,h)=crnr3: d2 = (crnr2+crnr3) / 2: Image(w,prey)=d2 - Image(0,h)=crnr4: d3 = (crnr3+crnr4) / 2: Image(prex,h)=d3 - d4 = (crnr4+crnr1) / 2: Image(0,prey)=d4 - fv = ((d1+d2+d3+d4) / 4) + (Int(rnd * hr) - rough) - If fv>255 Then - fv=255 - ELseif fv<0 Then - fv=0 - Endif - Image(Cint(prex),Cint(prey))=fv - Dim as double divisor, mdivx, mdivy, i, xs, ys, c1,c2,c3,c4, cx,cy, dx,dy - mdivx = w / 2: mdivy = h / 2 - w -= 1: h -= 1 - For i = 1 to iter - For ys = 0 To h Step mdivy - For xs = 0 To w Step mdivx - prex = mdivx / 2: prey = mdivy / 2 - cx = xs + mdivx : cy = ys + mdivy - c1 = Image(Cint(xs),Cint(ys)): c2 = Image(Cint(cx),Cint(ys)) - c3 = Image(Cint(cx),Cint(cy)): c4 = Image(Cint(xs),Cint(cy)) - d1 = (c1+c2) / 2: d2 = (c2+c3) / 2 - d3 = (c3+c4) / 2: d4 = (c4+c1) / 2 - dx = xs + prex: dy = ys + prey - Image(Cint(dx),Cint(ys))=d1 - Image(Cint(cx),Cint(dy))=d2 - Image(Cint(dx),Cint(cy))=d3 - Image(Cint(xs),Cint(dy))=d4 - fv = ((d1+d2+d3+d4) / 4) + (Int(rnd * hr) - rough) - If fv>255 Then - fv=255 - ELseif fv<0 Then - fv=0 - Endif - Image(Cint(dx),Cint(dy))=fv - Next xs - Next ys - mdivx = mdivx / 2 - mdivy = mdivy / 2 - hr = rough - rough = rough * prs - ScreenLock - For ys = 0 To h Step mdivy - For xs = 0 To w Step mdivx - Line (xs,ys)-(xs+mdivx,ys+mdivy), Grad(Image(xs,ys)), BF - Next xs - Next ys - ScreenUnlock - Next i -End Sub - - - -'test code - -#include "fbgfx.bi" -Using FB -#define ri(x) (Int(Rnd*x)) -ScreenRes 1280,1024,32,,1 -Randomize Timer - -Do - Rainbow - GenPlasma 1280,1024,ri(256),ri(256),ri(256),ri(256),300,8,Rnd - Locate 1,1: Print "Press the spacebar for another pattern. Press ESC to quit" - Do - If MultiKey(&h01) Then - End - ElseIf MultiKey(SC_SPACE) Then - Goto ExitDo - EndIf - Loop - ExitDo: -Loop diff --git a/samples/FreeBasic/ir.bas b/samples/FreeBasic/ir.bas new file mode 100644 index 0000000000..d084f74332 --- /dev/null +++ b/samples/FreeBasic/ir.bas @@ -0,0 +1,326 @@ +'' intermediate representation - core module +'' +'' chng: dec/2006 written [v1ctor] + +#include once "fb.bi" +#include once "fbint.bi" +#include once "ir.bi" +#include once "emit.bi" +#include once "ir-private.bi" + +dim shared ir as IRCTX + +sub irInit( ) + select case( env.clopt.backend ) + case FB_BACKEND_GCC + ir.vtbl = irhlc_vtbl + case FB_BACKEND_LLVM + ir.vtbl = irllvm_vtbl + case FB_BACKEND_GAS64 + ir.vtbl = irgas64_vtbl + case else + assert( env.clopt.backend = FB_BACKEND_GAS ) + ir.vtbl = irtac_vtbl + end select + + '' reset ir.options becasue irSetOption() will merge (OR) values + ir.options = 0 + + ir.vtbl.init( ) +end sub + +sub irEnd( ) + ir.vtbl.end( ) + + ir.options = 0 + + #if __FB_DEBUG__ + '' debugging - reset the vtable - shouldn't matter in production + '' because ir.vtbl calls should never be called outside irInit()/irEnd() + dim null_vtbl as IR_VTBL + ir.vtbl = null_vtbl + #endif + +end sub + +dim shared irhl as IRHLCONTEXT + +sub irhlInit( ) + flistInit( @irhl.vregs, IR_INITVREGNODES, sizeof( IRVREG ) ) + listInit( @irhl.callargs, 32, sizeof( IRCALLARG ), LIST_FLAGS_NOCLEAR ) +end sub + +sub irhlEnd( ) + listEnd( @irhl.callargs ) + flistEnd( @irhl.vregs ) +end sub + +sub irhlEmitProcBegin( ) + irhl.regcount = 0 +end sub + +sub irhlEmitProcEnd( ) + flistReset( @irhl.vregs ) +end sub + +sub irhlEmitPushArg _ + ( _ + byval param as FBSYMBOL ptr, _ + byval vr as IRVREG ptr, _ + byval udtlen as longint, _ + byval level as integer, _ + byval lreg as IRVREG ptr _ _ + ) + + '' Remember for later, so during _emitCall[Ptr] we can emit the whole + '' call in one go + dim as IRCALLARG ptr arg = listNewNode( @irhl.callargs ) + arg->param = param + arg->vr = vr + arg->level = level + + '' ignore udtlen, it's only used by ir-tac.bas:_emitPushArg() + '' ignore lreg, it's only used by ir-tac.bas:_emitPushArg() + +end sub + +function irhlNewVreg _ + ( _ + byval dtype as integer, _ + byval subtype as FBSYMBOL ptr, _ + byval vtype as integer _ + ) as IRVREG ptr + + dim as IRVREG ptr v = any + + v = flistNewItem( @irhl.vregs ) + + v->typ = vtype + v->dtype = dtype + v->subtype = subtype + if( vtype = IR_VREGTYPE_REG ) then + v->reg = irhl.regcount + irhl.regcount += 1 + else + v->reg = INVALID + end if + v->regFamily = 0 + v->vector = 0 + v->sym = NULL + v->ofs = 0 + v->mult = 0 + v->vidx = NULL + v->vaux = NULL + + function = v +end function + +function irhlAllocVreg _ + ( _ + byval dtype as integer, _ + byval subtype as FBSYMBOL ptr _ + ) as IRVREG ptr + function = irhlNewVreg( dtype, subtype, IR_VREGTYPE_REG ) +end function + +function irhlAllocVrImm _ + ( _ + byval dtype as integer, _ + byval subtype as FBSYMBOL ptr, _ + byval value as longint _ + ) as IRVREG ptr + + dim as IRVREG ptr vr = any + + vr = irhlNewVreg( dtype, subtype, IR_VREGTYPE_IMM ) + vr->value.i = value + + function = vr +end function + +function irhlAllocVrImmF _ + ( _ + byval dtype as integer, _ + byval subtype as FBSYMBOL ptr, _ + byval value as double _ + ) as IRVREG ptr + + dim as IRVREG ptr vr = any + + vr = irhlNewVreg( dtype, subtype, IR_VREGTYPE_IMM ) + vr->value.f = value + + function = vr +end function + +function irhlAllocVrVar _ + ( _ + byval dtype as integer, _ + byval subtype as FBSYMBOL ptr, _ + byval symbol as FBSYMBOL ptr, _ + byval ofs as longint _ + ) as IRVREG ptr + + dim as IRVREG ptr vr = irhlNewVreg( dtype, subtype, IR_VREGTYPE_VAR ) + + vr->sym = symbol + vr->ofs = ofs + + function = vr +end function + +function irhlAllocVrIdx _ + ( _ + byval dtype as integer, _ + byval subtype as FBSYMBOL ptr, _ + byval symbol as FBSYMBOL ptr, _ + byval ofs as longint, _ + byval mult as integer, _ + byval vidx as IRVREG ptr _ + ) as IRVREG ptr + + dim as IRVREG ptr vr = irhlNewVreg( dtype, subtype, IR_VREGTYPE_IDX ) + + vr->sym = symbol + vr->ofs = ofs + vr->vidx = vidx + + function = vr +end function + +function irhlAllocVrPtr _ + ( _ + byval dtype as integer, _ + byval subtype as FBSYMBOL ptr, _ + byval ofs as longint, _ + byval vidx as IRVREG ptr _ + ) as IRVREG ptr + + dim as IRVREG ptr vr = irhlNewVreg( dtype, subtype, IR_VREGTYPE_PTR ) + + vr->ofs = ofs + vr->vidx = vidx + + function = vr +end function + +function irhlAllocVrOfs _ + ( _ + byval dtype as integer, _ + byval subtype as FBSYMBOL ptr, _ + byval symbol as FBSYMBOL ptr, _ + byval ofs as longint _ + ) as IRVREG ptr + + dim as IRVREG ptr vr = irhlNewVreg( dtype, subtype, IR_VREGTYPE_OFS ) + + vr->sym = symbol + vr->ofs = ofs + + function = vr +end function + +'' DATA descriptor arrays must be emitted based on the order indicated by the +'' FBSYMBOL.var_.data.prev linked list, not in the symtb order. +sub irForEachDataStmt( byval callback as sub( byval as FBSYMBOL ptr ) ) + var sym = astGetLastDataStmtSymbol( ) + while( sym ) + callback( sym ) + sym = sym->var_.data.prev + wend +end sub + +sub irhlFlushStaticInitializer( byval sym as FBSYMBOL ptr ) + astLoadStaticInitializer( symbGetTypeIniTree( sym ), sym ) + symbSetTypeIniTree( sym, NULL ) +end sub + +#if __FB_DEBUG__ +function vregDumpToStr( byval v as IRVREG ptr ) as string + dim as string s + dim as string regname + + if( v = NULL ) then + return "" + end if + + static as zstring ptr vregtypes(IR_VREGTYPE_IMM to IR_VREGTYPE_OFS) = _ + { _ + @"imm", @"var", @"idx", @"ptr", @"reg", @"ofs" _ + } + + #if 0 + s += "[" + hex( v, 8 ) + "] " + #endif + + s += *vregtypes(v->typ) + + select case( v->typ ) + case IR_VREGTYPE_IMM + s += " " + if( typeGetClass( v->dtype ) = FB_DATACLASS_FPOINT ) then + s += str( v->value.f ) + else + s += str( v->value.i ) + end if + + case IR_VREGTYPE_REG + if( env.clopt.backend = FB_BACKEND_GAS ) then + regname = emitDumpRegName( v->dtype, v->reg ) + if( len( regname ) > 0 ) then + s += " " + ucase( regname ) + else + s += " " + str( v->reg ) + end if + else + ''s += " reg=" + s += " " + str( v->reg ) + end if + end select + + if( v->sym ) then + s += " " + *symbGetName( v->sym ) + end if + + if( v->typ <> IR_VREGTYPE_REG ) then + if( v->ofs ) then + if( (env.clopt.backend = FB_BACKEND_GAS) and (v->sym <> NULL) ) then + s += " [" + *symbGetMangledName( v->sym ) + if( v->ofs >= 0 ) then + s += "+" + end if + s += str( v->ofs ) + s += "]" + else + s += " ofs=" + str( v->ofs ) + end if + end if + if( v->mult ) then + s += " mult=" + str( v->mult ) + end if + end if + + s += " " + typeDumpToStr( v->dtype, v->subtype ) + + if( v->typ <> IR_VREGTYPE_REG ) then + if( v->vidx ) then + s += " vidx=<" + vregDumpToStr( v->vidx ) + ">" + end if + end if + + '' If it's a longint vreg, show vaux + '' ASM backend: uses vaux, so always show it + '' C/LLVM backends: don't use vaux, so only show it if it's set + if( ISLONGINT( v->dtype ) and _ + ((env.clopt.backend = FB_BACKEND_GAS) or (v->vaux <> NULL)) ) then + s += " vaux=<" + vregDumpToStr( v->vaux ) + ">" + end if + + function = s +end function + +sub vregDump( byval v as IRVREG ptr ) + print vregDumpToStr( v ) +end sub + +#endif From adc5fe025cbbae2e4c002a84acf00fc988d72642 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 2 Apr 2023 23:13:56 -0400 Subject: [PATCH 08/28] Simplify BASIC heuristic Co-authored-by: John Gardner --- lib/linguist/heuristics.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 704baeabfe..c2076e7a8c 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -91,7 +91,7 @@ disambiguations: - language: FreeBasic pattern: '^[ \t]*#(?:define|endif|endmacro|ifn?def|if|include|lang|macro)\s' - language: BASIC - pattern: '\A\s*\d+' + pattern: '\A\s*\d' - language: VBA and: - named_pattern: vb-module From ae5eb41c0ff21eb156178209cf92a06b10f3d4a8 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 2 Apr 2023 23:25:11 -0400 Subject: [PATCH 09/28] Combine the 2 top declarations Co-authored-by: John Gardner --- lib/linguist/heuristics.yml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index c2076e7a8c..2256af675a 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -853,8 +853,7 @@ named_patterns: - '^\s*#If\s(:?VBA7|Win64)\b' - '^\s*Dim\s[0-9a-zA-Z_]*\sAs\s(?:LongPtr|LongLong)\b' # Top module declarations unique to VBA - - '^\s*Option\sPrivate\sModule\b' - - '^\s*Option\sCompare\sDatabase\b' + - '^\s*Option\s+(?:Private\s+Module|Compare\s+Database)\b' # Libraries/Objects preloaded with VBA - '(?:\s|\()(?:VBA|Access|Excel|Outlook|PowerPoint|Visio|Word)\.\w+' # VBA Libraries invocation - '\b(?:ThisDrawing|AcadObject)\b' # AutoCAD Objects From 0516c53acac7853c932b7384e1b6110394e631fc Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 2 Apr 2023 23:28:45 -0400 Subject: [PATCH 10/28] Simplify heuristic Co-authored-by: John Gardner --- lib/linguist/heuristics.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 2256af675a..a8db9b1d68 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -851,7 +851,7 @@ named_patterns: # VBA7 new 64-bit features (https://learn.microsoft.com/en-us/office/vba/language/concepts/getting-started/64-bit-visual-basic-for-applications-overview) - '^\s*(?:Public|Private)?\s+Declare\s+PtrSafe\s+(?:Sub|Function)\b' - '^\s*#If\s(:?VBA7|Win64)\b' - - '^\s*Dim\s[0-9a-zA-Z_]*\sAs\s(?:LongPtr|LongLong)\b' + - '^\s*Dim\s[0-9a-zA-Z_]*\sAs\sLong(?:Ptr|Long)\b' # Top module declarations unique to VBA - '^\s*Option\s+(?:Private\s+Module|Compare\s+Database)\b' # Libraries/Objects preloaded with VBA From 434d62c53f4c265542365a0ab8341dddd6caaa54 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 2 Apr 2023 23:29:19 -0400 Subject: [PATCH 11/28] Simplify heuristic Co-authored-by: John Gardner --- lib/linguist/heuristics.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index a8db9b1d68..7808e22a4f 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -855,7 +855,7 @@ named_patterns: # Top module declarations unique to VBA - '^\s*Option\s+(?:Private\s+Module|Compare\s+Database)\b' # Libraries/Objects preloaded with VBA - - '(?:\s|\()(?:VBA|Access|Excel|Outlook|PowerPoint|Visio|Word)\.\w+' # VBA Libraries invocation + - '(?:\s|\()(?:VBA|Access|Excel|Outlook|PowerPoint|Visio|Word)\.\w' # VBA Libraries invocation - '\b(?:ThisDrawing|AcadObject)\b' # AutoCAD Objects - '\b(?:ThisWorkbook|ActiveWorkbook|ActiveSheet|ActiveChart|ActiveCell|WorksheetFunction)\b' # Excel Objects - '\bRange\("(?:[a-zA-Z]+\d+|[a-zA-Z]+\d+:[a-zA-Z]+\d+|[a-zA-Z]+:[a-zA-Z]+|\d+:\d+)"\)' # Excel range From 65535a996e32d45430950548464c4a64299874c2 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 2 Apr 2023 23:30:59 -0400 Subject: [PATCH 12/28] Another one https://www.youtube.com/watch?v=jEI3N9kIyP4 Co-authored-by: John Gardner --- lib/linguist/heuristics.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 7808e22a4f..17b4c70795 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -846,7 +846,7 @@ named_patterns: raku: '^\s*(?:use\s+v6\b|\bmodule\b|\b(?:my\s+)?class\b)' vb-class: '^\s*VERSION\s+[0-9]\.[0-9]\s+CLASS' vb-form: '^\s*VERSION\s+[0-9]\.[0-9]{2}' - vb-module: '^\s*Attribute\s+VB_Name\s+=\s+' + vb-module: '^\s*Attribute\s+VB_Name\s+=\s' vba: # VBA7 new 64-bit features (https://learn.microsoft.com/en-us/office/vba/language/concepts/getting-started/64-bit-visual-basic-for-applications-overview) - '^\s*(?:Public|Private)?\s+Declare\s+PtrSafe\s+(?:Sub|Function)\b' From ef1e18a05edb4f7b0c5be4e1195509af59350f72 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 2 Apr 2023 23:40:28 -0400 Subject: [PATCH 13/28] Remove URL --- lib/linguist/heuristics.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 17b4c70795..9796a8d6db 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -848,7 +848,7 @@ named_patterns: vb-form: '^\s*VERSION\s+[0-9]\.[0-9]{2}' vb-module: '^\s*Attribute\s+VB_Name\s+=\s' vba: - # VBA7 new 64-bit features (https://learn.microsoft.com/en-us/office/vba/language/concepts/getting-started/64-bit-visual-basic-for-applications-overview) + # VBA7 new 64-bit features - '^\s*(?:Public|Private)?\s+Declare\s+PtrSafe\s+(?:Sub|Function)\b' - '^\s*#If\s(:?VBA7|Win64)\b' - '^\s*Dim\s[0-9a-zA-Z_]*\sAs\sLong(?:Ptr|Long)\b' From b6329c2267d6ec417bc0cc293ea2f9f62ac3fa8c Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 9 Apr 2023 13:12:01 -0400 Subject: [PATCH 14/28] Put all comments on seperate line --- lib/linguist/heuristics.yml | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 9796a8d6db..3303767967 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -854,11 +854,16 @@ named_patterns: - '^\s*Dim\s[0-9a-zA-Z_]*\sAs\sLong(?:Ptr|Long)\b' # Top module declarations unique to VBA - '^\s*Option\s+(?:Private\s+Module|Compare\s+Database)\b' - # Libraries/Objects preloaded with VBA - - '(?:\s|\()(?:VBA|Access|Excel|Outlook|PowerPoint|Visio|Word)\.\w' # VBA Libraries invocation - - '\b(?:ThisDrawing|AcadObject)\b' # AutoCAD Objects - - '\b(?:ThisWorkbook|ActiveWorkbook|ActiveSheet|ActiveChart|ActiveCell|WorksheetFunction)\b' # Excel Objects - - '\bRange\("(?:[a-zA-Z]+\d+|[a-zA-Z]+\d+:[a-zA-Z]+\d+|[a-zA-Z]+:[a-zA-Z]+|\d+:\d+)"\)' # Excel range - - '\b(?:ActiveExplorer|ActiveInspector)\b' # Outlook Objects - - '\b(?:ActiveWindow\.Presentation|ActivePresentation)\b' # PowerPoint Objects - - '\b(?:ActiveDocument|Selection\.Find|Selection\.Paragraphs)\b' # Word Objects + # VBA Libraries invocation + - '(?:\s|\()(?:VBA|Access|Excel|Outlook|PowerPoint|Visio|Word)\.\w' + # AutoCAD Objects + - '\b(?:ThisDrawing|AcadObject)\b' + # Excel Objects + - '\b(?:ThisWorkbook|ActiveWorkbook|ActiveSheet|ActiveChart|ActiveCell|WorksheetFunction)\b' + - '\bRange\("(?:[a-zA-Z]+\d+|[a-zA-Z]+\d+:[a-zA-Z]+\d+|[a-zA-Z]+:[a-zA-Z]+|\d+:\d+)"\)' + # Outlook Objects + - '\b(?:ActiveExplorer|ActiveInspector)\b' + # PowerPoint Objects + - '\b(?:ActiveWindow\.Presentation|ActivePresentation)\b' + # Word Objects + - '\b(?:ActiveDocument|Selection\.Find|Selection\.Paragraphs)\b' From 4e15c6d6dd520e2be759bec0fad0c4cc066f2c73 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 9 Apr 2023 13:17:31 -0400 Subject: [PATCH 15/28] Using regular space (U+0020) where applicable --- lib/linguist/heuristics.yml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 3303767967..3b69dc2d70 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -844,16 +844,16 @@ named_patterns: - '^\s*package\s+[^\W\d]\w*(?:::\w+)*\s*(?:[;{]|\sv?\d)' - '[\s$][^\W\d]\w*(?::\w+)*->[a-zA-Z_\[({]' raku: '^\s*(?:use\s+v6\b|\bmodule\b|\b(?:my\s+)?class\b)' - vb-class: '^\s*VERSION\s+[0-9]\.[0-9]\s+CLASS' - vb-form: '^\s*VERSION\s+[0-9]\.[0-9]{2}' - vb-module: '^\s*Attribute\s+VB_Name\s+=\s' + vb-class: '^\s*VERSION [0-9]\.[0-9] CLASS' + vb-form: '^\s*VERSION [0-9]\.[0-9]{2}' + vb-module: '^\s*Attribute VB_Name = ' vba: # VBA7 new 64-bit features - - '^\s*(?:Public|Private)?\s+Declare\s+PtrSafe\s+(?:Sub|Function)\b' + - '^\s*(?:Public|Private)? Declare PtrSafe (?:Sub|Function)\b' - '^\s*#If\s(:?VBA7|Win64)\b' - - '^\s*Dim\s[0-9a-zA-Z_]*\sAs\sLong(?:Ptr|Long)\b' + - '^\s*Dim [0-9a-zA-Z_]*[ ]*As Long(?:Ptr|Long)\b' # Top module declarations unique to VBA - - '^\s*Option\s+(?:Private\s+Module|Compare\s+Database)\b' + - '^\s*Option (?:Private Module|Compare Database)\b' # VBA Libraries invocation - '(?:\s|\()(?:VBA|Access|Excel|Outlook|PowerPoint|Visio|Word)\.\w' # AutoCAD Objects From ed3826d0c387c9eaf0d71d0c5af849925b6f9e96 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 9 Apr 2023 13:22:47 -0400 Subject: [PATCH 16/28] Tweak Excel object rules Tweak some more heuristics Simplify Range heuristic to account for cases like Range(B & row_number) Edit heuristics --- lib/linguist/heuristics.yml | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 3b69dc2d70..2c2189f46e 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -848,22 +848,22 @@ named_patterns: vb-form: '^\s*VERSION [0-9]\.[0-9]{2}' vb-module: '^\s*Attribute VB_Name = ' vba: - # VBA7 new 64-bit features + - '\b[vV][bB][aA]\b' + # VBA7 new 64-bit features - '^\s*(?:Public|Private)? Declare PtrSafe (?:Sub|Function)\b' - '^\s*#If\s(:?VBA7|Win64)\b' - - '^\s*Dim [0-9a-zA-Z_]*[ ]*As Long(?:Ptr|Long)\b' + - '^\s*(?:Dim|Const) [0-9a-zA-Z_]*[ ]*As Long(?:Ptr|Long)\b' # Top module declarations unique to VBA - '^\s*Option (?:Private Module|Compare Database)\b' - # VBA Libraries invocation - - '(?:\s|\()(?:VBA|Access|Excel|Outlook|PowerPoint|Visio|Word)\.\w' - # AutoCAD Objects + # General VBA libraries and objects + - '(?:\s|\()(?:Access|Excel|Outlook|PowerPoint|Visio|Word|VBIDE|Application\.VBE)\.\w' + - '\b(?:(?:Active)?VBProjects?|VBComponents?)\b' + # AutoCAD objects - '\b(?:ThisDrawing|AcadObject)\b' - # Excel Objects - - '\b(?:ThisWorkbook|ActiveWorkbook|ActiveSheet|ActiveChart|ActiveCell|WorksheetFunction)\b' - - '\bRange\("(?:[a-zA-Z]+\d+|[a-zA-Z]+\d+:[a-zA-Z]+\d+|[a-zA-Z]+:[a-zA-Z]+|\d+:\d+)"\)' - # Outlook Objects - - '\b(?:ActiveExplorer|ActiveInspector)\b' - # PowerPoint Objects - - '\b(?:ActiveWindow\.Presentation|ActivePresentation)\b' - # Word Objects - - '\b(?:ActiveDocument|Selection\.Find|Selection\.Paragraphs)\b' + # Excel objects + - '\b(?:(?:This|Active)?Workbooks?|Worksheets?|Active(:?Sheet|Chart|Cell)|WorksheetFunction)\b' + - '\bRange\(".*\)' + - '\bCells\([0-9a-zA-Z_], (?:[0-9a-zA-Z_]*|"[a-zA-Z]{1-3}*")\)' + # Outlook, PowerPoint and Word objects + - '\b(?:Active(?:Explorer|Inspector|Window\.Presentation|Presentation|Document)|Selection\.(?:Find|Paragraphs))\b' + From 11db47d478954b05e225f5fb632f6578803574f8 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 9 Apr 2023 13:27:55 -0400 Subject: [PATCH 17/28] Replace VB6 samples --- samples/Visual Basic 6.0/Module1.bas | 111 ++ samples/Visual Basic 6.0/XmlUtil.bas | 266 +++ samples/Visual Basic 6.0/mdTlsNative.bas | 1943 ---------------------- samples/Visual Basic 6.0/modLoader.bas | 1128 ------------- 4 files changed, 377 insertions(+), 3071 deletions(-) create mode 100644 samples/Visual Basic 6.0/Module1.bas create mode 100644 samples/Visual Basic 6.0/XmlUtil.bas delete mode 100644 samples/Visual Basic 6.0/mdTlsNative.bas delete mode 100644 samples/Visual Basic 6.0/modLoader.bas diff --git a/samples/Visual Basic 6.0/Module1.bas b/samples/Visual Basic 6.0/Module1.bas new file mode 100644 index 0000000000..a391625b59 --- /dev/null +++ b/samples/Visual Basic 6.0/Module1.bas @@ -0,0 +1,111 @@ +Attribute VB_Name = "Module1" +Option Explicit +DefObj A-Z + +#Const ImplUseDebugLog = (USE_DEBUG_LOG <> 0) + +'--- for WideCharToMultiByte +Private Const CP_UTF8 As Long = 65001 + +Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) +Private Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long +Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long +Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long +Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long +Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long + +Public Function DesignDumpArray(baData() As Byte, Optional ByVal lPos As Long, Optional ByVal lSize As Long = -1) As String + If lSize < 0 Then + lSize = LenB(CStr(baData)) - lPos + End If + If lSize > 0 Then + DesignDumpArray = DesignDumpMemory(VarPtr(baData(lPos)), lSize) + End If +End Function + +Public Function DesignDumpMemory(ByVal lPtr As Long, ByVal lSize As Long) As String + Dim lIdx As Long + Dim sHex As String + Dim sChar As String + Dim lValue As Long + Dim aResult() As String + + ReDim aResult(0 To (lSize + 15) \ 16) As String +' Debug.Assert RedimStats("DesignDumpMemory.aResult", UBound(aResult) + 1) + For lIdx = 0 To ((lSize + 15) \ 16) * 16 + If lIdx < lSize Then + If IsBadReadPtr(lPtr, 1) = 0 Then + Call CopyMemory(lValue, ByVal lPtr, 1) + sHex = sHex & Right$("0" & Hex$(lValue), 2) & " " + If lValue >= 32 Then + sChar = sChar & Chr$(lValue) + Else + sChar = sChar & "." + End If + Else + sHex = sHex & "?? " + sChar = sChar & "." + End If + Else + sHex = sHex & " " + End If + If ((lIdx + 1) Mod 4) = 0 Then + sHex = sHex & " " + End If + If ((lIdx + 1) Mod 16) = 0 Then + aResult(lIdx \ 16) = Right$("000" & Hex$(lIdx - 15), 4) & " - " & sHex & sChar + sHex = vbNullString + sChar = vbNullString + End If + lPtr = (lPtr Xor &H80000000) + 1 Xor &H80000000 + Next + DesignDumpMemory = Join(aResult, vbCrLf) +End Function + +Public Function FromUtf8Array(baText() As Byte) As String + Dim lSize As Long + + If UBound(baText) >= 0 Then + FromUtf8Array = String$(2 * UBound(baText), 0) + lSize = MultiByteToWideChar(CP_UTF8, 0, baText(0), UBound(baText) + 1, StrPtr(FromUtf8Array), Len(FromUtf8Array)) + FromUtf8Array = Left$(FromUtf8Array, lSize) + End If +End Function + +Public Function ToUtf8Array(sText As String) As Byte() + Dim baRetVal() As Byte + Dim lSize As Long + + lSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), ByVal 0, 0, 0, 0) + If lSize > 0 Then + ReDim baRetVal(0 To lSize - 1) As Byte + Call WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), baRetVal(0), lSize, 0, 0) + Else + baRetVal = vbNullString + End If + ToUtf8Array = baRetVal +End Function + +Public Property Get TimerEx() As Double + Dim cFreq As Currency + Dim cValue As Currency + + Call QueryPerformanceFrequency(cFreq) + Call QueryPerformanceCounter(cValue) + TimerEx = cValue / cFreq +End Property + +Public Function At(vArray As Variant, ByVal lIdx As Long) As Variant + On Error GoTo QH + At = vArray(lIdx) +QH: +End Function + +#If ImplUseDebugLog Then +Public Sub DebugLog(sModule As String, sFunction As String, sText As String, Optional ByVal eType As LogEventTypeConstants = vbLogEventTypeInformation) + Debug.Print Format$(TimerEx, "0.000") & " " & Switch( _ + eType = vbLogEventTypeError, "[ERROR]", _ + eType = vbLogEventTypeWarning, "[WARN]", _ + True, "[INFO]") & " " & sText & " [" & sModule & "." & sFunction & "]" +End Sub +#End If diff --git a/samples/Visual Basic 6.0/XmlUtil.bas b/samples/Visual Basic 6.0/XmlUtil.bas new file mode 100644 index 0000000000..5f0b23fd66 --- /dev/null +++ b/samples/Visual Basic 6.0/XmlUtil.bas @@ -0,0 +1,266 @@ +Attribute VB_Name = "XmlUtil" +'[XmlUtil.bas] + +' +' XML Parser by Jason Thorn (Fork by Alex Dragokas) +' + +' Fork v1.4 +' - added .NodeValueByName +' - removed err.raise when trying to parse empty file +' - added .LoadFile method (returns FALSE, if error happens, or file is empty. +' - .LoadData is now a function (TRUE, if success with loading) +' - improved UTF16 LE format detection. +' + +' Fork v1.3 [28.11.2017] +' - added all possible error handlers +' - replaced error handlers based on Err.raise by separate function (ErrorMsg), just because I don't like at all when class raises runtime error. +'If you want to form a code logic according to critical errors, just add anything like global "LastErrorCode" variable to that function, or put Err.Raise once. +' - Fixed the range of cyrillic characters (Russian and Ukrainian) for tag names. +' - Added support of 'CDATA' type values +' - Removed attempt to serialize empty string. +' +' Fork v1.2 [27.10.2017] +' +' - added recognition of UTF-16 LE xml. +' - added protection against infinite loop, just in case. +' - fixed bug when empty tag /> could not be identified. +' +' Fork v1.1 [23.11.2015] +' +' - added " +Public Const ascTagTerm As Byte = 47 '/ +Public Const ascAmper As Byte = 38 '& +Public Const ascSemiColon As String = 59 '; + +' Letter Characters (Begining And Ending for Simplicity) +Public Const ascLowerFirst As Byte = 97 'a +Public Const ascLowerLast As Byte = 122 'z +Public Const ascUpperFirst As Byte = 65 'A +Public Const ascUpperLast As Byte = 90 'Z +Public Const ascUnderScore As Byte = 95 '_ +Public Const ascColon As Byte = 58 ': + +' Digit Characters +Public Const ascNumFirst As Byte = 48 '0 +Public Const ascNumLast As Byte = 57 '9 + +' Other Characters +Public Const ascEquals As Byte = 61 ' = +Public Const ascApos As Byte = 39 ' Single Quote +Public Const ascQuote As Byte = 34 ' Double Quote +Public Const ascPound As Byte = 35 ' # +Public Const ascSquareBracketOpen As Byte = 91 ' [ +Public Const ascSquareBracketClose As Byte = 93 ' ] + +' Special Strings +Public Const strAmp As String = "amp" '& +Public Const strLessThan As String = "lt" '< +Public Const strMoreThan As String = "gt" '> +Public Const strApostrophe As String = "apos" '' +Public Const strQuote As String = "quot" '" +Public Const strTagCDataBegin As String = "" + +Public Function DecodeEscape(Data() As Integer, Start As Long) As String + On Error GoTo Err_Trap + + Do ' Until we find a semicolon + Start = Start + 1 + If Data(Start) = ascSemiColon Then _ + Exit Do + DecodeEscape = DecodeEscape & ChrW$(Data(Start)) + Loop While Start <= UBound(Data) + + Select Case DecodeEscape + Case strAmp + DecodeEscape = "&" + + Case strApostrophe + DecodeEscape = "'" + + Case strLessThan + DecodeEscape = "<" + + Case strMoreThan + DecodeEscape = ">" + + Case strQuote + DecodeEscape = """" + + Case Else + If Data(Start - Len(DecodeEscape)) = ascPound Then + ' Numeric Escape Sequence + If Data(Start - (Len(DecodeEscape) + 1)) = AscW("x") Then + ' Hexadecimal + DecodeEscape = Right$(DecodeEscape, Len(DecodeEscape) - 2) + Else + ' Decimal + DecodeEscape = Right$(DecodeEscape, Len(DecodeEscape) - 1) + End If + Else + ' Custom Entity Reference + ' Not Currently Supported + DecodeEscape = vbNullString + End If + End Select +Exit Function + +Err_Trap: + Select Case Error + ' Exceptions Raised: + Case 9 + 'Unexpected End of Data [array index out of bounds] + ErrorMsg Err, "XmlUtil.DecodeEscape", "Unexpected end of data" + + Case Else + ' Log all other errors + ErrorMsg Err, "XmlUtil.DecodeEscape" + + End Select + If inIDE Then Stop: Resume Next +End Function + +' Parses a value contained within quotes +' Start identifies the begining quote and +' will identify the closing quote on exit +Public Function ParseValue(Data() As Integer, Start As Long) As String + Dim bEnd As Boolean + Dim QuoteChar As Byte + + On Error GoTo Err_Trap + + QuoteChar = Data(Start) + + Do + Select Case Data(Start) + Case QuoteChar + bEnd = Not bEnd + If Not bEnd Then Exit Do + + Case Is <> ascTagBegin, Is <> ascAmper + ParseValue = ParseValue & ChrW$(Data(Start)) + + Case ascAmper + ParseValue = ParseValue & DecodeEscape(Data(), Start) + + Case Else + ' The only other case is the Begin Tag which is invalid in this context + + End Select + Start = Start + 1 + Loop While Start <= UBound(Data) +Exit Function + +Err_Trap: + Select Case Error + ' Exceptions Raised: + Case 9 + 'Unexpected End of Data [array index out of bounds] + ErrorMsg Err, "XmlUtil.ParseValue", "Unexpected end of data" + + Case Else + ' Log all other errors + ErrorMsg Err, "XmlUtil.ParseValue" + End Select + If inIDE Then Stop: Resume Next +End Function + +' Start Identifies the First Character to Check +' Upon completion, Start should point to the first +' non-delimitng character after the Name Value is read +Public Function ParseName(Data() As Integer, Start As Long) As String + Dim bEnd As Boolean + + On Error GoTo Err_Trap + + Do + Select Case Data(Start) + ' Delimitng Characters + Case ascSpace, ascTab, ascCr, ascLf, ascEquals, ascSemiColon + bEnd = True + + Case ascTagEnd, ascApos, ascQuote + If Data(Start - 1) = ascTagTerm Then Start = Start - 1 'to support /> + Exit Do + + ' Letter Characters + Case ascUpperFirst To ascUpperLast, _ + ascLowerFirst To ascLowerLast, _ + ascUnderScore, ascColon, _ + ascNumFirst To ascNumLast, _ + &H41& To &H5A&, _ + &H61& To &H7A&, _ + &HC0& To &HFF&, _ + &HB7&, _ + &HA5&, &HA8&, &HAA&, &HAF&, &HB2&, &HB3&, &HB4&, &HB8&, &HBA&, &HBF& + + 'A-Z + 'a-z + '- + '&HB7 + ',,,,,,,,, + + If bEnd Then + Exit Do + Else + ParseName = ParseName & ChrW$(Data(Start)) + End If + + Case Else + ' Error . . . Normally not too many charater + ' types can be used for the Name Identifier + + End Select + Start = Start + 1 + Loop While Start <= UBound(Data) +Exit Function + +Err_Trap: + Select Case Error + ' Exceptions Raised: + Case 9 + 'Unexpected End of Data [array index out of bounds] + ErrorMsg Err, "XmlUtil.ParseName", "Unexpected end of data" + + Case Else + ' Log all other errors + ErrorMsg Err, "XmlUtil.ParseName" + End Select + If inIDE Then Stop: Resume Next +End Function + +''// Common error handler +'Public Function ErrorMsg(Error As ErrObject, sFunctionName As String, ParamArray aText()) +' Dim i As Long +' Dim s As String +' For i = 0 To UBound(aText) +' s = s & " " & aText(i) +' Next +' Debug.Print "Error: " & Error.Number & " in '" & sFunctionName & "' - " & Error.Description & IIf(Len(s) > 0, " - " & s, vbnullstring) +'End Function +' +'Public Function InIDE() As Boolean +' InIDE = (App.LogMode = 0) +'End Function diff --git a/samples/Visual Basic 6.0/mdTlsNative.bas b/samples/Visual Basic 6.0/mdTlsNative.bas deleted file mode 100644 index 2923c9e3e7..0000000000 --- a/samples/Visual Basic 6.0/mdTlsNative.bas +++ /dev/null @@ -1,1943 +0,0 @@ -Attribute VB_Name = "mdTlsNative" -'========================================================================= -' -' VbAsyncSocket Project (c) 2018-2022 by wqweto@gmail.com -' -' Simple and thin WinSock API wrappers for VB6 -' -' This project is licensed under the terms of the MIT license -' See the LICENSE file in the project root for more information -' -'========================================================================= -Option Explicit -DefObj A-Z -Private Const MODULE_NAME As String = "mdTlsNative" - -#Const ImplTlsServer = (ASYNCSOCKET_NO_TLSSERVER = 0) -#Const ImplUseShared = (ASYNCSOCKET_USE_SHARED <> 0) -#Const ImplUseDebugLog = (USE_DEBUG_LOG <> 0) -#Const ImplCaptureTraffic = CLng(ASYNCSOCKET_CAPTURE_TRAFFIC) '--- bitmask: 1 - traffic - -'========================================================================= -' API -'========================================================================= - -'--- for VirtualProtect -Private Const PAGE_EXECUTE_READWRITE As Long = &H40 -'--- for AcquireCredentialsHandle -Private Const UNISP_NAME As String = "Microsoft Unified Security Protocol Provider" -Private Const SECPKG_CRED_INBOUND As Long = 1 -Private Const SECPKG_CRED_OUTBOUND As Long = 2 -Private Const SCHANNEL_CRED_VERSION As Long = 4 -Private Const SCH_CREDENTIALS_VERSION As Long = 5 -Private Const SP_PROT_TLS1_0 As Long = &H40 Or &H80 -Private Const SP_PROT_TLS1_1 As Long = &H100 Or &H200 -Private Const SP_PROT_TLS1_2 As Long = &H400 Or &H800 -Private Const SP_PROT_TLS1_3 As Long = &H1000 Or &H2000 -Private Const SCH_CRED_MANUAL_CRED_VALIDATION As Long = 8 -Private Const SCH_CRED_NO_DEFAULT_CREDS As Long = &H10 -Private Const SCH_CRED_REVOCATION_CHECK_CHAIN_EXCLUDE_ROOT As Long = &H400 -Private Const SCH_USE_STRONG_CRYPTO As Long = &H400000 -'-- for InitializeSecurityContext -Private Const ISC_REQ_REPLAY_DETECT As Long = &H4 -Private Const ISC_REQ_SEQUENCE_DETECT As Long = &H8 -Private Const ISC_REQ_CONFIDENTIALITY As Long = &H10 -Private Const ISC_REQ_USE_SUPPLIED_CREDS As Long = &H80 -Private Const ISC_REQ_ALLOCATE_MEMORY As Long = &H100 -Private Const ISC_REQ_EXTENDED_ERROR As Long = &H4000 -Private Const ISC_REQ_STREAM As Long = &H8000& -Private Const SECURITY_NATIVE_DREP As Long = &H10 -'--- for ApiSecBuffer.BufferType -Private Const SECBUFFER_EMPTY As Long = 0 ' Undefined, replaced by provider -Private Const SECBUFFER_DATA As Long = 1 ' Packet data -Private Const SECBUFFER_TOKEN As Long = 2 ' Security token -Private Const SECBUFFER_EXTRA As Long = 5 ' Extra data -Private Const SECBUFFER_STREAM_TRAILER As Long = 6 ' Security Trailer -Private Const SECBUFFER_STREAM_HEADER As Long = 7 ' Security Header -Private Const SECBUFFER_ALERT As Long = 17 -Private Const SECBUFFER_APPLICATION_PROTOCOLS As Long = 18 -Private Const SECBUFFER_VERSION As Long = 0 -'--- SSPI/Schannel retvals -Private Const SEC_E_OK As Long = 0 -Private Const SEC_I_CONTINUE_NEEDED As Long = &H90312 -Private Const SEC_I_CONTEXT_EXPIRED As Long = &H90317 -Private Const SEC_I_INCOMPLETE_CREDENTIALS As Long = &H90320 -Private Const SEC_I_RENEGOTIATE As Long = &H90321 -Private Const SEC_E_INVALID_HANDLE As Long = &H80090301 -Private Const SEC_E_INCOMPLETE_MESSAGE As Long = &H80090318 -Private Const SEC_E_CERT_UNKNOWN As Long = &H80090327 -'--- for QueryContextAttributes -Private Const SECPKG_ATTR_STREAM_SIZES As Long = 4 -Private Const SECPKG_ATTR_REMOTE_CERT_CONTEXT As Long = &H53 -Private Const SECPKG_ATTR_ISSUER_LIST_EX As Long = &H59 -Private Const SECPKG_ATTR_CONNECTION_INFO As Long = &H5A -Private Const SECPKG_ATTR_CIPHER_INFO As Long = &H64 -Private Const SECPKG_ATTR_APPLICATION_PROTOCOL As Long = 35 -'--- for ApplyControlToken -Private Const SCHANNEL_SHUTDOWN As Long = 1 ' gracefully close down a connection -'--- for CryptDecodeObjectEx -Private Const X509_ASN_ENCODING As Long = 1 -Private Const PKCS_7_ASN_ENCODING As Long = &H10000 -Private Const PKCS_RSA_PRIVATE_KEY As Long = 43 -Private Const PKCS_PRIVATE_KEY_INFO As Long = 44 -Private Const X509_ECC_PRIVATE_KEY As Long = 82 -Private Const CRYPT_DECODE_NOCOPY_FLAG As Long = &H1 -Private Const CRYPT_DECODE_ALLOC_FLAG As Long = &H8000 -Private Const ERROR_FILE_NOT_FOUND As Long = 2 -'--- for CertOpenStore -Private Const CERT_STORE_PROV_MEMORY As Long = 2 -Private Const CERT_STORE_CREATE_NEW_FLAG As Long = &H2000 -'--- for CertAddEncodedCertificateToStore -Private Const CERT_STORE_ADD_USE_EXISTING As Long = 2 -'--- for CryptAcquireContext -Private Const PROV_RSA_FULL As Long = 1 -Private Const CRYPT_NEWKEYSET As Long = &H8 -Private Const CRYPT_DELETEKEYSET As Long = &H10 -Private Const AT_KEYEXCHANGE As Long = 1 -'--- for CertGetCertificateContextProperty -Private Const CERT_KEY_PROV_INFO_PROP_ID As Long = 2 -Private Const CERT_OCSP_RESPONSE_PROP_ID As Long = 70 -'--- for ALPN -Private Const SecApplicationProtocolNegotiationExt_ALPN As Long = 2 -Private Const SecApplicationProtocolNegotiationStatus_Success As Long = 1 -'--- OIDs -Private Const szOID_RSA_RSA As String = "1.2.840.113549.1.1.1" -Private Const szOID_ECC_PUBLIC_KEY As String = "1.2.840.10045.2.1" -Private Const szOID_ECC_CURVE_P256 As String = "1.2.840.10045.3.1.7" -Private Const szOID_ECC_CURVE_P384 As String = "1.3.132.0.34" -Private Const szOID_ECC_CURVE_P521 As String = "1.3.132.0.35" -'--- NCrypt -Private Const BCRYPT_ECDSA_PRIVATE_P256_MAGIC As Long = &H32534345 -Private Const BCRYPT_ECDSA_PRIVATE_P384_MAGIC As Long = &H34534345 -Private Const BCRYPT_ECDSA_PRIVATE_P521_MAGIC As Long = &H36534345 -Private Const MS_KEY_STORAGE_PROVIDER As String = "Microsoft Software Key Storage Provider" -Private Const NCRYPTBUFFER_PKCS_KEY_NAME As Long = 45 -Private Const NCRYPT_OVERWRITE_KEY_FLAG As Long = &H80 - -Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) -Private Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long -Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, ByRef lpflOldProtect As Long) As Long -Private Declare Function vbaObjSetAddref Lib "msvbvm60" Alias "__vbaObjSetAddref" (oDest As Any, ByVal lSrcPtr As Long) As Long -Private Declare Function lstrlenA Lib "kernel32" (ByVal lpStr As Long) As Long -Private Declare Function lstrlenW Lib "kernel32" (ByVal lpStr As Long) As Long -Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long -Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageW" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As Long, ByVal nSize As Long, ByVal Args As Long) As Long -'--- msvbvm60 -Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long -'--- version -Private Declare Function GetFileVersionInfo Lib "version" Alias "GetFileVersionInfoW" (ByVal lptstrFilename As Long, ByVal dwHandle As Long, ByVal dwLen As Long, lpData As Any) As Long -Private Declare Function VerQueryValue Lib "version" Alias "VerQueryValueW" (pBlock As Any, ByVal lpSubBlock As Long, lpBuffer As Any, puLen As Long) As Long -'--- security -Private Declare Function AcquireCredentialsHandle Lib "security" Alias "AcquireCredentialsHandleW" (ByVal pszPrincipal As Long, ByVal pszPackage As Long, ByVal fCredentialUse As Long, ByVal pvLogonId As Long, pAuthData As Any, ByVal pGetKeyFn As Long, ByVal pvGetKeyArgument As Long, phCredential As Currency, ByVal ptsExpiry As Long) As Long -Private Declare Function FreeCredentialsHandle Lib "security" (phContext As Currency) As Long -Private Declare Function AcceptSecurityContext Lib "security" (phCredential As Currency, ByVal phContext As Long, pInput As Any, ByVal fContextReq As Long, ByVal TargetDataRep As Long, phNewContext As Currency, pOutput As Any, pfContextAttr As Long, ByVal ptsExpiry As Long) As Long -Private Declare Function InitializeSecurityContext Lib "security" Alias "InitializeSecurityContextW" (phCredential As Currency, ByVal phContext As Long, ByVal pszTargetName As Long, ByVal fContextReq As Long, ByVal Reserved1 As Long, ByVal TargetDataRep As Long, pInput As Any, ByVal Reserved2 As Long, phNewContext As Currency, pOutput As Any, pfContextAttr As Long, ByVal ptsExpiry As Long) As Long -Private Declare Function DeleteSecurityContext Lib "security" (phContext As Currency) As Long -Private Declare Function FreeContextBuffer Lib "security" (ByVal pvContextBuffer As Long) As Long -Private Declare Function QueryContextAttributes Lib "security" Alias "QueryContextAttributesW" (phContext As Currency, ByVal ulAttribute As Long, pBuffer As Any) As Long -Private Declare Function DecryptMessage Lib "security" (phContext As Currency, pMessage As Any, ByVal MessageSeqNo As Long, ByVal pfQOP As Long) As Long -Private Declare Function EncryptMessage Lib "security" (phContext As Currency, ByVal fQOP As Long, pMessage As Any, ByVal MessageSeqNo As Long) As Long -Private Declare Function ApplyControlToken Lib "security" (phContext As Currency, pInput As Any) As Long -'--- crypt32 -Private Declare Function CryptDecodeObjectEx Lib "crypt32" (ByVal dwCertEncodingType As Long, ByVal lpszStructType As Any, pbEncoded As Any, ByVal cbEncoded As Long, ByVal dwFlags As Long, ByVal pDecodePara As Long, pvStructInfo As Any, pcbStructInfo As Long) As Long -Private Declare Function CertOpenStore Lib "crypt32" (ByVal lpszStoreProvider As Long, ByVal dwEncodingType As Long, ByVal hCryptProv As Long, ByVal dwFlags As Long, ByVal pvPara As Long) As Long -Private Declare Function CertCloseStore Lib "crypt32" (ByVal hCertStore As Long, ByVal dwFlags As Long) As Long -Private Declare Function CertAddEncodedCertificateToStore Lib "crypt32" (ByVal hCertStore As Long, ByVal dwCertEncodingType As Long, pbCertEncoded As Any, ByVal cbCertEncoded As Long, ByVal dwAddDisposition As Long, ByVal ppCertContext As Long) As Long -Private Declare Function CertSetCertificateContextProperty Lib "crypt32" (ByVal pCertContext As Long, ByVal dwPropId As Long, ByVal dwFlags As Long, pvData As Any) As Long -Private Declare Function CertFreeCertificateContext Lib "crypt32" (ByVal pCertContext As Long) As Long -Private Declare Function CertEnumCertificatesInStore Lib "crypt32" (ByVal hCertStore As Long, ByVal pPrevCertContext As Long) As Long -Private Declare Function CertGetCertificateContextProperty Lib "crypt32" (ByVal pCertContext As Long, ByVal dwPropId As Long, pvData As Any, pcbData As Long) As Long -Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, pcbBinary As Long, Optional ByVal pdwSkip As Long, Optional ByVal pdwFlags As Long) As Long -'--- advapi32 -Private Declare Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextW" (phProv As Long, ByVal pszContainer As Long, ByVal pszProvider As Long, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long -Private Declare Function CryptReleaseContext Lib "advapi32" (ByVal hProv As Long, ByVal dwFlags As Long) As Long -Private Declare Function CryptImportKey Lib "advapi32" (ByVal hProv As Long, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As Long, ByVal dwFlags As Long, phKey As Long) As Long -Private Declare Function CryptDestroyKey Lib "advapi32" (ByVal hKey As Long) As Long -Private Declare Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength As Long) As Long -'--- ncrypt -Private Declare Function NCryptOpenStorageProvider Lib "ncrypt" (phProvider As Long, ByVal pszProviderName As Long, ByVal dwFlags As Long) As Long -Private Declare Function NCryptImportKey Lib "ncrypt" (ByVal hProvider As Long, ByVal hImportKey As Long, ByVal pszBlobType As Long, pParameterList As Any, phKey As Long, pbData As Any, ByVal cbData As Long, ByVal dwFlags As Long) As Long -Private Declare Function NCryptFreeObject Lib "ncrypt" (ByVal hObject As Long) As Long - -Private Type SCHANNEL_CRED - dwVersion As Long - cCreds As Long - paCred As Long - hRootStore As Long - cMappers As Long - aphMappers As Long - cSupportedAlgs As Long - palgSupportedAlgs As Long - grbitEnabledProtocols As Long - dwMinimumCipherStrength As Long - dwMaximumCipherStrength As Long - dwSessionLifespan As Long - dwFlags As Long - dwCredFormat As Long -End Type - -Private Type SCH_CREDENTIALS - dwVersion As Long - dwCredFormat As Long - cCreds As Long - paCred As Long - hRootStore As Long - cMappers As Long - aphMappers As Long - dwSessionLifespan As Long - dwFlags As Long - cTlsParameters As Long - pTlsParameters As Long -End Type - -Private Type TLS_PARAMETERS - cAlpnIds As Long - rgstrAlpnIds As Long - grbitDisabledProtocols As Long - cDisabledCrypto As Long - pDisabledCrypto As Long - dwFlags As Long -End Type - -Private Type ApiSecBuffer - cbBuffer As Long - BufferType As Long - pvBuffer As Long -End Type - -Private Type ApiSecBufferDesc - ulVersion As Long - cBuffers As Long - pBuffers As Long -End Type - -Private Type ApiSecPkgContext_StreamSizes - cbHeader As Long - cbTrailer As Long - cbMaximumMessage As Long - cBuffers As Long - cbBlockSize As Long -End Type - -Private Type CRYPT_KEY_PROV_INFO - pwszContainerName As Long - pwszProvName As Long - dwProvType As Long - dwFlags As Long - cProvParam As Long - rgProvParam As Long - dwKeySpec As Long -End Type - -Private Type BCRYPT_ECCKEY_BLOB - dwMagic As Long - cbKey As Long - Buffer(0 To 1000) As Byte -End Type - -Private Type CRYPT_DATA_BLOB - cbData As Long - pbData As Long -End Type - -Private Type CRYPT_BIT_BLOB - cbData As Long - pbData As Long - cUnusedBits As Long -End Type - -Private Type CRYPT_ALGORITHM_IDENTIFIER - pszObjId As Long - Parameters As CRYPT_DATA_BLOB -End Type - -Private Type CERT_PUBLIC_KEY_INFO - Algorithm As CRYPT_ALGORITHM_IDENTIFIER - PublicKey As CRYPT_BIT_BLOB -End Type - -Private Type CRYPT_ECC_PRIVATE_KEY_INFO - dwVersion As Long - PrivateKey As CRYPT_DATA_BLOB - szCurveOid As Long - PublicKey As CRYPT_DATA_BLOB -End Type - -Private Type CRYPT_PRIVATE_KEY_INFO - dwVersion As Long - Algorithm As CRYPT_ALGORITHM_IDENTIFIER - PrivateKey As CRYPT_DATA_BLOB - pAttributes As Long -End Type - -Private Type CERT_CONTEXT - dwCertEncodingType As Long - pbCertEncoded As Long - cbCertEncoded As Long - pCertInfo As Long - hCertStore As Long -End Type - -Private Type SecPkgContext_IssuerListInfoEx - aIssuers As Long - cIssuers As Long -End Type - -Private Type SecPkgContext_ConnectionInfo - dwProtocol As Long - aiCipher As Long - dwCipherStrength As Long - aiHash As Long - dwHashStrength As Long - aiExch As Long - dwExchStrength As Long -End Type - -Private Const SZ_ALG_MAX_SIZE As Long = 64 -Private Type SecPkgContext_CipherInfo - dwVersion As Long - dwProtocol As Long - dwCipherSuite As Long - dwBaseCipherSuite As Long - szCipherSuite(0 To SZ_ALG_MAX_SIZE - 1) As Integer - szCipher(0 To SZ_ALG_MAX_SIZE - 1) As Integer - dwCipherLen As Long - dwCipherBlockLen As Long - szHash(0 To SZ_ALG_MAX_SIZE - 1) As Integer - dwHashLen As Long - szExchange(0 To SZ_ALG_MAX_SIZE - 1) As Integer - dwMinExchangeLen As Long - dwMaxExchangeLen As Long - szCertificate(0 To SZ_ALG_MAX_SIZE - 1) As Integer - dwKeyType As Long -End Type - -Private Const MAX_PROTOCOL_ID_SIZE As Long = &HFF& -Private Type SecPkgContext_ApplicationProtocol - ProtoNegoStatus As Long - ProtoNegoExt As Long - ProtocolIdSize As Byte - ProtocolId(0 To MAX_PROTOCOL_ID_SIZE) As Byte -End Type - -'========================================================================= -' Constants and member variables -'========================================================================= - -Private Const STR_VL_ALERTS As String = "0|Close notify|10|Unexpected message|20|Bad record mac|21|Decryption failed|22|Record overflow|30|Decompression failure|40|Handshake failure|41|No certificate|42|Bad certificate|43|Unsupported certificate|44|Certificate revoked|45|Certificate expired|46|Certificate unknown|47|Illegal parameter|48|Unknown certificate authority|50|Decode error|51|Decrypt error|70|Protocol version|71|Insufficient security|80|Internal error|90|User canceled|100|No renegotiation|109|Missing extension|110|Unsupported expension|112|Unrecognized name|116|Certificate required|120|No application protocol" -Private Const STR_UNKNOWN As String = "Unknown (%1)" -Private Const STR_FORMAT_ALERT As String = "%1." -'--- errors -Private Const ERR_UNEXPECTED_RESULT As String = "Unexpected result from %1 (%2)" -Private Const ERR_CONNECTION_CLOSED As String = "Connection closed" -Private Const ERR_UNKNOWN_ECC_PRIVKEY As String = "Unknown ECC private key (%1)" -Private Const ERR_UNKNOWN_PUBKEY As String = "Unknown public key (%1)" -Private Const ERR_NO_SERVER_COMPILED As String = "Server-side TLS not compiled (ASYNCSOCKET_NO_TLSSERVER = 1)" -'--- numeric -Private Const TLS_CONTENT_TYPE_ALERT As Long = 21 -Private Const LNG_FACILITY_WIN32 As Long = &H80070000 - -Private Enum UcsTlsLocalFeaturesEnum '--- bitmask - ucsTlsSupportTls10 = 2 ^ 0 - ucsTlsSupportTls11 = 2 ^ 1 - ucsTlsSupportTls12 = 2 ^ 2 - ucsTlsSupportTls13 = 2 ^ 3 - ucsTlsIgnoreServerCertificateErrors = 2 ^ 4 - ucsTlsSupportAll = ucsTlsSupportTls10 Or ucsTlsSupportTls11 Or ucsTlsSupportTls12 Or ucsTlsSupportTls13 -End Enum - -Private Enum UcsTlsStatesEnum - ucsTlsStateNew = 0 - ucsTlsStateClosed = 1 - ucsTlsStateHandshakeStart = 2 - ucsTlsStatePostHandshake = 8 - ucsTlsStateShutdown = 9 -End Enum - -Private Enum UcsTlsAlertDescriptionsEnum - uscTlsAlertCloseNotify = 0 - uscTlsAlertUnexpectedMessage = 10 - uscTlsAlertBadRecordMac = 20 - uscTlsAlertHandshakeFailure = 40 - uscTlsAlertBadCertificate = 42 - uscTlsAlertCertificateRevoked = 44 - uscTlsAlertCertificateExpired = 45 - uscTlsAlertCertificateUnknown = 46 - uscTlsAlertIllegalParameter = 47 - uscTlsAlertUnknownCa = 48 - uscTlsAlertDecodeError = 50 - uscTlsAlertDecryptError = 51 - uscTlsAlertProtocolVersion = 70 - uscTlsAlertInternalError = 80 - uscTlsAlertUserCanceled = 90 - uscTlsAlertMissingExtension = 109 - uscTlsAlertUnrecognizedName = 112 - uscTlsAlertCertificateRequired = 116 - uscTlsAlertNoApplicationProtocol = 120 -End Enum - -#If Not ImplUseShared Then -Private Enum UcsOsVersionEnum - ucsOsvNt4 = 400 - ucsOsvWin98 = 410 - ucsOsvWin2000 = 500 - ucsOsvXp = 501 - ucsOsvVista = 600 - ucsOsvWin7 = 601 - ucsOsvWin8 = 602 - [ucsOsvWin8.1] = 603 - ucsOsvWin10 = 1000 -End Enum -#End If - -Public Type UcsTlsContext - '--- config - IsServer As Boolean - RemoteHostName As String - LocalFeatures As UcsTlsLocalFeaturesEnum - ClientCertCallback As Long - AlpnProtocols As String - '--- state - State As UcsTlsStatesEnum - LastErrNumber As Long - LastError As String - LastErrSource As String - LastAlertCode As UcsTlsAlertDescriptionsEnum - AlpnNegotiated As String - SniRequested As String - '--- handshake - LocalCertificates As Collection - LocalPrivateKey As Collection - RemoteCertificates As Collection - RemoteCertStatuses As Collection - '--- SSPI - ContextReq As Long - hTlsCredentials As Currency - hTlsContext As Currency - TlsSizes As ApiSecPkgContext_StreamSizes - InDesc As ApiSecBufferDesc - InBuffers() As ApiSecBuffer - OutDesc As ApiSecBufferDesc - OutBuffers() As ApiSecBuffer - '--- I/O buffers - RecvBuffer() As Byte - RecvPos As Long -#If ImplCaptureTraffic <> 0 Then - TrafficDump As Collection -#End If -End Type - -Private Type UcsKeyInfo - AlgoObjId As String - KeyBlob() As Byte - BitLen As Long -End Type - -Public g_oRequestSocket As Object - -'========================================================================= -' Error handling -'========================================================================= - -Private Sub ErrRaise(ByVal Number As Long, Optional Source As Variant, Optional Description As Variant) - Err.Raise Number, Source, Description -End Sub - -'========================================================================= -' Properties -'========================================================================= - -Public Property Get TlsIsClosed(uCtx As UcsTlsContext) As Boolean - TlsIsClosed = (uCtx.State = ucsTlsStateClosed) -End Property - -Public Property Get TlsIsStarted(uCtx As UcsTlsContext) As Boolean - TlsIsStarted = (uCtx.State > ucsTlsStateClosed) -End Property - -Public Property Get TlsIsReady(uCtx As UcsTlsContext) As Boolean - TlsIsReady = (uCtx.State >= ucsTlsStatePostHandshake) -End Property - -Public Property Get TlsIsShutdown(uCtx As UcsTlsContext) As Boolean - TlsIsShutdown = (uCtx.State = ucsTlsStateShutdown) -End Property - -'========================================================================= -' TLS support -'========================================================================= - -Public Function TlsInitClient( _ - uCtx As UcsTlsContext, _ - Optional RemoteHostName As String, _ - Optional ByVal LocalFeatures As Long = ucsTlsSupportAll, _ - Optional ClientCertCallback As Object, _ - Optional AlpnProtocols As String) As Boolean - Dim uEmpty As UcsTlsContext - - On Error GoTo EH - With uEmpty - pvTlsClearLastError uEmpty - .State = ucsTlsStateHandshakeStart - .RemoteHostName = RemoteHostName - .LocalFeatures = LocalFeatures - .ClientCertCallback = ObjPtr(ClientCertCallback) - If RealOsVersion >= [ucsOsvWin8.1] Then - .AlpnProtocols = AlpnProtocols - End If - #If ImplCaptureTraffic <> 0 Then - Set .TrafficDump = New Collection - #End If - End With - uCtx = uEmpty - '--- success - TlsInitClient = True - Exit Function -EH: - pvTlsSetLastError uCtx, Err.Number, Err.Source, Err.Description -End Function - -Public Function TlsInitServer( _ - uCtx As UcsTlsContext, _ - Optional RemoteHostName As String, _ - Optional Certificates As Collection, _ - Optional PrivateKey As Collection, _ - Optional AlpnProtocols As String, _ - Optional ByVal LocalFeatures As Long = ucsTlsSupportAll) As Boolean -#If Not ImplTlsServer Then - ErrRaise vbObjectError, , ERR_NO_SERVER_COMPILED -#Else - Dim uEmpty As UcsTlsContext - - On Error GoTo EH - With uEmpty - pvTlsClearLastError uEmpty - .IsServer = True - .State = ucsTlsStateHandshakeStart - .RemoteHostName = RemoteHostName - .LocalFeatures = LocalFeatures - Set .LocalCertificates = Certificates - Set .LocalPrivateKey = PrivateKey - If RealOsVersion >= [ucsOsvWin8.1] Then - .AlpnProtocols = AlpnProtocols - End If - #If ImplCaptureTraffic <> 0 Then - Set .TrafficDump = New Collection - #End If - End With - uCtx = uEmpty - '--- success - TlsInitServer = True - Exit Function -EH: - pvTlsSetLastError uCtx, Err.Number, Err.Source, Err.Description -#End If -End Function - -Public Function TlsTerminate(uCtx As UcsTlsContext) - With uCtx - .State = ucsTlsStateClosed - If .hTlsContext <> 0 Then - Call DeleteSecurityContext(.hTlsContext) - .hTlsContext = 0 - End If - If .hTlsCredentials <> 0 Then - Call FreeCredentialsHandle(.hTlsCredentials) - .hTlsCredentials = 0 - End If - End With -End Function - -Public Function TlsHandshake(uCtx As UcsTlsContext, baInput() As Byte, ByVal lSize As Long, baOutput() As Byte, lOutputPos As Long) As Boolean - Const FUNC_NAME As String = "TlsHandshake" - Dim uCred As SCHANNEL_CRED - Dim uNewCred As SCH_CREDENTIALS - Dim uNewParams As TLS_PARAMETERS - Dim lContextAttr As Long - Dim hResult As Long - Dim lIdx As Long - Dim lPtr As Long - Dim oCallback As Object - Dim sKeyName As String - Dim pCertContext As Long - Dim aCred(0 To 0) As Long - Dim uIssuerInfo As SecPkgContext_IssuerListInfoEx - Dim uIssuerList() As CRYPT_DATA_BLOB - Dim cIssuers As Collection - Dim baCaDn() As Byte - Dim uCertContext As CERT_CONTEXT - Dim sApiSource As String - Dim uConnInfo As SecPkgContext_ConnectionInfo - Dim uCipherInfo As SecPkgContext_CipherInfo - Dim baAlpnBuffer() As Byte - Dim uAppProtocol As SecPkgContext_ApplicationProtocol - - On Error GoTo EH - With uCtx - If .State = ucsTlsStateClosed Then - pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME, ERR_CONNECTION_CLOSED - GoTo QH - End If - pvTlsClearLastError uCtx - If .ContextReq = 0 Then - .ContextReq = .ContextReq Or ISC_REQ_REPLAY_DETECT ' Detect replayed messages that have been encoded by using the EncryptMessage or MakeSignature functions. - .ContextReq = .ContextReq Or ISC_REQ_SEQUENCE_DETECT ' Detect messages received out of sequence. - .ContextReq = .ContextReq Or ISC_REQ_CONFIDENTIALITY ' Encrypt messages by using the EncryptMessage function. - .ContextReq = .ContextReq Or ISC_REQ_ALLOCATE_MEMORY ' The security package allocates output buffers for you. When you have finished using the output buffers, free them by calling the FreeContextBuffer function. - .ContextReq = .ContextReq Or ISC_REQ_EXTENDED_ERROR ' When errors occur, the remote party will be notified. - .ContextReq = .ContextReq Or ISC_REQ_STREAM ' Support a stream-oriented connection. - End If - If lSize < 0 Then - lSize = pvArraySize(baInput) - End If - If lSize > 0 Then - .RecvPos = pvWriteBuffer(.RecvBuffer, .RecvPos, VarPtr(baInput(0)), lSize) - End If - '--- note: doesn't work for encrypted alerts - If lSize = 7 Then - If baInput(0) = TLS_CONTENT_TYPE_ALERT Then - .LastAlertCode = baInput(6) - End If - End If -RetryCredentials: - If .hTlsCredentials = 0 Then - uCred.dwVersion = SCHANNEL_CRED_VERSION - uCred.grbitEnabledProtocols = IIf((.LocalFeatures And ucsTlsSupportTls10) <> 0, SP_PROT_TLS1_0, 0) Or _ - IIf((.LocalFeatures And ucsTlsSupportTls11) <> 0, SP_PROT_TLS1_1, 0) Or _ - IIf((.LocalFeatures And ucsTlsSupportTls12) <> 0, SP_PROT_TLS1_2, 0) - uCred.dwFlags = uCred.dwFlags Or SCH_CRED_MANUAL_CRED_VALIDATION ' Prevent Schannel from validating the received server certificate chain. - uCred.dwFlags = uCred.dwFlags Or SCH_CRED_NO_DEFAULT_CREDS ' Prevent Schannel from attempting to automatically supply a certificate chain for client authentication. - uCred.dwFlags = uCred.dwFlags Or SCH_CRED_REVOCATION_CHECK_CHAIN_EXCLUDE_ROOT ' Force TLS certificate status request extension (commonly known as OCSP stapling) to be sent on Vista or later - If pvCollectionCount(.LocalCertificates) > 0 Then - If pvTlsImportToCertStore(.LocalCertificates, .LocalPrivateKey, sKeyName, pCertContext) And pCertContext <> 0 Then - aCred(uCred.cCreds) = pCertContext - uCred.cCreds = uCred.cCreds + 1 - uCred.paCred = VarPtr(aCred(0)) - .ContextReq = .ContextReq Or ISC_REQ_USE_SUPPLIED_CREDS ' Schannel must not attempt to supply credentials for the client automatically. - End If - End If - If RealOsVersion(BuildNo:=lIdx) = ucsOsvWin10 And lIdx >= 20348 Then '--- 20348 = Windows Server 2022 - '--- use new credentials struct for TLS 1.3 support - uNewCred.dwVersion = SCH_CREDENTIALS_VERSION - uNewCred.cCreds = uCred.cCreds - uNewCred.paCred = uCred.paCred - uNewCred.dwFlags = uCred.dwFlags Or SCH_USE_STRONG_CRYPTO - uNewCred.cTlsParameters = 1 - uNewCred.pTlsParameters = VarPtr(uNewParams) - uNewParams.grbitDisabledProtocols = Not (uCred.grbitEnabledProtocols Or _ - IIf((.LocalFeatures And ucsTlsSupportTls13) <> 0, SP_PROT_TLS1_3, 0)) - hResult = AcquireCredentialsHandle(0, StrPtr(UNISP_NAME), IIf(.IsServer, SECPKG_CRED_INBOUND, SECPKG_CRED_OUTBOUND), 0, uNewCred, 0, 0, .hTlsCredentials, 0) - Else - hResult = -1 - End If - If hResult < 0 Then - hResult = AcquireCredentialsHandle(0, StrPtr(UNISP_NAME), IIf(.IsServer, SECPKG_CRED_INBOUND, SECPKG_CRED_OUTBOUND), 0, uCred, 0, 0, .hTlsCredentials, 0) - End If - If hResult < 0 Then - pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "AcquireCredentialsHandle", AlertCode:=.LastAlertCode - GoTo QH - End If - If pCertContext <> 0 Then - Call CertFreeCertificateContext(pCertContext) - pCertContext = 0 - End If - End If - If .hTlsContext = 0 Then - pvInitSecDesc .InDesc, 3, .InBuffers - pvInitSecDesc .OutDesc, 3, .OutBuffers - #If ImplTlsServer Then - If .IsServer Then - pvTlsParseHandshakeClientHello uCtx, baInput, 0 - End If - #End If - If LenB(.AlpnProtocols) <> 0 Then - pvTlsBuildAlpnBuffer baAlpnBuffer, 0, .AlpnProtocols - End If - End If - Do - If .RecvPos > 0 Then - #If (ImplCaptureTraffic And 1) <> 0 Then - .TrafficDump.Add FUNC_NAME & ".Input" & vbCrLf & TlsDesignDumpArray(.RecvBuffer, 0, .RecvPos) - #End If - pvInitSecBuffer .InBuffers(0), SECBUFFER_TOKEN, VarPtr(.RecvBuffer(0)), .RecvPos - lPtr = VarPtr(.InDesc) - Else - lPtr = 0 - End If - If pvArraySize(baAlpnBuffer) > 0 Then - pvInitSecBuffer .InBuffers(IIf(lPtr <> 0, 1, 0)), SECBUFFER_APPLICATION_PROTOCOLS, VarPtr(baAlpnBuffer(0)), UBound(baAlpnBuffer) + 1 - lPtr = VarPtr(.InDesc) - End If - #If ImplTlsServer Then - If .IsServer Then - hResult = AcceptSecurityContext(.hTlsCredentials, IIf(.hTlsContext <> 0, VarPtr(.hTlsContext), 0), ByVal lPtr, .ContextReq, _ - SECURITY_NATIVE_DREP, .hTlsContext, .OutDesc, lContextAttr, 0) - sApiSource = "AcceptSecurityContext" - Else - #End If - hResult = InitializeSecurityContext(.hTlsCredentials, IIf(.hTlsContext <> 0, VarPtr(.hTlsContext), 0), StrPtr(.RemoteHostName), .ContextReq, 0, _ - SECURITY_NATIVE_DREP, ByVal lPtr, 0, .hTlsContext, .OutDesc, lContextAttr, 0) - sApiSource = "InitializeSecurityContext" - #If ImplTlsServer Then - End If - #End If - If hResult = SEC_E_INCOMPLETE_MESSAGE Then - pvInitSecBuffer .InBuffers(1), SECBUFFER_EMPTY - Exit Do - ElseIf hResult < 0 Then - pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & sApiSource, AlertCode:=.LastAlertCode - '--- treat as warnings TLS1_ALERT_BAD_CERTIFICATE, TLS1_ALERT_UNSUPPORTED_CERT and TLS1_ALERT_CERTIFICATE_UNKNOWN - If hResult = SEC_E_CERT_UNKNOWN Then - TlsHandshake = True - End If - GoTo QH - Else - .RecvPos = 0 - For lIdx = 1 To UBound(.InBuffers) - With .InBuffers(lIdx) - If .cbBuffer > 0 Then - Select Case .BufferType - Case SECBUFFER_EXTRA - lPtr = .pvBuffer - If lPtr = 0 Then - lPtr = VarPtr(uCtx.RecvBuffer(uCtx.InBuffers(0).cbBuffer - .cbBuffer)) - End If - uCtx.RecvPos = pvWriteBuffer(uCtx.RecvBuffer, uCtx.RecvPos, lPtr, .cbBuffer) - Case SECBUFFER_ALERT - #If ImplUseDebugLog Then - DebugLog MODULE_NAME, FUNC_NAME, "InBuffers, SECBUFFER_ALERT:" & vbCrLf & TlsDesignDumpMemory(.pvBuffer, .cbBuffer), vbLogEventTypeWarning - #End If - Case Else - #If ImplUseDebugLog Then - DebugLog MODULE_NAME, FUNC_NAME, ".BufferType(" & lIdx & ")=" & .BufferType - #End If - End Select - End If - End With - pvInitSecBuffer .InBuffers(lIdx), SECBUFFER_EMPTY - Next - Erase baAlpnBuffer - For lIdx = 0 To UBound(.OutBuffers) - With .OutBuffers(lIdx) - If .cbBuffer > 0 Then - Select Case .BufferType - Case SECBUFFER_TOKEN - lOutputPos = pvWriteBuffer(baOutput, lOutputPos, .pvBuffer, .cbBuffer) - #If (ImplCaptureTraffic And 1) <> 0 Then - uCtx.TrafficDump.Add FUNC_NAME & ".Output" & vbCrLf & TlsDesignDumpMemory(.pvBuffer, .cbBuffer) - #End If - Case SECBUFFER_ALERT - #If ImplUseDebugLog Then - DebugLog MODULE_NAME, FUNC_NAME, "OutBuffers, SECBUFFER_ALERT:" & vbCrLf & TlsDesignDumpMemory(.pvBuffer, .cbBuffer), vbLogEventTypeWarning - #End If - End Select - If .pvBuffer <> 0 Then - Call FreeContextBuffer(.pvBuffer) - Debug.Assert Err.LastDllError = 0 - End If - End If - End With - pvInitSecBuffer .OutBuffers(lIdx), SECBUFFER_EMPTY - Next - Select Case hResult - Case SEC_I_CONTINUE_NEEDED - '--- do nothing - Case SEC_E_OK - hResult = QueryContextAttributes(.hTlsContext, SECPKG_ATTR_STREAM_SIZES, .TlsSizes) - If hResult < 0 Then - pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "QueryContextAttributes(SECPKG_ATTR_STREAM_SIZES)", AlertCode:=.LastAlertCode - GoTo QH - End If - pvInitSecDesc .InDesc, .TlsSizes.cBuffers, .InBuffers - pvInitSecDesc .OutDesc, .TlsSizes.cBuffers, .OutBuffers - If QueryContextAttributes(.hTlsContext, SECPKG_ATTR_REMOTE_CERT_CONTEXT, pCertContext) = 0 And pCertContext <> 0 Then - Call CopyMemory(uCertContext, ByVal pCertContext, Len(uCertContext)) - If Not pvTlsExportFromCertStore(uCertContext.hCertStore, .RemoteCertificates, .RemoteCertStatuses) Then - GoTo QH - End If - Call CertFreeCertificateContext(pCertContext) - pCertContext = 0 - End If - If LenB(.AlpnProtocols) <> 0 Then - .AlpnNegotiated = vbNullString - If QueryContextAttributes(.hTlsContext, SECPKG_ATTR_APPLICATION_PROTOCOL, uAppProtocol) = 0 Then - If uAppProtocol.ProtoNegoStatus = SecApplicationProtocolNegotiationStatus_Success Then - uAppProtocol.ProtocolId(uAppProtocol.ProtocolIdSize) = 0 - .AlpnNegotiated = pvToStringA(VarPtr(uAppProtocol.ProtocolId(0))) - End If - End If - End If - #If ImplUseDebugLog Then - If QueryContextAttributes(.hTlsContext, SECPKG_ATTR_CIPHER_INFO, uCipherInfo) = 0 Then - DebugLog MODULE_NAME, FUNC_NAME, "Using " & pvToStringW(VarPtr(uCipherInfo.szCipherSuite(0))) & " (&H" & Hex$(uCipherInfo.dwCipherSuite) & ") from " & .RemoteHostName - End If - If QueryContextAttributes(.hTlsContext, SECPKG_ATTR_CONNECTION_INFO, uConnInfo) = 0 Then - DebugLog MODULE_NAME, FUNC_NAME, pvTlsGetAlgName(uConnInfo.dwProtocol) & " using " & _ - pvTlsGetAlgName(uConnInfo.aiCipher) & " cipher with " & _ - pvTlsGetAlgName(uConnInfo.aiHash) & " hash and " & _ - pvTlsGetAlgName(uConnInfo.aiExch) & " key-exchange" & _ - IIf(LenB(.AlpnNegotiated) <> 0, " over " & .AlpnNegotiated & " (ALPN)", vbNullString) & _ - IIf(LenB(.SniRequested) <> 0, " for " & .SniRequested & " (SNI)", vbNullString) - End If - #End If - .State = ucsTlsStatePostHandshake - Exit Do - Case SEC_I_INCOMPLETE_CREDENTIALS - If .ClientCertCallback <> 0 Then - hResult = QueryContextAttributes(.hTlsContext, SECPKG_ATTR_ISSUER_LIST_EX, uIssuerInfo) - If hResult < 0 Then - pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "QueryContextAttributes(SECPKG_ATTR_ISSUER_LIST_EX)", AlertCode:=.LastAlertCode - GoTo QH - End If - Set cIssuers = New Collection - If uIssuerInfo.cIssuers > 0 Then - ReDim uIssuerList(0 To uIssuerInfo.cIssuers - 1) As CRYPT_DATA_BLOB - Debug.Assert uIssuerInfo.aIssuers <> 0 - Call CopyMemory(uIssuerList(0), ByVal uIssuerInfo.aIssuers, uIssuerInfo.cIssuers * Len(uIssuerList(0))) - For lIdx = 0 To UBound(uIssuerList) - pvWriteBuffer baCaDn, 0, uIssuerList(lIdx).pbData, uIssuerList(lIdx).cbData - pvArrayReallocate baCaDn, uIssuerList(lIdx).cbData, FUNC_NAME & ".baCaDn" - cIssuers.Add baCaDn - Next - End If - Call vbaObjSetAddref(oCallback, .ClientCertCallback) - If oCallback.FireOnCertificate(cIssuers) Then - Call FreeCredentialsHandle(.hTlsCredentials) - .hTlsCredentials = 0 - End If - ElseIf (.ContextReq And ISC_REQ_USE_SUPPLIED_CREDS) = 0 Then - .ContextReq = .ContextReq Or ISC_REQ_USE_SUPPLIED_CREDS - End If - GoTo RetryCredentials - Case SEC_I_CONTEXT_EXPIRED - .State = ucsTlsStateShutdown - Exit Do - Case Else - pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME & vbCrLf & sApiSource, _ - Replace(Replace(ERR_UNEXPECTED_RESULT, "%1", sApiSource), "%2", "&H" & Hex$(hResult)), AlertCode:=.LastAlertCode - GoTo QH - End Select - If .RecvPos = 0 Then - Exit Do - End If - End If - Loop - End With - '--- success - TlsHandshake = True -QH: - If pCertContext <> 0 Then - Call CertFreeCertificateContext(pCertContext) - End If - If LenB(sKeyName) Then - Call CryptAcquireContext(0, StrPtr(sKeyName), 0, PROV_RSA_FULL, CRYPT_DELETEKEYSET) - End If - Exit Function -EH: - pvTlsSetLastError uCtx, Err.Number, Err.Source, Err.Description - Resume QH -End Function - -Public Function TlsReceive(uCtx As UcsTlsContext, baInput() As Byte, ByVal lSize As Long, baPlainText() As Byte, lPos As Long, baOutput() As Byte, lOutputPos As Long) As Boolean - Const FUNC_NAME As String = "TlsReceive" - Dim hResult As Long - Dim lIdx As Long - Dim lPtr As Long - Dim baEmpty() As Byte - - On Error GoTo EH - With uCtx - If .State = ucsTlsStateClosed Then - pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME, ERR_CONNECTION_CLOSED - GoTo QH - End If - pvTlsClearLastError uCtx - If lSize < 0 Then - lSize = pvArraySize(baInput) - End If - If lSize > 0 Then - .RecvPos = pvWriteBuffer(.RecvBuffer, .RecvPos, VarPtr(baInput(0)), lSize) - End If - Do - If .RecvPos > 0 Then - lPtr = VarPtr(.RecvBuffer(0)) - #If (ImplCaptureTraffic And 1) <> 0 Then - .TrafficDump.Add FUNC_NAME & ".Input" & vbCrLf & TlsDesignDumpArray(.RecvBuffer, 0, .RecvPos) - #End If - Else - lPtr = VarPtr(.RecvPos) - End If - pvInitSecBuffer .InBuffers(0), SECBUFFER_DATA, lPtr, .RecvPos - hResult = DecryptMessage(.hTlsContext, .InDesc, 0, 0) - If hResult = SEC_E_INCOMPLETE_MESSAGE Then - pvInitSecBuffer .InBuffers(1), SECBUFFER_EMPTY - Exit Do - ElseIf hResult = SEC_E_INVALID_HANDLE And .RecvPos = 0 Then - '--- session on hTlsContext already closed so don't call pvTlsSetLastError - Exit Do - ElseIf hResult < 0 Then - pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "DecryptMessage" - GoTo QH - End If - .RecvPos = 0 - For lIdx = 1 To UBound(.InBuffers) - With .InBuffers(lIdx) - If .cbBuffer > 0 Then - Select Case .BufferType - Case SECBUFFER_DATA - lPos = pvWriteBuffer(baPlainText, lPos, .pvBuffer, .cbBuffer) - Case SECBUFFER_EXTRA - lPtr = .pvBuffer - If lPtr = 0 Then - lPtr = VarPtr(uCtx.RecvBuffer(uCtx.InBuffers(0).cbBuffer - .cbBuffer)) - End If - uCtx.RecvPos = pvWriteBuffer(uCtx.RecvBuffer, uCtx.RecvPos, lPtr, .cbBuffer) - Case SECBUFFER_ALERT - #If ImplUseDebugLog Then - DebugLog MODULE_NAME, FUNC_NAME, "InBuffers, SECBUFFER_ALERT:" & vbCrLf & TlsDesignDumpMemory(.pvBuffer, .cbBuffer), vbLogEventTypeWarning - #End If - Case SECBUFFER_STREAM_HEADER, SECBUFFER_STREAM_TRAILER - '--- do nothing - Case Else - #If ImplUseDebugLog Then - DebugLog MODULE_NAME, FUNC_NAME, ".BufferType(" & lIdx & ")=" & .BufferType - #End If - End Select - End If - End With - pvInitSecBuffer .InBuffers(lIdx), SECBUFFER_EMPTY - Next - Select Case hResult - Case SEC_E_OK - '--- do nothing - Case SEC_I_RENEGOTIATE - .State = ucsTlsStateHandshakeStart - '--- .RecvBuffer is populated already - If Not TlsHandshake(uCtx, baEmpty, 0, baOutput, lOutputPos) Then - GoTo QH - End If - Case SEC_I_CONTEXT_EXPIRED - .State = ucsTlsStateShutdown - Exit Do - Case Else - pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "DecryptMessage", _ - Replace(Replace(ERR_UNEXPECTED_RESULT, "%1", "DecryptMessage"), "%2", "&H" & Hex$(hResult)) - GoTo QH - End Select - If .RecvPos = 0 Then - Exit Do - End If - Loop - End With - '--- success - TlsReceive = True -QH: - Exit Function -EH: - pvTlsSetLastError uCtx, Err.Number, Err.Source, Err.Description - Resume QH -End Function - -Public Function TlsSend(uCtx As UcsTlsContext, baPlainText() As Byte, ByVal lSize As Long, baOutput() As Byte, lOutputPos As Long) As Boolean - Const FUNC_NAME As String = "TlsSend" - Dim hResult As Long - Dim lBufPos As Long - Dim lBufSize As Long - Dim lPos As Long - Dim lIdx As Long - - On Error GoTo EH - With uCtx - If .State = ucsTlsStateClosed Then - pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME, ERR_CONNECTION_CLOSED - GoTo QH - End If - pvTlsClearLastError uCtx - '--- figure out upper bound of total output and reserve space in baOutput - lIdx = (lSize + .TlsSizes.cbMaximumMessage - 1) \ .TlsSizes.cbMaximumMessage - pvWriteReserved baOutput, lOutputPos, .TlsSizes.cbHeader * lIdx + lSize + .TlsSizes.cbTrailer * lIdx - For lPos = 0 To lSize - 1 Step .TlsSizes.cbMaximumMessage - lBufPos = lOutputPos - lBufSize = lSize - lPos - If lBufSize > .TlsSizes.cbMaximumMessage Then - lBufSize = .TlsSizes.cbMaximumMessage - End If - pvWriteReserved baOutput, lOutputPos, .TlsSizes.cbHeader + lBufSize + .TlsSizes.cbTrailer - pvInitSecBuffer .InBuffers(0), SECBUFFER_STREAM_HEADER, VarPtr(baOutput(lBufPos)), .TlsSizes.cbHeader - lBufPos = lBufPos + .TlsSizes.cbHeader - Debug.Assert UBound(baPlainText) + 1 >= lPos + lBufSize - Call CopyMemory(baOutput(lBufPos), baPlainText(lPos), lBufSize) - pvInitSecBuffer .InBuffers(1), SECBUFFER_DATA, VarPtr(baOutput(lBufPos)), lBufSize - lBufPos = lBufPos + lBufSize - pvInitSecBuffer .InBuffers(2), SECBUFFER_STREAM_TRAILER, VarPtr(baOutput(lBufPos)), .TlsSizes.cbTrailer - For lIdx = 3 To UBound(.InBuffers) - pvInitSecBuffer .InBuffers(lIdx), SECBUFFER_EMPTY - Next - hResult = EncryptMessage(.hTlsContext, 0, .InDesc, 0) - If hResult < 0 Then - pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "EncryptMessage" - GoTo QH - End If - #If (ImplCaptureTraffic And 1) <> 0 Then - .TrafficDump.Add FUNC_NAME & ".Output" & vbCrLf & TlsDesignDumpArray(baOutput, lOutputPos, .InBuffers(0).cbBuffer + .InBuffers(1).cbBuffer + .InBuffers(2).cbBuffer) - #End If - '--- note: use cbBuffer's as returned by EncryptMessage because trailing MAC might be trimmed (shorter than initial .TlsSizes.cbTrailer) - lOutputPos = lOutputPos + .InBuffers(0).cbBuffer + .InBuffers(1).cbBuffer + .InBuffers(2).cbBuffer - For lIdx = 1 To UBound(.InBuffers) - With .InBuffers(lIdx) - If .cbBuffer > 0 Then - Select Case .BufferType - Case SECBUFFER_ALERT - #If ImplUseDebugLog Then - DebugLog MODULE_NAME, FUNC_NAME, "InBuffers, SECBUFFER_ALERT:" & vbCrLf & TlsDesignDumpMemory(.pvBuffer, .cbBuffer), vbLogEventTypeWarning - #End If - Case SECBUFFER_DATA, SECBUFFER_STREAM_HEADER, SECBUFFER_STREAM_TRAILER - '--- do nothing - Case Else - #If ImplUseDebugLog Then - DebugLog MODULE_NAME, FUNC_NAME, ".BufferType(" & lIdx & ")=" & .BufferType - #End If - End Select - End If - End With - pvInitSecBuffer .InBuffers(lIdx), SECBUFFER_EMPTY - Next - Select Case hResult - Case SEC_E_OK - '--- do nothing - Case Else - pvTlsSetLastError uCtx, vbObjectError, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "EncryptMessage", _ - Replace(Replace(ERR_UNEXPECTED_RESULT, "%1", "EncryptMessage"), "%2", "&H" & Hex$(hResult)) - GoTo QH - End Select - Next - End With - '--- success - TlsSend = True -QH: - Exit Function -EH: - pvTlsSetLastError uCtx, Err.Number, Err.Source, Err.Description - Resume QH -End Function - -Public Function TlsShutdown(uCtx As UcsTlsContext, baOutput() As Byte, lPos As Long) As Boolean - Const FUNC_NAME As String = "pvTlsShutdown" - Dim lType As Long - Dim hResult As Long - Dim lIdx As Long - Dim sApiSource As String - Dim lContextAttr As Long - - On Error GoTo QH - With uCtx - If .State = ucsTlsStateClosed Or .State = ucsTlsStateShutdown Then - '--- success - TlsShutdown = True - GoTo QH - End If - lType = SCHANNEL_SHUTDOWN - pvInitSecBuffer .InBuffers(0), SECBUFFER_TOKEN, VarPtr(lType), 4 - '--- note: passing more than one input buffer fails w/ SEC_E_INVALID_TOKEN (&H80090308) - .InDesc.cBuffers = 1 - hResult = ApplyControlToken(.hTlsContext, .InDesc) - .InDesc.cBuffers = .TlsSizes.cBuffers - If hResult < 0 Then - pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & "ApplyControlToken" - GoTo QH - End If - pvInitSecBuffer .OutBuffers(0), SECBUFFER_TOKEN - For lIdx = 1 To UBound(.OutBuffers) - pvInitSecBuffer .OutBuffers(lIdx), SECBUFFER_EMPTY - Next - #If ImplTlsServer Then - If .IsServer Then - hResult = AcceptSecurityContext(.hTlsCredentials, VarPtr(.hTlsContext), ByVal 0, .ContextReq, _ - SECURITY_NATIVE_DREP, .hTlsContext, .OutDesc, lContextAttr, 0) - sApiSource = "AcceptSecurityContext" - Else - #End If - hResult = InitializeSecurityContext(.hTlsCredentials, VarPtr(.hTlsContext), StrPtr(.RemoteHostName), .ContextReq, 0, _ - SECURITY_NATIVE_DREP, ByVal 0, 0, .hTlsContext, .OutDesc, lContextAttr, 0) - sApiSource = "InitializeSecurityContext" - #If ImplTlsServer Then - End If - #End If - If hResult < 0 Then - pvTlsSetLastError uCtx, hResult, MODULE_NAME & "." & FUNC_NAME & vbCrLf & sApiSource - GoTo QH - End If - For lIdx = 0 To UBound(.OutBuffers) - With .OutBuffers(lIdx) - If .BufferType = SECBUFFER_TOKEN And .cbBuffer > 0 Then - #If (ImplCaptureTraffic And 1) <> 0 Then - uCtx.TrafficDump.Add FUNC_NAME & ".Output" & vbCrLf & TlsDesignDumpMemory(.pvBuffer, .cbBuffer) - #End If - lPos = pvWriteBuffer(baOutput, lPos, .pvBuffer, .cbBuffer) - End If - If .pvBuffer <> 0 Then - Call FreeContextBuffer(.pvBuffer) - Debug.Assert Err.LastDllError = 0 - .pvBuffer = 0 - End If - End With - Next - .State = ucsTlsStateShutdown - End With - '--- success - TlsShutdown = True -QH: - Exit Function -EH: - pvTlsSetLastError uCtx, Err.Number, Err.Source, Err.Description - Resume QH -End Function - -Public Function TlsGetLastError(uCtx As UcsTlsContext, Optional LastErrNumber As Long, Optional LastErrSource As String) As String - LastErrNumber = uCtx.LastErrNumber - LastErrSource = uCtx.LastErrSource - TlsGetLastError = uCtx.LastError - If uCtx.LastAlertCode <> -1 Then - TlsGetLastError = IIf(LenB(TlsGetLastError) <> 0, TlsGetLastError & ". ", vbNullString) & Replace(STR_FORMAT_ALERT, "%1", pvTlsGetLastAlert(uCtx)) - End If -End Function - -Private Sub pvTlsClearLastError(uCtx As UcsTlsContext) - With uCtx - .LastErrNumber = 0 - .LastErrSource = vbNullString - .LastError = vbNullString - .LastAlertCode = 0 - End With -End Sub - -Private Sub pvTlsSetLastError( _ - uCtx As UcsTlsContext, _ - Optional ByVal ErrNumber As Long, _ - Optional ErrSource As String, _ - Optional ErrDescription As String, _ - Optional ByVal AlertCode As Long = -1) - Const FUNC_NAME As String = "pvTlsSetLastError" - - With uCtx - .LastErrNumber = ErrNumber - .LastErrSource = ErrSource - .LastAlertCode = AlertCode - If ErrNumber <> 0 And LenB(ErrDescription) = 0 Then - uCtx.LastError = GetSystemMessage(ErrNumber) - If LenB(.LastError) = 0 Then - .LastError = "Error &H" & Hex$(ErrNumber) - End If - Else - .LastError = ErrDescription - End If - If Right$(.LastError, 2) = vbCrLf Then - .LastError = Left$(.LastError, Len(.LastError) - 2) - End If - If Right$(.LastError, 1) = "." Then - .LastError = Left$(.LastError, Len(.LastError) - 1) - End If - If Left$(.LastError, 16) = "Automation error" Then - .LastError = Mid$(.LastError, 17) - End If - If .LastErrNumber <> 0 Then - .State = ucsTlsStateClosed - End If - #If ImplCaptureTraffic <> 0 Then - Clipboard.Clear - Clipboard.SetText TlsConcatCollection(.TrafficDump, vbCrLf) - #If ImplUseDebugLog Then - DebugLog MODULE_NAME, FUNC_NAME, "Traffic dump copied to clipboard" - #End If - #End If - End With -End Sub - -Private Function pvTlsGetLastAlert(uCtx As UcsTlsContext, Optional AlertCode As Long) As String - Static vTexts As Variant - - AlertCode = uCtx.LastAlertCode - If AlertCode >= 0 Then - If IsEmpty(vTexts) Then - vTexts = SplitOrReindex(STR_VL_ALERTS, "|") - End If - If AlertCode <= UBound(vTexts) Then - pvTlsGetLastAlert = vTexts(AlertCode) - End If - If LenB(pvTlsGetLastAlert) = 0 Then - pvTlsGetLastAlert = Replace(STR_UNKNOWN, "%1", AlertCode) - End If - End If -End Function - -#If ImplUseDebugLog Then -Private Function pvTlsGetAlgName(ByVal lAlgId As Long) As String - Select Case lAlgId - Case &H20& - pvTlsGetAlgName = "SSL3_CLIENT" - Case &H80& - pvTlsGetAlgName = "TLS1_0_CLIENT" - Case &H200& - pvTlsGetAlgName = "TLS1_1_CLIENT" - Case &H800& - pvTlsGetAlgName = "TLS1_2_CLIENT" - Case &H2000& - pvTlsGetAlgName = "TLS1_3_CLIENT" - Case &H10& - pvTlsGetAlgName = "SSL3_SERVER" - Case &H40& - pvTlsGetAlgName = "TLS1_0_SERVER" - Case &H100& - pvTlsGetAlgName = "TLS1_1_SERVER" - Case &H400& - pvTlsGetAlgName = "TLS1_2_SERVER" - Case &H1000 - pvTlsGetAlgName = "TLS1_3_SERVER" - Case &H6602& - pvTlsGetAlgName = "RC2" - Case &H6801& - pvTlsGetAlgName = "RC4" - Case &H6601& - pvTlsGetAlgName = "DES" - Case &H6603& - pvTlsGetAlgName = "3DES" - Case &H660E& - pvTlsGetAlgName = "AES_128" - Case &H660F& - pvTlsGetAlgName = "AES_192" - Case &H6610& - pvTlsGetAlgName = "AES_256" - Case &H8001& - pvTlsGetAlgName = "MD2" - Case &H8003& - pvTlsGetAlgName = "MD5" - Case &H8004& - pvTlsGetAlgName = "SHA1" - Case &H800C& - pvTlsGetAlgName = "SHA_256" - Case &H800D& - pvTlsGetAlgName = "SHA_384" - Case &H800E& - pvTlsGetAlgName = "SHA_512" - Case &HA400& - pvTlsGetAlgName = "RSA_KEYX" - Case &H2400& - pvTlsGetAlgName = "RSA_SIGN" - Case &HAA02& - pvTlsGetAlgName = "DH_EPHEM" - Case &HAA05& - pvTlsGetAlgName = "ECDH" - Case &HAE06& - pvTlsGetAlgName = "ECDH_EPHEM" - Case Else - pvTlsGetAlgName = "&H" & Hex$(lAlgId) - End Select -End Function -#End If - -Private Function pvTlsBuildAlpnBuffer(baOutput() As Byte, ByVal lPos As Long, sAlpnProtocols As String) As Long - Dim vElem As Variant - Dim sProtocol As String - Dim lSize As Long - - lPos = pvWriteReserved(baOutput, 0, 4) - lPos = pvWriteBuffer(baOutput, lPos, VarPtr(SecApplicationProtocolNegotiationExt_ALPN), 4) - lPos = pvWriteReserved(baOutput, lPos, 2) - For Each vElem In Split(sAlpnProtocols, "|") - vElem = Left$(vElem, 255) - lSize = Len(vElem) - lPos = pvWriteBuffer(baOutput, lPos, VarPtr(lSize), 1) - sProtocol = StrConv(vElem, vbFromUnicode) - lPos = pvWriteBuffer(baOutput, lPos, StrPtr(sProtocol), Len(vElem)) - Next - pvWriteBuffer baOutput, 8, VarPtr(lPos - 10), 2 - pvWriteBuffer baOutput, 0, VarPtr(lPos - 4), 4 - pvTlsBuildAlpnBuffer = lPos -End Function - -Private Function pvTlsParseHandshakeClientHello(uCtx As UcsTlsContext, baInput() As Byte, ByVal lPos As Long) As Long - Const TLS_CONTENT_TYPE_HANDSHAKE As Long = 22 - Const TLS_HANDSHAKE_TYPE_CLIENT_HELLO As Long = 1 - Dim lValue As Long - Dim lSize As Long - Dim lEnd As Long - Dim baTemp() As Byte - Dim lExtType As Long - Dim lExtSize As Long - Dim lNamePos As Long - Dim lNameType As Long - Dim lNameSize As Long - - lPos = pvReadLong(baInput, lPos, lValue) '--- content type - If lValue <> TLS_CONTENT_TYPE_HANDSHAKE Then - GoTo QH - End If - lPos = pvReadLong(baInput, lPos, lValue, Size:=2) '--- protocol version - lPos = lPos + 2 '--- skip handshake message size - lPos = pvReadLong(baInput, lPos, lValue) '--- handshake type - If lValue <> TLS_HANDSHAKE_TYPE_CLIENT_HELLO Then - GoTo QH - End If - lPos = lPos + 3 '--- skip size of client hello - lPos = lPos + 2 '--- skip Client Version - lPos = lPos + 32 '--- skip Client Random - lPos = pvReadLong(baInput, lPos, lSize, Size:=1) '--- skip Session ID - lPos = lPos + lSize - lPos = pvReadLong(baInput, lPos, lSize, Size:=2) '--- skip Cipher Suites - lPos = lPos + lSize - lPos = pvReadLong(baInput, lPos, lSize, Size:=1) '--- skip Compression Methods - lPos = lPos + lSize - lPos = pvReadLong(baInput, lPos, lSize, Size:=2) '--- size of Extensions - lEnd = lPos + lSize - Do While lPos < lEnd And lPos <= UBound(baInput) - lPos = pvReadLong(baInput, lPos, lExtType, Size:=2) - lPos = pvReadLong(baInput, lPos, lExtSize, Size:=2) - Select Case lExtType - Case 0 '--- Extension -- Server Name - lNamePos = pvReadLong(baInput, lPos, lValue, Size:=2) - Do While lNamePos < lPos + lValue - lNamePos = pvReadLong(baInput, lNamePos, lNameType, Size:=1) - lNamePos = pvReadLong(baInput, lNamePos, lNameSize, Size:=2) - If lNameType = 0 Then '--- FQDN - lNamePos = pvReadArray(baInput, lNamePos, baTemp, lNameSize) - uCtx.SniRequested = StrConv(baTemp, vbUnicode) - Else - lNamePos = lNamePos + lNameSize - End If - Loop - End Select - lPos = lPos + lExtSize - Loop -QH: - pvTlsParseHandshakeClientHello = lPos -End Function - -Private Function pvTlsImportToCertStore(cCerts As Collection, cPrivKey As Collection, sOutKeyName As String, pOutCertContext As Long) As Boolean - Const FUNC_NAME As String = "pvTlsImportToCertStore" - Const IDX_KEYNAME As Long = 1 - Const IDX_PROVNAME As Long = 2 - Const IDX_PROVTYPE As Long = 3 - Const IDX_KEYSPEC As Long = 4 - Dim hCertStore As Long - Dim lIdx As Long - Dim baCert() As Byte - Dim pCertContext As Long - Dim baPrivKey() As Byte - Dim sProvName As String - Dim sKeyName As String - Dim hProv As Long - Dim hKey As Long - Dim lPtr As Long - Dim uPrivKeyInfo As UcsKeyInfo - Dim uPublicKeyInfo As CERT_PUBLIC_KEY_INFO - Dim uProvInfo As CRYPT_KEY_PROV_INFO - Dim uEccBlob As BCRYPT_ECCKEY_BLOB - Dim lBlobSize As Long - Dim hNProv As Long - Dim hNKey As Long - Dim uDesc As ApiSecBufferDesc - Dim uBuffers() As ApiSecBuffer - Dim hResult As Long - Dim sApiSource As String - - '--- load server X.509 certificates to an in-memory certificate store - hCertStore = CertOpenStore(CERT_STORE_PROV_MEMORY, 0, 0, CERT_STORE_CREATE_NEW_FLAG, 0) - If hCertStore = 0 Then - hResult = Err.LastDllError - sApiSource = "CertOpenStore" - GoTo QH - End If - For lIdx = 1 To pvCollectionCount(cCerts) - baCert = cCerts.Item(lIdx) - If CertAddEncodedCertificateToStore(hCertStore, X509_ASN_ENCODING, baCert(0), UBound(baCert) + 1, CERT_STORE_ADD_USE_EXISTING, IIf(lIdx = 1, VarPtr(pCertContext), 0)) = 0 Then - hResult = Err.LastDllError - sApiSource = "CertAddEncodedCertificateToStore" - GoTo QH - End If - Next - If pCertContext <> 0 Then - If cPrivKey.Count > 1 Then - With cPrivKey - sKeyName = .Item(IDX_KEYNAME) - sProvName = .Item(IDX_PROVNAME) - uProvInfo.pwszContainerName = StrPtr(sKeyName) - uProvInfo.pwszProvName = StrPtr(sProvName) - If .Count > IDX_PROVNAME Then - uProvInfo.dwProvType = .Item(IDX_PROVTYPE) - uProvInfo.dwKeySpec = .Item(IDX_KEYSPEC) - End If - End With - ElseIf SearchCollection(cPrivKey, 1, RetVal:=baPrivKey) Then - sKeyName = "VbAsyncSocket" & pvGetRandomString() - If Not pvAsn1DecodePrivateKey(baPrivKey, uPrivKeyInfo) Then - GoTo QH - End If - Call CopyMemory(lPtr, ByVal UnsignedAdd(pCertContext, 12), 4) '--- dereference pCertContext->pCertInfo - lPtr = UnsignedAdd(lPtr, 56) '--- &pCertContext->pCertInfo->SubjectPublicKeyInfo - Call CopyMemory(uPublicKeyInfo, ByVal lPtr, Len(uPublicKeyInfo)) - Select Case pvToStringA(uPublicKeyInfo.Algorithm.pszObjId) - Case szOID_RSA_RSA - uProvInfo.pwszContainerName = StrPtr(sKeyName) - uProvInfo.dwProvType = PROV_RSA_FULL - uProvInfo.dwKeySpec = AT_KEYEXCHANGE - If CryptAcquireContext(hProv, uProvInfo.pwszContainerName, uProvInfo.pwszProvName, uProvInfo.dwProvType, uProvInfo.dwFlags) = 0 Then - If CryptAcquireContext(hProv, uProvInfo.pwszContainerName, uProvInfo.pwszProvName, uProvInfo.dwProvType, uProvInfo.dwFlags Or CRYPT_NEWKEYSET) = 0 Then - hResult = Err.LastDllError - sApiSource = "CryptAcquireContext" - GoTo QH - End If - sOutKeyName = sKeyName - End If - If CryptImportKey(hProv, uPrivKeyInfo.KeyBlob(0), UBound(uPrivKeyInfo.KeyBlob) + 1, 0, 0, hKey) = 0 Then - hResult = Err.LastDllError - sApiSource = "CryptImportKey" - GoTo QH - End If - Case szOID_ECC_PUBLIC_KEY - Select Case uPrivKeyInfo.AlgoObjId - Case szOID_ECC_CURVE_P256 - uEccBlob.dwMagic = BCRYPT_ECDSA_PRIVATE_P256_MAGIC - Case szOID_ECC_CURVE_P384 - uEccBlob.dwMagic = BCRYPT_ECDSA_PRIVATE_P384_MAGIC - Case szOID_ECC_CURVE_P521 - uEccBlob.dwMagic = BCRYPT_ECDSA_PRIVATE_P521_MAGIC - Case Else - ErrRaise vbObjectError, , Replace(ERR_UNKNOWN_ECC_PRIVKEY, "%1", uPrivKeyInfo.AlgoObjId) - End Select - lBlobSize = uPublicKeyInfo.PublicKey.cbData - 1 - uEccBlob.cbKey = UBound(uPrivKeyInfo.KeyBlob) + 1 - Call CopyMemory(uEccBlob.Buffer(0), ByVal UnsignedAdd(uPublicKeyInfo.PublicKey.pbData, 1), lBlobSize) - Call CopyMemory(uEccBlob.Buffer(lBlobSize), uPrivKeyInfo.KeyBlob(0), uEccBlob.cbKey) - lBlobSize = 8 + lBlobSize + uEccBlob.cbKey - '--- import key - uProvInfo.pwszContainerName = StrPtr(sKeyName) - uProvInfo.pwszProvName = StrPtr(MS_KEY_STORAGE_PROVIDER) - hResult = NCryptOpenStorageProvider(hNProv, uProvInfo.pwszProvName, 0) - If hResult < 0 Then - sApiSource = "NCryptOpenStorageProvider" - GoTo QH - End If - pvInitSecDesc uDesc, 1, uBuffers - pvInitSecBuffer uBuffers(0), NCRYPTBUFFER_PKCS_KEY_NAME, StrPtr(sKeyName), LenB(sKeyName) + 2 - hResult = NCryptImportKey(hNProv, 0, StrPtr("ECCPRIVATEBLOB"), uDesc, hNKey, uEccBlob, lBlobSize, NCRYPT_OVERWRITE_KEY_FLAG) - If hResult < 0 Then - sApiSource = "NCryptImportKey" - GoTo QH - End If - Case Else - ErrRaise vbObjectError, , Replace(ERR_UNKNOWN_PUBKEY, "%1", pvToStringA(uPublicKeyInfo.Algorithm.pszObjId)) - End Select - End If - If CertSetCertificateContextProperty(pCertContext, CERT_KEY_PROV_INFO_PROP_ID, 0, uProvInfo) = 0 Then - hResult = Err.LastDllError - sApiSource = "CertSetCertificateContextProperty" - GoTo QH - End If - pOutCertContext = pCertContext - pCertContext = 0 - End If - '--- success - pvTlsImportToCertStore = True -QH: - If hNKey <> 0 Then - Call NCryptFreeObject(hNKey) - End If - If hNProv <> 0 Then - Call NCryptFreeObject(hNProv) - End If - If hKey <> 0 Then - Call CryptDestroyKey(hKey) - End If - If hProv <> 0 Then - Call CryptReleaseContext(hProv, 0) - End If - If pCertContext <> 0 Then - Call CertFreeCertificateContext(pCertContext) - End If - If hCertStore <> 0 Then - Call CertCloseStore(hCertStore, 0) - End If - If LenB(sApiSource) <> 0 Then - ErrRaise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), FUNC_NAME & "." & sApiSource - End If -End Function - -Private Function pvTlsExportFromCertStore(ByVal hCertStore As Long, cCerts As Collection, cStatuses As Collection) As Boolean - Const FUNC_NAME As String = "pvTlsExportFromCertStore" - Dim uCertContext As CERT_CONTEXT - Dim baCert() As Byte - Dim pCertContext As Long - Dim lSize As Long - Dim hResult As Long - Dim sApiSource As String - - '--- export server X.509 certificates from certificate store - Set cCerts = New Collection - Set cStatuses = New Collection - Do - pCertContext = CertEnumCertificatesInStore(hCertStore, pCertContext) - If pCertContext = 0 Then - Exit Do - End If - Call CopyMemory(uCertContext, ByVal pCertContext, Len(uCertContext)) - pvWriteBuffer baCert, 0, uCertContext.pbCertEncoded, uCertContext.cbCertEncoded - pvArrayReallocate baCert, uCertContext.cbCertEncoded, FUNC_NAME & ".baCert" - cCerts.Add baCert - '--- collect OCSP response - If CertGetCertificateContextProperty(pCertContext, CERT_OCSP_RESPONSE_PROP_ID, ByVal 0, lSize) <> 0 And lSize > 0 Then - pvArrayReallocate baCert, lSize, FUNC_NAME & ".baCert" - If CertGetCertificateContextProperty(pCertContext, CERT_OCSP_RESPONSE_PROP_ID, baCert(0), lSize) = 0 Then - hResult = Err.LastDllError - sApiSource = "CertGetCertificateContextProperty" - GoTo QH - End If - cStatuses.Add baCert - End If - Loop - '--- success - pvTlsExportFromCertStore = True -QH: - If LenB(sApiSource) <> 0 Then - ErrRaise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), FUNC_NAME & "." & sApiSource - End If -End Function - -Private Function pvAsn1DecodePrivateKey(baPrivKey() As Byte, uRetVal As UcsKeyInfo) As Boolean - Const FUNC_NAME As String = "pvAsn1DecodePrivateKey" - Dim lPkiPtr As Long - Dim uPrivKey As CRYPT_PRIVATE_KEY_INFO - Dim lKeyPtr As Long - Dim lKeySize As Long - Dim lSize As Long - Dim uEccKeyInfo As CRYPT_ECC_PRIVATE_KEY_INFO - Dim hResult As Long - Dim sApiSource As String - - If CryptDecodeObjectEx(X509_ASN_ENCODING Or PKCS_7_ASN_ENCODING, PKCS_PRIVATE_KEY_INFO, baPrivKey(0), UBound(baPrivKey) + 1, CRYPT_DECODE_ALLOC_FLAG Or CRYPT_DECODE_NOCOPY_FLAG, 0, lPkiPtr, 0) <> 0 Then - Debug.Assert lPkiPtr <> 0 - Call CopyMemory(uPrivKey, ByVal lPkiPtr, Len(uPrivKey)) - If CryptDecodeObjectEx(X509_ASN_ENCODING Or PKCS_7_ASN_ENCODING, PKCS_RSA_PRIVATE_KEY, ByVal uPrivKey.PrivateKey.pbData, uPrivKey.PrivateKey.cbData, CRYPT_DECODE_ALLOC_FLAG Or CRYPT_DECODE_NOCOPY_FLAG, 0, lKeyPtr, lKeySize) = 0 Then - hResult = Err.LastDllError - sApiSource = "CryptDecodeObjectEx(PKCS_RSA_PRIVATE_KEY)" - GoTo QH - End If - uRetVal.AlgoObjId = pvToStringA(uPrivKey.Algorithm.pszObjId) - GoTo DecodeRsa - ElseIf CryptDecodeObjectEx(X509_ASN_ENCODING Or PKCS_7_ASN_ENCODING, PKCS_RSA_PRIVATE_KEY, baPrivKey(0), UBound(baPrivKey) + 1, CRYPT_DECODE_ALLOC_FLAG Or CRYPT_DECODE_NOCOPY_FLAG, 0, lKeyPtr, lKeySize) <> 0 Then - uRetVal.AlgoObjId = szOID_RSA_RSA -DecodeRsa: - pvArrayAllocate uRetVal.KeyBlob, lKeySize, FUNC_NAME & ".uRetVal.KeyBlob" - Debug.Assert lKeyPtr <> 0 - Call CopyMemory(uRetVal.KeyBlob(0), ByVal lKeyPtr, lKeySize) - Debug.Assert UBound(uRetVal.KeyBlob) + 1 >= 16 - Call CopyMemory(uRetVal.BitLen, uRetVal.KeyBlob(12), 4) - ElseIf CryptDecodeObjectEx(X509_ASN_ENCODING Or PKCS_7_ASN_ENCODING, X509_ECC_PRIVATE_KEY, baPrivKey(0), UBound(baPrivKey) + 1, CRYPT_DECODE_ALLOC_FLAG Or CRYPT_DECODE_NOCOPY_FLAG, 0, lKeyPtr, 0) <> 0 Then - Debug.Assert lKeyPtr <> 0 - Call CopyMemory(uEccKeyInfo, ByVal lKeyPtr, Len(uEccKeyInfo)) - uRetVal.AlgoObjId = pvToStringA(uEccKeyInfo.szCurveOid) - pvArrayAllocate uRetVal.KeyBlob, uEccKeyInfo.PrivateKey.cbData, FUNC_NAME & ".uRetVal.KeyBlob" - Debug.Assert uEccKeyInfo.PrivateKey.pbData <> 0 - Call CopyMemory(uRetVal.KeyBlob(0), ByVal uEccKeyInfo.PrivateKey.pbData, uEccKeyInfo.PrivateKey.cbData) - ElseIf Err.LastDllError = ERROR_FILE_NOT_FOUND Then - '--- no X509_ECC_PRIVATE_KEY struct type on NT4 -> decode in a wildly speculative way - Call CopyMemory(lSize, baPrivKey(6), 1) - If 7 + lSize <= UBound(baPrivKey) Then - uRetVal.AlgoObjId = szOID_ECC_CURVE_P256 - pvArrayAllocate uRetVal.KeyBlob, lSize, FUNC_NAME & ".uRetVal.KeyBlob" - Call CopyMemory(uRetVal.KeyBlob(0), baPrivKey(7), lSize) - Else - hResult = ERROR_FILE_NOT_FOUND - sApiSource = "CryptDecodeObjectEx(X509_ECC_PRIVATE_KEY)" - GoTo QH - End If - Else - hResult = Err.LastDllError - sApiSource = "CryptDecodeObjectEx(X509_ECC_PRIVATE_KEY)" - GoTo QH - End If - '--- success - pvAsn1DecodePrivateKey = True -QH: - If lKeyPtr <> 0 Then - Call LocalFree(lKeyPtr) - End If - If lPkiPtr <> 0 Then - Call LocalFree(lPkiPtr) - End If - If LenB(sApiSource) <> 0 Then - ErrRaise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), FUNC_NAME & "." & sApiSource - End If -End Function - -Private Sub pvArrayAllocate(baRetVal() As Byte, ByVal lSize As Long, sFuncName As String) - If lSize > 0 Then - ReDim baRetVal(0 To lSize - 1) As Byte - Else - baRetVal = vbNullString - End If - Debug.Assert RedimStats(MODULE_NAME & "." & sFuncName, lSize) -End Sub - -Private Sub pvArrayReallocate(baArray() As Byte, ByVal lSize As Long, sFuncName As String) - If lSize > 0 Then - ReDim Preserve baArray(0 To lSize - 1) As Byte - Else - baArray = vbNullString - End If - Debug.Assert RedimStats(MODULE_NAME & "." & sFuncName, lSize) -End Sub - -Private Property Get pvArraySize(baArray() As Byte) As Long - Dim lPtr As Long - - '--- peek long at ArrPtr(baArray) - Call CopyMemory(lPtr, ByVal ArrPtr(baArray), 4) - If lPtr <> 0 Then - pvArraySize = UBound(baArray) + 1 - End If -End Property - -Private Function pvWriteReserved(baBuffer() As Byte, ByVal lPos As Long, ByVal lSize As Long) As Long - pvWriteReserved = pvWriteBuffer(baBuffer, lPos, 0, lSize) -End Function - -Private Function pvWriteBuffer(baBuffer() As Byte, ByVal lPos As Long, ByVal lPtr As Long, ByVal lSize As Long) As Long - Const FUNC_NAME As String = "pvWriteBuffer" - Dim lBufPtr As Long - - '--- peek long at ArrPtr(baBuffer) - Call CopyMemory(lBufPtr, ByVal ArrPtr(baBuffer), 4) - If lBufPtr = 0 Then - pvArrayAllocate baBuffer, lPos + lSize, FUNC_NAME & ".baBuffer" - ElseIf UBound(baBuffer) < lPos + lSize - 1 Then - pvArrayReallocate baBuffer, lPos + lSize, FUNC_NAME & ".baRetVal" - End If - If lSize > 0 And lPtr <> 0 Then - Debug.Assert IsBadReadPtr(lPtr, lSize) = 0 - Call CopyMemory(baBuffer(lPos), ByVal lPtr, lSize) - End If - pvWriteBuffer = lPos + lSize -End Function - -Private Function pvReadLong(baBuffer() As Byte, ByVal lPos As Long, lValue As Long, Optional ByVal Size As Long = 1) As Long - Static baTemp(0 To 3) As Byte - - If lPos + Size <= pvArraySize(baBuffer) Then - If Size <= 1 Then - lValue = baBuffer(lPos) - Else - baTemp(Size - 1) = baBuffer(lPos + 0) - baTemp(Size - 2) = baBuffer(lPos + 1) - If Size >= 3 Then baTemp(Size - 3) = baBuffer(lPos + 2) - If Size >= 4 Then baTemp(Size - 4) = baBuffer(lPos + 3) - Call CopyMemory(lValue, baTemp(0), Size) - End If - Else - lValue = 0 - End If - pvReadLong = lPos + Size -End Function - -Private Function pvReadArray(baBuffer() As Byte, ByVal lPos As Long, baDest() As Byte, ByVal lSize As Long) As Long - Const FUNC_NAME As String = "pvReadArray" - - If lSize < 0 Then - lSize = pvArraySize(baBuffer) - lPos - End If - If lSize > 0 Then - pvArrayAllocate baDest, lSize, FUNC_NAME & ".baDest" - If lPos + lSize <= pvArraySize(baBuffer) Then - Call CopyMemory(baDest(0), baBuffer(lPos), lSize) - ElseIf lPos < pvArraySize(baBuffer) Then - Call CopyMemory(baDest(0), baBuffer(lPos), pvArraySize(baBuffer) - lPos) - End If - Else - Erase baDest - End If - pvReadArray = lPos + lSize -End Function - -'= Schannel buffers helpers ============================================== - -Private Sub pvInitSecDesc(uDesc As ApiSecBufferDesc, ByVal lCount As Long, uBuffers() As ApiSecBuffer) - ReDim uBuffers(0 To lCount - 1) - With uDesc - .ulVersion = SECBUFFER_VERSION - .cBuffers = lCount - .pBuffers = VarPtr(uBuffers(0)) - End With -End Sub - -Private Sub pvInitSecBuffer(uBuffer As ApiSecBuffer, ByVal lType As Long, Optional ByVal lPtr As Long, Optional ByVal lSize As Long) - With uBuffer - .BufferType = lType - .pvBuffer = lPtr - .cbBuffer = lSize - End With -End Sub - -Private Function pvToStringA(ByVal lPtr As Long) As String - If lPtr <> 0 Then - pvToStringA = String$(lstrlenA(lPtr), 0) - Call CopyMemory(ByVal pvToStringA, ByVal lPtr, Len(pvToStringA)) - End If -End Function - -#If ImplUseDebugLog Then -Private Function pvToStringW(ByVal lPtr As Long) As String - If lPtr <> 0 Then - pvToStringW = String$(lstrlenW(lPtr), 0) - Call CopyMemory(ByVal StrPtr(pvToStringW), ByVal lPtr, LenB(pvToStringW)) - End If -End Function -#End If - -Private Function pvCollectionCount(oCol As Collection) As Long - If Not oCol Is Nothing Then - pvCollectionCount = oCol.Count - End If -End Function - -Private Function pvGetRandomString(Optional Size As Long = 16, Optional Delimiter As String) As String - Dim baBuffer() As Byte - Dim aText() As String - Dim lIdx As Long - - ReDim baBuffer(0 To Size - 1) As Byte - Call RtlGenRandom(baBuffer(0), Size) - ReDim aText(0 To UBound(baBuffer)) As String - For lIdx = 0 To UBound(baBuffer) - aText(lIdx) = Right$("0" & Hex$(baBuffer(lIdx)), 2) - Next - pvGetRandomString = LCase$(Join(aText, Delimiter)) -End Function - -#If Not ImplUseShared Then -Public Function RedimStats(sFuncName As String, ByVal lSize As Long) As Boolean - #If sFuncName And lSize Then - #End If - RedimStats = True -End Function - -Public Sub RemoveCollection(ByVal oCol As Collection, Index As Variant) - If Not oCol Is Nothing Then - pvCallCollectionRemove oCol, Index - End If -End Sub - -Public Function SearchCollection(ByVal oCol As Collection, Index As Variant, Optional RetVal As Variant) As Boolean - Dim vItem As Variant - - If oCol Is Nothing Then - GoTo QH - ElseIf pvCallCollectionItem(oCol, Index, vItem) < 0 Then - GoTo QH - End If - If IsObject(vItem) Then - Set RetVal = vItem - Else - RetVal = vItem - End If - '--- success - SearchCollection = True -QH: -End Function - -Private Function pvCallCollectionItem(ByVal oCol As Collection, Index As Variant, Optional RetVal As Variant) As Long - Const IDX_COLLECTION_ITEM As Long = 7 - - pvPatchMethodTrampoline AddressOf mdTlsNative.pvCallCollectionItem, IDX_COLLECTION_ITEM - pvCallCollectionItem = pvCallCollectionItem(oCol, Index, RetVal) -End Function - -Private Function pvCallCollectionRemove(ByVal oCol As Collection, Index As Variant) As Long - Const IDX_COLLECTION_REMOVE As Long = 10 - - pvPatchMethodTrampoline AddressOf mdTlsNative.pvCallCollectionRemove, IDX_COLLECTION_REMOVE - pvCallCollectionRemove = pvCallCollectionRemove(oCol, Index) -End Function - -Private Function pvPatchMethodTrampoline(ByVal Pfn As Long, ByVal lMethodIdx As Long) As Boolean - Dim bInIDE As Boolean - - Debug.Assert pvSetTrue(bInIDE) - If bInIDE Then - '--- note: IDE is not large-address aware - Call CopyMemory(Pfn, ByVal Pfn + &H16, 4) - Else - Call VirtualProtect(Pfn, 12, PAGE_EXECUTE_READWRITE, 0) - End If - ' 0: 8B 44 24 04 mov eax,dword ptr [esp+4] - ' 4: 8B 00 mov eax,dword ptr [eax] - ' 6: FF A0 00 00 00 00 jmp dword ptr [eax+lMethodIdx*4] - Call CopyMemory(ByVal Pfn, -684575231150992.4725@, 8) - Call CopyMemory(ByVal (Pfn Xor &H80000000) + 8 Xor &H80000000, lMethodIdx * 4, 4) - '--- success - pvPatchMethodTrampoline = True -End Function - -Private Function pvSetTrue(bValue As Boolean) As Boolean - #If TWINBASIC = 0 Then - bValue = True - #End If - pvSetTrue = True -End Function - -Public Function FromBase64Array(sText As String) As Byte() - Const CRYPT_STRING_BASE64 As Long = 1 - Dim lSize As Long - Dim baOutput() As Byte - - On Error GoTo EH - lSize = Len(sText) + 1 - ReDim baOutput(0 To lSize - 1) As Byte - If CryptStringToBinary(StrPtr(sText), Len(sText), CRYPT_STRING_BASE64, VarPtr(baOutput(0)), lSize) <> 0 Then - If lSize > 0 Then - ReDim Preserve baOutput(0 To lSize - 1) As Byte - FromBase64Array = baOutput - Else - FromBase64Array = vbNullString - End If - Exit Function - End If -EH: - With CreateObject("MSXML2.DOMDocument").createElement("dummy") - .DataType = "bin.base64" - .Text = sText - If IsArray(.NodeTypedValue) Then - FromBase64Array = .NodeTypedValue - Else - FromBase64Array = vbNullString - End If - End With -End Function - -Private Function UnsignedAdd(ByVal lUnsignedPtr As Long, ByVal lSignedOffset As Long) As Long - '--- note: safely add *signed* offset to *unsigned* ptr for *unsigned* retval w/o overflow in LARGEADDRESSAWARE processes - UnsignedAdd = ((lUnsignedPtr Xor &H80000000) + lSignedOffset) Xor &H80000000 -End Function - -Private Function SplitOrReindex(Expression As String, Delimiter As String) As Variant - Dim vResult As Variant - Dim vTemp As Variant - Dim lIdx As Long - Dim lSize As Long - - vResult = Split(Expression, Delimiter) - '--- check if reindex needed - If IsNumeric(vResult(0)) Then - vTemp = vResult - For lIdx = 0 To UBound(vTemp) Step 2 - If lSize < vTemp(lIdx) Then - lSize = vTemp(lIdx) - End If - Next - ReDim vResult(0 To lSize) As Variant - Debug.Assert RedimStats(MODULE_NAME & ".SplitOrReindex.vResult", 0) - For lIdx = 0 To UBound(vTemp) Step 2 - vResult(vTemp(lIdx)) = vTemp(lIdx + 1) - Next - SplitOrReindex = vResult - End If -End Function - -Private Property Get RealOsVersion(Optional BuildNo As Long) As UcsOsVersionEnum - Static lVersion As Long - Static lBuildNo As Long - Dim baBuffer() As Byte - Dim lPtr As Long - Dim lSize As Long - Dim aVer(0 To 9) As Integer - - If lVersion = 0 Then - ReDim baBuffer(0 To 8192) As Byte - Call GetFileVersionInfo(StrPtr("kernel32.dll"), 0, UBound(baBuffer), baBuffer(0)) - Call VerQueryValue(baBuffer(0), StrPtr("\"), lPtr, lSize) - Call CopyMemory(aVer(0), ByVal lPtr, 20) - lVersion = aVer(9) * 100 + aVer(8) - lBuildNo = aVer(7) - End If - RealOsVersion = lVersion - BuildNo = lBuildNo -End Property - -Private Function GetSystemMessage(ByVal lLastDllError As Long) As String - Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000 - Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200 - Dim lSize As Long - - GetSystemMessage = String$(2000, 0) - lSize = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, lLastDllError, 0, StrPtr(GetSystemMessage), Len(GetSystemMessage), 0) - GetSystemMessage = Left$(GetSystemMessage, lSize) -End Function -#End If ' Not ImplUseShared - -Public Function TlsDesignDumpArray(baData() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As String - If Size < 0 Then - Size = UBound(baData) + 1 - Pos - End If - If Size > 0 Then - TlsDesignDumpArray = TlsDesignDumpMemory(VarPtr(baData(Pos)), Size) - End If -End Function - -Public Function TlsDesignDumpMemory(ByVal lPtr As Long, ByVal lSize As Long) As String - Dim lIdx As Long - Dim sHex As String - Dim sChar As String - Dim lValue As Long - Dim aResult() As String - - ReDim aResult(0 To (lSize + 15) \ 16) As String - Debug.Assert RedimStats("TlsDesignDumpMemory.aResult", UBound(aResult) + 1) - For lIdx = 0 To ((lSize + 15) \ 16) * 16 - If lIdx < lSize Then - If IsBadReadPtr(lPtr, 1) = 0 Then - Call CopyMemory(lValue, ByVal lPtr, 1) - sHex = sHex & Right$("0" & Hex$(lValue), 2) & " " - If lValue >= 32 Then - sChar = sChar & Chr$(lValue) - Else - sChar = sChar & "." - End If - Else - sHex = sHex & "?? " - sChar = sChar & "." - End If - Else - sHex = sHex & " " - End If - If ((lIdx + 1) Mod 4) = 0 Then - sHex = sHex & " " - End If - If ((lIdx + 1) Mod 16) = 0 Then - aResult(lIdx \ 16) = Right$("000" & Hex$(lIdx - 15), 4) & " - " & sHex & sChar - sHex = vbNullString - sChar = vbNullString - End If - lPtr = (lPtr Xor &H80000000) + 1 Xor &H80000000 - Next - TlsDesignDumpMemory = Join(aResult, vbCrLf) -End Function - -#If ImplCaptureTraffic <> 0 Then -Public Function TlsConcatCollection(oCol As Collection, Optional Separator As String = vbCrLf) As String - Dim lSize As Long - Dim vElem As Variant - - For Each vElem In oCol - lSize = lSize + Len(vElem) + Len(Separator) - Next - If lSize > 0 Then - TlsConcatCollection = String$(lSize - Len(Separator), 0) - lSize = 1 - For Each vElem In oCol - If lSize <= Len(TlsConcatCollection) Then - Mid$(TlsConcatCollection, lSize, Len(vElem) + Len(Separator)) = vElem & Separator - End If - lSize = lSize + Len(vElem) + Len(Separator) - Next - End If -End Function -#End If ' ImplCaptureTraffic - diff --git a/samples/Visual Basic 6.0/modLoader.bas b/samples/Visual Basic 6.0/modLoader.bas deleted file mode 100644 index 77b0b40dd9..0000000000 --- a/samples/Visual Basic 6.0/modLoader.bas +++ /dev/null @@ -1,1128 +0,0 @@ -Attribute VB_Name = "modLoader" -'[modLoader.bas] - -' // modLoader.bas - EXE (VB6) loader from memory -' // Krivous Anatoly Anatolevich (The trick), 2016 - -Option Explicit - -Public Enum MessagesID - MID_ERRORLOADINGCONST = 100 ' // Errors - MID_ERRORREADINGPROJECT = 101 ' - MID_ERRORCOPYINGFILE = 102 ' - MID_ERRORWIN32 = 103 ' - MID_ERROREXECUTELINE = 104 ' - MID_ERRORSTARTUPEXE = 105 ' - Project = 200 ' // Project resource ID - API_LIB_KERNEL32 = 300 ' // Library names - API_LIB_NTDLL = 350 ' - API_LIB_USER32 = 400 ' - MSG_LOADER_ERROR = 500 -End Enum - -Private Enum ERROR_MESSAGES - EM_NO_ERRORS - EM_UNABLE_TO_GET_NT_HEADERS - EM_INVALID_DATA_DIRECTORY - EM_UNABLE_TO_ALLOCATE_MEMORY - EM_UNABLE_TO_PROTECT_MEMORY - EM_LOADLIBRARY_FAILED - EM_PROCESS_INFORMATION_NOT_FOUND - EM_END -End Enum - -Private Type IMAGE_DOS_HEADER - e_magic_e_cblp As Long - e_cp As Integer - e_crlc As Integer - e_cparhdr As Integer - e_minalloc As Integer - e_maxalloc As Integer - e_ss As Integer - e_sp As Integer - e_csum As Integer - e_ip As Integer - e_cs As Integer - e_lfarlc As Integer - e_ovno As Integer - e_res(0 To 3) As Integer - e_oemid As Integer - e_oeminfo As Integer - e_res2(0 To 9) As Integer - e_lfanew As Long -End Type -Private Type IMAGE_DATA_DIRECTORY - VirtualAddress As Long - Size As Long -End Type -Private Type IMAGE_OPTIONAL_HEADER - Magic As Integer - MajorLinkerVersion As Byte - MinorLinkerVersion As Byte - SizeOfCode As Long - SizeOfInitializedData As Long - SizeOfUnitializedData As Long - AddressOfEntryPoint As Long - BaseOfCode As Long - BaseOfData As Long - ImageBase As Long - SectionAlignment As Long - FileAlignment As Long - MajorOperatingSystemVersion As Integer - MinorOperatingSystemVersion As Integer - MajorImageVersion As Integer - MinorImageVersion As Integer - MajorSubsystemVersion As Integer - MinorSubsystemVersion As Integer - W32VersionValue As Long - SizeOfImage As Long - SizeOfHeaders As Long - CheckSum As Long - SubSystem As Integer - DllCharacteristics As Integer - SizeOfStackReserve As Long - SizeOfStackCommit As Long - SizeOfHeapReserve As Long - SizeOfHeapCommit As Long - LoaderFlags As Long - NumberOfRvaAndSizes As Long - DataDirectory(15) As IMAGE_DATA_DIRECTORY -End Type -Private Type IMAGE_FILE_HEADER - Machine As Integer - NumberOfSections As Integer - TimeDateStamp As Long - PointerToSymbolTable As Long - NumberOfSymbols As Long - SizeOfOptionalHeader As Integer - Characteristics As Integer -End Type -Private Type IMAGE_NT_HEADERS - Signature As Long - FileHeader As IMAGE_FILE_HEADER - OptionalHeader As IMAGE_OPTIONAL_HEADER -End Type -Private Type IMAGE_SECTION_HEADER - SectionName(1) As Long - VirtualSize As Long - VirtualAddress As Long - SizeOfRawData As Long - PointerToRawData As Long - PointerToRelocations As Long - PointerToLinenumbers As Long - NumberOfRelocations As Integer - NumberOfLinenumbers As Integer - Characteristics As Long -End Type -Private Type IMAGE_IMPORT_DESCRIPTOR - Characteristics As Long - TimeDateStamp As Long - ForwarderChain As Long - pName As Long - FirstThunk As Long -End Type - -Private Type IMAGE_BASE_RELOCATION - VirtualAddress As Long - SizeOfBlock As Long -End Type - -Private Type UNICODE_STRING - Length As Integer - MaxLength As Integer - lpBuffer As Long -End Type -Private Type PROCESS_BASIC_INFORMATION - ExitStatus As Long - PebBaseAddress As Long - AffinityMask As Long - BasePriority As Long - UniqueProcessId As Long - InheritedFromUniqueProcessId As Long -End Type -Public Type LIST_ENTRY - Flink As Long - Blink As Long -End Type -Public Type PEB_LDR_DATA - Length As Long - Initialized As Long - SsHandle As Long - InLoadOrderModuleList As LIST_ENTRY - InMemoryOrderModuleList As LIST_ENTRY - InInitializationOrderModuleList As LIST_ENTRY -End Type -Public Type LDR_MODULE - InLoadOrderModuleList As LIST_ENTRY - InMemoryOrderModuleList As LIST_ENTRY - InInitOrderModuleList As LIST_ENTRY - BaseAddress As Long - EntryPoint As Long - SizeOfImage As Long - FullDllName As UNICODE_STRING - BaseDllName As UNICODE_STRING - Flags As Long - LoadCount As Integer - TlsIndex As Integer - HashTableEntry As LIST_ENTRY - TimeDateStamp As Long -End Type - -Private Type PEB - NotUsed As Long - Mutant As Long - ImageBaseAddress As Long - LoaderData As Long ' // Pointer to PEB_LDR_DATA - ProcessParameters As Long - ' // .... -End Type - -Private Const IMAGE_FILE_MACHINE_I386 As Long = &H14C -Private Const IMAGE_DOS_SIGNATURE As Long = &H5A4D -Private Const IMAGE_NT_SIGNATURE As Long = &H4550& -Private Const IMAGE_NT_OPTIONAL_HDR32_MAGIC As Long = &H10B& -Private Const IMAGE_FILE_RELOCS_STRIPPED As Long = &H1 -Private Const IMAGE_FILE_EXECUTABLE_IMAGE As Long = &H2 -Private Const IMAGE_FILE_32BIT_MACHINE As Long = &H100 -Private Const IMAGE_DIRECTORY_ENTRY_IMPORT As Long = 1 -Private Const IMAGE_DIRECTORY_ENTRY_BASERELOC As Long = 5 -Private Const IMAGE_SCN_MEM_EXECUTE As Long = &H20000000 -Private Const IMAGE_SCN_MEM_READ As Long = &H40000000 -Private Const IMAGE_SCN_MEM_WRITE As Long = &H80000000 -Private Const IMAGE_REL_BASED_HIGHLOW As Long = 3 -Private Const HEAP_NO_SERIALIZE As Long = &H1 -Private Const STATUS_SUCCESS As Long = 0 -Private Const STATUS_INFO_LENGTH_MISMATCH As Long = &HC0000004 -Private Const ProcessBasicInformation As Long = 0 - -'Private Declare Function SysAllocStringByteLen Lib "oleaut32.dll" (ByVal pszStrPtr As Long, ByVal length As Long) As Long - - -' // Obtain string from resource (it should be less or equal MAX_PATH) -Public Function ResGetString( _ - ByVal id As MessagesID) As Long - - Dim hInstance As Long - - ResGetString = llib.SysAllocStringLen(0, MAX_PATH) - - If ResGetString Then - - hInstance = llib.GetModuleHandle(ByVal 0&) - - If llib.LoadString(hInstance, id, ResGetString, MAX_PATH) = 0 Then llib.SysFreeString ResGetString: ResGetString = 0: Exit Function - If llib.SysReAllocString(ResGetString, ResGetString) = 0 Then llib.SysFreeString ResGetString: ResGetString = 0: Exit Function - - End If - - 'Dbg "ID: " & ID & ", Result: " & GetString - -End Function - -' // Run exe from project in memory -Public Function RunExeFromMemory(pFileInMemory As Long, dwSize As Long) As Boolean - Dim pFileData As Long - - ' // Alloc memory within top memory addresses - pFileData = llib.VirtualAlloc(ByVal 0&, dwSize, MEM_TOP_DOWN Or MEM_COMMIT, PAGE_READWRITE) - If pFileData = 0 Then Exit Function - - ' // Copy raw exe file to this memory - llib.CopyMemory ByVal pFileData, ByVal pFileInMemory, dwSize - - ' // Free decompressed project data - 'HeapFree GetProcessHeap(), HEAP_NO_SERIALIZE, pProjectData - 'pProjectData = 0 - - Dbg "pFileData = " & pFileData - - ' // Run exe from memory - RunExeFromMemory = RunExeFromMemoryEx(pFileData, True) - - ' ---------------------------------------------------- - ' // An error occurs - ' // Clean memory - - llib.VirtualFree ByVal pFileData, 0, MEM_RELEASE - -End Function - -' // Run EXE file by memory address -Private Function RunExeFromMemoryEx( _ - ByVal pExeData As Long, _ - ByVal IgnoreError As Boolean) As Boolean - Dim Length As Long: Dim pCode As Long - Dim pszMsg As Long: Dim pMsgTable As Long - Dim Index As Long: Dim pCurMsg As Long - - ' // Get size of shellcode - Length = GetAddr(AddressOf ENDSHELLLOADER) - GetAddr(AddressOf BEGINSHELLLOADER) - - ' // Alloc memory within top addresses - pCode = llib.VirtualAlloc(ByVal 0&, Length, MEM_TOP_DOWN Or MEM_COMMIT, PAGE_EXECUTE_READWRITE) - - ' // Copy shellcode to allocated memory - llib.CopyMemory ByVal pCode, ByVal GetAddr(AddressOf BEGINSHELLLOADER), Length - - Dbg "pCode = " & pCode - - Dbg "InitShellLoader" - - ' // Initialization of shellcode - If Not InitShellLoader(pCode) Then GoTo CleanUp - - Dbg "Splice" - - ' // Splice CallLoader function in order to call shellcode - Splice AddressOf CallLoader, pCode + GetAddr(AddressOf LoadExeFromMemory) - GetAddr(AddressOf BEGINSHELLLOADER) - - ' // Check ignore errors - If Not IgnoreError Then - - Dbg "VirtualAlloc" - - ' // Alloc memory for messages table - pMsgTable = llib.VirtualAlloc(ByVal 0&, 1024, MEM_TOP_DOWN Or MEM_COMMIT, PAGE_READWRITE) - If pMsgTable = 0 Then GoTo CleanUp - - ' // Skip pointers - pCurMsg = pMsgTable + EM_END * 4 - - For Index = 0 To EM_END - 1 - - Dbg "GetString" & Index - - ' // Load message string - pszMsg = ResGetString(MSG_LOADER_ERROR + Index) - If pszMsg = 0 Then GoTo CleanUp - - Length = llib.SysStringLen(pszMsg) - - llib.lstrcpyn ByVal pCurMsg, ByVal pszMsg, Length + 1 - - ' // Store pointer - llib.CopyMemory ByVal pMsgTable + Index * 4, pCurMsg, Len(pCurMsg) - - ' // Next message offset - pCurMsg = pCurMsg + (Length + 1) * 2 - - llib.SysFreeString pszMsg - - Next - - End If - - Dbg "CallLoader: pExeData = " & CStr(pExeData) - - ' // Call shellcode - CallLoader pExeData, pCode, pMsgTable - -CleanUp: - - If pMsgTable Then - llib.VirtualFree ByVal pMsgTable, 0, MEM_RELEASE - End If - - If pCode Then - llib.VirtualFree ByVal pCode, 0, MEM_RELEASE - End If - -End Function - -' // Shellcode initialization -Private Function InitShellLoader( _ - ByVal pShellCode As Long) As Boolean - Dim hLib As Long: Dim sName As Long - Dim sFunc As Long: Dim lpAddr As Long - Dim libIdx As Long: Dim fncIdx As Long - Dim libName As MessagesID ': Dim fncName As MessagesID - Dim fncSpc As Long: Dim splAddr As Long - - ' // +----------------------------------------------------------------+ - ' // | Fixing of API addresses | - ' // +----------------------------------------------------------------+ - ' // | In order to call api function from shellcode i use splicing of | - ' // | our VB functions and redirect call to corresponding api. | - ' // | I did same in the code that injects to other process. | - ' // +----------------------------------------------------------------+ - - splAddr = GetAddr(AddressOf tVirtualAlloc) - GetAddr(AddressOf BEGINSHELLLOADER) + pShellCode - - ' // Get size in bytes between stub functions - fncSpc = GetAddr(AddressOf tVirtualProtect) - GetAddr(AddressOf tVirtualAlloc) - - ' // Use 3 library: kernel32, ntdll user32 - For libIdx = 0 To 2 - - ' // Get number of imported functions depending on library - Select Case libIdx - Case 0: libName = API_LIB_KERNEL32: fncIdx = 13 - Case 1: libName = API_LIB_NTDLL: fncIdx = 1 - Case 2: libName = API_LIB_USER32: fncIdx = 1 - End Select - - ' // Get library name from resources - sName = ResGetString(libName): If sName = 0 Then Exit Function - - Dbg "Get module handle" - - ' // Get module handle - hLib = llib.GetModuleHandle(ByVal sName): If hLib = 0 Then Exit Function - llib.SysFreeString sName - - ' // Go thru functions - Do While fncIdx - - libName = libName + 1 - ' // Get function name - sName = ResGetString(libName): If sName = 0 Then Exit Function - - ' // Because of GetProcAddress works with ANSI string translate it to ANSI - sFunc = ToAnsi(sName): If sFunc = 0 Then Exit Function - - ' // Get function address - lpAddr = llib.GetProcAddress(hLib, sFunc) - llib.SysFreeString sName: llib.SysFreeString sFunc - - Dbg "Addr of function: " & libName & " is " & lpAddr - - ' // Error - If lpAddr = 0 Then Exit Function - - ' // Splice stub - Splice splAddr, lpAddr - - ' // Next stub - splAddr = splAddr + fncSpc - fncIdx = fncIdx - 1 - - Loop - - Next - - Dbg "Modify CallByPointer" - - ' // Modify CallByPointer - lpAddr = GetAddr(AddressOf CallByPointer) - GetAddr(AddressOf BEGINSHELLLOADER) + pShellCode - - ' // pop eax - 0x58 - ' // pop ecx - 0x59 - ' // push eax - 0x50 - ' // jmp ecx - 0xFFE1 - - llib.CopyMemory ByVal lpAddr, &HFF505958, 4 - llib.CopyMemory ByVal lpAddr + 4, &HE1, 1 - - ' // Success - InitShellLoader = True - -End Function - -' // Splice function -Private Sub Splice( _ - ByVal Func As Long, _ - ByVal NewAddr As Long) - ' // Set memory permissions - llib.VirtualProtect ByVal Func, 5, PAGE_EXECUTE_READWRITE, 0 - llib.CopyMemory ByVal Func, &HE9, 1 ' // JMP - llib.CopyMemory ByVal Func + 1, NewAddr - Func - 5, 4 ' // Relative address -End Sub - -' // Unicode->Ansi -Private Function ToAnsi( _ - ByVal s As Long) As Long - Dim Size As Long - - ' // Get string size - Size = llib.SysStringLen(s) - - ' // Alloc memory for ansi string - ToAnsi = llib.SysAllocStringByteLen(0, Size) - - ' // Translate - llib.WideCharToMultiByte CP_ACP, 0, s, Size, ToAnsi, Size, 0, 0 - -End Function - -' // Stub for calling shellcode -Private Function CallLoader( _ - ByVal Pointer As Long, _ - ByVal MyBaseAddress As Long, _ - ByVal ErrMsgTable As Long) As Boolean - CallLoader = 1 -End Function - -' // Begin of shellcode -Private Function BEGINSHELLLOADER() As Integer: End Function - -' // Parse exe in memory -Private Function LoadExeFromMemory( _ - ByVal pRawData As Long, _ - ByVal pMyBaseAddress As Long, _ - ByVal pErrMsgTable As Long) As Boolean - Dim NtHdr As IMAGE_NT_HEADERS - Dim pBase As Long - 'Dim Index As Long - Dim iError As ERROR_MESSAGES - 'Dim pszMsg As Long - - ' // Get IMAGE_NT_HEADERS - If GetImageNtHeaders(pRawData, NtHdr) = 0 Then - iError = EM_UNABLE_TO_GET_NT_HEADERS - EndProcess pErrMsgTable, iError - Exit Function - End If - - ' // Check flags - If NtHdr.FileHeader.Machine <> IMAGE_FILE_MACHINE_I386 Or _ - (NtHdr.FileHeader.Characteristics And IMAGE_FILE_EXECUTABLE_IMAGE) = 0 Or _ - (NtHdr.FileHeader.Characteristics And IMAGE_FILE_32BIT_MACHINE) = 0 Then Exit Function - - ' // Release main EXE memory. After that main exe is unloaded from memory. - 'llib.ZwUnmapViewOfSection llib.GetCurrentProcess(), llib.GetModuleHandle(ByVal 0&) - - ' // Reserve memory for EXE - iError = ReserveMemory(pRawData, pBase) - If iError Then - EndProcess pErrMsgTable, iError - Exit Function - End If - - ' // Place data - iError = ProcessSectionsAndHeaders(pRawData, pBase) - If iError Then - EndProcess pErrMsgTable, iError - Exit Function - End If - - ' // Update new base address - iError = UpdateNewBaseAddress(pBase) - If iError Then - EndProcess pErrMsgTable, iError - Exit Function - End If - - ' // Import table processing - iError = ProcessImportTable(pBase) - If iError Then - EndProcess pErrMsgTable, iError - Exit Function - End If - - ' // Relocations processing - iError = ProcessRelocations(pBase) - If iError Then - EndProcess pErrMsgTable, iError - Exit Function - End If - - ' // Set the memory attributes - iError = SetMemoryPermissions(pBase) - If iError Then - EndProcess pErrMsgTable, iError - Exit Function - End If - - ' // Release error message table - If pErrMsgTable Then - tVirtualFree pErrMsgTable, 0, MEM_RELEASE - End If - - ' // Call entry point - CallByPointer NtHdr.OptionalHeader.AddressOfEntryPoint + pBase - - ' // End process - EndProcess - -End Function - -' // Update new base address -Private Function UpdateNewBaseAddress( _ - ByVal pBase As Long) As ERROR_MESSAGES - Dim pPBI As Long: Dim PBIlen As Long - Dim PBI As PROCESS_BASIC_INFORMATION: Dim cPEB As PEB - Dim ntstat As Long - Dim ldrData As PEB_LDR_DATA - Dim ldrMod As LDR_MODULE - - ntstat = tNtQueryInformationProcess(tGetCurrentProcess(), ProcessBasicInformation, IntPtr(PBI.ExitStatus), Len(PBI), PBIlen) - - Do While ntstat = STATUS_INFO_LENGTH_MISMATCH - - PBIlen = PBIlen * 2 - - If pPBI Then - tHeapFree tGetProcessHeap(), HEAP_NO_SERIALIZE, pPBI - End If - - pPBI = tHeapAlloc(tGetProcessHeap(), HEAP_NO_SERIALIZE, PBIlen) - ntstat = tNtQueryInformationProcess(tGetCurrentProcess(), ProcessBasicInformation, pPBI, PBIlen, PBIlen) - - Loop - - If ntstat <> STATUS_SUCCESS Then - UpdateNewBaseAddress = EM_PROCESS_INFORMATION_NOT_FOUND - GoTo CleanUp - End If - - If pPBI Then - ' // Copy to PROCESS_BASIC_INFORMATION - tCopyMemory IntPtr(PBI.ExitStatus), pPBI, Len(PBI) - End If - - ' // Get PEB - tCopyMemory IntPtr(cPEB.NotUsed), PBI.PebBaseAddress, Len(cPEB) - - ' // Modify image base - cPEB.ImageBaseAddress = pBase - - ' // Restore PEB - tCopyMemory PBI.PebBaseAddress, IntPtr(cPEB.NotUsed), Len(cPEB) - - ' // Fix base address in PEB_LDR_DATA list - tCopyMemory IntPtr(ldrData.Length), cPEB.LoaderData, Len(ldrData) - - ' // Get first element - tCopyMemory IntPtr(ldrMod.InLoadOrderModuleList.Flink), ldrData.InLoadOrderModuleList.Flink, Len(ldrMod) - - ' // Fix base - ldrMod.BaseAddress = pBase - - ' // Restore - tCopyMemory ldrData.InLoadOrderModuleList.Flink, IntPtr(ldrMod.InLoadOrderModuleList.Flink), Len(ldrMod) - -CleanUp: - - ' // Free memory - If pPBI Then - tHeapFree tGetProcessHeap(), HEAP_NO_SERIALIZE, pPBI - End If - -End Function - -' // Set memory permissions -Private Function SetMemoryPermissions( _ - ByVal pBase As Long) As ERROR_MESSAGES - Dim iSec As Long: Dim pNtHdr As Long - Dim NtHdr As IMAGE_NT_HEADERS: Dim sec As IMAGE_SECTION_HEADER - Dim Attr As MEMPROTECT: Dim pSec As Long - Dim ret As Long - - pNtHdr = GetImageNtHeaders(pBase, NtHdr) - If pNtHdr = 0 Then - SetMemoryPermissions = EM_UNABLE_TO_GET_NT_HEADERS - Exit Function - End If - - ' // Get address of first section header - pSec = pNtHdr + 4 + Len(NtHdr.FileHeader) + NtHdr.FileHeader.SizeOfOptionalHeader - - ' // Go thru section headers - For iSec = 0 To NtHdr.FileHeader.NumberOfSections - 1 - - ' // Copy section descriptor - tCopyMemory IntPtr(sec.SectionName(0)), pSec, Len(sec) - - ' // Get type - If sec.Characteristics And IMAGE_SCN_MEM_EXECUTE Then - If sec.Characteristics And IMAGE_SCN_MEM_READ Then - If sec.Characteristics And IMAGE_SCN_MEM_WRITE Then - Attr = PAGE_EXECUTE_READWRITE - Else - Attr = PAGE_EXECUTE_READ - End If - Else - If sec.Characteristics And IMAGE_SCN_MEM_WRITE Then - Attr = PAGE_EXECUTE_WRITECOPY - Else - Attr = PAGE_EXECUTE - End If - End If - Else - If sec.Characteristics And IMAGE_SCN_MEM_READ Then - If sec.Characteristics And IMAGE_SCN_MEM_WRITE Then - Attr = PAGE_READWRITE - Else - Attr = PAGE_READONLY - End If - Else - If sec.Characteristics And IMAGE_SCN_MEM_WRITE Then - Attr = PAGE_WRITECOPY - Else - Attr = PAGE_NOACCESS - End If - End If - End If - - ' // Set memory permissions - If tVirtualProtect(sec.VirtualAddress + pBase, sec.VirtualSize, Attr, IntPtr(ret)) = 0 Then - SetMemoryPermissions = EM_UNABLE_TO_PROTECT_MEMORY - Exit Function - End If - - ' // Next section - pSec = pSec + Len(sec) - - Next - -End Function - -' // Process import table -Private Function ProcessImportTable( _ - ByVal pBase As Long) As ERROR_MESSAGES - Dim NtHdr As IMAGE_NT_HEADERS: Dim datDirectory As IMAGE_DATA_DIRECTORY - Dim dsc As IMAGE_IMPORT_DESCRIPTOR: Dim hLib As Long - Dim thnk As Long: Dim Addr As Long - Dim fnc As Long: Dim pData As Long - - If GetImageNtHeaders(pBase, NtHdr) = 0 Then - ProcessImportTable = EM_UNABLE_TO_GET_NT_HEADERS - Exit Function - End If - - ' // Import table processing - If NtHdr.OptionalHeader.NumberOfRvaAndSizes > 1 Then - - If GetDataDirectory(pBase, IMAGE_DIRECTORY_ENTRY_IMPORT, datDirectory) = 0 Then - ProcessImportTable = EM_INVALID_DATA_DIRECTORY - Exit Function - End If - - ' // If import table exists - If datDirectory.Size > 0 And datDirectory.VirtualAddress > 0 Then - - ' // Copy import descriptor - pData = datDirectory.VirtualAddress + pBase - tCopyMemory IntPtr(dsc.Characteristics), pData, Len(dsc) - - ' // Go thru all descriptors - Do Until dsc.Characteristics = 0 And _ - dsc.FirstThunk = 0 And _ - dsc.ForwarderChain = 0 And _ - dsc.pName = 0 And _ - dsc.TimeDateStamp = 0 - - If dsc.pName > 0 Then - - ' // Load needed library - hLib = tLoadLibrary(dsc.pName + pBase) - - If hLib = 0 Then - ProcessImportTable = EM_LOADLIBRARY_FAILED - Exit Function - End If - - If dsc.Characteristics Then fnc = dsc.Characteristics + pBase Else fnc = dsc.FirstThunk + pBase - - ' // Go to names table - tCopyMemory IntPtr(thnk), fnc, 4 - - ' // Go thru names table - Do While thnk - - ' // Check import type - If thnk < 0 Then - ' // By ordinal - Addr = tGetProcAddress(hLib, thnk And &HFFFF&) - Else - ' // By name - Addr = tGetProcAddress(hLib, thnk + 2 + pBase) - End If - - ' // Next function - fnc = fnc + 4 - tCopyMemory IntPtr(thnk), fnc, 4 - tCopyMemory dsc.FirstThunk + pBase, IntPtr(Addr), 4 - dsc.FirstThunk = dsc.FirstThunk + 4 - - Loop - - End If - - ' // Next descriptor - pData = pData + Len(dsc) - tCopyMemory IntPtr(dsc.Characteristics), pData, Len(dsc) - - Loop - - End If - - End If - -End Function - -' // Process relocations -Private Function ProcessRelocations( _ - ByVal pBase As Long) As ERROR_MESSAGES - Dim NtHdr As IMAGE_NT_HEADERS: Dim datDirectory As IMAGE_DATA_DIRECTORY - Dim relBase As IMAGE_BASE_RELOCATION: Dim entriesCount As Long - Dim relType As Long: Dim dwAddress As Long - Dim dwOrig As Long: Dim pRelBase As Long - Dim delta As Long: Dim pData As Long - - ' // Check if module has not been loaded to image base value - If GetImageNtHeaders(pBase, NtHdr) = 0 Then - ProcessRelocations = EM_UNABLE_TO_GET_NT_HEADERS - Exit Function - End If - - delta = pBase - NtHdr.OptionalHeader.ImageBase - - ' // Process relocations - If delta Then - - ' // Get address of relocation table - If GetDataDirectory(pBase, IMAGE_DIRECTORY_ENTRY_BASERELOC, datDirectory) = 0 Then - ProcessRelocations = EM_INVALID_DATA_DIRECTORY - Exit Function - End If - - If datDirectory.Size > 0 And datDirectory.VirtualAddress > 0 Then - - ' // Copy relocation base - pRelBase = datDirectory.VirtualAddress + pBase - tCopyMemory IntPtr(relBase.VirtualAddress), pRelBase, Len(relBase) - - Do While relBase.VirtualAddress - - ' // To first reloc chunk - pData = pRelBase + Len(relBase) - - entriesCount = (relBase.SizeOfBlock - Len(relBase)) \ 2 - - Do While entriesCount > 0 - - tCopyMemory IntPtr(relType), pData, 2 - - Select Case (relType \ 4096) And &HF - Case IMAGE_REL_BASED_HIGHLOW - - ' // Calculate address - dwAddress = relBase.VirtualAddress + (relType And &HFFF&) + pBase - - ' // Get original address - tCopyMemory IntPtr(dwOrig), dwAddress, Len(dwOrig) - - ' // Add delta - dwOrig = dwOrig + delta - - ' // Save - tCopyMemory dwAddress, IntPtr(dwOrig), Len(dwOrig) - - End Select - - pData = pData + 2 - entriesCount = entriesCount - 1 - - Loop - - ' // Next relocation base - pRelBase = pRelBase + relBase.SizeOfBlock - tCopyMemory IntPtr(relBase.VirtualAddress), pRelBase, Len(relBase) - - Loop - - End If - - End If - -End Function - -' // Reserve memory for EXE -Private Function ReserveMemory( _ - ByVal pRawExeData As Long, _ - ByRef pBase As Long) As ERROR_MESSAGES - Dim NtHdr As IMAGE_NT_HEADERS - Dim pLocBase As Long - - If GetImageNtHeaders(pRawExeData, NtHdr) = 0 Then - ReserveMemory = EM_UNABLE_TO_GET_NT_HEADERS - Exit Function - End If - - ' // Reserve memory for EXE - pLocBase = tVirtualAlloc(ByVal NtHdr.OptionalHeader.ImageBase, _ - NtHdr.OptionalHeader.SizeOfImage, _ - MEM_RESERVE, PAGE_EXECUTE_READWRITE) - If pLocBase = 0 Then - - ' // If relocation information not found error - If NtHdr.FileHeader.Characteristics And IMAGE_FILE_RELOCS_STRIPPED Then - - ReserveMemory = EM_UNABLE_TO_ALLOCATE_MEMORY - Exit Function - - Else - ' // Reserve memory in other region - pLocBase = tVirtualAlloc(ByVal 0&, NtHdr.OptionalHeader.SizeOfImage, _ - MEM_RESERVE, PAGE_EXECUTE_READWRITE) - - If pLocBase = 0 Then - - ReserveMemory = EM_UNABLE_TO_ALLOCATE_MEMORY - Exit Function - - End If - - End If - - End If - - pBase = pLocBase - -End Function - -' // Allocate memory for sections and copy them data to there -Private Function ProcessSectionsAndHeaders( _ - ByVal pRawExeData As Long, _ - ByVal pBase As Long) As ERROR_MESSAGES - - Dim iSec As Long - Dim pNtHdr As Long - Dim NtHdr As IMAGE_NT_HEADERS - Dim sec As IMAGE_SECTION_HEADER - Dim lpSec As Long - Dim pData As Long - - pNtHdr = GetImageNtHeaders(pRawExeData, NtHdr) - If pNtHdr = 0 Then - ProcessSectionsAndHeaders = EM_UNABLE_TO_GET_NT_HEADERS - Exit Function - End If - - ' // Alloc memory for headers - pData = tVirtualAlloc(ByVal pBase, NtHdr.OptionalHeader.SizeOfHeaders, MEM_COMMIT, PAGE_READWRITE) - If pData = 0 Then - ProcessSectionsAndHeaders = EM_UNABLE_TO_ALLOCATE_MEMORY - Exit Function - End If - - ' // Copy headers - tCopyMemory pData, pRawExeData, NtHdr.OptionalHeader.SizeOfHeaders - - ' // Get address of beginnig of sections headers - pData = pNtHdr + Len(NtHdr.Signature) + Len(NtHdr.FileHeader) + NtHdr.FileHeader.SizeOfOptionalHeader - - ' // Go thru sections - For iSec = 0 To NtHdr.FileHeader.NumberOfSections - 1 - - ' // Copy section descriptor - tCopyMemory IntPtr(sec.SectionName(0)), pData, Len(sec) - - ' // Alloc memory for section - lpSec = tVirtualAlloc(sec.VirtualAddress + pBase, sec.VirtualSize, MEM_COMMIT, PAGE_READWRITE) - If lpSec = 0 Then - ProcessSectionsAndHeaders = EM_UNABLE_TO_ALLOCATE_MEMORY - Exit Function - End If - - ' If there is initialized data - If sec.SizeOfRawData Then - - ' // Take into account file alignment - If sec.SizeOfRawData > sec.VirtualSize Then sec.SizeOfRawData = sec.VirtualSize - - ' // Copy initialized data to section - tCopyMemory lpSec, pRawExeData + sec.PointerToRawData, sec.SizeOfRawData - lpSec = lpSec + sec.SizeOfRawData - sec.VirtualSize = sec.VirtualSize - sec.SizeOfRawData - - End If - - ' // Fill remain part with zero - tFillMemory lpSec, sec.VirtualSize, 0 - - ' // Next section - pData = pData + Len(sec) - - Next - -End Function - -' // Get NT headers and return its address -Private Function GetImageNtHeaders( _ - ByVal pBase As Long, _ - ByRef pNtHeaders As IMAGE_NT_HEADERS) As Long - Dim dosHdr As IMAGE_DOS_HEADER - Dim NtHdr As IMAGE_NT_HEADERS - Dim pNtHdr As Long - - ' // Get DOS header - tCopyMemory IntPtr(dosHdr.e_magic_e_cblp), pBase, Len(dosHdr) - - ' // Check MZ signature and alignment - If (dosHdr.e_magic_e_cblp And &HFFFF&) <> IMAGE_DOS_SIGNATURE Or _ - (dosHdr.e_lfanew And &H3) <> 0 Then - Exit Function - End If - - ' // Get pointer to NT headers - pNtHdr = pBase + dosHdr.e_lfanew - - ' // Get NT headers - tCopyMemory IntPtr(NtHdr.Signature), pNtHdr, Len(NtHdr) - - ' // Check NT signature - If (NtHdr.Signature <> IMAGE_NT_SIGNATURE) Or _ - NtHdr.OptionalHeader.Magic <> IMAGE_NT_OPTIONAL_HDR32_MAGIC Or _ - NtHdr.FileHeader.SizeOfOptionalHeader <> Len(NtHdr.OptionalHeader) Then - Exit Function - End If - - tCopyMemory IntPtr(pNtHeaders.Signature), IntPtr(NtHdr.Signature), Len(NtHdr) - GetImageNtHeaders = pNtHdr - -End Function - -' // Get data directory and return its data -Private Function GetDataDirectory( _ - ByVal pBase As Long, _ - ByVal lIndex As Long, _ - ByRef pDirectory As IMAGE_DATA_DIRECTORY) As Long - Dim NtHdr As IMAGE_NT_HEADERS - Dim pNtHdr As Long - - - ' // Get NT headers - pNtHdr = GetImageNtHeaders(pBase, NtHdr) - If pNtHdr = 0 Then - Exit Function - End If - - ' // Check directory index - If lIndex < 0 Or lIndex >= NtHdr.OptionalHeader.NumberOfRvaAndSizes Then - Exit Function - End If - - ' // Copy directory data - tCopyMemory IntPtr(pDirectory.VirtualAddress), IntPtr(NtHdr.OptionalHeader.DataDirectory(lIndex).VirtualAddress), Len(pDirectory) - GetDataDirectory = pNtHdr + Len(NtHdr.Signature) + Len(NtHdr.FileHeader) + &H60 + lIndex * Len(pDirectory) - -End Function - -' // Error message -Private Sub EndProcess( _ - Optional ByVal pMsgTable As Long = 0, _ - Optional ByVal lMsgNumber As Long = 0) - - Dim pszMsg As Long - - If pMsgTable Then - ' // Get message offset - tCopyMemory IntPtr(pszMsg), pMsgTable + lMsgNumber * 4, 4 - ' // Show message box - tMessageBox 0, pszMsg, 0, MB_ICONERROR - - End If - - tExitProcess 0 - -End Sub - -' // Call function by pointer -Private Sub CallByPointer( _ - ByVal pFuncAddress As Long) - -End Sub - -' // Stubs for API calling -Private Function tVirtualAlloc( _ - ByVal lpAddress As Long, _ - ByVal dwSize As Long, _ - ByVal flAllocationType As ALLOCATIONTYPE, _ - ByVal flProtect As MEMPROTECT) As Long - tVirtualAlloc = 2 -End Function -Private Function tVirtualProtect( _ - ByVal lpAddress As Long, _ - ByVal dwSize As Long, _ - ByVal flNewProtect As MEMPROTECT, _ - ByVal flOldProtect As MEMPROTECT) As Long - tVirtualProtect = 3 -End Function -Private Function tVirtualFree( _ - ByVal lpAddress As Long, _ - ByVal dwSize As Long, _ - ByVal dwFreeType As FREETYPE) As Long - tVirtualFree = 4 -End Function -Private Function tCopyMemory( _ - ByVal lpDst As Long, _ - ByVal lpSrc As Long, _ - ByVal Size As Long) As Long - tCopyMemory = 5 -End Function -Private Function tFillMemory( _ - ByVal lpDst As Long, _ - ByVal dwSize As Long, _ - ByVal Char As Byte) As Long - tFillMemory = 6 -End Function -Private Function tlstrcpyn( _ - ByRef lpString1 As Long, _ - ByRef lpString2 As Long, _ - ByVal iMaxLength As Long) As Long - tlstrcpyn = 7 -End Function -Private Function tLoadLibrary( _ - ByVal lpFileName As Long) As Long - tLoadLibrary = 8 -End Function -Private Function tGetProcAddress( _ - ByVal hModule As Long, _ - ByVal lpProcName As Long) As Long - tGetProcAddress = 9 -End Function -Private Function tExitProcess( _ - ByVal uExitCode As Long) As Long - tExitProcess = 10 -End Function -Private Function tHeapAlloc( _ - ByVal hHeap As Long, _ - ByVal dwFlags As Long, _ - ByVal dwBytes As Long) As Long - tHeapAlloc = 11 -End Function -Private Function tHeapFree( _ - ByVal hHeap As Long, _ - ByVal dwFlags As Long, _ - ByVal lpMem As Long) As Long - tHeapFree = 12 -End Function -Private Function tGetProcessHeap() As Long - tGetProcessHeap = 13 -End Function -Private Function tGetCurrentProcess() As Long - tGetCurrentProcess = 14 -End Function -Private Function tNtQueryInformationProcess( _ - ByVal ProcessHandle As Long, _ - ByVal InformationClass As Long, _ - ByVal ProcessInformation As Long, _ - ByVal ProcessInformationLength As Long, _ - ByRef ReturnLength As Long) As Long - tNtQueryInformationProcess = 16 -End Function -Private Function tMessageBox( _ - ByVal hwnd As Long, _ - ByVal lpText As Long, _ - ByVal lpCaption As Long, _ - ByVal uType As MESSAGEBOXCONSTANTS) As MESSAGEBOXRETURN - tMessageBox = 17 -End Function - -' // VarPtr analog -Private Function IntPtr( _ - ByRef Value As Long) As Long - IntPtr = tlstrcpyn(Value, 0, 0) -End Function - -' // Get AddressOf -Private Function GetAddr( _ - ByVal Addr As Long) As Long - GetAddr = Addr: Exit Function -End Function - -' // End of shellcode -Private Function ENDSHELLLOADER() As Long: End Function - From 9dc9407495756f80aea05f5608dab41519632850 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 9 Apr 2023 13:40:32 -0400 Subject: [PATCH 18/28] Change VBA sample --- samples/VBA/ErrorHandling.bas | 20 + samples/VBA/JsonConverter.bas | 1123 --------------------------------- 2 files changed, 20 insertions(+), 1123 deletions(-) create mode 100644 samples/VBA/ErrorHandling.bas delete mode 100644 samples/VBA/JsonConverter.bas diff --git a/samples/VBA/ErrorHandling.bas b/samples/VBA/ErrorHandling.bas new file mode 100644 index 0000000000..4f2250eebc --- /dev/null +++ b/samples/VBA/ErrorHandling.bas @@ -0,0 +1,20 @@ +Attribute VB_Name = "ErrorHandling" +Option Explicit + +Public Sub RaiseError(errNumber As Integer, Optional errSource As String = "", Optional errDescription As String = "") + If errSource = "" Then + 'set default values + errSource = Err.Source + errDescription = Err.Description + End If + Err.Raise vbObjectError + errNumber, errSource, errDescription +End Sub + + +Public Sub handleError(Optional errLocation As String = "") + Dim errorMessage As String + errorMessage = "Error in " & errLocation & ", [" & Err.Source & "] : error number " & Err.Number & vbNewLine & Err.Description + Debug.Print errorMessage + MsgBox errorMessage, vbCritical, "vbaDeveloper ErrorHandler" +End Sub + diff --git a/samples/VBA/JsonConverter.bas b/samples/VBA/JsonConverter.bas deleted file mode 100644 index 876b86501b..0000000000 --- a/samples/VBA/JsonConverter.bas +++ /dev/null @@ -1,1123 +0,0 @@ -Attribute VB_Name = "JsonConverter" -'' -' VBA-JSON v2.3.1 -' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON -' -' JSON Converter for VBA -' -' Errors: -' 10001 - JSON parse error -' -' @class JsonConverter -' @author tim.hall.engr@gmail.com -' @license MIT (http://www.opensource.org/licenses/mit-license.php) -'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' -' -' Based originally on vba-json (with extensive changes) -' BSD license included below -' -' JSONLib, http://code.google.com/p/vba-json/ -' -' Copyright (c) 2013, Ryo Yokoyama -' All rights reserved. -' -' Redistribution and use in source and binary forms, with or without -' modification, are permitted provided that the following conditions are met: -' * Redistributions of source code must retain the above copyright -' notice, this list of conditions and the following disclaimer. -' * Redistributions in binary form must reproduce the above copyright -' notice, this list of conditions and the following disclaimer in the -' documentation and/or other materials provided with the distribution. -' * Neither the name of the nor the -' names of its contributors may be used to endorse or promote products -' derived from this software without specific prior written permission. -' -' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -' DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY -' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND -' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' -Option Explicit - -' === VBA-UTC Headers -#If Mac Then - -#If VBA7 Then - -' 64-bit Mac (2016) -Private Declare PtrSafe Function utc_popen Lib "/usr/lib/libc.dylib" Alias "popen" _ - (ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr -Private Declare PtrSafe Function utc_pclose Lib "/usr/lib/libc.dylib" Alias "pclose" _ - (ByVal utc_File As LongPtr) As LongPtr -Private Declare PtrSafe Function utc_fread Lib "/usr/lib/libc.dylib" Alias "fread" _ - (ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr -Private Declare PtrSafe Function utc_feof Lib "/usr/lib/libc.dylib" Alias "feof" _ - (ByVal utc_File As LongPtr) As LongPtr - -#Else - -' 32-bit Mac -Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _ - (ByVal utc_Command As String, ByVal utc_Mode As String) As Long -Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _ - (ByVal utc_File As Long) As Long -Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _ - (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long -Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _ - (ByVal utc_File As Long) As Long - -#End If - -#ElseIf VBA7 Then - -' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx -' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx -' http://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx -Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ - (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long -Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ - (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long -Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ - (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long - -#Else - -Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ - (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long -Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ - (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long -Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ - (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long - -#End If - -#If Mac Then - -#If VBA7 Then -Private Type utc_ShellResult - utc_Output As String - utc_ExitCode As LongPtr -End Type - -#Else - -Private Type utc_ShellResult - utc_Output As String - utc_ExitCode As Long -End Type - -#End If - -#Else - -Private Type utc_SYSTEMTIME - utc_wYear As Integer - utc_wMonth As Integer - utc_wDayOfWeek As Integer - utc_wDay As Integer - utc_wHour As Integer - utc_wMinute As Integer - utc_wSecond As Integer - utc_wMilliseconds As Integer -End Type - -Private Type utc_TIME_ZONE_INFORMATION - utc_Bias As Long - utc_StandardName(0 To 31) As Integer - utc_StandardDate As utc_SYSTEMTIME - utc_StandardBias As Long - utc_DaylightName(0 To 31) As Integer - utc_DaylightDate As utc_SYSTEMTIME - utc_DaylightBias As Long -End Type - -#End If -' === End VBA-UTC - -Private Type json_Options - ' VBA only stores 15 significant digits, so any numbers larger than that are truncated - ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits - ' See: http://support.microsoft.com/kb/269370 - ' - ' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits - ' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True` - UseDoubleForLargeNumbers As Boolean - - ' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys - AllowUnquotedKeys As Boolean - - ' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson - EscapeSolidus As Boolean -End Type -Public JsonOptions As json_Options - -' ============================================= ' -' Public Methods -' ============================================= ' - -'' -' Convert JSON string to object (Dictionary/Collection) -' -' @method ParseJson -' @param {String} json_String -' @return {Object} (Dictionary or Collection) -' @throws 10001 - JSON parse error -'' -Public Function ParseJson(ByVal JsonString As String) As Object - Dim json_Index As Long - json_Index = 1 - - ' Remove vbCr, vbLf, and vbTab from json_String - JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "") - - json_SkipSpaces JsonString, json_Index - Select Case VBA.Mid$(JsonString, json_Index, 1) - Case "{" - Set ParseJson = json_ParseObject(JsonString, json_Index) - Case "[" - Set ParseJson = json_ParseArray(JsonString, json_Index) - Case Else - ' Error: Invalid JSON string - Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['") - End Select -End Function - -'' -' Convert object (Dictionary/Collection/Array) to JSON -' -' @method ConvertToJson -' @param {Variant} JsonValue (Dictionary, Collection, or Array) -' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string -' @return {String} -'' -Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String - Dim json_Buffer As String - Dim json_BufferPosition As Long - Dim json_BufferLength As Long - Dim json_Index As Long - Dim json_LBound As Long - Dim json_UBound As Long - Dim json_IsFirstItem As Boolean - Dim json_Index2D As Long - Dim json_LBound2D As Long - Dim json_UBound2D As Long - Dim json_IsFirstItem2D As Boolean - Dim json_Key As Variant - Dim json_Value As Variant - Dim json_DateStr As String - Dim json_Converted As String - Dim json_SkipItem As Boolean - Dim json_PrettyPrint As Boolean - Dim json_Indentation As String - Dim json_InnerIndentation As String - - json_LBound = -1 - json_UBound = -1 - json_IsFirstItem = True - json_LBound2D = -1 - json_UBound2D = -1 - json_IsFirstItem2D = True - json_PrettyPrint = Not IsMissing(Whitespace) - - Select Case VBA.VarType(JsonValue) - Case VBA.vbNull - ConvertToJson = "null" - Case VBA.vbDate - ' Date - json_DateStr = ConvertToIso(VBA.CDate(JsonValue)) - - ConvertToJson = """" & json_DateStr & """" - Case VBA.vbString - ' String (or large number encoded as string) - If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then - ConvertToJson = JsonValue - Else - ConvertToJson = """" & json_Encode(JsonValue) & """" - End If - Case VBA.vbBoolean - If JsonValue Then - ConvertToJson = "true" - Else - ConvertToJson = "false" - End If - Case VBA.vbArray To VBA.vbArray + VBA.vbByte - If json_PrettyPrint Then - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) - json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace) - Else - json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) - json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace) - End If - End If - - ' Array - json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength - - On Error Resume Next - - json_LBound = LBound(JsonValue, 1) - json_UBound = UBound(JsonValue, 1) - json_LBound2D = LBound(JsonValue, 2) - json_UBound2D = UBound(JsonValue, 2) - - If json_LBound >= 0 And json_UBound >= 0 Then - For json_Index = json_LBound To json_UBound - If json_IsFirstItem Then - json_IsFirstItem = False - Else - ' Append comma to previous line - json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength - End If - - If json_LBound2D >= 0 And json_UBound2D >= 0 Then - ' 2D Array - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - End If - json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength - - For json_Index2D = json_LBound2D To json_UBound2D - If json_IsFirstItem2D Then - json_IsFirstItem2D = False - Else - json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength - End If - - json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) - - ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null - If json_Converted = "" Then - ' (nest to only check if converted = "") - If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then - json_Converted = "null" - End If - End If - - If json_PrettyPrint Then - json_Converted = vbNewLine & json_InnerIndentation & json_Converted - End If - - json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength - Next json_Index2D - - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - End If - - json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength - json_IsFirstItem2D = True - Else - ' 1D Array - json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1) - - ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null - If json_Converted = "" Then - ' (nest to only check if converted = "") - If json_IsUndefined(JsonValue(json_Index)) Then - json_Converted = "null" - End If - End If - - If json_PrettyPrint Then - json_Converted = vbNewLine & json_Indentation & json_Converted - End If - - json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength - End If - Next json_Index - End If - - On Error GoTo 0 - - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) - Else - json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) - End If - End If - - json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength - - ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) - - ' Dictionary or Collection - Case VBA.vbObject - If json_PrettyPrint Then - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) - Else - json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) - End If - End If - - ' Dictionary - If VBA.TypeName(JsonValue) = "Dictionary" Then - json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength - For Each json_Key In JsonValue.Keys - ' For Objects, undefined (Empty/Nothing) is not added to object - json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1) - If json_Converted = "" Then - json_SkipItem = json_IsUndefined(JsonValue(json_Key)) - Else - json_SkipItem = False - End If - - If Not json_SkipItem Then - If json_IsFirstItem Then - json_IsFirstItem = False - Else - json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength - End If - - If json_PrettyPrint Then - json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted - Else - json_Converted = """" & json_Key & """:" & json_Converted - End If - - json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength - End If - Next json_Key - - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) - Else - json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) - End If - End If - - json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength - - ' Collection - ElseIf VBA.TypeName(JsonValue) = "Collection" Then - json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength - For Each json_Value In JsonValue - If json_IsFirstItem Then - json_IsFirstItem = False - Else - json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength - End If - - json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) - - ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null - If json_Converted = "" Then - ' (nest to only check if converted = "") - If json_IsUndefined(json_Value) Then - json_Converted = "null" - End If - End If - - If json_PrettyPrint Then - json_Converted = vbNewLine & json_Indentation & json_Converted - End If - - json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength - Next json_Value - - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) - Else - json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) - End If - End If - - json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength - End If - - ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) - Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal - ' Number (use decimals for numbers) - ConvertToJson = VBA.Replace(JsonValue, ",", ".") - Case Else - ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType - ' Use VBA's built-in to-string - On Error Resume Next - ConvertToJson = JsonValue - On Error GoTo 0 - End Select -End Function - -' ============================================= ' -' Private Functions -' ============================================= ' - -Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary - Dim json_Key As String - Dim json_NextChar As String - - Set json_ParseObject = New Dictionary - json_SkipSpaces json_String, json_Index - If VBA.Mid$(json_String, json_Index, 1) <> "{" Then - Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'") - Else - json_Index = json_Index + 1 - - Do - json_SkipSpaces json_String, json_Index - If VBA.Mid$(json_String, json_Index, 1) = "}" Then - json_Index = json_Index + 1 - Exit Function - ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then - json_Index = json_Index + 1 - json_SkipSpaces json_String, json_Index - End If - - json_Key = json_ParseKey(json_String, json_Index) - json_NextChar = json_Peek(json_String, json_Index) - If json_NextChar = "[" Or json_NextChar = "{" Then - Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) - Else - json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) - End If - Loop - End If -End Function - -Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection - Set json_ParseArray = New Collection - - json_SkipSpaces json_String, json_Index - If VBA.Mid$(json_String, json_Index, 1) <> "[" Then - Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['") - Else - json_Index = json_Index + 1 - - Do - json_SkipSpaces json_String, json_Index - If VBA.Mid$(json_String, json_Index, 1) = "]" Then - json_Index = json_Index + 1 - Exit Function - ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then - json_Index = json_Index + 1 - json_SkipSpaces json_String, json_Index - End If - - json_ParseArray.Add json_ParseValue(json_String, json_Index) - Loop - End If -End Function - -Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant - json_SkipSpaces json_String, json_Index - Select Case VBA.Mid$(json_String, json_Index, 1) - Case "{" - Set json_ParseValue = json_ParseObject(json_String, json_Index) - Case "[" - Set json_ParseValue = json_ParseArray(json_String, json_Index) - Case """", "'" - json_ParseValue = json_ParseString(json_String, json_Index) - Case Else - If VBA.Mid$(json_String, json_Index, 4) = "true" Then - json_ParseValue = True - json_Index = json_Index + 4 - ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then - json_ParseValue = False - json_Index = json_Index + 5 - ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then - json_ParseValue = Null - json_Index = json_Index + 4 - ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then - json_ParseValue = json_ParseNumber(json_String, json_Index) - Else - Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['") - End If - End Select -End Function - -Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String - Dim json_Quote As String - Dim json_Char As String - Dim json_Code As String - Dim json_Buffer As String - Dim json_BufferPosition As Long - Dim json_BufferLength As Long - - json_SkipSpaces json_String, json_Index - - ' Store opening quote to look for matching closing quote - json_Quote = VBA.Mid$(json_String, json_Index, 1) - json_Index = json_Index + 1 - - Do While json_Index > 0 And json_Index <= Len(json_String) - json_Char = VBA.Mid$(json_String, json_Index, 1) - - Select Case json_Char - Case "\" - ' Escaped string, \\, or \/ - json_Index = json_Index + 1 - json_Char = VBA.Mid$(json_String, json_Index, 1) - - Select Case json_Char - Case """", "\", "/", "'" - json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - Case "b" - json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - Case "f" - json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - Case "n" - json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - Case "r" - json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - Case "t" - json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - Case "u" - ' Unicode character escape (e.g. \u00a9 = Copyright) - json_Index = json_Index + 1 - json_Code = VBA.Mid$(json_String, json_Index, 4) - json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength - json_Index = json_Index + 4 - End Select - Case json_Quote - json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition) - json_Index = json_Index + 1 - Exit Function - Case Else - json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - End Select - Loop -End Function - -Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant - Dim json_Char As String - Dim json_Value As String - Dim json_IsLargeNumber As Boolean - - json_SkipSpaces json_String, json_Index - - Do While json_Index > 0 And json_Index <= Len(json_String) - json_Char = VBA.Mid$(json_String, json_Index, 1) - - If VBA.InStr("+-0123456789.eE", json_Char) Then - ' Unlikely to have massive number, so use simple append rather than buffer here - json_Value = json_Value & json_Char - json_Index = json_Index + 1 - Else - ' Excel only stores 15 significant digits, so any numbers larger than that are truncated - ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits - ' See: http://support.microsoft.com/kb/269370 - ' - ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number - ' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16) - json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16) - If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then - json_ParseNumber = json_Value - Else - ' VBA.Val does not use regional settings, so guard for comma is not needed - json_ParseNumber = VBA.Val(json_Value) - End If - Exit Function - End If - Loop -End Function - -Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String - ' Parse key with single or double quotes - If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then - json_ParseKey = json_ParseString(json_String, json_Index) - ElseIf JsonOptions.AllowUnquotedKeys Then - Dim json_Char As String - Do While json_Index > 0 And json_Index <= Len(json_String) - json_Char = VBA.Mid$(json_String, json_Index, 1) - If (json_Char <> " ") And (json_Char <> ":") Then - json_ParseKey = json_ParseKey & json_Char - json_Index = json_Index + 1 - Else - Exit Do - End If - Loop - Else - Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''") - End If - - ' Check for colon and skip if present or throw if not present - json_SkipSpaces json_String, json_Index - If VBA.Mid$(json_String, json_Index, 1) <> ":" Then - Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'") - Else - json_Index = json_Index + 1 - End If -End Function - -Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean - ' Empty / Nothing -> undefined - Select Case VBA.VarType(json_Value) - Case VBA.vbEmpty - json_IsUndefined = True - Case VBA.vbObject - Select Case VBA.TypeName(json_Value) - Case "Empty", "Nothing" - json_IsUndefined = True - End Select - End Select -End Function - -Private Function json_Encode(ByVal json_Text As Variant) As String - ' Reference: http://www.ietf.org/rfc/rfc4627.txt - ' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab - Dim json_Index As Long - Dim json_Char As String - Dim json_AscCode As Long - Dim json_Buffer As String - Dim json_BufferPosition As Long - Dim json_BufferLength As Long - - For json_Index = 1 To VBA.Len(json_Text) - json_Char = VBA.Mid$(json_Text, json_Index, 1) - json_AscCode = VBA.AscW(json_Char) - - ' When AscW returns a negative number, it returns the twos complement form of that number. - ' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result. - ' https://support.microsoft.com/en-us/kb/272138 - If json_AscCode < 0 Then - json_AscCode = json_AscCode + 65536 - End If - - ' From spec, ", \, and control characters must be escaped (solidus is optional) - - Select Case json_AscCode - Case 34 - ' " -> 34 -> \" - json_Char = "\""" - Case 92 - ' \ -> 92 -> \\ - json_Char = "\\" - Case 47 - ' / -> 47 -> \/ (optional) - If JsonOptions.EscapeSolidus Then - json_Char = "\/" - End If - Case 8 - ' backspace -> 8 -> \b - json_Char = "\b" - Case 12 - ' form feed -> 12 -> \f - json_Char = "\f" - Case 10 - ' line feed -> 10 -> \n - json_Char = "\n" - Case 13 - ' carriage return -> 13 -> \r - json_Char = "\r" - Case 9 - ' tab -> 9 -> \t - json_Char = "\t" - Case 0 To 31, 127 To 65535 - ' Non-ascii characters -> convert to 4-digit hex - json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4) - End Select - - json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength - Next json_Index - - json_Encode = json_BufferToString(json_Buffer, json_BufferPosition) -End Function - -Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String - ' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef) - json_SkipSpaces json_String, json_Index - json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters) -End Function - -Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long) - ' Increment index to skip over spaces - Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " " - json_Index = json_Index + 1 - Loop -End Sub - -Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean - ' Check if the given string is considered a "large number" - ' (See json_ParseNumber) - - Dim json_Length As Long - Dim json_CharIndex As Long - json_Length = VBA.Len(json_String) - - ' Length with be at least 16 characters and assume will be less than 100 characters - If json_Length >= 16 And json_Length <= 100 Then - Dim json_CharCode As String - - json_StringIsLargeNumber = True - - For json_CharIndex = 1 To json_Length - json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1)) - Select Case json_CharCode - ' Look for .|0-9|E|e - Case 46, 48 To 57, 69, 101 - ' Continue through characters - Case Else - json_StringIsLargeNumber = False - Exit Function - End Select - Next json_CharIndex - End If -End Function - -Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, ErrorMessage As String) - ' Provide detailed parse error message, including details of where and what occurred - ' - ' Example: - ' Error parsing JSON: - ' {"abcde":True} - ' ^ - ' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '[' - - Dim json_StartIndex As Long - Dim json_StopIndex As Long - - ' Include 10 characters before and after error (if possible) - json_StartIndex = json_Index - 10 - json_StopIndex = json_Index + 10 - If json_StartIndex <= 0 Then - json_StartIndex = 1 - End If - If json_StopIndex > VBA.Len(json_String) Then - json_StopIndex = VBA.Len(json_String) - End If - - json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _ - VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _ - VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _ - ErrorMessage -End Function - -Private Sub json_BufferAppend(ByRef json_Buffer As String, _ - ByRef json_Append As Variant, _ - ByRef json_BufferPosition As Long, _ - ByRef json_BufferLength As Long) - ' VBA can be slow to append strings due to allocating a new string for each append - ' Instead of using the traditional append, allocate a large empty string and then copy string at append position - ' - ' Example: - ' Buffer: "abc " - ' Append: "def" - ' Buffer Position: 3 - ' Buffer Length: 5 - ' - ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer - ' Buffer: "abc " - ' Buffer Length: 10 - ' - ' Put "def" into buffer at position 3 (0-based) - ' Buffer: "abcdef " - ' - ' Approach based on cStringBuilder from vbAccelerator - ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp - ' - ' and clsStringAppend from Philip Swannell - ' https://github.com/VBA-tools/VBA-JSON/pull/82 - - Dim json_AppendLength As Long - Dim json_LengthPlusPosition As Long - - json_AppendLength = VBA.Len(json_Append) - json_LengthPlusPosition = json_AppendLength + json_BufferPosition - - If json_LengthPlusPosition > json_BufferLength Then - ' Appending would overflow buffer, add chunk - ' (double buffer length or append length, whichever is bigger) - Dim json_AddedLength As Long - json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength) - - json_Buffer = json_Buffer & VBA.Space$(json_AddedLength) - json_BufferLength = json_BufferLength + json_AddedLength - End If - - ' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error: - ' Function call on left-hand side of assignment must return Variant or Object - Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append) - json_BufferPosition = json_BufferPosition + json_AppendLength -End Sub - -Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String - If json_BufferPosition > 0 Then - json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition) - End If -End Function - -'' -' VBA-UTC v1.0.6 -' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter -' -' UTC/ISO 8601 Converter for VBA -' -' Errors: -' 10011 - UTC parsing error -' 10012 - UTC conversion error -' 10013 - ISO 8601 parsing error -' 10014 - ISO 8601 conversion error -' -' @module UtcConverter -' @author tim.hall.engr@gmail.com -' @license MIT (http://www.opensource.org/licenses/mit-license.php) -'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' - -' (Declarations moved to top) - -' ============================================= ' -' Public Methods -' ============================================= ' - -'' -' Parse UTC date to local date -' -' @method ParseUtc -' @param {Date} UtcDate -' @return {Date} Local date -' @throws 10011 - UTC parsing error -'' -Public Function ParseUtc(utc_UtcDate As Date) As Date - On Error GoTo utc_ErrorHandling - -#If Mac Then - ParseUtc = utc_ConvertDate(utc_UtcDate) -#Else - Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION - Dim utc_LocalDate As utc_SYSTEMTIME - - utc_GetTimeZoneInformation utc_TimeZoneInfo - utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate - - ParseUtc = utc_SystemTimeToDate(utc_LocalDate) -#End If - - Exit Function - -utc_ErrorHandling: - Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description -End Function - -'' -' Convert local date to UTC date -' -' @method ConvertToUrc -' @param {Date} utc_LocalDate -' @return {Date} UTC date -' @throws 10012 - UTC conversion error -'' -Public Function ConvertToUtc(utc_LocalDate As Date) As Date - On Error GoTo utc_ErrorHandling - -#If Mac Then - ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True) -#Else - Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION - Dim utc_UtcDate As utc_SYSTEMTIME - - utc_GetTimeZoneInformation utc_TimeZoneInfo - utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate - - ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate) -#End If - - Exit Function - -utc_ErrorHandling: - Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description -End Function - -'' -' Parse ISO 8601 date string to local date -' -' @method ParseIso -' @param {Date} utc_IsoString -' @return {Date} Local date -' @throws 10013 - ISO 8601 parsing error -'' -Public Function ParseIso(utc_IsoString As String) As Date - On Error GoTo utc_ErrorHandling - - Dim utc_Parts() As String - Dim utc_DateParts() As String - Dim utc_TimeParts() As String - Dim utc_OffsetIndex As Long - Dim utc_HasOffset As Boolean - Dim utc_NegativeOffset As Boolean - Dim utc_OffsetParts() As String - Dim utc_Offset As Date - - utc_Parts = VBA.Split(utc_IsoString, "T") - utc_DateParts = VBA.Split(utc_Parts(0), "-") - ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2))) - - If UBound(utc_Parts) > 0 Then - If VBA.InStr(utc_Parts(1), "Z") Then - utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":") - Else - utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+") - If utc_OffsetIndex = 0 Then - utc_NegativeOffset = True - utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-") - End If - - If utc_OffsetIndex > 0 Then - utc_HasOffset = True - utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":") - utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":") - - Select Case UBound(utc_OffsetParts) - Case 0 - utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0) - Case 1 - utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0) - Case 2 - ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues - utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2)))) - End Select - - If utc_NegativeOffset Then: utc_Offset = -utc_Offset - Else - utc_TimeParts = VBA.Split(utc_Parts(1), ":") - End If - End If - - Select Case UBound(utc_TimeParts) - Case 0 - ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0) - Case 1 - ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0) - Case 2 - ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues - ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2)))) - End Select - - ParseIso = ParseUtc(ParseIso) - - If utc_HasOffset Then - ParseIso = ParseIso - utc_Offset - End If - End If - - Exit Function - -utc_ErrorHandling: - Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description -End Function - -'' -' Convert local date to ISO 8601 string -' -' @method ConvertToIso -' @param {Date} utc_LocalDate -' @return {Date} ISO 8601 string -' @throws 10014 - ISO 8601 conversion error -'' -Public Function ConvertToIso(utc_LocalDate As Date) As String - On Error GoTo utc_ErrorHandling - - ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z") - - Exit Function - -utc_ErrorHandling: - Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description -End Function - -' ============================================= ' -' Private Functions -' ============================================= ' - -#If Mac Then - -Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date - Dim utc_ShellCommand As String - Dim utc_Result As utc_ShellResult - Dim utc_Parts() As String - Dim utc_DateParts() As String - Dim utc_TimeParts() As String - - If utc_ConvertToUtc Then - utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _ - "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _ - " +'%s'` +'%Y-%m-%d %H:%M:%S'" - Else - utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _ - "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _ - "+'%Y-%m-%d %H:%M:%S'" - End If - - utc_Result = utc_ExecuteInShell(utc_ShellCommand) - - If utc_Result.utc_Output = "" Then - Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed" - Else - utc_Parts = Split(utc_Result.utc_Output, " ") - utc_DateParts = Split(utc_Parts(0), "-") - utc_TimeParts = Split(utc_Parts(1), ":") - - utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _ - TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2)) - End If -End Function - -Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult -#If VBA7 Then - Dim utc_File As LongPtr - Dim utc_Read As LongPtr -#Else - Dim utc_File As Long - Dim utc_Read As Long -#End If - - Dim utc_Chunk As String - - On Error GoTo utc_ErrorHandling - utc_File = utc_popen(utc_ShellCommand, "r") - - If utc_File = 0 Then: Exit Function - - Do While utc_feof(utc_File) = 0 - utc_Chunk = VBA.Space$(50) - utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File)) - If utc_Read > 0 Then - utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read)) - utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk - End If - Loop - -utc_ErrorHandling: - utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File)) -End Function - -#Else - -Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME - utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value) - utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value) - utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value) - utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value) - utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value) - utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value) - utc_DateToSystemTime.utc_wMilliseconds = 0 -End Function - -Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date - utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _ - TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond) -End Function - -#End If From 9a00ee77a41d4ec6848838bec1c7297b986409bf Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 9 Apr 2023 14:11:00 -0400 Subject: [PATCH 19/28] Modify heuristic to include "vba" prefix (PascalCase or camelCase) --- lib/linguist/heuristics.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 2c2189f46e..27d5c3a012 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -848,7 +848,7 @@ named_patterns: vb-form: '^\s*VERSION [0-9]\.[0-9]{2}' vb-module: '^\s*Attribute VB_Name = ' vba: - - '\b[vV][bB][aA]\b' + - '\b(?:VBA\b|[vV]ba[\bA-Z])' # VBA7 new 64-bit features - '^\s*(?:Public|Private)? Declare PtrSafe (?:Sub|Function)\b' - '^\s*#If\s(:?VBA7|Win64)\b' From 60907615abbad6aab937ef0d55515e81cd3199f3 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 9 Apr 2023 14:33:39 -0400 Subject: [PATCH 20/28] Add BASIC sample --- samples/BASIC/spacesc.bas | 260 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 260 insertions(+) create mode 100644 samples/BASIC/spacesc.bas diff --git a/samples/BASIC/spacesc.bas b/samples/BASIC/spacesc.bas new file mode 100644 index 0000000000..056b6a3955 --- /dev/null +++ b/samples/BASIC/spacesc.bas @@ -0,0 +1,260 @@ +10 ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +20 ' SPACE ESCAPE! By Neil C. Obremski (Feb-Mar 2011), Music by Scott Happell +30 ' +40 DEFINT A-Z: KEY OFF: RANDOMIZE TIMER: OPTION BASE 1 +50 DEF FNRAND (N) = 1 + FIX(RND * N) +60 DEF FNMOVE (N) = FIX(RND * 3) - 1 +70 DEF FNSEEK (ME, YOU) = ME + SGN(YOU - ME) +80 HS! = 0: LS = 0 ' High Score and Saved Location +90 ON ERROR GOTO 9700 +100 ' Initialize Keyboard (ESC=QUIT, ARROW KEYS=MOVE) +110 KEY 15, CHR$(0) + CHR$(1): KEY(15) ON: ON KEY(15) GOSUB 9990 +120 KEY(11) ON: KEY(12) ON: KEY(13) ON: KEY(14) ON +130 ON KEY(11) GOSUB 160: ON KEY(12) GOSUB 170 +140 ON KEY(13) GOSUB 180: ON KEY(14) GOSUB 190 +150 GOTO 200 +160 MY = MY - 1: RETURN ' 11 = ARROW UP +170 MX = MX - 1: RETURN ' 12 = ARROW LEFT +180 MX = MX + 1: RETURN ' 13 = ARROW RIGHT +190 MY = MY + 1: RETURN ' 14 = ARROW DOWN +200 ' Initialize Star Field +210 SC = 0: DIM SX(31), SY(31), SS(31), SO(31) +220 FOR I = 1 TO 31 +230 SX(I) = FIX(RND * 320): SY(I) = FIX(RND * 200) +240 SS(I) = .5 + (((31 - I) / 31) * 5) +250 SO(I) = 0 +260 NEXT I +270 ' Initialize Palette Rotation DATA and Music List +280 DATA 14, 8, 13, 5, 14, 6, 13, 13, 14, 14, 13, 5, 14, 8, 13, 13, 14, 6, 13, 5, 14, 14, 13, 13, 0, 0 +290 DIM BGM$(10): ON PLAY(2) GOSUB 9600 +300 ' Initialize Variables / Reset Game +310 I = 0: N = 0 ' Misc. Integer Register +320 PX = 20: OX = PX: PY = 8: OY = PY: PT! = 0 ' Player +330 TX = 0: TY = 0: TD = 0: TS = 0 ' Missile (Torpedo) +340 FX = 0: FY = 0: FD = 0: FS = 0 ' Fragment (X,Y,dir,speed) +350 AX = 0: AH = 0: AL = 0 ' Asteroid (X, height, and Length) +360 WX = 0: WY = 0 ' Worm Hole +370 L = LS ' Location +380 DX = 0: DM$ = "" ' Dash Message +390 C1 = 1: C2 = 2: C3 = 3: C4 = 4: C5 = 5: C6 = 6: C7 = 7: C8 = 8: C9 = 9: C10 = 10: C11 = 11: C12 = 12: C13 = 13: C14 = 14: C15 = 15 +500 ' Title Screen +510 SCREEN 7, 1, 0, 0: WIDTH 40: WINDOW: VIEW: CLS : COLOR C15 +520 ' "SPACE" DATA +530 DATA 201,205,181, 32,201,205,187, 32,201,205,187, 32,201,205,181, 32,201,205,181, 32 +540 DATA 186, 32, 32, 32,186, 32,186, 32,186, 32,186, 32,186, 32, 32, 32,186, 32, 32, 32 +550 DATA 200,205,187, 32,204,205,188, 32,204,205,185, 32,186, 32, 32, 32,204,181, 32, 32 +560 DATA 32, 32,186, 32,186, 32, 32, 32,186, 32,186, 32,186, 32, 32, 32,186, 32, 32, 32 +570 DATA 198,205,188, 32,208, 32, 32, 32,208, 32,208, 32,200,205,181, 32,200,205,181, 32 +580 ' "ESCAPE" DATA +590 DATA 201,205,181, 32,201,205,181, 32,201,205,181, 32,201,205,187, 32,201,205,187, 32,201,205,181, 32 +600 DATA 186, 32, 32, 32,186, 32, 32, 32,186, 32, 32, 32,186, 32,186, 32,186, 32,186, 32,186, 32, 32, 32 +610 DATA 204,181, 32, 32,200,205,187, 32,186, 32, 32, 32,204,205,185, 32,204,205,188, 32,204,181, 32, 32 +620 DATA 186, 32, 32, 32, 32, 32,186, 32,186, 32, 32, 32,186, 32,186, 32,186, 32, 32, 32,186, 32, 32, 32 +630 DATA 200,205,181, 32,198,205,188, 32,200,205,181, 32,208, 32,208, 32,208, 32, 32, 32,200,205,181, 32 +640 ' MUSIC DATA +650 BGM$(1) = "MN T178 O3 D4 A4 > D4 < A4": BGM$(2) = "D4 G4 A8 G4 A8": BGM$(3) = "D4 A4 > D4 < A4." +660 BGM$(4) = "P8 G4 A8 G4 F#8": BGM$(5) = "< B4 > B4 > C#4 D4 E8": BGM$(6) = "D8 C#8 D8 C#8 < B8" +670 BGM$(7) = "< B4 > B4 > C#4 D4 E8": BGM$(8) = "D8 C#8 D8 C#8 < A8": BGM$(9) = "": BGM$(10) = "" +680 IF LS = 0 THEN MUS = 1: PLAY ON: PLAY "MB " + BGM$(1) +700 RESTORE 530: FOR Y = 1 TO 5: LOCATE Y + 2, 3: FOR X = 1 TO 20: READ I: PRINT CHR$(I); : NEXT X, Y +710 RESTORE 590: FOR Y = 1 TO 5: LOCATE Y + 12, 16: FOR X = 1 TO 24: READ I: PRINT CHR$(I); : NEXT X, Y +720 LOCATE 10, 10: COLOR C8: PRINT "BY NEIL C. OBREMSKI" +725 LOCATE 11, 10: COLOR C8: PRINT "MUSIC: SCOTT HAPPELL" +730 LOCATE 21, 9: COLOR C11: PRINT "PRESS ANY KEY TO START" +740 LOCATE 25, 8: COLOR C15: PRINT USING " HIGH SCORE = #,###,### "; HS!; +750 IF LS = 1000 THEN LOCATE 22, 7: COLOR C2: PRINT "(CHECKPOINT: MINE BARRIER)" +760 IF LS = 2000 THEN LOCATE 22, 6: COLOR C2: PRINT "(CHECKPOINT: FRAGMENT FIELD)" +770 IF LS = 3000 THEN LOCATE 22, 7: COLOR C2: PRINT "(CHECKPOINT: ASTEROID BELT)" +780 IF LS = 4000 THEN LOCATE 22, 10: COLOR C2: PRINT "(CHECKPOINT: CANYON)" +870 RESTORE 280 +880 IF L = 0 THEN DX = 1: DM$ = " GET READY!" ELSE DX = 0 +890 MX = 0: MY = 0: SC = 0: WHILE INKEY$ <> "": A$ = INKEY$: WEND +900 ' Wait for ANY key (including arrows) +920 WHILE TIMER < T2: WEND: T1! = TIMER + .0167: T2! = T1! + .0167: A$ = INKEY$ +930 FOR I = SC TO 1 STEP -1: PSET (SX(I), SY(I)), SO(I): NEXT I +940 SC = 0 +950 WHILE TIMER < T1! +960 IF SC < 31 THEN SC = SC + 1: GOSUB 7000 +970 WEND +980 IF A$ = "" AND MX = 0 AND MY = 0 THEN 900 +990 CLS : SC = 0: PLAY OFF +1000 ' Dash Message +1010 IF DX = 1 THEN PLAY "MB MN T255 O1 A8 A8" +1020 LOCATE 25, 1: COLOR C15 +1030 IF DX < LEN(DM$) THEN PRINT RIGHT$(DM$, DX); SPACE$(40 - DX); +1040 IF DX >= LEN(DM$) AND DX < 40 THEN PRINT SPC(DX - LEN(DM$)); DM$; SPACE$(40 - DX); +1050 IF DX >= 40 THEN PRINT SPC(DX - LEN(DM$)); LEFT$(DM$, LEN(DM$) - (DX - 40)); +1060 IF DX = 40 + LEN(DM$) THEN DX = 0 ELSE DX = DX + 1 +1070 LOCATE 25, 1: PRINT "" +1090 GOTO 2090 +1100 ' Keybuffer Check (i.e. QB arrow key check) +1110 IF K$ = CHR$(0) + CHR$(72) THEN GOSUB 160 +1120 IF K$ = CHR$(0) + CHR$(75) THEN GOSUB 170 +1130 IF K$ = CHR$(0) + CHR$(77) THEN GOSUB 180 +1140 IF K$ = CHR$(0) + CHR$(80) THEN GOSUB 190 +1150 WHILE INKEY$ <> "": WEND ' clear buffer +1160 RETURN +2000 ' Main Loop +2010 T1! = TIMER + .0167: T2! = TIMER + .0167 +2020 I = MX: OX = PX: PX = PX + I: MX = MX - I +2030 IF PX < 1 THEN PX = 1 ELSE IF PX > 40 THEN PX = 40 +2040 I = MY: OY = PY - 1: PY = PY + I: MY = MY - I +2050 IF PY < 1 THEN PY = 1 ELSE IF PY > 20 THEN PY = 20 +2060 L = L + 1 +2070 FOR I = SC TO 1 STEP -1: PSET (SX(I), SY(I)), SO(I): NEXT I +2080 IF DX <> 0 THEN 1000 ELSE LOCATE 25, 1: COLOR C15: PRINT USING " SCORE:#,###,### HIGH SCORE:#,###,###"; PT!; HS! +2090 IF OY > 0 THEN LOCATE OY, OX: COLOR C14: PRINT "*"; +2130 PT! = PT! + (PY * 1 + (L / 310)): IF HS! < PT! THEN HS! = PT! +2140 IF WX = 0 THEN GOSUB 8500 ELSE GOSUB 8000 +2180 ' Process Level Segment and Collision Detect +2190 SC = 0: ON (1 + FIX(L / 1000)) GOTO 2500, 2600, 2700, 2800, 2900, 9200 +2200 I = SCREEN(PY, PX): IF I <> 0 AND I <> 32 AND I <> 42 AND I <> 86 THEN GOTO 9000 +2210 LOCATE PY, PX: COLOR C3: PRINT "V"; +2220 K$ = INKEY$: IF K$ <> "" THEN GOSUB 1100 +2260 ' Stars and Wait +2270 WHILE TIMER < T1! +2280 IF SC < 31 THEN SC = SC + 1: GOSUB 7000 +2290 WEND +2300 IF C1 <> 0 THEN READ I, N: IF I = 0 THEN RESTORE 280: READ I, N: PALETTE I, N ELSE PALETTE I, N +2310 WHILE TIMER < T2!: WEND +2490 GOTO 2000 +2500 ' Level 1 (0000-0999): Missiles Only +2510 IF L = 60 THEN DX = 1: DM$ = " INCOMING MISSILES!" +2520 IF L < 100 THEN 2200 +2530 IF L > 100 AND L MOD 60 = 0 THEN PLAY "MB MN O1 T255 C8" +2540 IF TX = 0 THEN GOSUB 4500 ELSE GOSUB 4000 +2590 GOTO 2200 +2600 ' Level 2 (1000-1999): Mines and Missiles +2610 IF L = 1000 THEN DX = 1: DM$ = " APPROACHING MINE BARRIER!" +2620 IF L = 1066 THEN LS = 1000: DX = 1: DM$ = " CHECKPOINT SAVED" +2630 IF L > 1122 AND L MOD 45 = 0 THEN PLAY "MB MN O1 T255 D8" +2640 GOSUB 3000 +2650 IF TX = 0 THEN GOSUB 4500 ELSE GOSUB 4000 +2690 GOTO 2200 +2700 ' Level 3 (2000-2999): Mines and Fragments +2710 IF L = 2000 THEN DX = 1: DM$ = " APPROACHING FRAGMENT FIELD!" +2720 IF L = 2068 THEN LS = 2000: DX = 1: DM$ = " CHECKPOINT SAVED" +2730 IF L > 2123 AND L MOD 30 = 0 THEN PLAY "MB MN O1 T255 E8" +2740 GOSUB 3000 +2750 IF FX = 0 THEN GOSUB 5500 ELSE GOSUB 5000 +2790 GOTO 2200 +2800 ' Level 4 (3000-3999): Mines, Frags, and Asteroids +2810 IF L = 3000 THEN DX = 1: DM$ = " APPROACHING ASTEROID BELT!" +2820 IF L = 3067 THEN LS = 3000: DX = 1: DM$ = " CHECKPOINT SAVED" +2830 IF L > 3122 AND L MOD 30 = 0 THEN PLAY "MB MN O1 T255 F8" +2840 GOSUB 3000 +2850 IF FX = 0 THEN GOSUB 5500 ELSE GOSUB 5000 +2860 IF AX = 0 THEN GOSUB 6500 ELSE GOSUB 6000 +2890 GOTO 2200 +2900 ' Level 5 (4000-4999): Mines, Frags, Missiles, and Canyon +2910 IF L = 4000 THEN DX = 1: DM$ = " APPROACHING CANYON!" +2920 IF L = 4060 THEN LS = 4000: DX = 1: DM$ = " CHECKPOINT SAVED" +2930 IF L = 4117 THEN DX = 1: DM$ = " MORE MISSILES DETECTED!" +2935 IF L > 4183 AND L MOD 15 = 0 THEN PLAY "MB O1 T255 F8" +2940 I = 1 + FIX(((L - 3999) / 1000) * 16): COLOR C6 +2950 LOCATE 24, 1: PRINT STRING$(I, 219); CHR$(221); : LOCATE 24, 40 - I: PRINT CHR$(222); STRING$(I, 219); +2960 GOSUB 3000 +2970 IF TX <> 0 THEN GOSUB 4000 ELSE IF L > 4117 THEN GOSUB 4500 +2980 IF FX = 0 THEN GOSUB 5500 ELSE GOSUB 5000 +2990 GOTO 2200 +3000 ' Draw Mine +3010 IF L < 2000 AND RND > ((L - 999) / 1000) THEN RETURN +3020 I = FNRAND(40) +3030 IF SCREEN(24, I) = 0 OR SCREEN(24, I) = 32 THEN LOCATE 24, I: COLOR C13: PRINT "X"; +3040 RETURN +4000 ' Missile (Main) +4010 IF TY > 10 THEN TX = 0: RETURN +4020 IF TY > 1 THEN LOCATE TY - 1, TX: COLOR C14: PRINT "." +4030 TX = TX + TD: IF TX < 1 OR TX > 40 THEN TX = 0: RETURN +4040 IF L MOD TS = 0 THEN TY = TY + 1: TD = SGN(PX - TX) +4050 I = SCREEN(TY, TX) +4060 IF I <> 0 AND I <> 32 AND I <> 42 AND I <> 46 AND I <> 86 THEN PT! = PT! + 100: GOTO 4090 +4070 LOCATE TY, TX: COLOR C4: PRINT "!" +4080 RETURN +4090 TX = 0: PLAY "MB T255 O1 L1 D8" +4100 RETURN +4500 ' Missile (Create) +4510 IF L MOD 30 <> 0 THEN RETURN +4520 TX = PX + FNMOVE(0): TY = 1: TD = SGN(PX - TX) +4530 IF TX < 1 THEN TX = 1 ELSE IF TX > 40 THEN TX = 40 +4540 TS = FNRAND(8) + 6 +4550 RETURN +5000 ' Fragment (Main) +5010 FY = FY - 1: IF FY < 1 THEN FX = 0: RETURN +5020 LOCATE FY, FX: PRINT " "; +5030 IF L MOD FS = 0 THEN FX = FX + FD: IF FX < 1 OR FX > 40 THEN FX = 0: RETURN +5040 LOCATE FY, FX: COLOR C7: PRINT "#"; +5050 RETURN +5500 ' Fragment (Create) +5510 FX = FNRAND(40): FD = SGN(PX - FX) +5520 FY = 25: FS = FNRAND(4) +5530 RETURN +6000 ' Asteroid (Main) +6010 AX = AX + FNMOVE(0) +6020 AL = AL + FNMOVE(0) +6030 IF AX < 1 THEN AX = 1 ELSE IF AX > 40 THEN AX = 40 +6040 IF AL < 1 THEN AX = 0: RETURN +6050 IF AX + AL > 40 THEN AL = 40 - AX + 1 +6060 LOCATE 24, AX: COLOR C8: PRINT STRING$(AL, 178); +6070 AH = AH - 1: IF AH = 0 THEN AX = 0 +6080 RETURN +6500 ' Asteroid (Create) +6510 IF L MOD 10 <> 0 THEN RETURN +6520 AX = FNRAND(40): AL = FNRAND(3): AH = FNRAND(15) + 5 +6530 RETURN +7000 ' Star (Main) +7010 SY(SC) = SY(SC) - SS(SC) +7020 IF SY(SC) < 0 THEN SX(SC) = FIX(RND * 320): SY(SC) = 199 +7030 SO(SC) = POINT(SX(SC), SY(SC)) +7040 IF 0 = SO(SC) THEN PSET (SX(SC), SY(SC)), 11 +7050 RETURN +8000 ' WormHole (Main) +8010 RETURN +8500 ' WormHole (Create) +8510 RETURN +9000 DM$ = "YOU BLEW UP!": I = 0: PLAY "MB O1 T255 ML E2 C1" +9010 WHILE INKEY$ <> "": A$ = INKEY$: WEND +9020 LOCATE 25, 1: PRINT SPACE$(40); +9030 FOR SC = 1 TO 31 +9040 IF POINT(SX(SC), SY(SC)) = 0 THEN PSET (SX(SC), SY(SC)), 11 +9050 NEXT SC +9100 T1! = TIMER + .0333: A$ = INKEY$: I = I + 1 +9110 IF I < 30 THEN CIRCLE (PX * 8 - 4, PY * 8 - 4), I, FNRAND(15) +9120 IF I > 30 AND I < 60 THEN CIRCLE (PX * 8 - 4, PY * 8 - 4), I - 30, 0 +9140 IF A$ = "Y" OR A$ = "y" THEN 300 +9150 IF A$ = "N" OR A$ = "n" THEN 9990 +9160 WHILE TIMER < T1!: WEND +9170 IF I <= 60 THEN 9100 ELSE 9400 +9200 ' Level X (5000-5150): FINISHED! FREE AND CLEAR! +9210 IF L > 5150 GOTO 9300 +9220 GOTO 2200 +9300 DM$ = "YOU ESCAPED!" +9310 WHILE INKEY$ <> "": A$ = INKEY$: WEND +9320 GOTO 9400 +9400 ' Death Theme +9410 BGM$(1) = "MN T70 O2 B8 > D8 F#8 < B8": BGM$(2) = "> D8 F#8 < B8 > D8 G8": BGM$(3) = "< B8 > D8 G8 < B8 > D8" +9420 BGM$(4) = "G8 < B8 > D8 F#8 < A8": BGM$(5) = "> D8 F#8 < A8 > D8 F#8 ": BGM$(6) = "< A8 > C#8 E8 < A8 > C#8" +9430 BGM$(7) = "E8 < A8 > C#8": BGM$(8) = "": BGM$(9) = "": BGM$(10) = "" +9440 MUS = 1: PLAY ON: PLAY "MB " + BGM$(1) +9500 ' MESSAGE BOX Y/N +9510 COLOR C15: LOCATE 25, 1: PRINT USING " HIGH SCORE = #,###,### "; HS!; +9520 LOCATE 10, 10: PRINT CHR$(201); STRING$(20, 205); CHR$(187) +9530 LOCATE 11, 10: PRINT CHR$(186); SPC((20 - LEN(DM$)) / 2); DM$; SPC((20 - LEN(DM$)) / 2); CHR$(186) +9540 LOCATE 12, 10: PRINT CHR$(199); STRING$(20, 196); CHR$(182) +9550 LOCATE 13, 10: PRINT CHR$(186); " PLAY AGAIN (Y/N) ? "; CHR$(186) +9560 LOCATE 14, 10: PRINT CHR$(200); STRING$(20, 205); CHR$(188) +9570 IF A$ = "Y" OR A$ = "y" THEN PLAY OFF: GOTO 300 +9580 IF A$ = "N" OR A$ = "n" THEN PLAY OFF: GOTO 9990 +9590 A$ = INKEY$: GOTO 9570 +9600 ' MUSIC HANDLER +9610 MUS = MUS + 1: IF BGM$(MUS) = "" THEN MUS = 1 +9620 PLAY "MB " + BGM$(MUS) +9630 RETURN +9700 ' Error handling (only currently handles SCREEN 7 => 1 downgrade) +9710 IF ERR <> 5 <> ERL = 510 THEN PRINT ERR; " ON "; ERL: END +9720 C1 = 0: C2 = 0: C3 = 0: C4 = 0: C5 = 0: C6 = 0: C7 = 0: C8 = 0: C9 = 0: C10 = 0: C11 = 0: C12 = 0: C13 = 0: C14 = 0: C15 = 0 +9730 SCREEN 1 +9740 RESUME NEXT +9890 GOTO 100 +9990 CLS : SCREEN 0, 0, 0, 0: WIDTH 80: CLS : END + \ No newline at end of file From f9d0526196d80fad271dfa78c2bfb0c6cc6e189c Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 9 Apr 2023 15:18:05 -0400 Subject: [PATCH 21/28] Add FreeBasic sample --- samples/FreeBasic/User_Control.bas | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 samples/FreeBasic/User_Control.bas diff --git a/samples/FreeBasic/User_Control.bas b/samples/FreeBasic/User_Control.bas new file mode 100644 index 0000000000..5dd16f4bb5 --- /dev/null +++ b/samples/FreeBasic/User_Control.bas @@ -0,0 +1,9 @@ +#include once "mff/UserControl.bi" + +Using My.Sys.Forms + +'#Region "UserControl" + Type UserControl1 Extends UserControl + + End Type +'#End Region From bee1d017ac1521864f987cf621f897c83aa9232f Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 9 Apr 2023 15:51:25 -0400 Subject: [PATCH 22/28] Change new FreeBasic sample --- samples/FreeBasic/Picture.bas | 266 +++++++++++++++++++++++++++++ samples/FreeBasic/User_Control.bas | 9 - 2 files changed, 266 insertions(+), 9 deletions(-) create mode 100644 samples/FreeBasic/Picture.bas delete mode 100644 samples/FreeBasic/User_Control.bas diff --git a/samples/FreeBasic/Picture.bas b/samples/FreeBasic/Picture.bas new file mode 100644 index 0000000000..0095a9cb9c --- /dev/null +++ b/samples/FreeBasic/Picture.bas @@ -0,0 +1,266 @@ +'############################################################################### +'# Picture.bas # +'# This file is part of MyFBFramework # +'# Authors: Nastase Eodor, Liu ZiQI # +'# Based on: # +'# TStatic.bi # +'# FreeBasic Windows GUI ToolKit # +'# Copyright (c) 2007-2008 Nastase Eodor # +'# Version 1.0.0 # +'# Created by Liu ZiQI (2019) # +'############################################################################### +'https://blog.csdn.net/mmmvp/article/details/365155 +#include once "Picture.bi" +Namespace My.Sys.Forms + #ifndef ReadProperty_Off + Private Function Picture.ReadProperty(PropertyName As String) As Any Ptr + Select Case LCase(PropertyName) + Case "graphic": Return Cast(Any Ptr, @This.Graphic) + Case "tabindex": Return @FTabIndex + Case Else: Return Base.ReadProperty(PropertyName) + End Select + Return 0 + End Function + #endif + + #ifndef WriteProperty_Off + Private Function Picture.WriteProperty(PropertyName As String, Value As Any Ptr) As Boolean + If Value = 0 Then + Select Case LCase(PropertyName) + Case Else: Return Base.WriteProperty(PropertyName, Value) + End Select + Else + Select Case LCase(PropertyName) + Case "graphic": This.Graphic = QWString(Value) + Case "tabindex": TabIndex = QInteger(Value) + Case Else: Return Base.WriteProperty(PropertyName, Value) + End Select + End If + Return True + End Function + #endif + + Private Property Picture.TabIndex As Integer + Return FTabIndex + End Property + + Private Property Picture.TabIndex(Value As Integer) + ChangeTabIndex Value + End Property + + Private Property Picture.TabStop As Boolean + Return FTabStop + End Property + + Private Property Picture.TabStop(Value As Boolean) + ChangeTabStop Value + End Property + + Private Property Picture.Style As Integer + Return FStyle + End Property + + Private Property Picture.Style(Value As Integer) + If Value <> FStyle Then + FStyle = Value + #ifndef __USE_GTK__ + Base.Style = WS_CHILD Or SS_NOTIFY Or AStyle(abs_(FStyle)) Or ARealSizeImage(abs_(FRealSizeImage)) Or ACenterImage(abs_(FCenterImage)) + #endif + RecreateWnd + End If + End Property + + Private Property Picture.RealSizeImage As Boolean + Return FRealSizeImage + End Property + + Private Property Picture.RealSizeImage(Value As Boolean) + If Value <> FRealSizeImage Then + FRealSizeImage = Value + #ifndef __USE_GTK__ + Base.Style = WS_CHILD Or SS_NOTIFY Or AStyle(abs_(FStyle)) Or ARealSizeImage(abs_(FRealSizeImage)) Or ACenterImage(abs_(FCenterImage)) + #endif + RecreateWnd + End If + End Property + + Private Property Picture.CenterImage As Boolean + Return FCenterImage + End Property + + Private Property Picture.CenterImage(Value As Boolean) + If Value <> FCenterImage Then + FCenterImage = Value + #ifndef __USE_GTK__ + Base.Style = WS_CHILD Or SS_NOTIFY Or AStyle(abs_(FStyle)) Or ARealSizeImage(abs_(FRealSizeImage)) Or ACenterImage(abs_(FCenterImage)) + #endif + RecreateWnd + End If + End Property + + Private Sub Picture.GraphicChange(ByRef Sender As My.Sys.Drawing.GraphicType, Image As Any Ptr, ImageType As Integer) + With Sender + If .Ctrl->Child Then + #ifdef __USE_GTK__ + If GTK_IS_IMAGE(QPicture(.Ctrl->Child).ImageWidget) Then + Select Case ImageType + Case 0 + gtk_image_set_from_pixbuf(GTK_IMAGE(QPicture(.Ctrl->Child).ImageWidget), .Bitmap.Handle) + Case 1 + gtk_image_set_from_pixbuf(GTK_IMAGE(QPicture(.Ctrl->Child).ImageWidget), .Icon.Handle) + End Select + End If + #else + Select Case ImageType + Case 0 + QPicture(.Ctrl->Child).Style = PictureStyle.ssBitmap + QPicture(.Ctrl->Child).Perform(BM_SETIMAGE,ImageType,CInt(Sender.Bitmap.Handle)) + Case 1 + QPicture(.Ctrl->Child).Style = PictureStyle.ssIcon + QPicture(.Ctrl->Child).Perform(BM_SETIMAGE,ImageType,CInt(Sender.Icon.Handle)) + Case 2 + QPicture(.Ctrl->Child).Style = PictureStyle.ssCursor + QPicture(.Ctrl->Child).Perform(BM_SETIMAGE,ImageType,CInt(Sender.Icon.Handle)) + Case 3 + QPicture(.Ctrl->Child).Style = PictureStyle.ssEmf + QPicture(.Ctrl->Child).Perform(BM_SETIMAGE,ImageType,CInt(0)) + End Select + #endif + End If + End With + End Sub + + #ifndef __USE_GTK__ + Private Sub Picture.HandleIsAllocated(ByRef Sender As Control) + If Sender.Child Then + With QPicture(Sender.Child) + .Perform(STM_SETIMAGE,.Graphic.ImageType,CInt(.Graphic.Image)) + End With + End If + End Sub + + Private Sub Picture.WndProc(ByRef Message As Message) + End Sub + #endif + + Private Sub Picture.ProcessMessage(ByRef Message As Message) + #ifndef __USE_GTK__ + Select Case Message.Msg + Case WM_SIZE + InvalidateRect(Handle,NULL,True) + Case WM_CTLCOLORSTATIC ', WM_CTLCOLORBTN + If This.Parent Then This.Parent->ProcessMessage Message + If Message.Result <> 0 Then Return + Case CM_CTLCOLOR + Static As HDC Dc + Dc = Cast(HDC,Message.wParam) + SetBkMode Dc, TRANSPARENT + SetTextColor Dc, This.Font.Color + SetBkColor Dc, This.BackColor + SetBkMode Dc, OPAQUE + Case CM_COMMAND + If Message.wParamHi = STN_CLICKED Then + If OnClick Then OnClick(This) + End If + If Message.wParamHi = STN_DBLCLK Then + If OnDblClick Then OnDblClick(This) + End If + Case WM_ERASEBKGND + Dim As ..RECT R + GetClientRect Handle, @R + FillRect Cast(HDC, Message.wParam), @R, Brush.Handle + Message.Result = -1 + Canvas.TransferDoubleBuffer(0, 0, This.Width, This.Height) + Case CM_DRAWITEM + Dim As DRAWITEMSTRUCT Ptr diStruct + Dim As My.Sys.Drawing.Rect R + Dim As HDC Dc + diStruct = Cast(DRAWITEMSTRUCT Ptr,Message.lParam) + R = *Cast(My.Sys.Drawing.Rect Ptr, @diStruct->rcItem) + Dc = diStruct->hDC + If OnDraw Then + OnDraw(This,R,Dc) + Else + End If + End Select + #endif + Base.ProcessMessage(Message) + End Sub + + + Private Operator Picture.Cast As Control Ptr + Return Cast(Control Ptr, @This) + End Operator + + Private Constructor Picture + #ifdef __USE_GTK__ + ImageWidget = gtk_image_new() + widget = gtk_layout_new(null, null) + If gtk_is_widget(ImageWidget) Then gtk_layout_put(GTK_LAYOUT(widget), ImageWidget, 0, 0) + This.RegisterClass "Picture", @This + #else + 'https://blog.csdn.net/mmmvp/article/details/365155 + '常数 说明 + Astyle(0)=0 + Astyle(1)=SS_BITMAP'在静态控件中显示一幅位图(.BMP)，由控件的文本(TEXT)指定一幅包含在资源中的位图文件(非文件名)，该风格忽略控件的宽度和高度，控件将自动调整大小以适应位图。 + Astyle(2)=SS_ICON'在静态控件中显示一幅图标(.ICO)，由控件的文本(TEXT)指定一幅包含在资源中的图标文件(非文件名)，该风格忽略控件的宽度和高度，控件将自动调整大小以适应图标。 + Astyle(3)=SS_ENHMETAFILE'在静态控件中显示一增强幅图元文件(.EMF)。由控件的文本(TEXT)指定图元文件名。控件大小固定不变，图元文件按比例缩放显示在控件客户区中。 + Astyle(4)=SS_BLACKFRAME'用系统颜色组的窗口边界色(缺省为黑色)绘制一个边框，框内使用与底部窗体相同的颜色（透明）。 + Astyle(5)=SS_BLACKRECT'用系统颜色组的窗口边界色(缺省为黑色)绘制一个矩形实心控件。 + Astyle(6)=SS_GRAYFRAME'用系统颜色组的屏幕背景色绘制一个边框，框内使用与底部窗体相同的颜色（透明）。 + Astyle(7)=SS_GRAYRECT'用系统颜色组的屏幕背景色绘制一个矩形实心控件。 + Astyle(8)=SS_WHITEFRAME'用系统颜色组的窗口背景色(缺省为白色)绘制一个边框，框内使用与底部窗体相同的颜色（透明）。 + Astyle(9)=SS_WHITERECT'用系统颜色组的窗口背景色(缺省为白色)色绘制一个矩形实心控件。 + Astyle(10)=SS_ETCHEDFRAME'用下凹的3D线条绘制一个边框，框内使用与底部窗体相同的颜色（透明）。 + Astyle(11)=SS_ETCHEDHORZ'用下凹的3D线条绘制控件的上下两边，框内使用与底部窗体相同的颜色（透明）。 + Astyle(12)=SS_ETCHEDVERT'用下凹的3D线条绘制控件的左右两边，框内使用与底部窗体相同的颜色（透明）。 + Astyle(13)=SS_RIGHTJUST'与SS_BITMAP 或 SS_ICON 配合当需要对控件的大小进行自动调整时以控件的右下角为基准，只有控件的上边和左边的位置改变。 + Astyle(14)=SS_NOPREFIX'禁止对字符“&”进行解释，通常字符“&”会被解释成在下一个字符加一个下画线，“&&”会被解释成一个字符“&”，用户可以使用SS_NOPREFIX风格来禁止这项解释。 + Astyle(15)=SS_NOTIFY'当控件被用户单击或双击控件时向父窗口传送STN_CLICKED, STN_DBLCLK, STN_DISABLE, 或 STN_ENABLE 通知消息。 + Astyle(16)=SS_OWNERDRAW'自绘静态控件，每当控件需要重画时，父窗口将收到WM_DRAWITEM消息。 + Astyle(17)=SS_REALSIZEIMAGE'禁止根据位图或图标大小自动进行控件尺寸的调整，如果本常数被设定，大于控件的图片其超出部份将被截去。 + Astyle(18)=SS_SUNKEN'绘制一个下沉的控件。 + Astyle(19)=SS_CENTER'文本显示水平居中，显示之前先对文本进行格式化，超过控件宽度将自动换行。 + Astyle(20)=SS_CENTERIMAGE'文本显示垂直居中。本常数还设定当位图或图标小于控件客户区时使用图片左上角点的颜色填充控件边缘。 + Astyle(21)=SS_LEFT'文本显示居左，显示之前先对文本进行格式化，超过控件宽度将自动换行。 + Astyle(22)=SS_LEFTNOWORDWRAP'文本显示居左，超过控件宽度部份将被截去，不进行自动换行处理。 + Astyle(23)=SS_RIGHT'文本显示居右，显示之前先对文本进行格式化，超过控件宽度将自动换行。 + Astyle(24)=SS_SIMPLE'文本在控件的左上角单行显示，不进行自动换行处理。父窗口进程不能对WM_CTLCOLORSTATIC消息进行处理。 + + ACenterImage(0) = SS_RIGHTJUST + ACenterImage(1) = SS_CENTERIMAGE + ARealSizeImage(0)= 0 + ARealSizeImage(1)= SS_REALSIZEIMAGE + #endif + This.Canvas.Ctrl = @This + Graphic.Ctrl = @This + Graphic.OnChange = @GraphicChange + FRealSizeImage = 1 + FCenterImage = 1 + FStyle = 0 + With This + .Child = @This + #ifndef __USE_GTK__ + .RegisterClass "Picture", "Static" + .ChildProc = @WndProc + Base.ExStyle = 0 + Base.Style = WS_CHILD Or SS_NOTIFY Or ARealSizeImage(Abs_(FRealSizeImage)) Or ACenterImage(Abs_(FCenterImage)) Or AStyle(Abs_(FStyle)) + .BackColor = GetSysColor(COLOR_BTNFACE) + FDefaultBackColor = .BackColor + .OnHandleIsAllocated = @HandleIsAllocated + #endif + WLet(FClassName, "Picture") + WLet(FClassAncestor, "Static") + FTabIndex = -1 + .Width =80 + .Height = 60 + End With + End Constructor + Private Destructor Picture + #ifdef __USE_GTK__ + If gtk_is_widget(ImageWidget) Then + gtk_widget_destroy(ImageWidget) + End If + #endif + End Destructor +End Namespace diff --git a/samples/FreeBasic/User_Control.bas b/samples/FreeBasic/User_Control.bas deleted file mode 100644 index 5dd16f4bb5..0000000000 --- a/samples/FreeBasic/User_Control.bas +++ /dev/null @@ -1,9 +0,0 @@ -#include once "mff/UserControl.bi" - -Using My.Sys.Forms - -'#Region "UserControl" - Type UserControl1 Extends UserControl - - End Type -'#End Region From 2d16003f93b7ddc9b4e00cfb3e6a10caab923edf Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 9 Apr 2023 20:21:48 -0400 Subject: [PATCH 23/28] Restore Plasma Generation.bas --- samples/FreeBasic/Plasma Generation.bas | 125 ++++++++++++++++++++++++ 1 file changed, 125 insertions(+) create mode 100644 samples/FreeBasic/Plasma Generation.bas diff --git a/samples/FreeBasic/Plasma Generation.bas b/samples/FreeBasic/Plasma Generation.bas new file mode 100644 index 0000000000..0273ae94a4 --- /dev/null +++ b/samples/FreeBasic/Plasma Generation.bas @@ -0,0 +1,125 @@ +'+++++ IMPORTANT +++++ +' - The only reason this +' code doesnt generate +' plasma instantaneously +' is because it draws +' each iteration instead +' of the final product. +' It looks cooler this +' way : ) + + +Dim Shared As Integer Grad(0 To 255) + + +'+=============================================================+ +Sub Rainbow() + Dim As Integer i, b, badd, g, gadd, r, radd, rx, gx, bx + rx = 2 + gx = -2 + bx = -2 + b=Int(Rnd * 256):badd= bx + g=Int(Rnd * 256):gadd= gx + r=Int(Rnd * 256):radd= rx + For i = 0 To 255 + b += badd + g += gadd + r += radd + If b < 0 Then badd = -bx: b = 0 + If b > 255 Then badd = bx: b = 255 + If g < 0 Then gadd = -gx: g = 0 + If g > 255 Then gadd = gx: g = 255 + If r > 255 Then radd = -rx: r = 255 + If r < 0 Then radd = rx: r = 0 + Grad(i) = RGB(r,g,b) + Next i +End Sub +'+==============+MAKE THIS WHATEVER YOU WANT : )+==============+ + + +Rainbow + + +Sub GenPlasma(byval w as integer, byval h as integer, _ + byval crnr1 as integer, byval crnr2 as integer, _ + byval crnr3 as integer, byval crnr4 as integer, _ + byval rough as integer, byval iter as integer, _ + byval prs as double) + Dim as double prex, prey, d1, d2, d3, d4, hr, fv, Image(0 to w,0 to h) + hr = rough * 2 + prex = w / 2: prey = h / 2 + Image(0,0)=crnr1 + Image(w,0)=crnr2: d1 = (crnr1+crnr2) / 2: Image(prex,0)=d1 + Image(w,h)=crnr3: d2 = (crnr2+crnr3) / 2: Image(w,prey)=d2 + Image(0,h)=crnr4: d3 = (crnr3+crnr4) / 2: Image(prex,h)=d3 + d4 = (crnr4+crnr1) / 2: Image(0,prey)=d4 + fv = ((d1+d2+d3+d4) / 4) + (Int(rnd * hr) - rough) + If fv>255 Then + fv=255 + ELseif fv<0 Then + fv=0 + Endif + Image(Cint(prex),Cint(prey))=fv + Dim as double divisor, mdivx, mdivy, i, xs, ys, c1,c2,c3,c4, cx,cy, dx,dy + mdivx = w / 2: mdivy = h / 2 + w -= 1: h -= 1 + For i = 1 to iter + For ys = 0 To h Step mdivy + For xs = 0 To w Step mdivx + prex = mdivx / 2: prey = mdivy / 2 + cx = xs + mdivx : cy = ys + mdivy + c1 = Image(Cint(xs),Cint(ys)): c2 = Image(Cint(cx),Cint(ys)) + c3 = Image(Cint(cx),Cint(cy)): c4 = Image(Cint(xs),Cint(cy)) + d1 = (c1+c2) / 2: d2 = (c2+c3) / 2 + d3 = (c3+c4) / 2: d4 = (c4+c1) / 2 + dx = xs + prex: dy = ys + prey + Image(Cint(dx),Cint(ys))=d1 + Image(Cint(cx),Cint(dy))=d2 + Image(Cint(dx),Cint(cy))=d3 + Image(Cint(xs),Cint(dy))=d4 + fv = ((d1+d2+d3+d4) / 4) + (Int(rnd * hr) - rough) + If fv>255 Then + fv=255 + ELseif fv<0 Then + fv=0 + Endif + Image(Cint(dx),Cint(dy))=fv + Next xs + Next ys + mdivx = mdivx / 2 + mdivy = mdivy / 2 + hr = rough + rough = rough * prs + ScreenLock + For ys = 0 To h Step mdivy + For xs = 0 To w Step mdivx + Line (xs,ys)-(xs+mdivx,ys+mdivy), Grad(Image(xs,ys)), BF + Next xs + Next ys + ScreenUnlock + Next i +End Sub + + + +'test code + +#include "fbgfx.bi" +Using FB +#define ri(x) (Int(Rnd*x)) +ScreenRes 1280,1024,32,,1 +Randomize Timer + +Do + Rainbow + GenPlasma 1280,1024,ri(256),ri(256),ri(256),ri(256),300,8,Rnd + Locate 1,1: Print "Press the spacebar for another pattern. Press ESC to quit" + Do + If MultiKey(&h01) Then + End + ElseIf MultiKey(SC_SPACE) Then + Goto ExitDo + EndIf + Loop + ExitDo: +Loop From 2571a7a3cc5635e85c6a3ed7f63d895c61f227d9 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Sun, 16 Apr 2023 22:28:12 -0400 Subject: [PATCH 24/28] Update samples --- samples/FreeBasic/Picture.bas | 266 ------------------ samples/FreeBasic/Plasma Generation.bas | 125 --------- samples/FreeBasic/array_clearobj.bas | 56 ++++ samples/FreeBasic/makescript.bas | 174 ++++++++++++ samples/FreeBasic/try_catch_throw.bas | 347 ------------------------ samples/Visual Basic 6.0/Module2.bas | 170 ++++++++++++ samples/Visual Basic 6.0/XmlUtil.bas | 266 ------------------ 7 files changed, 400 insertions(+), 1004 deletions(-) delete mode 100644 samples/FreeBasic/Picture.bas delete mode 100644 samples/FreeBasic/Plasma Generation.bas create mode 100644 samples/FreeBasic/array_clearobj.bas create mode 100644 samples/FreeBasic/makescript.bas delete mode 100644 samples/FreeBasic/try_catch_throw.bas create mode 100644 samples/Visual Basic 6.0/Module2.bas delete mode 100644 samples/Visual Basic 6.0/XmlUtil.bas diff --git a/samples/FreeBasic/Picture.bas b/samples/FreeBasic/Picture.bas deleted file mode 100644 index 0095a9cb9c..0000000000 --- a/samples/FreeBasic/Picture.bas +++ /dev/null @@ -1,266 +0,0 @@ -'############################################################################### -'# Picture.bas # -'# This file is part of MyFBFramework # -'# Authors: Nastase Eodor, Liu ZiQI # -'# Based on: # -'# TStatic.bi # -'# FreeBasic Windows GUI ToolKit # -'# Copyright (c) 2007-2008 Nastase Eodor # -'# Version 1.0.0 # -'# Created by Liu ZiQI (2019) # -'############################################################################### -'https://blog.csdn.net/mmmvp/article/details/365155 -#include once "Picture.bi" -Namespace My.Sys.Forms - #ifndef ReadProperty_Off - Private Function Picture.ReadProperty(PropertyName As String) As Any Ptr - Select Case LCase(PropertyName) - Case "graphic": Return Cast(Any Ptr, @This.Graphic) - Case "tabindex": Return @FTabIndex - Case Else: Return Base.ReadProperty(PropertyName) - End Select - Return 0 - End Function - #endif - - #ifndef WriteProperty_Off - Private Function Picture.WriteProperty(PropertyName As String, Value As Any Ptr) As Boolean - If Value = 0 Then - Select Case LCase(PropertyName) - Case Else: Return Base.WriteProperty(PropertyName, Value) - End Select - Else - Select Case LCase(PropertyName) - Case "graphic": This.Graphic = QWString(Value) - Case "tabindex": TabIndex = QInteger(Value) - Case Else: Return Base.WriteProperty(PropertyName, Value) - End Select - End If - Return True - End Function - #endif - - Private Property Picture.TabIndex As Integer - Return FTabIndex - End Property - - Private Property Picture.TabIndex(Value As Integer) - ChangeTabIndex Value - End Property - - Private Property Picture.TabStop As Boolean - Return FTabStop - End Property - - Private Property Picture.TabStop(Value As Boolean) - ChangeTabStop Value - End Property - - Private Property Picture.Style As Integer - Return FStyle - End Property - - Private Property Picture.Style(Value As Integer) - If Value <> FStyle Then - FStyle = Value - #ifndef __USE_GTK__ - Base.Style = WS_CHILD Or SS_NOTIFY Or AStyle(abs_(FStyle)) Or ARealSizeImage(abs_(FRealSizeImage)) Or ACenterImage(abs_(FCenterImage)) - #endif - RecreateWnd - End If - End Property - - Private Property Picture.RealSizeImage As Boolean - Return FRealSizeImage - End Property - - Private Property Picture.RealSizeImage(Value As Boolean) - If Value <> FRealSizeImage Then - FRealSizeImage = Value - #ifndef __USE_GTK__ - Base.Style = WS_CHILD Or SS_NOTIFY Or AStyle(abs_(FStyle)) Or ARealSizeImage(abs_(FRealSizeImage)) Or ACenterImage(abs_(FCenterImage)) - #endif - RecreateWnd - End If - End Property - - Private Property Picture.CenterImage As Boolean - Return FCenterImage - End Property - - Private Property Picture.CenterImage(Value As Boolean) - If Value <> FCenterImage Then - FCenterImage = Value - #ifndef __USE_GTK__ - Base.Style = WS_CHILD Or SS_NOTIFY Or AStyle(abs_(FStyle)) Or ARealSizeImage(abs_(FRealSizeImage)) Or ACenterImage(abs_(FCenterImage)) - #endif - RecreateWnd - End If - End Property - - Private Sub Picture.GraphicChange(ByRef Sender As My.Sys.Drawing.GraphicType, Image As Any Ptr, ImageType As Integer) - With Sender - If .Ctrl->Child Then - #ifdef __USE_GTK__ - If GTK_IS_IMAGE(QPicture(.Ctrl->Child).ImageWidget) Then - Select Case ImageType - Case 0 - gtk_image_set_from_pixbuf(GTK_IMAGE(QPicture(.Ctrl->Child).ImageWidget), .Bitmap.Handle) - Case 1 - gtk_image_set_from_pixbuf(GTK_IMAGE(QPicture(.Ctrl->Child).ImageWidget), .Icon.Handle) - End Select - End If - #else - Select Case ImageType - Case 0 - QPicture(.Ctrl->Child).Style = PictureStyle.ssBitmap - QPicture(.Ctrl->Child).Perform(BM_SETIMAGE,ImageType,CInt(Sender.Bitmap.Handle)) - Case 1 - QPicture(.Ctrl->Child).Style = PictureStyle.ssIcon - QPicture(.Ctrl->Child).Perform(BM_SETIMAGE,ImageType,CInt(Sender.Icon.Handle)) - Case 2 - QPicture(.Ctrl->Child).Style = PictureStyle.ssCursor - QPicture(.Ctrl->Child).Perform(BM_SETIMAGE,ImageType,CInt(Sender.Icon.Handle)) - Case 3 - QPicture(.Ctrl->Child).Style = PictureStyle.ssEmf - QPicture(.Ctrl->Child).Perform(BM_SETIMAGE,ImageType,CInt(0)) - End Select - #endif - End If - End With - End Sub - - #ifndef __USE_GTK__ - Private Sub Picture.HandleIsAllocated(ByRef Sender As Control) - If Sender.Child Then - With QPicture(Sender.Child) - .Perform(STM_SETIMAGE,.Graphic.ImageType,CInt(.Graphic.Image)) - End With - End If - End Sub - - Private Sub Picture.WndProc(ByRef Message As Message) - End Sub - #endif - - Private Sub Picture.ProcessMessage(ByRef Message As Message) - #ifndef __USE_GTK__ - Select Case Message.Msg - Case WM_SIZE - InvalidateRect(Handle,NULL,True) - Case WM_CTLCOLORSTATIC ', WM_CTLCOLORBTN - If This.Parent Then This.Parent->ProcessMessage Message - If Message.Result <> 0 Then Return - Case CM_CTLCOLOR - Static As HDC Dc - Dc = Cast(HDC,Message.wParam) - SetBkMode Dc, TRANSPARENT - SetTextColor Dc, This.Font.Color - SetBkColor Dc, This.BackColor - SetBkMode Dc, OPAQUE - Case CM_COMMAND - If Message.wParamHi = STN_CLICKED Then - If OnClick Then OnClick(This) - End If - If Message.wParamHi = STN_DBLCLK Then - If OnDblClick Then OnDblClick(This) - End If - Case WM_ERASEBKGND - Dim As ..RECT R - GetClientRect Handle, @R - FillRect Cast(HDC, Message.wParam), @R, Brush.Handle - Message.Result = -1 - Canvas.TransferDoubleBuffer(0, 0, This.Width, This.Height) - Case CM_DRAWITEM - Dim As DRAWITEMSTRUCT Ptr diStruct - Dim As My.Sys.Drawing.Rect R - Dim As HDC Dc - diStruct = Cast(DRAWITEMSTRUCT Ptr,Message.lParam) - R = *Cast(My.Sys.Drawing.Rect Ptr, @diStruct->rcItem) - Dc = diStruct->hDC - If OnDraw Then - OnDraw(This,R,Dc) - Else - End If - End Select - #endif - Base.ProcessMessage(Message) - End Sub - - - Private Operator Picture.Cast As Control Ptr - Return Cast(Control Ptr, @This) - End Operator - - Private Constructor Picture - #ifdef __USE_GTK__ - ImageWidget = gtk_image_new() - widget = gtk_layout_new(null, null) - If gtk_is_widget(ImageWidget) Then gtk_layout_put(GTK_LAYOUT(widget), ImageWidget, 0, 0) - This.RegisterClass "Picture", @This - #else - 'https://blog.csdn.net/mmmvp/article/details/365155 - '常数 说明 - Astyle(0)=0 - Astyle(1)=SS_BITMAP'在静态控件中显示一幅位图(.BMP)，由控件的文本(TEXT)指定一幅包含在资源中的位图文件(非文件名)，该风格忽略控件的宽度和高度，控件将自动调整大小以适应位图。 - Astyle(2)=SS_ICON'在静态控件中显示一幅图标(.ICO)，由控件的文本(TEXT)指定一幅包含在资源中的图标文件(非文件名)，该风格忽略控件的宽度和高度，控件将自动调整大小以适应图标。 - Astyle(3)=SS_ENHMETAFILE'在静态控件中显示一增强幅图元文件(.EMF)。由控件的文本(TEXT)指定图元文件名。控件大小固定不变，图元文件按比例缩放显示在控件客户区中。 - Astyle(4)=SS_BLACKFRAME'用系统颜色组的窗口边界色(缺省为黑色)绘制一个边框，框内使用与底部窗体相同的颜色（透明）。 - Astyle(5)=SS_BLACKRECT'用系统颜色组的窗口边界色(缺省为黑色)绘制一个矩形实心控件。 - Astyle(6)=SS_GRAYFRAME'用系统颜色组的屏幕背景色绘制一个边框，框内使用与底部窗体相同的颜色（透明）。 - Astyle(7)=SS_GRAYRECT'用系统颜色组的屏幕背景色绘制一个矩形实心控件。 - Astyle(8)=SS_WHITEFRAME'用系统颜色组的窗口背景色(缺省为白色)绘制一个边框，框内使用与底部窗体相同的颜色（透明）。 - Astyle(9)=SS_WHITERECT'用系统颜色组的窗口背景色(缺省为白色)色绘制一个矩形实心控件。 - Astyle(10)=SS_ETCHEDFRAME'用下凹的3D线条绘制一个边框，框内使用与底部窗体相同的颜色（透明）。 - Astyle(11)=SS_ETCHEDHORZ'用下凹的3D线条绘制控件的上下两边，框内使用与底部窗体相同的颜色（透明）。 - Astyle(12)=SS_ETCHEDVERT'用下凹的3D线条绘制控件的左右两边，框内使用与底部窗体相同的颜色（透明）。 - Astyle(13)=SS_RIGHTJUST'与SS_BITMAP 或 SS_ICON 配合当需要对控件的大小进行自动调整时以控件的右下角为基准，只有控件的上边和左边的位置改变。 - Astyle(14)=SS_NOPREFIX'禁止对字符“&”进行解释，通常字符“&”会被解释成在下一个字符加一个下画线，“&&”会被解释成一个字符“&”，用户可以使用SS_NOPREFIX风格来禁止这项解释。 - Astyle(15)=SS_NOTIFY'当控件被用户单击或双击控件时向父窗口传送STN_CLICKED, STN_DBLCLK, STN_DISABLE, 或 STN_ENABLE 通知消息。 - Astyle(16)=SS_OWNERDRAW'自绘静态控件，每当控件需要重画时，父窗口将收到WM_DRAWITEM消息。 - Astyle(17)=SS_REALSIZEIMAGE'禁止根据位图或图标大小自动进行控件尺寸的调整，如果本常数被设定，大于控件的图片其超出部份将被截去。 - Astyle(18)=SS_SUNKEN'绘制一个下沉的控件。 - Astyle(19)=SS_CENTER'文本显示水平居中，显示之前先对文本进行格式化，超过控件宽度将自动换行。 - Astyle(20)=SS_CENTERIMAGE'文本显示垂直居中。本常数还设定当位图或图标小于控件客户区时使用图片左上角点的颜色填充控件边缘。 - Astyle(21)=SS_LEFT'文本显示居左，显示之前先对文本进行格式化，超过控件宽度将自动换行。 - Astyle(22)=SS_LEFTNOWORDWRAP'文本显示居左，超过控件宽度部份将被截去，不进行自动换行处理。 - Astyle(23)=SS_RIGHT'文本显示居右，显示之前先对文本进行格式化，超过控件宽度将自动换行。 - Astyle(24)=SS_SIMPLE'文本在控件的左上角单行显示，不进行自动换行处理。父窗口进程不能对WM_CTLCOLORSTATIC消息进行处理。 - - ACenterImage(0) = SS_RIGHTJUST - ACenterImage(1) = SS_CENTERIMAGE - ARealSizeImage(0)= 0 - ARealSizeImage(1)= SS_REALSIZEIMAGE - #endif - This.Canvas.Ctrl = @This - Graphic.Ctrl = @This - Graphic.OnChange = @GraphicChange - FRealSizeImage = 1 - FCenterImage = 1 - FStyle = 0 - With This - .Child = @This - #ifndef __USE_GTK__ - .RegisterClass "Picture", "Static" - .ChildProc = @WndProc - Base.ExStyle = 0 - Base.Style = WS_CHILD Or SS_NOTIFY Or ARealSizeImage(Abs_(FRealSizeImage)) Or ACenterImage(Abs_(FCenterImage)) Or AStyle(Abs_(FStyle)) - .BackColor = GetSysColor(COLOR_BTNFACE) - FDefaultBackColor = .BackColor - .OnHandleIsAllocated = @HandleIsAllocated - #endif - WLet(FClassName, "Picture") - WLet(FClassAncestor, "Static") - FTabIndex = -1 - .Width =80 - .Height = 60 - End With - End Constructor - Private Destructor Picture - #ifdef __USE_GTK__ - If gtk_is_widget(ImageWidget) Then - gtk_widget_destroy(ImageWidget) - End If - #endif - End Destructor -End Namespace diff --git a/samples/FreeBasic/Plasma Generation.bas b/samples/FreeBasic/Plasma Generation.bas deleted file mode 100644 index 0273ae94a4..0000000000 --- a/samples/FreeBasic/Plasma Generation.bas +++ /dev/null @@ -1,125 +0,0 @@ -'+++++ IMPORTANT +++++ -' - The only reason this -' code doesnt generate -' plasma instantaneously -' is because it draws -' each iteration instead -' of the final product. -' It looks cooler this -' way : ) - - -Dim Shared As Integer Grad(0 To 255) - - -'+=============================================================+ -Sub Rainbow() - Dim As Integer i, b, badd, g, gadd, r, radd, rx, gx, bx - rx = 2 - gx = -2 - bx = -2 - b=Int(Rnd * 256):badd= bx - g=Int(Rnd * 256):gadd= gx - r=Int(Rnd * 256):radd= rx - For i = 0 To 255 - b += badd - g += gadd - r += radd - If b < 0 Then badd = -bx: b = 0 - If b > 255 Then badd = bx: b = 255 - If g < 0 Then gadd = -gx: g = 0 - If g > 255 Then gadd = gx: g = 255 - If r > 255 Then radd = -rx: r = 255 - If r < 0 Then radd = rx: r = 0 - Grad(i) = RGB(r,g,b) - Next i -End Sub -'+==============+MAKE THIS WHATEVER YOU WANT : )+==============+ - - -Rainbow - - -Sub GenPlasma(byval w as integer, byval h as integer, _ - byval crnr1 as integer, byval crnr2 as integer, _ - byval crnr3 as integer, byval crnr4 as integer, _ - byval rough as integer, byval iter as integer, _ - byval prs as double) - Dim as double prex, prey, d1, d2, d3, d4, hr, fv, Image(0 to w,0 to h) - hr = rough * 2 - prex = w / 2: prey = h / 2 - Image(0,0)=crnr1 - Image(w,0)=crnr2: d1 = (crnr1+crnr2) / 2: Image(prex,0)=d1 - Image(w,h)=crnr3: d2 = (crnr2+crnr3) / 2: Image(w,prey)=d2 - Image(0,h)=crnr4: d3 = (crnr3+crnr4) / 2: Image(prex,h)=d3 - d4 = (crnr4+crnr1) / 2: Image(0,prey)=d4 - fv = ((d1+d2+d3+d4) / 4) + (Int(rnd * hr) - rough) - If fv>255 Then - fv=255 - ELseif fv<0 Then - fv=0 - Endif - Image(Cint(prex),Cint(prey))=fv - Dim as double divisor, mdivx, mdivy, i, xs, ys, c1,c2,c3,c4, cx,cy, dx,dy - mdivx = w / 2: mdivy = h / 2 - w -= 1: h -= 1 - For i = 1 to iter - For ys = 0 To h Step mdivy - For xs = 0 To w Step mdivx - prex = mdivx / 2: prey = mdivy / 2 - cx = xs + mdivx : cy = ys + mdivy - c1 = Image(Cint(xs),Cint(ys)): c2 = Image(Cint(cx),Cint(ys)) - c3 = Image(Cint(cx),Cint(cy)): c4 = Image(Cint(xs),Cint(cy)) - d1 = (c1+c2) / 2: d2 = (c2+c3) / 2 - d3 = (c3+c4) / 2: d4 = (c4+c1) / 2 - dx = xs + prex: dy = ys + prey - Image(Cint(dx),Cint(ys))=d1 - Image(Cint(cx),Cint(dy))=d2 - Image(Cint(dx),Cint(cy))=d3 - Image(Cint(xs),Cint(dy))=d4 - fv = ((d1+d2+d3+d4) / 4) + (Int(rnd * hr) - rough) - If fv>255 Then - fv=255 - ELseif fv<0 Then - fv=0 - Endif - Image(Cint(dx),Cint(dy))=fv - Next xs - Next ys - mdivx = mdivx / 2 - mdivy = mdivy / 2 - hr = rough - rough = rough * prs - ScreenLock - For ys = 0 To h Step mdivy - For xs = 0 To w Step mdivx - Line (xs,ys)-(xs+mdivx,ys+mdivy), Grad(Image(xs,ys)), BF - Next xs - Next ys - ScreenUnlock - Next i -End Sub - - - -'test code - -#include "fbgfx.bi" -Using FB -#define ri(x) (Int(Rnd*x)) -ScreenRes 1280,1024,32,,1 -Randomize Timer - -Do - Rainbow - GenPlasma 1280,1024,ri(256),ri(256),ri(256),ri(256),300,8,Rnd - Locate 1,1: Print "Press the spacebar for another pattern. Press ESC to quit" - Do - If MultiKey(&h01) Then - End - ElseIf MultiKey(SC_SPACE) Then - Goto ExitDo - EndIf - Loop - ExitDo: -Loop diff --git a/samples/FreeBasic/array_clearobj.bas b/samples/FreeBasic/array_clearobj.bas new file mode 100644 index 0000000000..af923bb153 --- /dev/null +++ b/samples/FreeBasic/array_clearobj.bas @@ -0,0 +1,56 @@ +/' ERASE for static arrays of objects: re-init the elements '/ + +#include "fb.bi" + +extern "C" +sub fb_hArrayCtorObj( array as FBARRAY ptr, ctor as FB_DEFCTOR, base_idx as size_t ) + dim as size_t i, elements, element_len + dim as FBARRAYDIM ptr _dim + dim as ubyte ptr this_ + + if ( array->_ptr = NULL ) then + exit sub + end if + + _dim = @array->dimTB(0) + elements = _dim->elements - base_idx + _dim += 1 + + i = 1 + while( i < array->dimensions ) + elements *= _dim->elements + i += 1 + _dim += 1 + wend + + /' call ctors '/ + element_len = array->element_len + this_ = array->_ptr + + while( elements > 0 ) + /' !!!FIXME!!! check exceptions (only if rewritten in C++) '/ + ctor( this_ ) + this_ += element_len + elements -= 1 + wend +end sub + +function fb_ArrayClearObj FBCALL ( array as FBARRAY ptr, ctor as FB_DEFCTOR, dtor as FB_DEFCTOR ) as long + /' destruct all objects in the array + (dtor can be NULL if there only is a ctor) '/ + if ( dtor <> 0 ) then + fb_ArrayDestructObj( array, dtor ) + end if + + /' re-initialize (ctor can be NULL if there only is a dtor) '/ + if( ctor <> 0) then + /' if a ctor exists, it should handle the whole initialization '/ + fb_hArrayCtorObj( array, ctor, 0 ) + else + /' otherwise, just clear '/ + fb_ArrayClear( array ) + end if + + return fb_ErrorSetNum( FB_RTERROR_OK ) +end function +end extern \ No newline at end of file diff --git a/samples/FreeBasic/makescript.bas b/samples/FreeBasic/makescript.bas new file mode 100644 index 0000000000..d016ce6672 --- /dev/null +++ b/samples/FreeBasic/makescript.bas @@ -0,0 +1,174 @@ +#define NULL 0 +#define FALSE 0 +#define TRUE (-1) +#define STRINGIFY(s) #s + +private sub fatalCantOpenFile(byref file as string) + print "Error: Could not open file: '" + file + "'" + end 1 +end sub + +private function strReplace _ + ( _ + byref text as string, _ + byref a as string, _ + byref b as string _ + ) as string + + static as string result + static as string keep + + result = text + + dim as integer alen = len(a) + dim as integer blen = len(b) + + dim as integer p = 0 + do + p = instr(p + 1, result, a) + if (p = 0) then + exit do + end if + + keep = mid(result, p + alen) + result = left(result, p - 1) + result += b + result += keep + p += blen - 1 + loop + + return result +end function + +'' Searches backwards for the last '/' or '\'. +private function findFileName(byref path as string) as integer + for i as integer = (len(path)-1) to 0 step -1 + dim as integer ch = path[i] + if ((ch = asc("/")) or (ch = asc("\"))) then + return i + 1 + end if + next + return 0 +end function + +private function pathStripFile(byref path as string) as string + return left(path, findFileName(path)) +end function + +private function pathStripComponent(byref path as string) as string + dim as string s = path + + '' Strip path div at the end + dim as integer length = len(s) + if (length > 0) then + dim as integer ch = s[length-1] + if ((ch = asc("/")) or (ch = asc("\"))) then + s = left(s, len(s) - 1) + end if + end if + + '' Strip the last component + return pathStripFile(s) +end function + +private sub emitPath(byval o as integer, byref cmd as string, byref path as string) + print #o, " " + cmd + " ""$INSTDIR\" + path + """" +end sub + +private sub emitRmDirs(byval o as integer, byref prevpath as string, byref path as string) + '' RMDir foo\bar\baz + '' RMDir foo\bar + '' RMDir foo + while ((len(prevpath) > 0) and (prevpath <> left(path, len(prevpath)))) + emitPath(o, "RMDir ", prevpath) + prevpath = pathStripComponent(prevpath) + wend +end sub + +private sub emitInstallerFiles _ + ( _ + byref manifest as string, _ + byval o as integer, _ + byval install as integer _ + ) + + dim as integer f = freefile() + if (open(manifest, for input, as #f)) then + fatalCantOpenFile(manifest) + end if + + dim as string filename = "" + dim as string path = "" + dim as string prevpath = "" + + while (eof(f) = FALSE) + line input #f, filename + + if (len(filename)) then + '' Use backslashes for NSIS... + filename = strReplace(filename, "/", "\") + + path = pathStripFile(filename) + if (path <> prevpath) then + if (install) then + emitPath(o, "SetOutPath", path) + else + emitRmDirs(o, prevpath, path) + end if + prevpath = path + end if + + if (install) then + filename = " File """ + filename + """" + else + filename = " Delete ""$INSTDIR\" + filename + """" + end if + + print #o, filename + end if + wend + + if (install = FALSE) then + emitRmDirs(o, prevpath, path) + end if + + close #f +end sub + +if (__FB_ARGC__ <> 4) then + print "Usage: makescript manifest.lst template.nsi outputscript.nsi" + end 1 +end if + +dim as string manifest = *__FB_ARGV__[1] +dim as string inscript = *__FB_ARGV__[2] +dim as string outscript = *__FB_ARGV__[3] + +dim as integer i = freefile() +if (open(inscript, for input, as #i)) then + fatalCantOpenFile(inscript) +end if + +dim as integer o = freefile() +if (open(outscript, for output, as #o)) then + fatalCantOpenFile(outscript) +end if + +dim as string ln = "" + +while (eof(i) = FALSE) + line input #i, ln + + select case (trim(ln)) + case ";;;INSTALL;;;" + emitInstallerFiles(manifest, o, TRUE) + + case ";;;UNINSTALL;;;" + emitInstallerFiles(manifest, o, FALSE) + + case else + ln = strReplace(ln, ";;;FBVERSION;;;", STRINGIFY(FBVERSION)) + print #o, ln + + end select +wend diff --git a/samples/FreeBasic/try_catch_throw.bas b/samples/FreeBasic/try_catch_throw.bas deleted file mode 100644 index 2f647abdaf..0000000000 --- a/samples/FreeBasic/try_catch_throw.bas +++ /dev/null @@ -1,347 +0,0 @@ -#include "windows.bi" -#include "crt/setjmp.bi" - -#define VERBOSE 0 ' 0 not verbose , not 0 verbose mode - -If VERBOSE Then Print "in verbose mode" - - -Declare Function raise cdecl Alias "raise"(ByVal signal As Long) As Long - -Declare Function setjmp2 cdecl Alias "_setjmp" (ByVal As jmp_buf Ptr, ByVal As Any Ptr = 0) As Long - -Declare Function VectoredHandler(ByVal pexp As PEXCEPTION_POINTERS) As Long - -Type exdata - jump As jmp_buf Ptr - icod As Long - file As String - proc As String - msg As String - Line As Long - h1 As Any Ptr -End Type - -ReDim Shared As exdata e_exceptions(0 To 1) -Dim Shared As Integer e_pos - -e_exceptions(0).h1 = AddVectoredExceptionHandler(0 , @VectoredHandler) - - - -#define Try Do : e_pos += 1 : _ -If UBound(e_exceptions) < e_pos Then : ReDim Preserve e_exceptions(0 To UBound(e_exceptions) * 2 ) : End If : _ -e_exceptions(e_pos).jump = New jmp_buf : _ -e_exceptions(e_pos).h1 = AddVectoredExceptionHandler(e_pos , @VectoredHandler) : _ -e_exceptions(e_pos).icod = setjmp2(e_exceptions(e_pos).jump): If (e_exceptions(e_pos).icod = 0) Then : _ - If VERBOSE Then Print Space(e_pos) & "in Try block , e_pos = " & e_pos - - #macro Catch(e , _type) -ElseIf e_exceptions(e_pos).icod = _type Then - Dim As exdata e = e_exceptions(e_pos) - If VERBOSE Then Print Space(e_pos) & " in Catch block , e_pos = " & e_pos - #endmacro - - #macro Catch_Any(e) -Else - Dim As exdata e = e_exceptions(e_pos) - If VERBOSE Then Print Space(e_pos) & " in Catch_any block , e_pos = " & e_pos - #endmacro - - #define Finally End If: If e_pos Then: - - #define EndTry Delete e_exceptions(e_pos).jump : RemoveVectoredExceptionHandler(e_exceptions(e_pos).h1) : _ - e_pos -= 1 : End If : Exit Do : Loop - -#define THROW(_type) _ -e_exceptions(e_pos).file = __FILE__: _ -e_exceptions(e_pos).proc = __FUNCTION__: _ -e_exceptions(e_pos).line = __LINE__: _ -e_exceptions(e_pos).msg = "": _ -If e_pos > 0 Then : e_exceptions(e_pos).icod = _type : longjmp(e_exceptions(e_pos).jump, _type): _ -Else : Show_Catch(e_exceptions(0), 0): End If - -#define THROW_MSG(_type , mess) _ -e_exceptions(e_pos).file = __FILE__: _ -e_exceptions(e_pos).proc = __FUNCTION__: _ -e_exceptions(e_pos).line = __LINE__: _ -e_exceptions(e_pos).msg = mess: _ -If e_pos > 0 Then : e_exceptions(e_pos).icod = _type : longjmp(e_exceptions(e_pos).jump, _type): _ -Else : Show_Catch(e_exceptions(0), 0) : End If - - -Sub Show_Catch(ByRef e As exdata, ByVal flag As Integer = 1) - Dim As String status - If flag Then - If VERBOSE Then Print Space(e_pos) & " e_exceptions message : " ; e.msg - status = "e_exceptions message : " & e.msg - Else - If VERBOSE Then Print Space(e_pos) & " error exceptions : Throw outside Try-Catch bloc " & e.msg - status = "error exceptions : Throw outside Try-Catch bloc" & Chr(10,10) & "e_exceptions message : " & e.msg - End If - If VERBOSE Then Print Space(e_pos) & " e_exception code = " ; Str(e.icod) - status &= Chr(10,10) & " e_exception code = " & Str(e.icod) - If VERBOSE Then Print Space(e_pos) & " file = " ; e.file - status &= Chr(10) & " file = " & e.file - If VERBOSE Then Print Space(e_pos) & " proc = " ; e.proc - status &= Chr(10) & " proc = " & e.proc - If VERBOSE Then Print Space(e_pos) & " line = " ; Str(e.line) - status &= Chr(10) & " line = " & Str(e.line) - If flag Then - messagebox 0, status, "Catched Exception ", MB_ICONWARNING - Else - messagebox 0, status, "Catched Exception wihout Try_Catch", MB_ICONWARNING - End If -End Sub - - -Function VectoredHandler(ByVal pexp As PEXCEPTION_POINTERS) As Long - Dim As PEXCEPTION_RECORD pexr = pexp -> ExceptionRecord - Dim As PCONTEXT pctxr = pexp -> ContextRecord - Dim As Long iflag - Dim As String status - If VERBOSE Then Print "Exception code : &h" ; Hex(pexr -> ExceptionCode) - - Select Case (pexr -> ExceptionCode) - Case EXCEPTION_ACCESS_VIOLATION - status = "Error: EXCEPTION_ACCESS_VIOLATION" - Case EXCEPTION_ARRAY_BOUNDS_EXCEEDED - status = "Error: EXCEPTION_ARRAY_BOUNDS_EXCEEDED" - Case EXCEPTION_BREAKPOINT - status = "EXCEPTION_BREAKPOINT" - iflag = -1 - Case EXCEPTION_DATATYPE_MISALIGNMENT - status = "Error: EXCEPTION_DATATYPE_MISALIGNMENT" - Case EXCEPTION_ILLEGAL_INSTRUCTION - status = "Error: EXCEPTION_ILLEGAL_INSTRUCTION" - Case EXCEPTION_IN_PAGE_ERROR - status = "Error: EXCEPTION_IN_PAGE_ERROR" - Case EXCEPTION_INT_DIVIDE_BY_ZERO - status = "Error: EXCEPTION_INT_DIVIDE_BY_ZERO" - Case EXCEPTION_INT_OVERFLOW - status = "Error: EXCEPTION_INT_OVERFLOW" - Case EXCEPTION_INVALID_DISPOSITION - status = "Error: EXCEPTION_INVALID_DISPOSITION" - Case EXCEPTION_NONCONTINUABLE_EXCEPTION - status = "Error: EXCEPTION_NONCONTINUABLE_EXCEPTION" - Case EXCEPTION_PRIV_INSTRUCTION - status = "Error: EXCEPTION_PRIV_INSTRUCTION" - Case EXCEPTION_SINGLE_STEP - status = "Error: EXCEPTION_SINGLE_STEP" - Case EXCEPTION_STACK_OVERFLOW - status = "Error: EXCEPTION_STACK_OVERFLOW" - Case Else - iflag = 1 - End Select - - If iflag = 0 Then - If VERBOSE Then - Dim RetVal As Long - RetVal = MessageBox(0, Chr(10) & " Warning ..." & Chr(10,10) _ - & " Ok to Abort now !" & Chr(10,10) & " Cancel to try to continue", _ - status, MB_ICONERROR Or MB_OKCANCEL Or MB_APPLMODAL Or MB_TOPMOST) - If RetVal = IDOK Then - raise(4) 'signal abort - Else - iflag = -1 - End If - Else - messagebox 0, "Close to abort !", status, MB_ICONERROR - raise(4) 'signal abort - End If - End If - - If VERBOSE Then Print "Exception address : &h" ; - ''-------------------------------------------------------------------- - '' Increment the instruction pointer in the context record past the - '' 1-byte breakpoint instruction to avoid having the exception recur. - ''-------------------------------------------------------------------- - #ifndef __FB_64BIT__ - If VERBOSE Then Print Hex(pctxr -> Eip) - pctxr -> Eip += 1 - #else - If VERBOSE Then Print Hex(pctxr -> Rip) - pctxr -> Rip += 1 - #endif - 'return EXCEPTION_CONTINUE_EXECUTION '-1 - 'return EXCEPTION_CONTINUE_SEARCH '0 - If iflag = -1 Then THROW_MSG( - 1, status) - Return - 1 -End Function - - - -' define e_exception types -#define DIVISION_BY_ZERO 221 ' can be any number -#define FORCED_TO_ZERO 222 ' can be any number -#define NOTHING_EX 250 ' can be any number - - -' function that can throw an e_exceptions -Function div1(ByVal a As Integer , ByVal b As Integer) As Double - If b = 0 And a = 0 Then - 'print "Any key to Breakpoint..." - 'sleep - Asm .byte 0xcc '' Breakpoint (INT 3) - End If - If b = 0 Then THROW_MSG(DIVISION_BY_ZERO, "Division by zero") - If b > a Then THROW_MSG(FORCED_TO_ZERO, "Forced to zero") - - Try - If b < a Then THROW_MSG(NOTHING_EX, "nothing noticed") - Catch_Any(e) - Show_Catch(e) - Finally - Print " div result printed" - EndTry - Return a / b - -End Function - -' test function (calls div): -Function add_div(ByVal a As Integer , ByVal b As Integer , ByVal c As Single) As Integer - Return div1(a + b , c) -End Function - -' main func: -Sub test() - Try - Try - Print add_div(10 , 5 , 1) - Catch_Any(e) - Show_Catch(e) - - Finally - Print " div 1 done" - EndTry - Try - Print add_div(10 , 5 , 0) - Catch_Any(e) - Show_Catch(e) - Finally - Print " div 2 done" - EndTry - Try - Print add_div(10 , 5 , 30) - Catch_Any(e) - Show_Catch(e) - Finally - Print " div 3 done" - EndTry - Try - Print add_div(0 , 0 , 0) - Catch_Any(e) - Show_Catch(e) - Finally - Print " div 4 done" - EndTry - Print "put a breakpoint here" - Asm .byte 0xcc '' Breakpoint (INT 3) - Catch_Any(e) - Print "catched something global in test()" - Show_Catch(e) - Finally - Print "finally test()" - EndTry - -End Sub - -Sub stack_overflow() - Dim As Long foo(10000)'allocate something big on the stack - Print "loop" - stack_overflow() -End Sub - -'********************************************************************************************** -'test code begins here -'********************************************************************************************** -Print : Print "test a breakpoint here" -Asm .byte 0xcc - -Print : Print "test function here" -test() ' nested try_catch tests - -If VERBOSE Then - Print : Print "test a segmentation fault here" - Dim intPtr As Integer Ptr = 0 - intPtr[1000] = 1 'really difficult to segfault (probably malloc is over protected) -End If - - - -'print : print "test a stack_overflow here" 'uncomment these 2 lines -'stack_overflow() ' not really trapped it crashs before been trapped.... - - - -' the Try..Catch block -Try - - - test() - - - Catch(e , DIVISION_BY_ZERO) - If e.msg <> "" Then Show_Catch(e) - Try - test() - - Catch_Any(e) - Show_Catch(e) - - Finally - - Print " finally1" - EndTry - Catch_Any(e) ' this will catch any other e_exceptions (that is not DIVISION_BY_ZERO) - Show_Catch(e) - -Finally - - Print " this is executed allways, no mather if an e_exceptions was thrown or not" - -EndTry - - -Try - - test() - Print "extra test" - Dim d0 As Double = div1(17, 0) - - Catch(e , DIVISION_BY_ZERO) - Show_Catch(e) - - Try - test() - Catch_Any(e) - Show_Catch(e) - Finally - Print " finally2" - EndTry - Catch_Any(e) ' this will catch any other e_exceptions (that is not DIVISION_BY_ZERO) - Show_Catch(e) -Finally - Print " last finally" -EndTry - -Try - Dim k As String - 'print div(17 , 25) - Print " test ctrl-c to abort , any key to continue" 'the ctrl-c aborts as normal , not trapped - While 1 - 'print div(17 , 25) - k = Inkey() - If k <> "" Then Exit While - Sleep 1 - Wend - Catch_Any(e) - Show_Catch(e) -Finally - - Print " finally before leaving" -EndTry - -Print "press any key to finish" -Sleep - diff --git a/samples/Visual Basic 6.0/Module2.bas b/samples/Visual Basic 6.0/Module2.bas new file mode 100644 index 0000000000..21bf43f95c --- /dev/null +++ b/samples/Visual Basic 6.0/Module2.bas @@ -0,0 +1,170 @@ +Attribute VB_Name = "modMain" +' +' Type library registration tool by Alex Dragokas +' +' v.1.1 +' + +Option Explicit + +Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long +Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long +Private Declare Sub ExitProcess Lib "kernel32" (ByVal uExitCode As Long) +Private Declare Function OemToChar Lib "user32.dll" Alias "OemToCharA" (ByVal lpszScr As String, ByVal lpszDst As String) As Long +Private Declare Function CharToOem Lib "user32.dll" Alias "CharToOemA" (ByVal lpszScr As String, ByVal lpszDst As String) As Long +Private Declare Function LoadTypeLib Lib "OleAut32.dll" (ByVal szFile As Long, pptlib As ITypeLib) As Long +Private Declare Function RegisterTypeLib Lib "OleAut32.dll" (ByVal ptlib As ITypeLib, ByVal szFullPath As Long, ByVal szHelpDir As Long) As Long +Private Declare Function RegisterTypeLibForUser Lib "OleAut32.dll" (ByVal ptlib As ITypeLib, ByVal szFullPath As Long, ByVal szHelpDir As Long) As Long +Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long +Private Declare Sub OaEnablePerUserTLibRegistration Lib "OleAut32.dll" () + +Const STD_OUTPUT_HANDLE As Long = -11& +Const STD_ERROR_HANDLE As Long = -12& +Const INVALID_HANDLE_VALUE As Long = &HFFFFFFFF +Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10 +Const S_OK As Long = 0 + +Public cOut As Long +Public cErr As Long + + +Private Sub Main() + On Error GoTo ErrorHandler + + Dim lret As Long + Dim FileName As String + Dim ExitCode As Long + Dim hLib As Long + Dim ITL As ITypeLib + Dim argv() As String + Dim argc As Long + Dim i As Long + Dim bUseAdmin As Boolean + + cOut = GetStdHandle(STD_OUTPUT_HANDLE) + cErr = GetStdHandle(STD_ERROR_HANDLE) + ExitCode = 1 + + WriteC "" + + If Len(Command()) = 0 Then Using: ExitProcess 1 + + ParseCommandLine Command(), argc, argv + + For i = 1 To argc + Select Case UCase(argv(i)) + + Case "/ADMIN" + bUseAdmin = True + ReLaunch + + Case Else + FileName = UnQuote(argv(i)) + End Select + Next + + WriteC "FILE: " & FileName + + lret = GetFileAttributes(StrPtr(FileName)) + + If lret <> INVALID_HANDLE_VALUE And (0 = (lret And FILE_ATTRIBUTE_DIRECTORY)) Then + + lret = LoadTypeLib(StrPtr(FileName), ITL) + + If lret = S_OK Then + + If bUseAdmin Then + lret = RegisterTypeLib(ITL, StrPtr(FileName), 0&) + Else + lret = RegisterTypeLibForUser(ITL, StrPtr(FileName), 0&) 'by default + End If + + If lret = S_OK Then + + ExitCode = 0 + Else + WriteC TlibErr2Text(lret), cErr + End If + Else + WriteC TlibErr2Text(lret), cErr + End If + Else + WriteC "File is not found.", cErr + End If + + If 0 = ExitCode Then + WriteC "Success." + Else + If IsProcessElevated() And Not bUseAdmin Then + WriteC "", cErr + WriteC "WARNING: process launched with administrative privileges.", cErr + WriteC "It is not guarantied succesful registration in such mode.", cErr + WriteC "Please, use /admin key, or run this application as non-elevated.", cErr + WriteC "", cErr + End If + WriteC "Failed!", cErr + End If + + 'MsgBox "ready" + ExitProcess ExitCode + Exit Sub +ErrorHandler: + WriteC "Error #" & Err.Number & ". LastDll: 0x" & Hex(Err.LastDllError) & ". " & Err.Description, cErr + ExitProcess 1 +End Sub + +Private Function TlibErr2Text(lErr As Long) + Dim sMsg As String + If lErr = S_OK Then + TlibErr2Text = "Success." + Else + On Error Resume Next + Err.Raise lErr + TlibErr2Text = "Error: " & CStr(lErr) & " - " & Err.Description + End If +End Function + +Public Sub WriteC(ByVal txt As String, Optional cHandle As Long) + Dim dwWritten As Long + Debug.Print txt + txt = txt & vbNewLine + Call CharToOem(txt, txt) + WriteFile IIf(cHandle = 0, cOut, cHandle), StrPtr(StrConv(txt, vbFromUnicode)), Len(txt), dwWritten, 0& +End Sub + +Private Function UnQuote(sStr As String) As String + If Left$(sStr, 1) = """" And Right$(sStr, 1) = """" And Len(sStr) > 1 Then + UnQuote = Mid$(sStr, 2, Len(sStr) - 2) + Else + UnQuote = sStr + End If +End Function + +Sub Using() + WriteC "Type library registration tool by Alex Dragokas" + WriteC "" + WriteC "Using:" + WriteC "" + WriteC "Regtlib.exe [Path\file.tlb] [/admin]" + WriteC "" + WriteC "/admin - [optional key], to register tlb under HKLM (system wide) hive." +End Sub + +Sub ReLaunch() + Dim lExitCode As Long + If Not IsProcessElevated() Then + + lExitCode = RunAsAndWait(App.Path & "\" & App.EXEName, Command()) + + '// TODO: how to return user defined exit code from ShellExecuteEx correctly? ( I don't know ) + + If 0 = lExitCode Then + WriteC "Success." + Else + WriteC "Exit code: " & lExitCode, cErr + WriteC "Failed!", cErr + End If + + ExitProcess lExitCode + End If +End Sub diff --git a/samples/Visual Basic 6.0/XmlUtil.bas b/samples/Visual Basic 6.0/XmlUtil.bas deleted file mode 100644 index 5f0b23fd66..0000000000 --- a/samples/Visual Basic 6.0/XmlUtil.bas +++ /dev/null @@ -1,266 +0,0 @@ -Attribute VB_Name = "XmlUtil" -'[XmlUtil.bas] - -' -' XML Parser by Jason Thorn (Fork by Alex Dragokas) -' - -' Fork v1.4 -' - added .NodeValueByName -' - removed err.raise when trying to parse empty file -' - added .LoadFile method (returns FALSE, if error happens, or file is empty. -' - .LoadData is now a function (TRUE, if success with loading) -' - improved UTF16 LE format detection. -' - -' Fork v1.3 [28.11.2017] -' - added all possible error handlers -' - replaced error handlers based on Err.raise by separate function (ErrorMsg), just because I don't like at all when class raises runtime error. -'If you want to form a code logic according to critical errors, just add anything like global "LastErrorCode" variable to that function, or put Err.Raise once. -' - Fixed the range of cyrillic characters (Russian and Ukrainian) for tag names. -' - Added support of 'CDATA' type values -' - Removed attempt to serialize empty string. -' -' Fork v1.2 [27.10.2017] -' -' - added recognition of UTF-16 LE xml. -' - added protection against infinite loop, just in case. -' - fixed bug when empty tag /> could not be identified. -' -' Fork v1.1 [23.11.2015] -' -' - added " -Public Const ascTagTerm As Byte = 47 '/ -Public Const ascAmper As Byte = 38 '& -Public Const ascSemiColon As String = 59 '; - -' Letter Characters (Begining And Ending for Simplicity) -Public Const ascLowerFirst As Byte = 97 'a -Public Const ascLowerLast As Byte = 122 'z -Public Const ascUpperFirst As Byte = 65 'A -Public Const ascUpperLast As Byte = 90 'Z -Public Const ascUnderScore As Byte = 95 '_ -Public Const ascColon As Byte = 58 ': - -' Digit Characters -Public Const ascNumFirst As Byte = 48 '0 -Public Const ascNumLast As Byte = 57 '9 - -' Other Characters -Public Const ascEquals As Byte = 61 ' = -Public Const ascApos As Byte = 39 ' Single Quote -Public Const ascQuote As Byte = 34 ' Double Quote -Public Const ascPound As Byte = 35 ' # -Public Const ascSquareBracketOpen As Byte = 91 ' [ -Public Const ascSquareBracketClose As Byte = 93 ' ] - -' Special Strings -Public Const strAmp As String = "amp" '& -Public Const strLessThan As String = "lt" '< -Public Const strMoreThan As String = "gt" '> -Public Const strApostrophe As String = "apos" '' -Public Const strQuote As String = "quot" '" -Public Const strTagCDataBegin As String = "" - -Public Function DecodeEscape(Data() As Integer, Start As Long) As String - On Error GoTo Err_Trap - - Do ' Until we find a semicolon - Start = Start + 1 - If Data(Start) = ascSemiColon Then _ - Exit Do - DecodeEscape = DecodeEscape & ChrW$(Data(Start)) - Loop While Start <= UBound(Data) - - Select Case DecodeEscape - Case strAmp - DecodeEscape = "&" - - Case strApostrophe - DecodeEscape = "'" - - Case strLessThan - DecodeEscape = "<" - - Case strMoreThan - DecodeEscape = ">" - - Case strQuote - DecodeEscape = """" - - Case Else - If Data(Start - Len(DecodeEscape)) = ascPound Then - ' Numeric Escape Sequence - If Data(Start - (Len(DecodeEscape) + 1)) = AscW("x") Then - ' Hexadecimal - DecodeEscape = Right$(DecodeEscape, Len(DecodeEscape) - 2) - Else - ' Decimal - DecodeEscape = Right$(DecodeEscape, Len(DecodeEscape) - 1) - End If - Else - ' Custom Entity Reference - ' Not Currently Supported - DecodeEscape = vbNullString - End If - End Select -Exit Function - -Err_Trap: - Select Case Error - ' Exceptions Raised: - Case 9 - 'Unexpected End of Data [array index out of bounds] - ErrorMsg Err, "XmlUtil.DecodeEscape", "Unexpected end of data" - - Case Else - ' Log all other errors - ErrorMsg Err, "XmlUtil.DecodeEscape" - - End Select - If inIDE Then Stop: Resume Next -End Function - -' Parses a value contained within quotes -' Start identifies the begining quote and -' will identify the closing quote on exit -Public Function ParseValue(Data() As Integer, Start As Long) As String - Dim bEnd As Boolean - Dim QuoteChar As Byte - - On Error GoTo Err_Trap - - QuoteChar = Data(Start) - - Do - Select Case Data(Start) - Case QuoteChar - bEnd = Not bEnd - If Not bEnd Then Exit Do - - Case Is <> ascTagBegin, Is <> ascAmper - ParseValue = ParseValue & ChrW$(Data(Start)) - - Case ascAmper - ParseValue = ParseValue & DecodeEscape(Data(), Start) - - Case Else - ' The only other case is the Begin Tag which is invalid in this context - - End Select - Start = Start + 1 - Loop While Start <= UBound(Data) -Exit Function - -Err_Trap: - Select Case Error - ' Exceptions Raised: - Case 9 - 'Unexpected End of Data [array index out of bounds] - ErrorMsg Err, "XmlUtil.ParseValue", "Unexpected end of data" - - Case Else - ' Log all other errors - ErrorMsg Err, "XmlUtil.ParseValue" - End Select - If inIDE Then Stop: Resume Next -End Function - -' Start Identifies the First Character to Check -' Upon completion, Start should point to the first -' non-delimitng character after the Name Value is read -Public Function ParseName(Data() As Integer, Start As Long) As String - Dim bEnd As Boolean - - On Error GoTo Err_Trap - - Do - Select Case Data(Start) - ' Delimitng Characters - Case ascSpace, ascTab, ascCr, ascLf, ascEquals, ascSemiColon - bEnd = True - - Case ascTagEnd, ascApos, ascQuote - If Data(Start - 1) = ascTagTerm Then Start = Start - 1 'to support /> - Exit Do - - ' Letter Characters - Case ascUpperFirst To ascUpperLast, _ - ascLowerFirst To ascLowerLast, _ - ascUnderScore, ascColon, _ - ascNumFirst To ascNumLast, _ - &H41& To &H5A&, _ - &H61& To &H7A&, _ - &HC0& To &HFF&, _ - &HB7&, _ - &HA5&, &HA8&, &HAA&, &HAF&, &HB2&, &HB3&, &HB4&, &HB8&, &HBA&, &HBF& - - 'A-Z - 'a-z - '- - '&HB7 - ',,,,,,,,, - - If bEnd Then - Exit Do - Else - ParseName = ParseName & ChrW$(Data(Start)) - End If - - Case Else - ' Error . . . Normally not too many charater - ' types can be used for the Name Identifier - - End Select - Start = Start + 1 - Loop While Start <= UBound(Data) -Exit Function - -Err_Trap: - Select Case Error - ' Exceptions Raised: - Case 9 - 'Unexpected End of Data [array index out of bounds] - ErrorMsg Err, "XmlUtil.ParseName", "Unexpected end of data" - - Case Else - ' Log all other errors - ErrorMsg Err, "XmlUtil.ParseName" - End Select - If inIDE Then Stop: Resume Next -End Function - -''// Common error handler -'Public Function ErrorMsg(Error As ErrObject, sFunctionName As String, ParamArray aText()) -' Dim i As Long -' Dim s As String -' For i = 0 To UBound(aText) -' s = s & " " & aText(i) -' Next -' Debug.Print "Error: " & Error.Number & " in '" & sFunctionName & "' - " & Error.Description & IIf(Len(s) > 0, " - " & s, vbnullstring) -'End Function -' -'Public Function InIDE() As Boolean -' InIDE = (App.LogMode = 0) -'End Function From 4af46cd1f26f851753d89b8d67ac50d52e3ec5b2 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Thu, 20 Apr 2023 00:46:15 -0400 Subject: [PATCH 25/28] Combine rules --- lib/linguist/heuristics.yml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index 27d5c3a012..a099aa64ec 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -858,12 +858,11 @@ named_patterns: # General VBA libraries and objects - '(?:\s|\()(?:Access|Excel|Outlook|PowerPoint|Visio|Word|VBIDE|Application\.VBE)\.\w' - '\b(?:(?:Active)?VBProjects?|VBComponents?)\b' - # AutoCAD objects - - '\b(?:ThisDrawing|AcadObject)\b' + # AutoCAD, Outlook, PowerPoint and Word objects + - '\b(?:ThisDrawing|AcadObject|Active(?:Explorer|Inspector|Window\.Presentation|Presentation|Document)|Selection\.(?:Find|Paragraphs))\b' # Excel objects - '\b(?:(?:This|Active)?Workbooks?|Worksheets?|Active(:?Sheet|Chart|Cell)|WorksheetFunction)\b' - '\bRange\(".*\)' - '\bCells\([0-9a-zA-Z_], (?:[0-9a-zA-Z_]*|"[a-zA-Z]{1-3}*")\)' - # Outlook, PowerPoint and Word objects - - '\b(?:Active(?:Explorer|Inspector|Window\.Presentation|Presentation|Document)|Selection\.(?:Find|Paragraphs))\b' + From 544108e0583be8e2df2defbf3b0d6dfcf4478e8b Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Thu, 20 Apr 2023 10:23:05 -0400 Subject: [PATCH 26/28] Heuristics adjustments --- lib/linguist/heuristics.yml | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index a099aa64ec..c3b348f125 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -844,25 +844,22 @@ named_patterns: - '^\s*package\s+[^\W\d]\w*(?:::\w+)*\s*(?:[;{]|\sv?\d)' - '[\s$][^\W\d]\w*(?::\w+)*->[a-zA-Z_\[({]' raku: '^\s*(?:use\s+v6\b|\bmodule\b|\b(?:my\s+)?class\b)' - vb-class: '^\s*VERSION [0-9]\.[0-9] CLASS' - vb-form: '^\s*VERSION [0-9]\.[0-9]{2}' - vb-module: '^\s*Attribute VB_Name = ' + vb-class: '^[ ]*VERSION [0-9]\.[0-9] CLASS' + vb-form: '^[ ]*VERSION [0-9]\.[0-9]{2}' + vb-module: '^[ ]*Attribute VB_Name = ' vba: - '\b(?:VBA\b|[vV]ba[\bA-Z])' # VBA7 new 64-bit features - - '^\s*(?:Public|Private)? Declare PtrSafe (?:Sub|Function)\b' - - '^\s*#If\s(:?VBA7|Win64)\b' - - '^\s*(?:Dim|Const) [0-9a-zA-Z_]*[ ]*As Long(?:Ptr|Long)\b' + - '^[ ]*(?:Public|Private)? Declare PtrSafe (?:Sub|Function)\b' + - '^[ ]*#If (?:VBA7|Win64)\b' + - '^[ ]*(?:Dim|Const) [0-9a-zA-Z_]*[ ]*As Long(?:Ptr|Long)\b' # Top module declarations unique to VBA - - '^\s*Option (?:Private Module|Compare Database)\b' + - '^[ ]*Option (?:Private Module|Compare Database)\b' # General VBA libraries and objects - - '(?:\s|\()(?:Access|Excel|Outlook|PowerPoint|Visio|Word|VBIDE|Application\.VBE)\.\w' - - '\b(?:(?:Active)?VBProjects?|VBComponents?)\b' + - '(?: |\()(?:Access|Excel|Outlook|PowerPoint|Visio|Word|VBIDE)\.\w' + - '\b(?:(?:Active)?VBProjects?|VBComponents?|Application\.(?:VBE|ScreenUpdating))\b' # AutoCAD, Outlook, PowerPoint and Word objects - '\b(?:ThisDrawing|AcadObject|Active(?:Explorer|Inspector|Window\.Presentation|Presentation|Document)|Selection\.(?:Find|Paragraphs))\b' # Excel objects - - '\b(?:(?:This|Active)?Workbooks?|Worksheets?|Active(:?Sheet|Chart|Cell)|WorksheetFunction)\b' - - '\bRange\(".*\)' - - '\bCells\([0-9a-zA-Z_], (?:[0-9a-zA-Z_]*|"[a-zA-Z]{1-3}*")\)' - - + - '\b(?:(?:This|Active)?Workbooks?|Worksheets?|Active(?:Sheet|Chart|Cell)|WorksheetFunction)\b' + - '\b(?:Range\(".*|Cells\([0-9a-zA-Z_]*, (?:[0-9a-zA-Z_]*|"[a-zA-Z]{1,3}"))\)' From 4b2e5d67a403df46f6f38ffeb1e3e130e6cfbf16 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Thu, 27 Apr 2023 19:45:22 -0400 Subject: [PATCH 27/28] Update heuristics.yml Fix issue with `\b` and make sure we match with `VBAObject` --- lib/linguist/heuristics.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index c3b348f125..bddd1f3c77 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -848,7 +848,7 @@ named_patterns: vb-form: '^[ ]*VERSION [0-9]\.[0-9]{2}' vb-module: '^[ ]*Attribute VB_Name = ' vba: - - '\b(?:VBA\b|[vV]ba[\bA-Z])' + - '\b(?:VBA|[vV]ba)(?:\b|[_A-Z0-9])' # VBA7 new 64-bit features - '^[ ]*(?:Public|Private)? Declare PtrSafe (?:Sub|Function)\b' - '^[ ]*#If (?:VBA7|Win64)\b' From 1c00759b3447920fa84a614926e77361c8d36373 Mon Sep 17 00:00:00 2001 From: Martin Leduc <31558169+DecimalTurn@users.noreply.github.com> Date: Tue, 9 May 2023 21:58:31 -0400 Subject: [PATCH 28/28] Change characters ordering and remove VBA7 (already matching first pattern) --- lib/linguist/heuristics.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/linguist/heuristics.yml b/lib/linguist/heuristics.yml index bddd1f3c77..0b297ce4f8 100644 --- a/lib/linguist/heuristics.yml +++ b/lib/linguist/heuristics.yml @@ -848,10 +848,10 @@ named_patterns: vb-form: '^[ ]*VERSION [0-9]\.[0-9]{2}' vb-module: '^[ ]*Attribute VB_Name = ' vba: - - '\b(?:VBA|[vV]ba)(?:\b|[_A-Z0-9])' + - '\b(?:VBA|[vV]ba)(?:\b|[0-9A-Z_])' # VBA7 new 64-bit features - '^[ ]*(?:Public|Private)? Declare PtrSafe (?:Sub|Function)\b' - - '^[ ]*#If (?:VBA7|Win64)\b' + - '^[ ]*#If Win64\b' - '^[ ]*(?:Dim|Const) [0-9a-zA-Z_]*[ ]*As Long(?:Ptr|Long)\b' # Top module declarations unique to VBA - '^[ ]*Option (?:Private Module|Compare Database)\b'