Quantcast
Channel: VBForums - CodeBank - Visual Basic 6 and earlier
Viewing all 1487 articles
Browse latest View live

GMail Using OAuth 2.0

$
0
0
Hello friends,
Ive seen several posts recently with concerns about google disabling username/password gmail useage from 'less secure apps'.
Ive been working with OAuth alot in other projects so Im somewhat familiar with using it.
Ive decided to create a small example of how to send email from GMail using OAuth 2.0.
I cobbled this example together over a couple weekends as I had time so my appologies if it isnt as 'consistent' as it could be.
You will need to do some setup work on google before this code will work.
Please read the README file before running the code.
Regards,
Lewis

Name:  ss.jpg
Views: 29
Size:  40.3 KB
Attached Images
 
Attached Files

PNG with alpha channel into standard VB6 image control

$
0
0
Ok, I developed this in another thread, with the help of several other members (LaVolpe, Dilettante, Wqweto, Schmidt, & The Trick).

All it does is read a standard RGBA type (32bpp) PNG file and place it into a VB6 image control (with its alpha channel intact).

I've tested it on PNG files of several different sizes, and it displays an image control of exactly the same pixel width & height.

There are also optional scaling and overall opacity settings in the LoadPngIntoPictureWithAlpha call. You're welcome to use those as your needs arise.

Just as an FYI, the LoadPngIntoPictureWithAlpha creates an image that is not stretched for any changed (non 96) DPI settings (where you're running your monitor at non-100% scale). So, it's probably best to use this in a DPI aware mode (or at least you should be aware that this thing will be pixel-for-pixel with respect to the original PNG). Another option would be to figure out your monitor's scaling, and then feed that into the scale argument of the LoadPngIntoPictureWithAlpha call.

I just listed the API and UDT declarations (at the top of the BAS module) in the order in which they were used. You're certainly welcome to re-order them in anyway you like.

In the attached project, there's also a translucent (not fully transparent) PNG included for your testing.

If you check the display size of the image control, either turn the border off on it, or remember that there are 4 extra pixels (2 per side) that make that border.

Name:  Alpha3.jpg
Views: 54
Size:  62.4 KB

I might do more with this in the future, but this piece of it is done.
Attached Images
 
Attached Files

[VB6/VBA] Pure VB6 implementation of SHA-224, SHA-256, HMAC-SHA224 and HMAC-SHA256

$
0
0
Deliberately does not use any API calls so is not the sharpest tool in the shed

Code:

'--- mdSHA2.bas
Option Explicit
DefObj A-Z

Private PowerOf2(0 To 31)  As Long

Private Function LShift(ByVal lX As Long, ByVal lN As Long) As Long
    If lN = 0 Then
        LShift = lX
    Else
        LShift = (lX And (PowerOf2(31 - lN) - 1)) * PowerOf2(lN) Or -((lX And PowerOf2(31 - lN)) <> 0) * &H80000000
    End If
End Function

Private Function RShift(ByVal lX As Long, ByVal lN As Long) As Long
    If lN = 0 Then
        RShift = lX
    Else
        RShift = (lX And &H7FFFFFFF) \ PowerOf2(lN) Or -(lX < 0) * PowerOf2(31 - lN)
    End If
End Function

Private Function RRotate(ByVal lX As Long, ByVal lN As Long) As Long
    '--- RRotate = RShift(X, n) Or LShift(X, 32 - n)
    Debug.Assert lN <> 0
    RRotate = ((lX And &H7FFFFFFF) \ PowerOf2(lN) - (lX < 0) * PowerOf2(31 - lN)) Or _
        ((lX And (PowerOf2(lN - 1) - 1)) * PowerOf2(32 - lN) Or -((lX And PowerOf2(lN - 1)) <> 0) * &H80000000)
End Function

Private Function UAdd(ByVal lX As Long, ByVal lY As Long) As Long
    If (lX Xor lY) > 0 Then
        UAdd = ((lX Xor &H80000000) + lY) Xor &H80000000
    Else
        UAdd = lX + lY
    End If
End Function

Private Function Ch(ByVal lX As Long, ByVal lY As Long, ByVal lZ As Long) As Long
    Ch = (lX And lY) Xor ((Not lX) And lZ)
End Function

Private Function Maj(ByVal lX As Long, ByVal lY As Long, ByVal lZ As Long) As Long
    Maj = (lX And lY) Xor (lX And lZ) Xor (lY And lZ)
End Function

Private Function BigSigma0(ByVal lX As Long) As Long
    BigSigma0 = RRotate(lX, 2) Xor RRotate(lX, 13) Xor RRotate(lX, 22)
End Function

Private Function BigSigma1(ByVal lX As Long) As Long
    BigSigma1 = RRotate(lX, 6) Xor RRotate(lX, 11) Xor RRotate(lX, 25)
End Function

Private Function SmallSigma0(ByVal lX As Long) As Long
    SmallSigma0 = RRotate(lX, 7) Xor RRotate(lX, 18) Xor RShift(lX, 3)
End Function

Private Function SmallSigma1(ByVal lX As Long) As Long
    SmallSigma1 = RRotate(lX, 17) Xor RRotate(lX, 19) Xor RShift(lX, 10)
End Function

Private Sub ToBigEndian(aRetVal() As Long, baBuffer() As Byte, ByVal lPos As Long, ByVal lSize As Long)
    Dim lIdx            As Long
    Dim lOutSize        As Long
    Dim lOutIdx        As Long
    Dim lOffset        As Long
   
    If lSize < 0 Then
        lSize = UBound(baBuffer) + 1
    End If
    lOutSize = ((lSize + 8) \ 64 + 1) * 16
    ReDim aRetVal(0 To lOutSize - 1) As Long
    For lIdx = 0 To lSize - lPos - 1
        lOutIdx = lIdx \ 4
        lOffset = 24 - (lIdx Mod 4) * 8
        aRetVal(lOutIdx) = aRetVal(lOutIdx) Or LShift(baBuffer(lPos + lIdx), lOffset)
    Next
    lOutIdx = lIdx \ 4
    lOffset = 24 - (lIdx Mod 4) * 8
    aRetVal(lOutIdx) = aRetVal(lOutIdx) Or LShift(&H80, lOffset)
    aRetVal(lOutSize - 1) = LShift(lSize, 3)
    aRetVal(lOutSize - 2) = RShift(lSize, 29)
End Sub

Private Sub FromBigEndian(baRetVal() As Byte, aInput() As Long, ByVal lPos As Long, ByVal lSize As Long)
    Dim lIdx            As Long
    Dim lWord          As Long
   
    If lSize < 0 Then
        lSize = UBound(aInput) + 1
    End If
    ReDim baRetVal(0 To lSize * 4 - 1) As Byte
    For lIdx = 0 To lSize - lPos - 1
        lWord = aInput(lPos + lIdx)
        baRetVal(4 * lIdx + 0) = RShift(lWord, 24) And &HFF&
        baRetVal(4 * lIdx + 1) = (lWord And &HFF0000) \ &H10000 And &HFF&
        baRetVal(4 * lIdx + 2) = (lWord And &HFF00) \ &H100& And &HFF&
        baRetVal(4 * lIdx + 3) = lWord And &HFF&
    Next
End Sub

Private Sub SHA2(baOutput() As Byte, ByVal lOutPos As Long, ByVal lOutSize As Long, baInput() As Byte, ByVal lPos As Long, ByVal lSize As Long, H() As Long)
    Static K(0 To 63)  As Long
    Dim M()            As Long
    Dim W(0 To 63)      As Long
    Dim lA              As Long
    Dim lB              As Long
    Dim lC              As Long
    Dim lD              As Long
    Dim lE              As Long
    Dim lF              As Long
    Dim lG              As Long
    Dim lH              As Long
    Dim lT1            As Long
    Dim lT2            As Long
    Dim lIdx            As Long
    Dim lJdx            As Long
    Dim vElem          As Variant
   
    If PowerOf2(0) = 0 Then
        For lIdx = 0 To 30
            PowerOf2(lIdx) = 2& ^ lIdx
        Next
        PowerOf2(31) = &H80000000
        '--- K: first 32 bits of the fractional parts of the cube roots of the first 64 primes
        For Each vElem In Split("428A2F98 71374491 B5C0FBCF E9B5DBA5 3956C25B 59F111F1 923F82A4 AB1C5ED5 D807AA98 12835B01 243185BE 550C7DC3 72BE5D74 80DEB1FE 9BDC06A7 C19BF174 E49B69C1 EFBE4786 FC19DC6 240CA1CC 2DE92C6F 4A7484AA 5CB0A9DC 76F988DA 983E5152 A831C66D B00327C8 BF597FC7 C6E00BF3 D5A79147 6CA6351 14292967 27B70A85 2E1B2138 4D2C6DFC 53380D13 650A7354 766A0ABB 81C2C92E 92722C85 A2BFE8A1 A81A664B C24B8B70 C76C51A3 D192E819 D6990624 F40E3585 106AA070 19A4C116 1E376C08 2748774C 34B0BCB5 391C0CB3 4ED8AA4A 5B9CCA4F 682E6FF3 748F82EE 78A5636F 84C87814 8CC70208 90BEFFFA A4506CEB BEF9A3F7 C67178F2")
            K(lJdx) = "&H" & vElem
            lJdx = lJdx + 1
        Next
    End If
    ToBigEndian M, baInput, lPos, lSize
    For lIdx = 0 To UBound(M) Step 16
        lA = H(0)
        lB = H(1)
        lC = H(2)
        lD = H(3)
        lE = H(4)
        lF = H(5)
        lG = H(6)
        lH = H(7)
        For lJdx = 0 To 63
            If lJdx < 16 Then
                W(lJdx) = M(lJdx + lIdx)
            Else
                W(lJdx) = UAdd(UAdd(UAdd(SmallSigma1(W(lJdx - 2)), W(lJdx - 7)), SmallSigma0(W(lJdx - 15))), W(lJdx - 16))
            End If
            lT1 = UAdd(UAdd(UAdd(UAdd(lH, BigSigma1(lE)), Ch(lE, lF, lG)), K(lJdx)), W(lJdx))
            lT2 = UAdd(BigSigma0(lA), Maj(lA, lB, lC))
            lH = lG
            lG = lF
            lF = lE
            lE = UAdd(lD, lT1)
            lD = lC
            lC = lB
            lB = lA
            lA = UAdd(lT1, lT2)
        Next
        H(0) = UAdd(lA, H(0))
        H(1) = UAdd(lB, H(1))
        H(2) = UAdd(lC, H(2))
        H(3) = UAdd(lD, H(3))
        H(4) = UAdd(lE, H(4))
        H(5) = UAdd(lF, H(5))
        H(6) = UAdd(lG, H(6))
        H(7) = UAdd(lH, H(7))
    Next
    FromBigEndian baOutput, H, lOutPos, lOutSize
End Sub

Public Sub CryptoSHA224(baRetVal() As Byte, baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Dim H(0 To 7)      As Long

    H(0) = &HC1059ED8
    H(1) = &H367CD507
    H(2) = &H3070DD17
    H(3) = &HF70E5939
    H(4) = &HFFC00B31
    H(5) = &H68581511
    H(6) = &H64F98FA7
    H(7) = &HBEFA4FA4
    SHA2 baRetVal, 0, 7, baBuffer, Pos, Size, H
End Sub

Public Sub CryptoSHA256(baRetVal() As Byte, baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Dim H(0 To 7)      As Long

    H(0) = &H6A09E667
    H(1) = &HBB67AE85
    H(2) = &H3C6EF372
    H(3) = &HA54FF53A
    H(4) = &H510E527F
    H(5) = &H9B05688C
    H(6) = &H1F83D9AB
    H(7) = &H5BE0CD19
    SHA2 baRetVal, 0, 8, baBuffer, Pos, Size, H
End Sub

Private Sub HMAC(baRetVal() As Byte, ByVal lHashSize As Long, baKey() As Byte, baBuffer() As Byte, ByVal lPos As Long, ByVal lSize As Long)
    Const BLOCK_SIZE    As Long = 64
    Const INNER_PAD    As Long = &H36
    Const OUTER_PAD    As Long = &H5C
    Dim lIdx            As Long
    Dim baPass()        As Byte
    Dim baPad()        As Byte
    Dim baHash()        As Byte
   
    If UBound(baKey) < BLOCK_SIZE Then
        baPass = baKey
    ElseIf lHashSize = 256 Then
        CryptoSHA256 baPass, baKey
    Else
        CryptoSHA224 baPass, baKey
    End If
    If lSize < 0 Then
        lSize = UBound(baBuffer) + 1
    End If
    ReDim baPad(0 To lSize + BLOCK_SIZE - 1) As Byte
    For lIdx = 0 To UBound(baPass)
        baPad(lIdx) = baPass(lIdx) Xor INNER_PAD
    Next
    For lIdx = lIdx To BLOCK_SIZE - 1
        baPad(lIdx) = INNER_PAD
    Next
    For lIdx = 0 To lSize - lPos - 1
        baPad(BLOCK_SIZE + lIdx) = baBuffer(lPos + lIdx)
    Next
    If lHashSize = 256 Then
        CryptoSHA256 baHash, baPad
    Else
        CryptoSHA224 baHash, baPad
    End If
    lSize = UBound(baHash) + 1
    ReDim baPad(0 To lSize + BLOCK_SIZE - 1) As Byte
    For lIdx = 0 To UBound(baPass)
        baPad(lIdx) = baPass(lIdx) Xor OUTER_PAD
    Next
    For lIdx = lIdx To BLOCK_SIZE - 1
        baPad(lIdx) = OUTER_PAD
    Next
    For lIdx = 0 To lSize - 1
        baPad(BLOCK_SIZE + lIdx) = baHash(lIdx)
    Next
    If lHashSize = 256 Then
        CryptoSHA256 baRetVal, baPad
    Else
        CryptoSHA224 baRetVal, baPad
    End If
End Sub

Public Sub CryptoHMAC224(baRetVal() As Byte, baKey() As Byte, baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    HMAC baRetVal, 224, baKey, baBuffer, Pos, Size
End Sub

Public Sub CryptoHMAC256(baRetVal() As Byte, baKey() As Byte, baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    HMAC baRetVal, 256, baKey, baBuffer, Pos, Size
End Sub

CryptoHMAC224 and CryptoHMAC256 functions tested with hmac_sha224_test.json and hmac_sha256_test.json from Project Wycheproof test vectors.

cheers,
</wqw>

UDT to String and Vice-Versa

$
0
0
This occasionally comes up when we need to get a UDT into a String, and back again. We may want to do this for inter-process communications, or maybe to easily get it into a Variant or Collection, or several other reasons.

One way is to serialize it with a named pipe. This is effectively the same as writing the UDT to a file, and then opening the file as Binary and reading in the bytes, and then stuffing them into a String.

However, it doesn't need to be this complicated. We can just directly copy the UDT into our string. And that's what I've outlined. As a note, any internal and/or external padding should be handled just fine, as LenB picks that up.

Here's some code for a BAS module to do this:
Code:


Option Explicit
'
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
'
Public Type TestUdtType
    s1 As String * 5
    s2 As String * 5
    i1 As Long
    d1 As Double
End Type
'

Public Function StringFromUdt(u As TestUdtType) As String
    StringFromUdt = String$((LenB(u) + 1&) \ 2&, vbNullChar)
    CopyMemory ByVal StrPtr(StringFromUdt), u, LenB(u)    ' On odd length UDTs, it won't completely fill the last Unicode character, but that's fine.
End Function

Public Function UdtFromString(s As String) As TestUdtType
    If Len(s) <> (LenB(UdtFromString) + 1&) \ 2& Then Err.Raise 13&, , "String isn't correct length for this UDT"
    CopyMemory UdtFromString, ByVal StrPtr(s), LenB(UdtFromString)
End Function


And here's a bit of test code you can put into a Form1:
Code:


Option Explicit

Private Sub Form_Load()
    Dim u As TestUdtType
    u.s1 = "asdf"
    u.s2 = "qwer"
    u.i1 = 1234
    u.d1 = 5.678

    Dim s As String
    s = StringFromUdt(u)
    Debug.Print s
    Dim u2 As TestUdtType
    u2 = UdtFromString(s)
    Debug.Print u2.s1, u2.s2, u2.i1, u2.d1

End Sub


Ok yes, I understand that this is specific to any particular UDT. But that's sort of always the case with these UDTs. To use this, just patch in your UDT declaration (instead of the "Public Type TestUdtType" declaration), and then search-and-replace all occurrences of TestUdtType with the name of your UDT, and you're all set.

In fact, if you've got several UDTs you wish to do this with, you can just make multiple copies of the StringFromUdt and UdtFromString functions, and name them different names to denote your UDT names.

-----------

This isn't complicated stuff, but it is something that comes up somewhat often.

Also, as a caveat, you probably shouldn't do this with UDTs that contain pointers (to BSTR Strings, objects, and/or dynamic arrays). It will still work, but UDTs with pointers must be handled with great care when copying them in any way other than a regular Let statement.

Microsoft hardening DCOM, forcing packet integrity on March 14, 2023

$
0
0
DCOM = Distributed Com Object Model

Update Release Behavior Change
June 8, 2021 Hardening changes disabled by default, but with ability to enable them using a register key.
June 14, 2022 Hardening changes enabled by default, but with ability to disable them using a register key.
March 14, 2023 Hardening changes enabled by default, with no ability to disable them.
By this point, you must resolve any compatibility issues with the hardening changes and applications in your environment.

Microsoft is saying that applications must leverage "Packet Integrity" or higher for COM + communications.
Packet Integrity = Authenticates credentials and verifies that no call data has been modified in transit.
Packet Privacy = Authenticates credentials and encrypts the packet, including the data and the sender's identity and signature.

I am using VB6 with my DataEnvironment.Dsr connecting as follows:
Data Link Connection: Provider=SQLNCLI.1;Persist Security Info=False;Extended Properties="Server=MyServer;Database=MyDataBase;Uid=MyUserID;"

My registry setting that is turned off for Packet Integrity is: Computer>HKEY_LOCAL_MACHINE>SOFTWARE>Microsoft>Ole>AppCompat
Registry Name = RequireIntegrityActivationAuthenticationLevel
Registry Value = 0x00000000 (Base Hexadecimal) (disabling Packet Integrity)

When I change the registry value to 0x00000001 (Base Hexadecimal) (enabling Packet Integrity) to test what will happen March 14, 2023, my apps no longer work.

Microsoft SQL Server Login

Connection failed:
SQL State: '08001'
SQL Server Error: 10061
TCP Provider: No connection could be made because the target machine actively refused it.

Connection failed:
SQL State: '08001'
SQL Server Error: 10061

Connection failed:
SQL State: 'HYT00'
SQL Server Error: 0


Does anyone know what addition to the connection string is needed to be able to run with Packet Integrity?

select case send data

$
0
0
client side
Code:

Private Sub sckClient_DataArrival(ByVal bytesTotal As Long)
    Dim strData As String, strPackets() As String
    Dim strTrunc As String, bolTrunc As Boolean
    Dim lonLoop As Long, lonTruncStart As Long
    Dim lonUB As Long
   
    sckClient.GetData strData, vbString, bytesTotal
    strBuffer = strBuffer & strData
    strData = vbNullString
   
    If Right$(strBuffer, 1) <> Chr$(4) Then
        bolTrunc = True
        lonTruncStart = InStrRev(strBuffer, Chr$(4))
        If lonTruncStart > 0 Then
            strTrunc = Mid$(strBuffer, lonTruncStart + 1)
        End If
    End If
   
    If InStr(1, strBuffer, Chr$(4)) > 0 Then
        strPackets() = Split(strBuffer, Chr$(4))
        lonUB = UBound(strPackets)
       
        If bolTrunc Then lonUB = lonUB - 1
       
        For lonLoop = 0 To lonUB
            If Len(strPackets(lonLoop)) > 3 Then
               
                Select Case Left$(strPackets(lonLoop), 3)
                   
                    'Packet is a chat message.
                    Case "MSG"
                        ParseChatMessage strPackets(lonLoop)
                       
                    'User list has been sent.
                    Case "LST"
                        ParseUserList strPackets(lonLoop)
                    frmChat.Label2.Caption = frmChat.lstUsers.ListCount
                   
                    Case "ENT", "LEA"
                        ParseUserEntersLeaves strPackets(lonLoop)
             
                    'Add your own here! :)
                   
                    Case "Kick"
                      Debug.Print "cazzcazzcazzcazzcazzcazzcazzcazzcazzcazzcazzcazzcazzcazz"
                     
                Case "cazz"
                Debug.Print "ServeuserServeuserServeuserServeuserServeuserServeuserServeuserServeuser"
                        'Do something.
                   
                    'Case "YYY"
                        'Do something.
                       
                End Select
            End If
        Next lonLoop
   
    End If
   
    Erase strPackets
   
    strBuffer = vbNullString
   
    If bolTrunc Then
        strBuffer = strTrunc
    End If
   
    strTrunc = vbNullString
End Sub


server button click to client
this works
Code:

Private Sub cmdSend_Click()
    If Len(txtMsg.Text) > 0 Then
        If sckClient.State <> sckConnected Then
            AddStatusMessage rtbChat, RGB(128, 0, 0), "> Not connected! Cannot send message."
        Else
            Dim strPacket As String
           
            strPacket = "MSG" & Chr$(2) & strMyNickname & Chr$(2) & txtMsg.Text & Chr$(4)
            sckClient.SendData strPacket
            txtMsg.Text = ""
        End If
    End If
End Sub

why isnt my custom code not working
Code:

Dim strPacket As String
   
 strPacket = "Kick" & Chr$(2) & strMyNickname & Chr$(4)
        SendGlobalData strPacket


Code:

Public Sub SendGlobalData(Data As String)
    Dim intLoop As Integer
   
    On Error GoTo ErrorHandler
   
    With frmChat
        If .sckServer.UBound > 0 Then
            For intLoop = 1 To .sckServer.UBound
                .sckServer(intLoop).SendData Data
                DoEvents
            Next intLoop
        End If
    End With
   
    Exit Sub
   
ErrorHandler:
    'if err.Number = 40006 then 'Socket not connected.
    Resume Next
End Sub

Arrays in Far Memory

$
0
0
Ok, this is an idea I've been playing around with, inspired by some work by Dilettante and The Trick. And much thanks goes out to both of them.

My idea was to use those concepts and create a class that "looks like" an array (of any numeric data type of your choosing). The primary feature this will have that other typical VB6 arrays don't have is that the data is stored in far memory. These arrays can expand past our 2GB (or 4GB with LAA) VB6 limitations. It's a single class module that you can include into any project. Furthermore, you can instantiate it as many times as you like to create as many far memory arrays as you like.

Furthermore, because this is in far memory, you can actually use it as a way to communicate across processes (so long as you know the "name" of the memory file that you're using). See documentation in the class for more information on this. And, just as an FYI, these far memory files hang around so long as one process has a file handle opened against it. When the last handle is closed, the file is purged from far memory.

Also, don't let the nomenclature of "file" confuse you. These are memory files, not disk based files, other than the possibility that the data may get pushed into the OS's paging virtual memory if you ask for more memory than is available in your computer. And, if this happens, these things will perform much slower than when this doesn't happen.

One CAVEAT about these things. When developing in the IDE, it's not the best idea to use the "Stop" button when you've got one (or more) copies of the MemoryBasedArray.cls array instantiated. The reason is, once you call the Initialization procedure within that class, you have a far memory file open. And it's the Class_Terminate event that closes that file. If you don't explicitly close it, even when returning to IDE development mode, that file will stay open. There's no great harm in this, and it won't crash the IDE. However, the next time you execute your program, you will probably get a "File Already Open" error. And then, the only way to clear that error is to close the IDE and re-open it.

What types of arrays will this thing store? It will store any of the VB6 intrinsic types: vbByte, vbBoolean, vbInteger, vbLong, vbSingle, vbCurrency, vbDate, vbDouble, & vbDecimal.

Notice that even vbDecimal is included in that list. The entire Variant (holding a Decimal) is stored in that case, all 16 bytes.

There is also a vbString option/specification. These aren't exactly BSTR strings nor fixed-length-strings. They're better thought of as similar to fixed database fields specified to hold Unicode strings. Also, there are some criteria for these things ... primarily that they can't have vbNullChar values in the trailing characters of the string. The vbNullChar is used for padding within the buffer. And, when these strings are returned, they're right-trimmed for vbNullChar. So long as the trailing character of an input string isn't vbNullChar, they can contain other vbNullChar values with no problem.

Also, the Value (both Let & Get) property of this class is the default, so, once instantiated and initialized, you can use it like a true array (with the index and value).

There is a "test" project attached. I've also shown the code of the class, but you're better off to get the class out of the test project. As, that way, the Value property will stay the default property.

Code:

' Ideas herein were inspired by some work that Dilettante & The Trick (vbforums.com) have done.
'
' With this class, you can create an array that uses "far" memory,
' and isn't limited to the 2GB (or 4GB with LAA) that VB6 is limited to.
'
' Initialize must be called immediately after instantiation.
' Then, the Value property (Get & Let) can be used.
'
Option Explicit
'
Private Type SYSTEM_INFO
    Reserved1(27&)              As Byte
    dwAllocationGranularity    As Long    ' For purposes herein, this is all we need.
    Reserved2(3&)              As Byte
End Type
'
Private Declare Function CreateFileMapping Lib "kernel32" Alias "CreateFileMappingA" (ByVal hFile As Long, ByVal lpFileMappigAttributes As Long, ByVal flProtect As Long, ByVal dwMaximumSizeHigh As Long, ByVal dwMaximumSizeLow As Long, ByVal lpName As String) As Long
Private Declare Function MapViewOfFile Lib "kernel32" (ByVal hFileMappingObject As Long, ByVal dwDesiredAccess As Long, ByVal dwFileOffsetHigh As Long, ByVal dwFileOffsetLow As Long, ByVal dwNumberOfBytesToMap As Long) As Long
Private Declare Function OpenFileMapping Lib "kernel32" Alias "OpenFileMappingA" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As String) As Long
Private Declare Function UnmapViewOfFile Lib "kernel32" (ByVal lpBaseAddress As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Long, ByRef Source As Long, ByVal Length As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (ByRef Destination As Long, ByVal Length As Long)
Private Declare Sub GetSystemInfo Lib "kernel32" (ByRef lpSystemInfo As SYSTEM_INFO)
Private Declare Function VariantChangeType Lib "oleaut32" (Dest As Variant, src As Variant, ByVal wFlags As Integer, ByVal vt As Long) As Long
'
Private mbInit          As Boolean
Private mhMemFile      As Long
Private miVarType      As Long
Private miItemBytes    As Long
Private mvMaxCount      As Variant  ' Decimal.
Private miVariantOffset As Long
Private miGranularity  As Long
'
Private mpMapView      As Long
Private mdwViewHigh    As Long
Private mdwViewLow      As Long
'

Public Sub Initialize(ByRef sUniqueName As String, iVarType As VBA.VbVarType, iMaxItemCount As Variant, Optional iFixedStringCharLen As Long = 10&, Optional bOpenOnlyNoCreate As Boolean = False)
    '
    ' sUniqueName is a system-wide thing.  If other programs are using CreateFileMapping,
    ' the sUniqueName must be unique with respect to those, and not only names used within this project.
    '
    ' iVarType is simply the variable type you'll be storing in this array.
    ' Or, fixed length strings (not the same as VB6's fixed length strings) are allowed.
    '
    ' iMaxItemCount is the maximum (not necessily used) number of items in the array.
    ' You will get an error if you overflow this when using the Value properties.
    ' Note that far memory is allocated based on this iMaxItemCount argument.
    ' This iMaxItemCount must be a numeric integer.  It's not a Long so that even more than a Long's limits can be used.
    '
    ' If iVarType = vbString then iFixedStringCharLen is examined for how long they should be.
    ' As a note, these strings CAN'T end in vbNullChar, as that's reserved for padding in these things.
    ' Also, their length must an integer divisor of the system's granularity (typically some power of 2).
    '
    If mbInit Then Exit Sub                ' Only allow this to be called once.
    If Not IsNumeric(iMaxItemCount) Then Err.Raise 13&, TypeName(Me), "iMaxItemCount must be numeric."
    If iMaxItemCount < 1& Then Err.Raise 5&, TypeName(Me), "Count must be at least 1."
    '
    ' Save granularity.
    miGranularity = MemAllocGranularity
    '
    ' The only allowed types are: vbBoolean, vbByte, vbCurrency, vbDate, vbDecimal, vbDouble, vbInteger, vbLong, vbSingle, or vbString.
    Select Case iVarType
    Case vbByte:                        miItemBytes = 1&:  miVariantOffset = 8&    ' These are the length (bytes) and offset with a variant for our data types.
    Case vbBoolean, vbInteger:          miItemBytes = 2&:  miVariantOffset = 8&    ' In most cases (all but Decimal), a variant stores data at an 8 byte offset.
    Case vbLong, vbSingle:              miItemBytes = 4&:  miVariantOffset = 8&
    Case vbCurrency, vbDate, vbDouble:  miItemBytes = 8&:  miVariantOffset = 8&
    Case vbDecimal:                    miItemBytes = 16&:  miVariantOffset = 0&    ' This is the one case where all 14 bytes of the variant's data are used.
    Case vbString
        ' This one needs a bit of special handling.
        miItemBytes = iFixedStringCharLen * 2&  ' Unicode.
        Select Case True
        Case miGranularity < miItemBytes
            Err.Raise 6&, TypeName(Me), "Fixed string length (" & CStr(iFixedStringCharLen) & ") overflow. They can't be longer than the system's granularity / 2 (" & CStr(miGranularity / 2) & ")."
        Case iFixedStringCharLen < 1&
            Err.Raise 6&, TypeName(Me), "Fixed string length underflow. Length: " & CStr(iFixedStringCharLen)
        Case miGranularity Mod miItemBytes <> 0
            Err.Raise 6&, TypeName(Me), "Fixed string length * 2 (for Unicode) (" & CStr(iFixedStringCharLen) & ") not an even divisor of the system's granularity (" & CStr(miGranularity) & ")."
        End Select
        '
        miVariantOffset = 8&    ' But, in this case, it's the BSTR pointer.
    Case Else: Err.Raise 13&, TypeName(Me), "Invalid variable type specified."
    End Select
    '
    ' Save our initialization properties.
    miVarType = iVarType
    mvMaxCount = CDec(iMaxItemCount)
    '
    ' Figure out byte size of Mapped File, and round UP to a multiple of MemAllocGranularity.
    Dim vTotalBytes As Variant
    vTotalBytes = CDec(miItemBytes) * mvMaxCount
    vTotalBytes = Int((vTotalBytes - CDec(1&) + CDec(miGranularity)) / CDec(miGranularity)) * CDec(miGranularity)
    '
    ' Copy low and high into MapViewOfFile offset arguments.
    Dim dwMaximumSizeHigh  As Long
    Dim dwMaximumSizeLow    As Long
    '
    '  Variant structure with a Decimal.
    '      VariantType As Integer  ' Reserved, to act as the Variant Type when sitting in a 16-Byte-Variant.  Equals vbDecimal(14) when it's a Decimal type.
    '      Base10NegExp As Byte    ' Base 10 exponent (0 to 28), moving decimal to right (smaller numbers) as this value goes higher.  Top three bits are never used.
    '      sign As Byte            ' Sign bit only.  Other bits aren't used.
    '      Hi32 As Long            ' Mantissa.
    '      Lo32 As Long            ' Mantissa.
    '      Mid32 As Long          ' Mantissa.
    CopyMemory dwMaximumSizeHigh, ByVal PtrAdd(VarPtr(vTotalBytes), 12&), 4&      ' Mid32
    CopyMemory dwMaximumSizeLow, ByVal PtrAdd(VarPtr(vTotalBytes), 8&), 4&        ' Lo32
    '
    ' Create our memory file.
    Const INVALID_HANDLE_VALUE  As Long = -1&
    Const PAGE_READWRITE        As Long = 4&
    Const FILE_MAP_WRITE        As Long = 2&
    Const FILE_MAP_READ        As Long = 4&
    '
    If Not bOpenOnlyNoCreate Then
        mhMemFile = CreateFileMapping(INVALID_HANDLE_VALUE, 0&, PAGE_READWRITE, dwMaximumSizeHigh, dwMaximumSizeLow, sUniqueName)
        If mhMemFile = 0& Then
            If Err.LastDllError = 1450& Then
                Err.Raise Err.LastDllError, TypeName(Me), "CreateFileMapping error ERROR_NO_SYSTEM_RESOURCES.  This probably means you don't have enough memory in this computer to map file(s) as large as you're trying to, or maybe memory is full with other executing programs."
            Else
                Err.Raise Err.LastDllError, TypeName(Me), "CreateFileMapping API system error."
            End If
        End If
        '
        Const ERROR_ALREADY_EXISTS  As Long = 183&
        If Err.LastDllError = ERROR_ALREADY_EXISTS Then CloseMemFile: Err.Raise 55&, TypeName(Me), sUniqueName & " already open."
    Else
        mhMemFile = OpenFileMapping(FILE_MAP_READ + FILE_MAP_WRITE, 0&, sUniqueName)
        If mhMemFile = 0& Then Err.Raise Err.LastDllError, TypeName(Me), "OpenFileMapping API system error.  Make sure the file exists."
    End If
    '
    ' All done and ready to be used.
    mbInit = True
End Sub

Private Sub Class_Terminate()
    ' When all handles to the mapped object are closed, it disappears.
    ' When in the IDE, abnormal termination can leave the file open,
    ' and only way to get rid of it is to restart the IDE.
    ' When compiled, it's not a problem.
    '
    CloseMemFile
End Sub

Private Sub CloseMemFile()
    If mpMapView Then
        ApiZ UnmapViewOfFile(mpMapView)
        mpMapView = 0&
    End If
    If mhMemFile Then
        ApiZ CloseHandle(mhMemFile)
        mhMemFile = 0&
    End If
End Sub




Public Property Let Value(index As Variant, vValue As Variant)
    ' Zero based index.  It can be any numeric value, but will always be treated as an integer,
    ' and internally, it'll be handled as a Decimal.
    '
    ' If you need an index larger than 2147483647 (&h7fffffff), you can cast a string to a decimal
    ' using something like: CDec("99999999999"), or just use Decimal types in the first place for your indices.
    '
    If Not mbInit Then Exit Property
    '
    ' Make sure we've got valid arguments.
    If VarType(vValue) <> miVarType Then CloseMemFile: Err.Raise 13&, TypeName(Me), "Value type doesn't match initialization type: " & TypeName(vValue)
    Dim vDecIdx As Variant
    vDecIdx = ValidateIndex(index)
    '
    ' Create a map view of our memory file.
    Dim iGranOffset As Long
    iGranOffset = CreateSingleItemMapping(vDecIdx)
    '
    ' Put data into memory mapped file.
    If miVarType <> vbString Then
        CopyMemory ByVal PtrAdd(mpMapView, iGranOffset), ByVal PtrAdd(VarPtr(vValue), miVariantOffset), miItemBytes
    Else
        ZeroMemory ByVal PtrAdd(mpMapView, iGranOffset), miItemBytes
        Dim iChars As Long
        iChars = miItemBytes \ 2&
        Dim s As String
        s = String$(iChars, vbNullChar)    ' Create a buffer.
        Mid$(s, 1&, Len(vValue)) = vValue  ' s is now padded with vbNullChar if necessary.
        CopyMemory ByVal PtrAdd(mpMapView, iGranOffset), ByVal StrPtr(s), miItemBytes  ' We ignore the BSTR zero terminator.
    End If
End Property

Public Property Get Value(index As Variant) As Variant
    ' Zero based index.  See notes in "Let Value" property.
    '
    If Not mbInit Then Exit Property
    '
    ' Make sure we've got valid arguments.
    Dim vDecIdx As Variant
    vDecIdx = ValidateIndex(index)
    '
    ' Create a map view of our memory file.
    Dim iGranOffset As Long
    iGranOffset = CreateSingleItemMapping(vDecIdx)
    '
    ' Get data from memory mapped file.
    If miVarType <> vbString Then
        Value = CLng(0&)
        If miVarType <> vbLong Then ApiE VariantChangeType(Value, Value, 0&, miVarType), "VariantChangeType" ' Make our variant the correct type.
        CopyMemory ByVal PtrAdd(VarPtr(Value), miVariantOffset), ByVal PtrAdd(mpMapView, iGranOffset), miItemBytes
    Else ' Handle strings.
        Dim iChars As Long
        iChars = miItemBytes \ 2&
        Dim ia() As Integer
        ReDim ia(1& To iChars) ' Create a buffer.
        CopyMemory ByVal VarPtr(ia(1&)), ByVal PtrAdd(mpMapView, iGranOffset), miItemBytes
        ' Need to trim null characters (from end).
        Dim i As Long
        For i = UBound(ia) To 1& Step -1&
            If ia(i) Then Exit For ' We found something non-zero.
        Next
        If i Then  ' If it wound down to 0, then it was all zeroes.
            Dim s As String
            s = Space$(i)
            CopyMemory ByVal StrPtr(s), ByVal VarPtr(ia(1&)), i * 2& ' Unicode.
            Value = s
        Else
            Value = vbNullString
        End If
    End If
End Property





Private Function ValidateIndex(index As Variant) As Variant ' vDecIdx is returned.
    If Not IsNumeric(index) Then CloseMemFile: Err.Raise 9&, TypeName(Me), "Bad index type: " & TypeName(index)
    Dim vDecIdx As Variant
    vDecIdx = CDec(index)
    If vDecIdx < 0& Or (vDecIdx + 1&) > mvMaxCount Then CloseMemFile: Err.Raise 9&, TypeName(Me), "Bad index range: " & CStr(vDecIdx)
    If vDecIdx <> Int(vDecIdx) Then CloseMemFile: Err.Raise 9&, TypeName(Me), "Bad index value: " & CStr(vDecIdx)
    '
    ValidateIndex = vDecIdx
End Function

Private Function CreateSingleItemMapping(ByVal vDecIdx As Variant) As Long
    ' The iGranOffset is returned, which is an offset in the "View" to the specific item requested.
    ' mpMapView is also set.
    '
    ' Convert vDecIdx into a byte offset.
    vDecIdx = vDecIdx * CDec(miItemBytes)
    '
    ' Calculate an offset that appreciates granularity.
    Dim vTemp As Variant
    vTemp = Int(vDecIdx / CDec(miGranularity))  ' Rounds down, preserving Decimal type.
    vTemp = vTemp * CDec(miGranularity)        ' This can now be used in MapViewOfFile API call.
    CreateSingleItemMapping = vDecIdx - vTemp  ' This provides an offset for addressing a single item.
    '
    ' Copy low and high into MapViewOfFile offset arguments.
    Dim dwFileOffsetHigh    As Long
    Dim dwFileOffsetLow    As Long
    '
    '  Variant structure with a Decimal.
    '      VariantType As Integer  ' Reserved, to act as the Variant Type when sitting in a 16-Byte-Variant.  Equals vbDecimal(14) when it's a Decimal type.
    '      Base10NegExp As Byte    ' Base 10 exponent (0 to 28), moving decimal to right (smaller numbers) as this value goes higher.  Top three bits are never used.
    '      sign As Byte            ' Sign bit only.  Other bits aren't used.
    '      Hi32 As Long            ' Mantissa.
    '      Lo32 As Long            ' Mantissa.
    '      Mid32 As Long          ' Mantissa.
    CopyMemory dwFileOffsetHigh, ByVal PtrAdd(VarPtr(vTemp), 12&), 4&      ' Mid32
    CopyMemory dwFileOffsetLow, ByVal PtrAdd(VarPtr(vTemp), 8&), 4&        ' Lo32
    '
    ' Make sure we need to do something.
    If mpMapView = 0& Or mdwViewHigh <> dwFileOffsetHigh Or mdwViewLow <> dwFileOffsetLow Then
        If mpMapView Then ApiZ UnmapViewOfFile(mpMapView)
        mdwViewHigh = 0&
        mdwViewLow = 0&
        '
        ' Create a mapview of our memory file.
        Const FILE_MAP_WRITE = 2&
        Const FILE_MAP_READ = 4&
        mpMapView = MapViewOfFile(mhMemFile, FILE_MAP_READ + FILE_MAP_WRITE, dwFileOffsetHigh, dwFileOffsetLow, miGranularity)
        If mpMapView = 0& Then CloseMemFile: Err.Raise Err.LastDllError, TypeName(Me), "MapViewOfFile system error."
        '
        mdwViewHigh = dwFileOffsetHigh
        mdwViewLow = dwFileOffsetLow
    End If
End Function

Private Function MemAllocGranularity() As Long
    ' When using MapViewOfFile, the quad_word offset must be a multiple of this granularity (per MSDN).
    Dim si As SYSTEM_INFO
    GetSystemInfo si
    MemAllocGranularity = si.dwAllocationGranularity
End Function

Private Function PtrAdd(ByVal Ptr As Long, ByVal iOffset As Long) As Long
    ' For adding (or subtracting) a small number from a pointer.
    PtrAdd = (Ptr Xor &H80000000) + iOffset Xor &H80000000
End Function

Private Function ApiZ(ApiReturn As Long, Optional sApiCall As String) As Long
    ' This one is for API calls that report error by returning ZERO.
    '
    If ApiReturn <> 0& Then
        ApiZ = ApiReturn
        Exit Function
    End If
    '
    Dim sErr As String
    If Len(sApiCall) Then
        sErr = sApiCall & " error " & CStr(Err.LastDllError)
    Else
        sErr = "API Error " & CStr(Err.LastDllError)
    End If
    '
    Dim InIDE As Boolean: Debug.Assert MakeTrue(InIDE)
    If InIDE Then
        Debug.Print sErr
        Stop
    Else
        Err.Raise vbObjectError + 1147221504, TypeName(Me), sErr
    End If
End Function

Private Sub ApiE(ApiReturn As Long, Optional sApiCall As String)
    ' Just a general error processing procedure for API errors.
    ' For API calls where 0& is OK.
    '
    If ApiReturn = 0& Then Exit Sub
    '
    Dim sErr As String
    If Len(sApiCall) Then
        sErr = sApiCall & " error " & CStr(ApiReturn)
    Else
        sErr = "API Error " & CStr(ApiReturn)
    End If
    '
    Dim InIDE As Boolean: Debug.Assert MakeTrue(InIDE)
    If InIDE Then
        Debug.Print sErr
        Stop
    Else
        Err.Raise vbObjectError + 1147221504 - ApiReturn, TypeName(Me), sErr
    End If
End Sub

Private Function MakeTrue(ByRef b As Boolean) As Boolean
    b = True
    MakeTrue = True
End Function

---------------

Also, in the thread where I was initially developing this, there was some discussion of putting UDTs into these things. With the use of these helper procedures, you could do that. However, there are a couple of caveats. As stated above, these fixed length strings must be an integer divisor of the system's granularity, which is some power of 2. So, you may need to round up to such a number when specifying iFixedStringCharLen in the Initialization.

Also, as stated above, using those fixed length strings with this, you can't pass in strings with any trailing vbNullChar values. Having a string with a trailing vbNullChar would be easy to do if the last item in the UDT was a number with a value of zero. So, you may need to append some non-zero value (possibly just any character) to the end of the resulting string (from the UDT) to avoid this.

---------------

I've now tested in many ways, but here's the test code in the attached Form1. I've tested both the fixed length strings and the decimal type (both a bit unusual).

Code:

Option Explicit
'


Private Sub Form_Load()
   
    Debug.Print
    Debug.Print "********************************"
    Debug.Print "String array test:"
       
   
    Dim oStr As ArraysInFarMemory
    Set oStr = New ArraysInFarMemory
    oStr.Initialize "StrTest", vbString, 700000, 256&
    '
    oStr(0&) = "aaaa"              ' Illustrating default property.
    oStr.Value(1&) = "bbbbbbbbbbbb" ' Too long so it'll be truncated.
    oStr.Value(2&) = vbNullString
    oStr(300000) = "dddddddd"      ' Illustrating default property.
   
    Debug.Print "'"; oStr.Value(0&); "'"; "          should be 'aaaa'"
    Debug.Print "'"; oStr(1&); "'"; "  should be 'bbbbbbbbbbbb'"          ' Illustrates default property.
    Debug.Print "'"; oStr.Value(2&); "'"; "              should be empty"
    Debug.Print "'"; oStr.Value(3&); "'"; "              should be empty"
    Debug.Print "'"; oStr.Value(4&); "'"; "              should be empty"
   
    Dim c As Long
    For c = 1& To 500000
        oStr(c) = CStr(c)
        If oStr(c) <> CStr(c) Then Debug.Print "bad put/get": Stop
   
        If c Mod 50000 = 0& Then Debug.Print CStr(c)
   
    Next
    Set oStr = Nothing
   
    Debug.Print "Successfully stored and retrieved 500,000 string values,"
    Debug.Print "verifying that they were stored correctly."
    Debug.Print
   
    Stop
   
   
    Debug.Print
    Debug.Print "********************************"
    Debug.Print "Decimal array test:"
   
   
    ' We'll use the default property of the class for all of this work.
   
    Dim oDec As ArraysInFarMemory
    Set oDec = New ArraysInFarMemory
    oDec.Initialize "DecimalTest", vbDecimal, 500000

    oDec(0&) = CDec("987654321987654321987654321")  ' Decimals can hold REALLY big numbers.
    oDec(400000) = CDec("999888")
   
    Debug.Print oDec(0&); "  should be 987654321987654321987654321"
    Debug.Print oDec(400000); "  should be 999888"
   
   
    Dim d As Long
   
    For d = 0& To 490000
        oDec(d) = CDec(d)
        If oDec(d) <> CDec(d) Then Debug.Print "bad put/get": Stop
   
        If d Mod 50000 = 0& Then Debug.Print CDec(d)
    Next
    Set oDec = Nothing
   
    Debug.Print "Successfully stored and retrieved 490,000 decimal values,"
    Debug.Print "verifying that they were stored correctly."
    Debug.Print
   
    Stop
   
    Unload Me
   
End Sub



Notice I've put in some Stop commands, just so you can see what's going on. Again, be careful to not use the Stop "button" too much with this stuff, as you'll be reloading your IDE if you do, to clear the "File Already Open" error.

---------------

I look forward to any discussion anyone might like to have about this stuff.
Attached Files

Encrypted File Transfer

$
0
0
Attached are sample programs that facilitate sending a file over the WAN (Wide Area Network) fully encrypted.

Transferring a file unencrypted over the Internet using SimpleSock is usually quite straight forward. You connect to the receiving machine and transfer data to the Winsock buffer in blocks less than the size of the outgoing buffer (usually 65,536 bytes). Winsock sends packets of data to the receiver at a rate that is dependent on the network being used (WiFi uses a lower packet size than hard wired). When the outgoing buffer is full, it halts the sending of data to the buffer until the buffer is able to handle more data. On the receiving end, the Winsock buffer receives data until it cannot accept any more. Once the incoming buffer is able to process more data, it will accept more data. This is all accomplished on the boundary of a packet. Winsock is buffered and the file system is buffered. We simply need to know the file length.

That is all fine and dandy as long as the receiver is able to receive data at approximately the same rate as the sender. But when you introduce encryption to the mix, it becomes a whole different ball game. Data can only be processed as a complete record, and the header defines the record length, not the file length. That outgoing record must be encrypted before it can be processed. Therefore we must halt the sending of a new record until the present record has been completely sent, so it can be received as a complete record to be decrypted. That is accomplished by using the SimpleSock SendComplete routine. Using a fixed maximum record length, anything less than that length will be considered the last record for the file. But what if the last record exactly coincides with a record boundary. In this remote case, the sender sends one more record of zero length along with just the header.

So what is the appropriate length for a record. A record size too large places an excessive load on the encryption/decryption routines and slows things down. A record size too small places an excessive load on the network system. Gmail sends attachment files using a record size of 1,408 bytes and it is painfully slow sending larger attachments. So Gmail offers a secondary system to receive those larger files when using a browser. TLS 1.3 uses a maximum record size of 2^14 (16,384 bytes), and this is what I have chosen to use in this sample program.

The encryption protocol I have chosen to use in this sample program is RC4. It is fast and its limitations are overcome by using a 256 bit key and relatively large record sizes. The current sample uses a fixed 32 byte key, but the intention is to use TLS 1.3 to establish the network connection in the next version. The Agreed Secret calculated by each party would be used as the key for each file transfer, as the connection is terminated after each file. This results in a different key being used for each file transfer.

To receive a file, start the "RecvFile" program. I have arbitrarily chosen port 1159 to listen on, and "C:\Temp" to store the file. When the file starts to download, the file name will appear in a text box and the text box will be made visible. If the file already exists in the chosen path, an addendum by way of "(x)" will be added to the filename when it is saved.

To send a file, start the "SendFile" program. Enter the location of the receiving program as either an IP address or a domain name. A domain name must be DNS hosted or configured in the "HOSTS" file. Click the "Connect" button, and if successful the status will be reflected in the status bar. Unsuccessful attempts will eventually time out and display an error in the status bar. Next, click on the 3 dots in the upper right corner. This activate a Common Dialog which you can use to navigate and select the file you want to send. Then click the "SendFile" button. There are ample debug messages to visualize the progress and a timer message to tell you how many ms the transfer took.

J.A. Coutts
Attached Files

[VB6] SHA-3 pure VB6 implementation in 266 LOC

$
0
0
This tiny module includes CryptoSHA3 function that can be used to calculate SHA-3 hash in all bit-sizes: SHA3-224, SHA3-256, SHA3-384 and SHA3-512.

The module also includes CryptoKeccak function which calculates the legacy Keccak hash as it was implemented before being accepted as SHA-3 officially and CryptoShake function for SHAKE-128, SHAKE-256 and SHAKE-512 which can produce hashes in arbitrary output length.

This module uses VT_I8 Variants for the 64-bit arithmetic in Keccak sponge permutation function so it's not the fastest hasher on the block, one might expect performance around the 1MB/s mark when compiled.

All the public functions could be used with other non-standard bit-sizes but do this on your own risk only.

Code:

'--- mdSha3.bas
Option Explicit
DefObj A-Z

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VariantChangeType Lib "oleaut32" (Dest As Variant, src As Variant, ByVal wFlags As Integer, ByVal vt As Long) As Long
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long

Private Type SAFEARRAY1D
    cDims              As Integer
    fFeatures          As Integer
    cbElements          As Long
    cLocks              As Long
    pvData              As Long
    cElements          As Long
    lLbound            As Long
End Type

Private Const LNG_ROUNDS            As Long = 24
Private Const LNG_SPONGE_WORDS      As Long = 25

Private LNG_POW2(0 To 63)      As Variant
Private LNG_RND_C(0 To 23)      As Variant

Private Type HashState
    DigestSize      As Long
    Capacity        As Long
    Absorbed        As Long
    Words(0 To LNG_SPONGE_WORDS - 1) As Variant
    Bytes()        As Byte
    PeekArray      As SAFEARRAY1D
End Type

Private Function ROTL64(lX As Variant, ByVal lN As Long) As Variant
    '--- ROTL64 = LShift(X, n) Or RShift(X, 64 - n)
    Debug.Assert lN <> 0
    ROTL64 = ((lX And (LNG_POW2(63 - lN) - 1)) * LNG_POW2(lN) Or -((lX And LNG_POW2(63 - lN)) <> 0) * LNG_POW2(63)) Or _
        ((lX And (LNG_POW2(63) Xor -1)) \ LNG_POW2(64 - lN) Or -(lX < 0) * LNG_POW2(lN - 1))
End Function

Private Sub Theta(uState As HashState)
    Static C(0 To 4)    As Variant
    Dim lIdx            As Long
    Dim lJdx            As Long
    Dim vTemp          As Variant
   
    With uState
        For lIdx = 0 To 4
            C(lIdx) = .Words(lIdx) Xor .Words(lIdx + 5) Xor .Words(lIdx + 10) Xor .Words(lIdx + 15) Xor .Words(lIdx + 20)
        Next
        For lIdx = 0 To 4
            vTemp = C((lIdx + 4) Mod 5) Xor ROTL64(C((lIdx + 1) Mod 5), 1)
            For lJdx = 0 To 24 Step 5
                .Words(lIdx + lJdx) = .Words(lIdx + lJdx) Xor vTemp
            Next
        Next
    End With
End Sub

Private Sub Rho(uState As HashState)
    With uState
'        .Words(0) = ROTL64(.Words(0), 0)
        .Words(1) = ROTL64(.Words(1), 1)
        .Words(2) = ROTL64(.Words(2), 62)
        .Words(3) = ROTL64(.Words(3), 28)
        .Words(4) = ROTL64(.Words(4), 27)
        .Words(5) = ROTL64(.Words(5), 36)
        .Words(6) = ROTL64(.Words(6), 44)
        .Words(7) = ROTL64(.Words(7), 6)
        .Words(8) = ROTL64(.Words(8), 55)
        .Words(9) = ROTL64(.Words(9), 20)
        .Words(10) = ROTL64(.Words(10), 3)
        .Words(11) = ROTL64(.Words(11), 10)
        .Words(12) = ROTL64(.Words(12), 43)
        .Words(13) = ROTL64(.Words(13), 25)
        .Words(14) = ROTL64(.Words(14), 39)
        .Words(15) = ROTL64(.Words(15), 41)
        .Words(16) = ROTL64(.Words(16), 45)
        .Words(17) = ROTL64(.Words(17), 15)
        .Words(18) = ROTL64(.Words(18), 21)
        .Words(19) = ROTL64(.Words(19), 8)
        .Words(20) = ROTL64(.Words(20), 18)
        .Words(21) = ROTL64(.Words(21), 2)
        .Words(22) = ROTL64(.Words(22), 61)
        .Words(23) = ROTL64(.Words(23), 56)
        .Words(24) = ROTL64(.Words(24), 14)
    End With
End Sub

Private Sub Pi(uState As HashState)
    Dim aTemp()        As Variant
   
    With uState
        aTemp = .Words
'        .Words(0) = aTemp(0)
        .Words(10) = aTemp(1)
        .Words(20) = aTemp(2)
        .Words(5) = aTemp(3)
        .Words(15) = aTemp(4)
        .Words(16) = aTemp(5)
        .Words(1) = aTemp(6)
        .Words(11) = aTemp(7)
        .Words(21) = aTemp(8)
        .Words(6) = aTemp(9)
        .Words(7) = aTemp(10)
        .Words(17) = aTemp(11)
        .Words(2) = aTemp(12)
        .Words(12) = aTemp(13)
        .Words(22) = aTemp(14)
        .Words(23) = aTemp(15)
        .Words(8) = aTemp(16)
        .Words(18) = aTemp(17)
        .Words(3) = aTemp(18)
        .Words(13) = aTemp(19)
        .Words(14) = aTemp(20)
        .Words(24) = aTemp(21)
        .Words(9) = aTemp(22)
        .Words(19) = aTemp(23)
        .Words(4) = aTemp(24)
    End With
End Sub

Private Sub Chi(uState As HashState)
    Static C(0 To 4)    As Variant
    Dim lIdx            As Long
    Dim lJdx            As Long
   
    With uState
        For lJdx = 0 To 24 Step 5
            For lIdx = 0 To 4
                C(lIdx) = .Words(lIdx + lJdx)
            Next
            For lIdx = 0 To 4
                .Words(lIdx + lJdx) = .Words(lIdx + lJdx) Xor (Not C((lIdx + 1) Mod 5) And C((lIdx + 2) Mod 5))
            Next
        Next
    End With
End Sub

Private Sub Iota(uState As HashState, ByVal lIdx As Long)
    uState.Words(0) = uState.Words(0) Xor LNG_RND_C(lIdx)
End Sub

Private Sub Keccak(uState As HashState)
    Dim lIdx            As Long
   
    For lIdx = 0 To LNG_ROUNDS - 1
        Theta uState
        Rho uState
        Pi uState
        Chi uState
        Iota uState, lIdx
    Next
End Sub

Private Sub Absorb(uState As HashState, baBuffer() As Byte, ByVal lPos As Long, ByVal lSize As Long)
    Dim lIdx            As Long
    Dim lOffset        As Long
   
    If lSize < 0 Then
        lSize = UBound(baBuffer) + 1
    End If
    With uState
        lOffset = PeekByte(uState, .Absorbed)
        For lIdx = lPos To lSize - lPos - 1
            .Bytes(lOffset) = .Bytes(lOffset) Xor baBuffer(lIdx)
            If .Absorbed = .Capacity - 1 Then
                Keccak uState
                .Absorbed = 0
            Else
                .Absorbed = .Absorbed + 1
            End If
            If lOffset = 7 Then
                lOffset = PeekByte(uState, .Absorbed)
            Else
                lOffset = lOffset + 1
            End If
        Next
    End With
End Sub

Private Sub Squeeze(uState As HashState, baOutput() As Byte, ByVal lOutSize As Long, ByVal lLFSR As Long)
    Dim lIdx            As Long
    Dim lOffset        As Long
    Dim uEmpty          As HashState
   
    With uState
        ReDim baOutput(0 To lOutSize - 1) As Byte
        lOffset = PeekByte(uState, .Absorbed)
        .Bytes(lOffset) = .Bytes(lOffset) Xor lLFSR
        lOffset = PeekByte(uState, .Capacity - 1)
        .Bytes(lOffset) = .Bytes(lOffset) Xor &H80
        lOffset = PeekByte(uState, 0)
        For lIdx = 0 To UBound(baOutput)
            If lIdx Mod .Capacity = 0 Then
                Keccak uState
            End If
            baOutput(lIdx) = .Bytes(lOffset)
            If lOffset = 7 Then
                lOffset = PeekByte(uState, lIdx + 1)
            Else
                lOffset = lOffset + 1
            End If
        Next
    End With
    uState = uEmpty
End Sub

Private Sub Init(uState As HashState, ByVal lBitSize As Long)
    Dim lIdx            As Long
    Dim vElem          As Variant
   
    If LNG_POW2(0) = 0 Then
        LNG_POW2(0) = CLngLng(1)
        For lIdx = 1 To 63
            LNG_POW2(lIdx) = LNG_POW2(lIdx - 1) * 2
        Next
        lIdx = 0
        For Each vElem In Split("1 8082 800000000000808A 8000000080008000 808B 80000001 8000000080008081 8000000000008009 8A 88 80008009 8000000A 8000808B 800000000000008B 8000000000008089 8000000000008003 8000000000008002 8000000000000080 800A 800000008000000A 8000000080008081 8000000000008080 80000001 8000000080008008")
            LNG_RND_C(lIdx) = CLngLng("&H" & vElem)
            lIdx = lIdx + 1
        Next
    End If
    With uState
        .DigestSize = (lBitSize + 7) \ 8
        .Capacity = LNG_SPONGE_WORDS * 8 - 2 * .DigestSize
        .Words(0) = CLngLng(0)
        For lIdx = 1 To UBound(.Words)
            .Words(lIdx) = .Words(0)
        Next
        If .PeekArray.cDims = 0 Then
            With .PeekArray
                .cDims = 1
                .fFeatures = 1 ' FADF_AUTO
                .cbElements = 1
                .cLocks = 1
                .cElements = 8
            End With
            Call CopyMemory(ByVal ArrPtr(.Bytes), VarPtr(.PeekArray), 4)
        End If
    End With
End Sub

Private Function CLngLng(vValue As Variant) As Variant
    Const VT_I8 As Long = &H14
    Call VariantChangeType(CLngLng, vValue, 0, VT_I8)
End Function

Private Function PeekByte(uState As HashState, ByVal lOffset As Long) As Long
    uState.PeekArray.pvData = VarPtr(uState.Words(lOffset \ 8)) + 8
    PeekByte = lOffset Mod 8
End Function

Public Sub CryptoSHA3(ByVal lBitSize As Long, baOutput() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Dim uState          As HashState
   
    Init uState, lBitSize
    Absorb uState, baInput, Pos, Size
    Squeeze uState, baOutput, uState.DigestSize, &H6
End Sub

Public Sub CryptoKeccak(ByVal lBitSize As Long, baOutput() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Dim uState          As HashState
   
    Init uState, lBitSize
    Absorb uState, baInput, Pos, Size
    Squeeze uState, baOutput, uState.DigestSize, &H1
End Sub

Public Sub CryptoShake(ByVal lBitSize As Long, baOutput() As Byte, ByVal lOutSize As Long, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Dim uState          As HashState
   
    Init uState, lBitSize
    Absorb uState, baInput, Pos, Size
    Squeeze uState, baOutput, lOutSize, &H1F
End Sub

Here is a sample usage of the hash function with some test vectors from here.

Code:

Option Explicit

Private Sub Form_Load()
    Dim baInput()      As Byte
    Dim baHash()        As Byte
   
    baInput = StrConv("abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu", vbFromUnicode)
    CryptoSHA3 224, baHash, baInput
    Debug.Print ToHex(baHash)
    '-> 543e6868e1666c1a643630df77367ae5a62a85070a51c14cbf665cbc
   
    CryptoSHA3 256, baHash, baInput
    Debug.Print ToHex(baHash)
    '-> 916f6061fe879741ca6469b43971dfdb28b1a32dc36cb3254e812be27aad1d18
   
    CryptoSHA3 384, baHash, baInput
    Debug.Print ToHex(baHash)
    '-> 79407d3b5916b59c3e30b09822974791c313fb9ecc849e406f23592d04f625dc8c709b98b43b3852b337216179aa7fc7
   
    CryptoSHA3 512, baHash, baInput
    Debug.Print ToHex(baHash)
    '-> afebb2ef542e6579c50cad06d2e578f9f8dd6881d7dc824d26360feebf18a4fa73e3261122948efcfd492e74e82e2189ed0fb440d187f382270cb455f21dd185
   
    CryptoShake 128, baHash, 32, baInput, Size:=0
    Debug.Print ToHex(baHash)
    '-> 7f9c2ba4e88f827d616045507605853ed73b8093f6efbc88eb1a6eacfa66ef26
   
    CryptoShake 256, baHash, 64, baInput, Size:=0
    Debug.Print ToHex(baHash)
    '-> 46b9dd2b0ba88d13233b3feb743eeb243fcd52ea62b81b82b50c27646ed5762fd75dc4ddd8c0f200cb05019d67b592f6fc821c49479ab48640292eacb3b7c4be
End Sub

Public Function ToHex(baText() As Byte, Optional Delimiter As String) As String
    Dim aText()        As String
    Dim lIdx            As Long
   
    If LenB(CStr(baText)) <> 0 Then
        ReDim aText(0 To UBound(baText)) As String
        For lIdx = 0 To UBound(baText)
            aText(lIdx) = Right$("0" & Hex$(baText(lIdx)), 2)
        Next
        ToHex = LCase$(Join(aText, Delimiter))
    End If
End Function

Public Function FromHex(sText As String) As Byte()
    Dim baRetVal()      As Byte
    Dim lIdx            As Long
   
    On Error GoTo QH
    '--- check for hexdump delimiter
    If sText Like "*[!0-9A-Fa-f]*" Then
        ReDim baRetVal(0 To Len(sText) \ 3) As Byte
        For lIdx = 1 To Len(sText) Step 3
            baRetVal(lIdx \ 3) = "&H" & Mid$(sText, lIdx, 2)
        Next
    ElseIf LenB(sText) <> 0 Then
        ReDim baRetVal(0 To Len(sText) \ 2 - 1) As Byte
        For lIdx = 1 To Len(sText) Step 2
            baRetVal(lIdx \ 2) = "&H" & Mid$(sText, lIdx, 2)
        Next
    Else
        baRetVal = vbNullString
    End If
    FromHex = baRetVal
QH:
End Function

cheers,
</wqw>

[VB6/VBA] SHA-3 pure VB implementation incl. HMAC

$
0
0
This mdSha3.bas module includes CryptoSha3 function that can be used to calculate SHA-3 hash in all bit-sizes: SHA3-224, SHA3-256, SHA3-384 and SHA3-512.

The module also includes CryptoKeccak function which calculates the legacy Keccak hash as it was implemented before being accepted as SHA-3 officially, CryptoShake function for SHAKE-128, SHAKE-256 and SHAKE-512 which can produce hashes in arbitrary output length and CryptoHmacSha3 function for HMAC construction with SHA-3 which is tested with hmac_sha3_256_test.json and the rest test vectors for HMAC-SHA3 from Project Wycheproof repo.

Under 32-bit VB6/VBA this module uses VT_I8 Variants for the 64-bit arithmetic in Keccak sponge permutation function so it's not the fastest hasher on the block, one might expect performance around the 1MB/s mark when compiled.

All the public functions could be used with other non-standard bit-sizes but do this on your own risk only.

Code:

'--- mdSha3.bas
Option Explicit
DefObj A-Z

#Const HasPtrSafe = (VBA7 <> 0) Or (TWINBASIC <> 0)
#Const LargeAddressAware = (Win64 = 0 And VBA7 = 0 And VBA6 = 0 And VBA5 = 0)

#If Win64 Then
    Private Const PTR_SIZE                  As Long = 8
#Else
    Private Const PTR_SIZE                  As Long = 4
    Private Const SIGN_BIT                  As Long = &H80000000
#End If

#If HasPtrSafe Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function ArrPtr Lib "vbe7" Alias "VarPtr" (Ptr() As Any) As LongPtr
Private Declare PtrSafe Function VariantChangeType Lib "oleaut32" (Dest As Variant, Src As Variant, ByVal wFlags As Integer, ByVal vt As VbVarType) As Long
#Else
Private Enum LongPtr
    [_]
End Enum
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As LongPtr
Private Declare Function VariantChangeType Lib "oleaut32" (Dest As Variant, Src As Variant, ByVal wFlags As Integer, ByVal vt As VbVarType) As Long
#End If

Private Type SAFEARRAY1D
    cDims              As Integer
    fFeatures          As Integer
    cbElements          As Long
    cLocks              As Long
    pvData              As LongPtr
    cElements          As Long
    lLbound            As Long
End Type

Private Const LNG_ROUNDS            As Long = 24
Private Const LNG_SPONGE_WORDS      As Long = 25

#If Win64 Then
    Private LNG_POW2(0 To 63)      As LongLong
    Private LNG_ROUND_C(0 To 23)    As LongLong
#Else
    Private LNG_POW2(0 To 63)      As Variant
    Private LNG_ROUND_C(0 To 23)    As Variant
#End If

Private Type HashState
    DigestSize      As Long
    Capacity        As Long
    Absorbed        As Long
    #If Win64 Then
        Words(0 To LNG_SPONGE_WORDS - 1) As LongLong
    #Else
        Words(0 To LNG_SPONGE_WORDS - 1) As Variant
    #End If
    Bytes()        As Byte
    PeekArray      As SAFEARRAY1D
End Type

#If Win64 Then
Private Function ROTL64(ByVal lX As LongLong, ByVal lN As Long) As LongLong
#Else
Private Function ROTL64(lX As Variant, ByVal lN As Long) As Variant
#End If
    '--- ROTL64 = LShift(X, n) Or RShift(X, 64 - n)
    Debug.Assert lN <> 0
    ROTL64 = ((lX And (LNG_POW2(63 - lN) - 1)) * LNG_POW2(lN) Or -((lX And LNG_POW2(63 - lN)) <> 0) * LNG_POW2(63)) Or _
        ((lX And (LNG_POW2(63) Xor -1)) \ LNG_POW2(64 - lN) Or -(lX < 0) * LNG_POW2(lN - 1))
End Function

Private Sub Keccak(uState As HashState)
    #If Win64 Then
        Static C(0 To 4) As LongLong
        Dim vTemp      As LongLong
        Dim aTemp()    As LongLong
    #Else
        Static C(0 To 4) As Variant
        Dim vTemp      As Variant
        Dim aTemp()    As Variant
    #End If
    Dim lRound          As Long
    Dim lIdx            As Long
    Dim lJdx            As Long
   
    With uState
    For lRound = 0 To LNG_ROUNDS - 1
        '--- Theta
        For lIdx = 0 To 4
            C(lIdx) = .Words(lIdx) Xor .Words(lIdx + 5) Xor .Words(lIdx + 10) Xor .Words(lIdx + 15) Xor .Words(lIdx + 20)
        Next
        For lIdx = 0 To 4
            vTemp = C((lIdx + 4) Mod 5) Xor ROTL64(C((lIdx + 1) Mod 5), 1)
            For lJdx = 0 To 24 Step 5
                .Words(lIdx + lJdx) = .Words(lIdx + lJdx) Xor vTemp
            Next
        Next
        '--- Rho & Pi
        aTemp = .Words
        .Words(10) = ROTL64(aTemp(1), 1)
        .Words(20) = ROTL64(aTemp(2), 62)
        .Words(5) = ROTL64(aTemp(3), 28)
        .Words(15) = ROTL64(aTemp(4), 27)
        .Words(16) = ROTL64(aTemp(5), 36)
        .Words(1) = ROTL64(aTemp(6), 44)
        .Words(11) = ROTL64(aTemp(7), 6)
        .Words(21) = ROTL64(aTemp(8), 55)
        .Words(6) = ROTL64(aTemp(9), 20)
        .Words(7) = ROTL64(aTemp(10), 3)
        .Words(17) = ROTL64(aTemp(11), 10)
        .Words(2) = ROTL64(aTemp(12), 43)
        .Words(12) = ROTL64(aTemp(13), 25)
        .Words(22) = ROTL64(aTemp(14), 39)
        .Words(23) = ROTL64(aTemp(15), 41)
        .Words(8) = ROTL64(aTemp(16), 45)
        .Words(18) = ROTL64(aTemp(17), 15)
        .Words(3) = ROTL64(aTemp(18), 21)
        .Words(13) = ROTL64(aTemp(19), 8)
        .Words(14) = ROTL64(aTemp(20), 18)
        .Words(24) = ROTL64(aTemp(21), 2)
        .Words(9) = ROTL64(aTemp(22), 61)
        .Words(19) = ROTL64(aTemp(23), 56)
        .Words(4) = ROTL64(aTemp(24), 14)
        '--- Chi
        For lJdx = 0 To 24 Step 5
            For lIdx = 0 To 4
                C(lIdx) = .Words(lIdx + lJdx)
            Next
            For lIdx = 0 To 4
                .Words(lIdx + lJdx) = .Words(lIdx + lJdx) Xor (Not C((lIdx + 1) Mod 5) And C((lIdx + 2) Mod 5))
            Next
        Next
        '--- Iota
        .Words(0) = .Words(0) Xor LNG_ROUND_C(lRound)
    Next
    End With
End Sub

Private Sub Absorb(uState As HashState, baBuffer() As Byte, ByVal lPos As Long, ByVal lSize As Long)
    Dim lIdx            As Long
    Dim lOffset        As Long
   
    If lSize < 0 Then
        lSize = UBound(baBuffer) + 1
    End If
    With uState
        lOffset = PeekByte(uState, .Absorbed)
        For lIdx = lPos To lSize - lPos - 1
            .Bytes(lOffset) = .Bytes(lOffset) Xor baBuffer(lIdx)
            If .Absorbed = .Capacity - 1 Then
                Keccak uState
                .Absorbed = 0
            Else
                .Absorbed = .Absorbed + 1
            End If
            #If Win64 Then
                lOffset = lOffset + 1
            #Else
                If lOffset = 7 Then
                    lOffset = PeekByte(uState, .Absorbed)
                Else
                    lOffset = lOffset + 1
                End If
            #End If
        Next
    End With
End Sub

Private Sub Squeeze(uState As HashState, baOutput() As Byte, ByVal lOutSize As Long, ByVal lLFSR As Long)
    Dim lIdx            As Long
    Dim lOffset        As Long
    Dim uEmpty          As HashState
   
    With uState
        ReDim baOutput(0 To lOutSize - 1) As Byte
        lOffset = PeekByte(uState, .Absorbed)
        .Bytes(lOffset) = .Bytes(lOffset) Xor lLFSR
        lOffset = PeekByte(uState, .Capacity - 1)
        .Bytes(lOffset) = .Bytes(lOffset) Xor &H80
        lOffset = PeekByte(uState, 0)
        For lIdx = 0 To UBound(baOutput)
            If lIdx Mod .Capacity = 0 Then
                Keccak uState
            End If
            baOutput(lIdx) = .Bytes(lOffset)
            #If Win64 Then
                lOffset = lOffset + 1
            #Else
                If lOffset = 7 Then
                    lOffset = PeekByte(uState, lIdx + 1)
                Else
                    lOffset = lOffset + 1
                End If
            #End If
        Next
    End With
    uState = uEmpty
End Sub

Private Sub Init(uState As HashState, ByVal lBitSize As Long)
    Dim lIdx            As Long
    Dim vElem          As Variant
   
    If LNG_POW2(0) = 0 Then
        LNG_POW2(0) = CLngLng(1)
        For lIdx = 1 To 63
            LNG_POW2(lIdx) = CVar(LNG_POW2(lIdx - 1)) * 2
        Next
        lIdx = 0
        For Each vElem In Split("1 8082 800000000000808A 8000000080008000 808B 80000001 8000000080008081 8000000000008009 8A 88 80008009 8000000A 8000808B 800000000000008B 8000000000008089 8000000000008003 8000000000008002 8000000000000080 800A 800000008000000A 8000000080008081 8000000000008080 80000001 8000000080008008")
            LNG_ROUND_C(lIdx) = CLngLng(CStr("&H" & vElem))
            #If Win64 Then
                Debug.Assert Hex(LNG_ROUND_C(lIdx)) = vElem
            #End If
            lIdx = lIdx + 1
        Next
    End If
    With uState
        .DigestSize = (lBitSize + 7) \ 8
        .Capacity = LNG_SPONGE_WORDS * 8 - 2 * .DigestSize
        .Words(0) = CLngLng(0)
        For lIdx = 1 To UBound(.Words)
            .Words(lIdx) = .Words(0)
        Next
        If .PeekArray.cDims = 0 Then
            With .PeekArray
                .cDims = 1
                .fFeatures = 1 ' FADF_AUTO
                .cbElements = 1
                .cLocks = 1
                #If Win64 Then
                    .pvData = VarPtr(uState.Words(0))
                    .cElements = LNG_SPONGE_WORDS * 8
                #Else
                    .cElements = 8
                #End If
            End With
            Call CopyMemory(ByVal ArrPtr(.Bytes), VarPtr(.PeekArray), PTR_SIZE)
        End If
    End With
End Sub

#If Win64 Then
    Private Function PeekByte(uState As HashState, ByVal lOffset As Long) As Long
        PeekByte = lOffset
    End Function
#Else
    Private Function PeekByte(uState As HashState, ByVal lOffset As Long) As Long
        #If LargeAddressAware Then
            uState.PeekArray.pvData = (VarPtr(uState.Words(lOffset \ 8)) Xor SIGN_BIT) + 8 Xor SIGN_BIT
        #Else
            uState.PeekArray.pvData = VarPtr(uState.Words(lOffset \ 8)) + 8
        #End If
        PeekByte = lOffset Mod 8
    End Function
   
    Private Function CLngLng(vValue As Variant) As Variant
        Const VT_I8 As Long = &H14
        Call VariantChangeType(CLngLng, vValue, 0, VT_I8)
    End Function
#End If

Public Sub CryptoSha3(ByVal lBitSize As Long, baOutput() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Dim uState          As HashState
   
    Init uState, lBitSize
    Absorb uState, baInput, Pos, Size
    Squeeze uState, baOutput, uState.DigestSize, &H6
End Sub

Public Sub CryptoKeccak(ByVal lBitSize As Long, baOutput() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Dim uState          As HashState
   
    Init uState, lBitSize
    Absorb uState, baInput, Pos, Size
    Squeeze uState, baOutput, uState.DigestSize, &H1
End Sub

Public Sub CryptoShake(ByVal lBitSize As Long, baOutput() As Byte, ByVal lOutSize As Long, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Dim uState          As HashState
   
    Init uState, lBitSize
    Absorb uState, baInput, Pos, Size
    Squeeze uState, baOutput, lOutSize, &H1F
End Sub

Public Sub CryptoHmacSha3(ByVal lBitSize As Long, baOutput() As Byte, baKey() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Const INNER_PAD    As Long = &H36
    Const OUTER_PAD    As Long = &H5C
    Dim lPadSize        As Long
    Dim lIdx            As Long
    Dim baPass()        As Byte
    Dim baPad()        As Byte
    Dim baHash()        As Byte
   
    '--- pad size is equal to sponge capacity
    lPadSize = LNG_SPONGE_WORDS * 8 - 2 * ((lBitSize + 7) \ 8)
    If UBound(baKey) < lPadSize Then
        baPass = baKey
    Else
        CryptoSha3 lBitSize, baPass, baKey
    End If
    If Size < 0 Then
        Size = UBound(baInput) + 1
    End If
    ReDim baPad(0 To Size + lPadSize - 1) As Byte
    For lIdx = 0 To UBound(baPass)
        baPad(lIdx) = baPass(lIdx) Xor INNER_PAD
    Next
    For lIdx = lIdx To lPadSize - 1
        baPad(lIdx) = INNER_PAD
    Next
    For lIdx = 0 To Size - Pos - 1
        baPad(lPadSize + lIdx) = baInput(Pos + lIdx)
    Next
    CryptoSha3 lBitSize, baHash, baPad
    Size = UBound(baHash) + 1
    ReDim baPad(0 To Size + lPadSize - 1) As Byte
    For lIdx = 0 To UBound(baPass)
        baPad(lIdx) = baPass(lIdx) Xor OUTER_PAD
    Next
    For lIdx = lIdx To lPadSize - 1
        baPad(lIdx) = OUTER_PAD
    Next
    For lIdx = 0 To Size - 1
        baPad(lPadSize + lIdx) = baHash(lIdx)
    Next
    CryptoSha3 lBitSize, baOutput, baPad
End Sub

Here is a sample usage of the hash function with some test vectors from here.

Code:

'--- Form1.frm
Option Explicit

Private Sub Form_Load()
    Dim baInput()      As Byte
    Dim baHash()        As Byte
   
    baInput = StrConv("abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu", vbFromUnicode)
    CryptoSha3 224, baHash, baInput
    Debug.Print ToHex(baHash)
    '-> 543e6868e1666c1a643630df77367ae5a62a85070a51c14cbf665cbc
   
    CryptoSha3 256, baHash, baInput
    Debug.Print ToHex(baHash)
    '-> 916f6061fe879741ca6469b43971dfdb28b1a32dc36cb3254e812be27aad1d18
   
    CryptoSha3 384, baHash, baInput
    Debug.Print ToHex(baHash)
    '-> 79407d3b5916b59c3e30b09822974791c313fb9ecc849e406f23592d04f625dc8c709b98b43b3852b337216179aa7fc7
   
    CryptoSha3 512, baHash, baInput
    Debug.Print ToHex(baHash)
    '-> afebb2ef542e6579c50cad06d2e578f9f8dd6881d7dc824d26360feebf18a4fa73e3261122948efcfd492e74e82e2189ed0fb440d187f382270cb455f21dd185
   
    CryptoShake 128, baHash, 32, baInput, Size:=0
    Debug.Print ToHex(baHash)
    '-> 7f9c2ba4e88f827d616045507605853ed73b8093f6efbc88eb1a6eacfa66ef26
   
    CryptoShake 256, baHash, 64, baInput, Size:=0
    Debug.Print ToHex(baHash)
    '-> 46b9dd2b0ba88d13233b3feb743eeb243fcd52ea62b81b82b50c27646ed5762fd75dc4ddd8c0f200cb05019d67b592f6fc821c49479ab48640292eacb3b7c4be
End Sub

Public Function ToHex(baText() As Byte, Optional Delimiter As String) As String
    Dim aText()        As String
    Dim lIdx            As Long
   
    If LenB(CStr(baText)) <> 0 Then
        ReDim aText(0 To UBound(baText)) As String
        For lIdx = 0 To UBound(baText)
            aText(lIdx) = Right$("0" & Hex$(baText(lIdx)), 2)
        Next
        ToHex = LCase$(Join(aText, Delimiter))
    End If
End Function

cheers,
</wqw>

Here's how to reference the same variable in 2 different ways.

$
0
0
This is similar to the way a union works in C or C++. It works by applying custom settings to a SAFEARRAY structure (aka safe array descriptor). I've done a lot of commenting on the code, so others can see exactly how it works.

Below is the code for the module, which contains the Windows API declarations part of the program.
Code:

Public Declare Sub PutMem4 Lib "msvbvm60.dll" (ByRef Destination As Any, ByVal Source As Long)
Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef ptr() As Any) As Long

Public Type SAFEARRAYBOUND
    NumberOfElements As Long
    FirstElementIndex As Long
End Type

Public Type SAFEARRAY
    VariantType As Long 'This is actually at offset = -4 in the structure.
    cDims As Integer 'THIS is the official start of the structure (offset = 0).
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Dim1Info As SAFEARRAYBOUND
End Type


And here's the code for Form1. It contains the body of the program's code.
Code:

Private Sub Form_Load()
    Dim MyLong As Long
    Dim MyArrayDescriptor As SAFEARRAY
    Dim ptrMyArrayDescriptor() As Byte
   
    'Set up the array descriptor so that the array will be a bytewise representation of the MyLong variable.
    With MyArrayDescriptor
        .VariantType = vbByte 'Data type is byte, and this is how the program would set it if using Redim to initialize the array, though programs written in VB6 actually ignore this field when reading the structure, and instead use the type originally set in the Dim statement when defining the array variable.
        .cDims = 1 'Number of dimensions.
        .cbElements = 1 'Number of bytes per element.
        .fFeatures = &H80 'Tell it to use the VariantType field, though this is actually ignored when VB6 programs read the descriptor in VB6 programs. I just set it like this because this is how VB6 programs set it as well if using Redim to initialize the array.
        .Dim1Info.NumberOfElements = 4
        .pvData = VarPtr(MyLong) 'This makes the array refer to the same location in memory as the MyLong variable.
    End With
   
   
    'Activate the array descriptor by pointing the ptrMyArrayDescriptor variable to the actual array descriptor.
    PutMem4 ByVal VarPtrArray(ptrMyArrayDescriptor), VarPtr(MyArrayDescriptor.cDims)
   
    'Set the MyLong variable to a large value that covers all 4 of its bytes.
    MyLong = &H12345678
   
    'Indepndantly print the value of each of the variable's 4 bytes, in hexadecimal format.
    Print Hex$(ptrMyArrayDescriptor(3))
    Print Hex$(ptrMyArrayDescriptor(2))
    Print Hex$(ptrMyArrayDescriptor(1))
    Print Hex$(ptrMyArrayDescriptor(0))
   
   
    PutMem4 ByVal VarPtrArray(ptrMyArrayDescriptor), 0
    'This last line of code deactivates the pointer to the safe array descriptor, by setting the pointer to 0.
    'This is needed to prevent the program from automatically attempting to deallocate both the descriptor and array content from memory.
    'VB6 automatically inserts code after the end of each function to clean up memory, by deallocating arrays that have gone out of scope.
    'This is normally good. As normally these would be allocated to the heap, or other system assigned memory location, when using Windows API functions to create a safe array.
    'However in this example, this memory is allocated to the stack by the variables called MyLong and MyArrayDescriptor.
    'The result is that the automatic array cleanup could corrupt the stack. Therefore manually setting this pointer to 0 is needed.
    'The stack itself is cleaned up when the function ends.
    'In fact, if the stack got corrupted as previously mentioned, the stack cleanup would likely make the program unstable or even crash immediately.
End Sub

Note that you need to set the AutoRedraw property of Form1 to True, in order for the output text to actually display (otherwise it gets cleared before the form displays on the screen).

If you have everything set up correctly, when you run the program you should see these 4 lines of text printed on the form.
Quote:

12
34
56
78

Large arrays (when arrays don't fit in memory)

$
0
0
Sometimes we need to store a lot of data in memory, but we find two restrictions:

1) VB6, as any 32 bits process, has a limit of using 2 GB RAM. It can be extended to 4 GB setting LARGEADDRESSAWARE but no more than that.

2) Some arrays (most) need to have available contiguous memory, and you usually hit that limit around 700 MB.

Here is a set of classes that use File Mapping.
It uses the name "File" but we are using it to create memory "files", to be able to use RAM memory outside our local 2 GB of our process.

This project is somewhat based in a very related project by Elroy. Thank you Elroy.

These classes can replace normal arrays with some code modifications.
Of course they are quite slower than normal arrays, but you can store a lot more data.
Sometimes it is not about surpassing the 700 MB or the 2 GB limits, but you may want to take out of the local memory some arrays to make room for other RAM consuming data that you need to handle in your in-process memory.

In this version there are 6 classes, that were the ones that I needed :cool:, but it is not difficult to add a new type not currently supported (such as Double or Boolean). If you need them you could modify the code from for example cLargeArrayDat.
Pay special attention to the Const cItemSizeBytes, it must the the size in memory of the data type in bytes. Also change all "As Date" to "As Boolean" (for example).

cLargeArrayLng.cls: Array of Long
cLargeArrayVar.cls Array of Variant
cLargeArrayDat.cls Array of Date
cLargeArrayUdt.cls Array of UDT
cLargeArrayStrFix.cls Array of Fixed size String
cLargeArrayStr.cls Array of variable size String

How to use them? for example:

Code:

    Dim MyLargeArrayDat As cLargeArrayDat
   
    Set MyLargeArrayDat = New cLargeArrayDat
    MyLargeArrayDat.ReDimArray 10000000
    MyLargeArrayDat(1000) = Now
    MyLargeArrayDat.ReDimPreserve 20000000
    Debug.Print MyLargeArrayDat(1000), MyLargeArrayDat(20000000)

All can be accessed like they were true arrays because the Item property was set to be the default property, with the exception of the UDT one, that VB6 does not allow to make Public properties of UDT and then I had to make it Friend, but doing so I lost the ability to set it as default, so for the UDT you need to access the elements like MylarArrayUDT.Item(1000).

Also regarding UDT. You can't access members of directly as with normal arrays, I mean:

Code:

    MyLargeArrayUDT.Item(100).Field1 = 5
    MyLargeArrayUDT.Item(100).Field2 = True

will not work, you need to copy the UDT to a temporary local variable and make the changes there, and then assign it to the large array again, like this:

Code:

    Dim TempVarMyUDT As MyUDT
   
    TempVarMyUDT = MyLargeArrayUDT.Item(100)
    TempVarMyUDT.Field1 = 5
    TempVarMyUDT.Field2 = True
    MyLargeArrayUDT.Item(100) = TempVarMyUDT

Also you will have to change all MyUDT occurrences to the actual name of your UDT.

For the cLargeArrayStrFix, you need to provide the string length at the time you first call ReDimArray.
Optionally you can change it at the ReDimPreserve or if the the first Redim is a ReDimPreserve it is then required.

The cLargeArrayStr does not allocate memory for all elements upfront because the elements lengths are variable, but it increases the memory size as needed.
When an element changes, it stores a new element at the end, and the space of the old element no longer in use is not reused. In other words: the FileMap always grows in size, it does not matter additions or modifications, they are all additions (regarding map size).

That worked well for my case because I didn't need to modify the strings once stored, but the code could be modified to reuse old string space when the new string is the same size or smaller than the old one.

Anyway there is a function ConsolitareRAM that can be used to get rid of all memory "holes" at once (the old, unused string spaces). But it takes some time to run.

The cLargeArrayStr by default also uses some local process memory, because it needs to keep the size and positions of all strings in the FileMap, so it has a couple of VB6 arrays to store that data.
But when these arrays grow too much and can no longer allocate space for them in the local memory, then it starts to use instead a cLargeArrayVar and a cLargeArrayLng to store that data. But then the operations become slower.
That is handled automatically, but it also provides a property LocalMemMode for the mode to be set explicitly.

In the RedimArray and RedimPreserve methods of all classes, there is a parameter nErrorModeSilent.
By default it is False. When there is not enough memory available then a normal error will be risen.
But if set to True, no error is risen when the operation failed and then you need to check the ErrorOnCreateMap property to know whether the operation was successful or not.

They have a property MapName that is not currently used by this code but that could be used to know the map name and be able to open the array from other process.
Attached Files

[VB6/VBA] X25519 for ECDH key exchange and Ed25519 for EdDSA signatures

$
0
0
This mdCurve25519.bas module implements X25519 key exchange and Ed25519 signatures in pure VB6.

EdDSA signatures use SHA-512 hashes internally so you'll need mdSha512.bas from this thread included in your project and CRYPT_HAS_SHA512 = 1 declared in conditional compilation for the CryptoEd25519Sign and CryptoEd25519Open functions to use CryptoSha512 routine from there.

Implementing X25519 key exchange with CryptoX25519PrivateKey, CryptoX25519PublicKey and CryptoX25519SharedSecret routines can be done without SHA-512 or any other source dependency.

Code:

'--- mdCurve25519.bas
Option Explicit
DefObj A-Z

#Const HasPtrSafe = (VBA7 <> 0) Or (TWINBASIC <> 0)
#Const HasSha512 = (CRYPT_HAS_SHA512 <> 0)

#If HasPtrSafe Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength As Long) As Long
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VariantChangeType Lib "oleaut32" (Dest As Variant, Src As Variant, ByVal wFlags As Integer, ByVal vt As VbVarType) As Long
Private Declare Function RtlGenRandom Lib "advapi32" Alias "SystemFunction036" (RandomBuffer As Any, ByVal RandomBufferLength As Long) As Long
#End If

Private Const LNG_ELEMSZ            As Long = 16
Private Const LNG_KEYSZ            As Long = 32
Private Const LNG_HASHSZ            As Long = 64 '--- SHA-512
Private Const LNG_HALFHASHSZ        As Long = LNG_HASHSZ \ 2
Private Const LNG_POW16            As Long = 2 ^ 16

#If HasPtrSafe Then
    Private m_lZero            As LongLong
#Else
    Private m_lZero            As Variant
#End If
Private LNG_POW2(0 To 7)        As Long
Private EmptyByteArray()        As Byte
Private m_uGf0                  As FieldElement
Private m_uGf1                  As FieldElement
Private m_uGfD                  As FieldElement
Private m_uGfD2                As FieldElement
Private m_uGfX                  As FieldElement
Private m_uGfY                  As FieldElement
Private m_uGfI                  As FieldElement
Private m_aL(0 To 63)          As Byte

Private Type FieldElement
#If HasPtrSafe Then
    Item(0 To LNG_ELEMSZ - 1) As LongLong
#Else
    Item(0 To LNG_ELEMSZ - 1) As Variant
#End If
End Type

Private Type XyztPoint
    Item(0 To 3)            As FieldElement
End Type

Private Type Array64
#If HasPtrSafe Then
    Item(0 To 63)          As LongLong
#Else
    Item(0 To 63)          As Variant
#End If
End Type

#If Not HasPtrSafe Then
    Private Function CLngLng(vValue As Variant) As Variant
        Const VT_I8 As Long = &H14
        Call VariantChangeType(CLngLng, vValue, 0, VT_I8)
    End Function
#End If

Private Sub pvInit()
    Dim lIdx            As Long
    Dim vElem          As Variant
   
    If LNG_POW2(0) = 0 Then
        LNG_POW2(0) = 1
        For lIdx = 1 To UBound(LNG_POW2)
            LNG_POW2(lIdx) = LNG_POW2(lIdx - 1) * 2
        Next
        EmptyByteArray = vbNullString
        m_lZero = CLngLng(0)
    End If
    If m_uGf1.Item(0) = 0 Then
        pvCurveAssign m_uGf0, "0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0"
        pvCurveAssign m_uGf1, "1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0"
        pvCurveAssign m_uGfD, "78A3 1359 4DCA 75EB D8AB 4141 0A4D 0070 E898 7779 4079 8CC7 FE73 2B6F 6CEE 5203"
        pvCurveAssign m_uGfD2, "F159 26B2 9B94 EBD6 B156 8283 149A 00E0 D130 EEF3 80F2 198E FCE7 56DF D9DC 2406"
        pvCurveAssign m_uGfX, "D51A 8F25 2D60 C956 A7B2 9525 C760 692C DC5C FDD6 E231 C0A4 53FE CD6E 36D3 2169"
        pvCurveAssign m_uGfY, "6658 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666 6666"
        pvCurveAssign m_uGfI, "A0B0 4A0E 1B27 C4EE E478 AD2F 1806 2F43 D7A7 3DFB 0099 2B4D DF0B 4FC1 2480 2B83"
        lIdx = 0
        For Each vElem In Split("ED D3 F5 5C 1A 63 12 58 D6 9C F7 A2 DE F9 DE 14 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10")
            m_aL(lIdx) = CByte("&H" & vElem)
            lIdx = lIdx + 1
        Next
    End If
End Sub

Private Sub pvCurveSel(uA As FieldElement, uB As FieldElement, ByVal bSwap As Boolean)
    Dim lIdx            As Long
#If HasPtrSafe Then
    Dim lTemp          As LongLong
#Else
    Dim lTemp          As Variant
#End If
   
    For lIdx = 0 To LNG_ELEMSZ - 1
        lTemp = (uA.Item(lIdx) Xor uB.Item(lIdx)) And bSwap
        uA.Item(lIdx) = uA.Item(lIdx) Xor lTemp
        uB.Item(lIdx) = uB.Item(lIdx) Xor lTemp
    Next
End Sub

Private Sub pvCurveCar(uRetVal As FieldElement)
    Dim lIdx            As Long
    Dim lNext          As Long
#If HasPtrSafe Then
    Dim lCarry          As LongLong
#Else
    Dim lCarry          As Variant
#End If
   
    For lIdx = 0 To LNG_ELEMSZ - 1
        uRetVal.Item(lIdx) = uRetVal.Item(lIdx) + LNG_POW16
        lCarry = (uRetVal.Item(lIdx) And -LNG_POW16) \ LNG_POW16
        uRetVal.Item(lIdx) = uRetVal.Item(lIdx) - lCarry * LNG_POW16
        If lIdx = LNG_ELEMSZ - 1 Then
            lCarry = 38 * (lCarry - 1)
        Else
            lCarry = lCarry - 1
        End If
        lNext = (lIdx + 1) Mod LNG_ELEMSZ
        uRetVal.Item(lNext) = uRetVal.Item(lNext) + lCarry
    Next
End Sub

Private Sub pvCurveAdd(uRetVal As FieldElement, uA As FieldElement, uB As FieldElement)
    Dim lIdx            As Long
   
    For lIdx = 0 To LNG_ELEMSZ - 1
        uRetVal.Item(lIdx) = uA.Item(lIdx) + uB.Item(lIdx)
    Next
End Sub

Private Sub pvCurveSub(uRetVal As FieldElement, uA As FieldElement, uB As FieldElement)
    Dim lIdx            As Long
   
    For lIdx = 0 To LNG_ELEMSZ - 1
        uRetVal.Item(lIdx) = uA.Item(lIdx) - uB.Item(lIdx)
    Next
End Sub

Private Sub pvCurveMul(uRetVal As FieldElement, uA As FieldElement, uB As FieldElement)
#If HasPtrSafe Then
    Static aTemp(0 To LNG_ELEMSZ * 2 - 1) As LongLong
#Else
    Static aTemp(0 To LNG_ELEMSZ * 2 - 1) As Variant
#End If
    Dim lIdx            As Long
    Dim lJdx            As Long
   
    For lIdx = 0 To UBound(aTemp)
        aTemp(lIdx) = CLng(0)
    Next
    For lIdx = 0 To LNG_ELEMSZ - 1
        For lJdx = 0 To LNG_ELEMSZ - 1
            aTemp(lIdx + lJdx) = aTemp(lIdx + lJdx) + uA.Item(lIdx) * uB.Item(lJdx)
        Next
    Next
    For lIdx = 0 To LNG_ELEMSZ - 1
        If lIdx < LNG_ELEMSZ - 1 Then
            uRetVal.Item(lIdx) = aTemp(lIdx) + 38 * aTemp(lIdx + LNG_ELEMSZ)
        Else
            uRetVal.Item(lIdx) = aTemp(lIdx)
        End If
    Next
    pvCurveCar uRetVal
    pvCurveCar uRetVal
End Sub

Private Sub pvCurveSqr(uRetVal As FieldElement, uA As FieldElement)
    pvCurveMul uRetVal, uA, uA
End Sub

Private Sub pvCurveInv(uRetVal As FieldElement, uA As FieldElement)
    Dim uTemp          As FieldElement
    Dim lIdx            As Long
   
    uTemp = uA
    For lIdx = 253 To 0 Step -1
        pvCurveMul uTemp, uTemp, uTemp
        If lIdx <> 2 And lIdx <> 4 Then
            pvCurveMul uTemp, uTemp, uA
        End If
    Next
    uRetVal = uTemp
End Sub

Private Sub pvCurvePow2523(uRetVal As FieldElement, uA As FieldElement)
    Dim uTemp          As FieldElement
    Dim lIdx            As Long
   
    uTemp = uA
    For lIdx = 250 To 0 Step -1
        pvCurveSqr uTemp, uTemp
        If lIdx <> 1 Then
            pvCurveMul uTemp, uTemp, uA
        End If
    Next
    uRetVal = uTemp
End Sub

Private Function pvCurveNeq(uA As FieldElement, uB As FieldElement) As Boolean
    Dim baA()          As Byte
    Dim baB()          As Byte
    Dim lIdx            As Long
    Dim lAccum            As Long
   
    pvCurvePack baA, uA
    pvCurvePack baB, uB
    For lIdx = 0 To UBound(baA)
        lAccum = lAccum Or (baA(lIdx) Xor baB(lIdx))
    Next
    pvCurveNeq = lAccum <> 0
End Function

Private Sub pvCurveUnpack(uRetVal As FieldElement, baInput() As Byte)
    Dim aTemp(0 To LNG_ELEMSZ - 1) As Integer
    Dim lIdx            As Long

    If UBound(baInput) >= 0 Then
        Debug.Assert (UBound(aTemp) + 1) * 2 >= UBound(baInput) + 1
        Call CopyMemory(aTemp(0), baInput(0), UBound(baInput) + 1)
    End If
    For lIdx = 0 To LNG_ELEMSZ - 1
        If aTemp(lIdx) < 0 Then
            uRetVal.Item(lIdx) = m_lZero + LNG_POW16 + aTemp(lIdx)
        Else
            uRetVal.Item(lIdx) = m_lZero + aTemp(lIdx)
        End If
    Next
End Sub

Private Sub pvCurvePack(baRetVal() As Byte, uA As FieldElement)
    Dim lRetry          As Long
    Dim lIdx            As Long
    Dim uTemp          As FieldElement
    Dim lFlag          As Long
   
    ReDim baRetVal(0 To LNG_KEYSZ - 1) As Byte
    For lRetry = 0 To 1
        uTemp.Item(0) = uA.Item(0) - &HFFED&
        For lIdx = 1 To LNG_ELEMSZ - 1
            lFlag = -((uTemp.Item(lIdx - 1) And LNG_POW16) <> 0)
            If lIdx = LNG_ELEMSZ - 1 Then
                lFlag = &H7FFF& + lFlag
            Else
                lFlag = &HFFFF& + lFlag
            End If
            uTemp.Item(lIdx) = uA.Item(lIdx) - lFlag
            uTemp.Item(lIdx - 1) = uTemp.Item(lIdx - 1) And &HFFFF&
        Next
        lFlag = -((uTemp.Item(LNG_ELEMSZ - 1) And LNG_POW16) <> 0)
        pvCurveSel uA, uTemp, lFlag = 0
    Next
    For lIdx = 0 To LNG_ELEMSZ - 1
        lFlag = CLng(uA.Item(lIdx) And LNG_POW16 - 1)
        Call CopyMemory(baRetVal(2 * lIdx), lFlag, 2)
    Next
End Sub

Private Sub pvCurveClampKey(baPriv() As Byte)
    baPriv(0) = baPriv(0) And &HF8
    baPriv(31) = baPriv(31) And &H7F Or &H40
End Sub

Private Sub pvCurveAssign(uRetVal As FieldElement, sText As String)
    Dim vElem          As Variant
    Dim lIdx            As Long

    For Each vElem In Split(sText)
        uRetVal.Item(lIdx) = CLngLng(CStr("&H" & vElem))
        lIdx = lIdx + 1
    Next
End Sub

Private Sub pvCurveScalarMult(baRetVal() As Byte, baPriv() As Byte, baPub() As Byte)
    Dim baKey()        As Byte
    Dim uX              As FieldElement
    Dim uA              As FieldElement
    Dim uB              As FieldElement
    Dim uC              As FieldElement
    Dim uD              As FieldElement
    Dim uE              As FieldElement
    Dim uF              As FieldElement
    Dim uG              As FieldElement
    Dim lIdx            As Long
    Dim lFlag          As Long
    Dim lPrev          As Long
   
    baKey = baPriv
    pvCurveClampKey baKey
   
    pvCurveUnpack uA, EmptyByteArray
    pvCurveUnpack uX, baPub
    uB = uX
    uC = uA
    uD = uA
    uG = uA
    uG.Item(0) = uG.Item(0) + &HDB41&
    uG.Item(1) = uG.Item(1) + 1
    uA.Item(0) = uG.Item(1)        ' a[0] = 1
    uD.Item(0) = uG.Item(1)        ' d[0] = 1
   
    For lIdx = 254 To 0 Step -1
        lPrev = lFlag
        lFlag = (baKey(lIdx \ 8) \ LNG_POW2(lIdx And 7)) And 1
       
        pvCurveSel uA, uB, lFlag Xor lPrev
        pvCurveSel uC, uD, lFlag Xor lPrev
       
        pvCurveAdd uE, uA, uC  ' e = a + c
        pvCurveSub uA, uA, uC  ' a = a - c
       
        pvCurveAdd uC, uB, uD  ' c = b + d
        pvCurveSub uB, uB, uD  ' b = b - d
       
        pvCurveMul uD, uE, uE  ' d = e * e
        pvCurveMul uF, uA, uA  ' f = a * a
        pvCurveMul uA, uC, uA  ' a = c * a
        pvCurveMul uC, uB, uE  ' c = b * e
       
        pvCurveAdd uE, uA, uC  ' e = a + c
        pvCurveSub uA, uA, uC  ' a = a - c
       
        pvCurveMul uB, uA, uA  ' b = a * a
        pvCurveSub uC, uD, uF  ' c = d - f
       
        pvCurveMul uA, uC, uG  ' a = c * g
        pvCurveAdd uA, uA, uD  ' a = a + d
       
        pvCurveMul uC, uC, uA  ' c = c * a
        pvCurveMul uA, uD, uF  ' a = d * f
        pvCurveMul uD, uB, uX  ' d = b * x
        pvCurveMul uB, uE, uE  ' b = e * e
    Next
    pvCurveInv uC, uC
    pvCurveMul uX, uA, uC
    pvCurvePack baRetVal, uX
End Sub

Private Sub pvCurveScalarBase(baRetVal() As Byte, baPriv() As Byte)
    Dim baBase(0 To LNG_KEYSZ - 1) As Byte
   
    baBase(0) = 9
    pvCurveScalarMult baRetVal, baPriv, baBase
End Sub

Public Sub CryptoX25519PrivateKey(baRetVal() As Byte, Optional Seed As Variant)
    If Not IsMissing(Seed) Then
        baRetVal = Seed
        ReDim Preserve baRetVal(0 To LNG_KEYSZ - 1) As Byte
    Else
        ReDim baRetVal(0 To LNG_KEYSZ - 1) As Byte
        Call RtlGenRandom(baRetVal(0), UBound(baRetVal) + 1)
    End If
    pvCurveClampKey baRetVal
End Sub

Public Sub CryptoX25519PublicKey(baRetVal() As Byte, baPriv() As Byte)
    pvInit
    pvCurveScalarBase baRetVal, baPriv
End Sub

Public Sub CryptoX25519SharedSecret(baRetVal() As Byte, baPriv() As Byte, baPub() As Byte)
    pvInit
    pvCurveScalarMult baRetVal, baPriv, baPub
End Sub

'= XyztPoint =============================================================

Private Sub pvEdDsaAdd(uP As XyztPoint, uQ As XyztPoint)
    Dim uA              As FieldElement
    Dim uB              As FieldElement
    Dim uC              As FieldElement
    Dim uD              As FieldElement
    Dim uE              As FieldElement
    Dim uF              As FieldElement
    Dim uG              As FieldElement
    Dim uH              As FieldElement
    Dim uT              As FieldElement
   
    pvCurveSub uA, uP.Item(1), uP.Item(0)
    pvCurveSub uT, uQ.Item(1), uQ.Item(0)
    pvCurveMul uA, uA, uT
    pvCurveAdd uB, uP.Item(0), uP.Item(1)
    pvCurveAdd uT, uQ.Item(0), uQ.Item(1)
    pvCurveMul uB, uB, uT
    pvCurveMul uC, uP.Item(3), uQ.Item(3)
    pvCurveMul uC, uC, m_uGfD2
    pvCurveMul uD, uP.Item(2), uQ.Item(2)
    pvCurveAdd uD, uD, uD
    pvCurveSub uE, uB, uA
    pvCurveSub uF, uD, uC
    pvCurveAdd uG, uD, uC
    pvCurveAdd uH, uB, uA
    pvCurveMul uP.Item(0), uE, uF
    pvCurveMul uP.Item(1), uH, uG
    pvCurveMul uP.Item(2), uG, uF
    pvCurveMul uP.Item(3), uE, uH
End Sub

Private Sub pvEdDsaCSwap(uP As XyztPoint, uQ As XyztPoint, ByVal bSwap As Boolean)
    pvCurveSel uP.Item(0), uQ.Item(0), bSwap
    pvCurveSel uP.Item(1), uQ.Item(1), bSwap
    pvCurveSel uP.Item(2), uQ.Item(2), bSwap
    pvCurveSel uP.Item(3), uQ.Item(3), bSwap
End Sub

Private Sub pvEdDsaPack(baRetVal() As Byte, ByVal lOutPos As Long, uP As XyztPoint)
    Dim uTx            As FieldElement
    Dim uTy            As FieldElement
    Dim uZi            As FieldElement
    Dim baTemp()        As Byte
   
    pvCurveInv uZi, uP.Item(2)
    pvCurveMul uTx, uP.Item(0), uZi
    pvCurveMul uTy, uP.Item(1), uZi
    pvCurvePack baTemp, uTy
    Debug.Assert UBound(baRetVal) + 1 >= lOutPos + LNG_KEYSZ
    Call CopyMemory(baRetVal(lOutPos), baTemp(0), LNG_KEYSZ)
    pvCurvePack baTemp, uTx
    lOutPos = lOutPos + LNG_KEYSZ - 1
    baRetVal(lOutPos) = baRetVal(lOutPos) Xor ((baTemp(0) And 1) * &H80)
End Sub

Private Sub pvEdDsaScalarMult(uP As XyztPoint, uQ As XyztPoint, baKey() As Byte, Optional ByVal lPos As Long)
    Dim lIdx            As Long
    Dim lFlag          As Long
   
    pvInit
    uP.Item(0) = m_uGf0
    uP.Item(1) = m_uGf1
    uP.Item(2) = m_uGf1
    uP.Item(3) = m_uGf0
    For lIdx = 255 To 0 Step -1
        lFlag = (baKey(lPos + lIdx \ 8) \ LNG_POW2(lIdx And 7)) And 1
        pvEdDsaCSwap uP, uQ, lFlag
        pvEdDsaAdd uQ, uP
        pvEdDsaAdd uP, uP
        pvEdDsaCSwap uP, uQ, lFlag
    Next
End Sub

Private Sub pvEdDsaScalarBase(uP As XyztPoint, baKey() As Byte, Optional ByVal lPos As Long)
    Dim uQ              As XyztPoint
   
    uQ.Item(0) = m_uGfX
    uQ.Item(1) = m_uGfY
    uQ.Item(2) = m_uGf1
    pvCurveMul uQ.Item(3), m_uGfX, m_uGfY
    pvEdDsaScalarMult uP, uQ, baKey, lPos
End Sub

Private Sub pvEdDsaModL(aRetVal() As Byte, ByVal lOutPos As Long, uX As Array64)
#If HasPtrSafe Then
    Dim lCarry          As LongLong
#Else
    Dim lCarry          As Variant
#End If
    Dim lIdx            As Long
    Dim lJdx            As Long
   
    For lIdx = 63 To 32 Step -1
        lCarry = m_lZero
        For lJdx = lIdx - 32 To lIdx - 13
            uX.Item(lJdx) = uX.Item(lJdx) + lCarry - 16 * uX.Item(lIdx) * m_aL(lJdx - (lIdx - 32))
            lCarry = (uX.Item(lJdx) + 128 And -&H100) \ &H100
            uX.Item(lJdx) = uX.Item(lJdx) - lCarry * &H100
        Next
        uX.Item(lJdx) = uX.Item(lJdx) + lCarry
        uX.Item(lIdx) = 0
    Next
    lCarry = 0
    For lJdx = 0 To 31
        uX.Item(lJdx) = uX.Item(lJdx) + lCarry - ((uX.Item(31) And -&H10) \ &H10) * m_aL(lJdx)
        lCarry = (uX.Item(lJdx) And -&H100) \ &H100
        uX.Item(lJdx) = uX.Item(lJdx) And &HFF
    Next
    For lJdx = 0 To 31
        uX.Item(lJdx) = uX.Item(lJdx) - lCarry * m_aL(lJdx)
    Next
    For lIdx = 0 To 31
        uX.Item(lIdx + 1) = uX.Item(lIdx + 1) + ((uX.Item(lIdx) And -&H100) \ &H100)
        aRetVal(lOutPos + lIdx) = CByte(uX.Item(lIdx) And &HFF)
    Next
End Sub

Private Sub pvEdDsaReduce(aRetVal() As Byte)
    Dim uX              As Array64
    Dim lIdx            As Long
   
    For lIdx = 0 To 63
        uX.Item(lIdx) = m_lZero + aRetVal(lIdx)
        aRetVal(lIdx) = 0
    Next
    pvEdDsaModL aRetVal, 0, uX
End Sub

Private Function pvEdDsaUnpackNeg(uR As XyztPoint, baKey() As Byte) As Boolean
    Dim uT              As FieldElement
    Dim uChk            As FieldElement
    Dim uNum            As FieldElement
    Dim uDen            As FieldElement
    Dim uDen2          As FieldElement
    Dim uDen4          As FieldElement
    Dim uDen6          As FieldElement
    Dim baTemp()        As Byte
   
    uR.Item(2) = m_uGf1
    pvCurveUnpack uR.Item(1), baKey
    pvCurveSqr uNum, uR.Item(1)
    pvCurveMul uDen, uNum, m_uGfD
    pvCurveSub uNum, uNum, m_uGf1
    pvCurveAdd uDen, uDen, m_uGf1
    pvCurveSqr uDen2, uDen
    pvCurveSqr uDen4, uDen2
    pvCurveMul uDen6, uDen4, uDen2
    pvCurveMul uT, uDen6, uNum
    pvCurveMul uT, uT, uDen
    pvCurvePow2523 uT, uT
    pvCurveMul uT, uT, uNum
    pvCurveMul uT, uT, uDen
    pvCurveMul uT, uT, uDen
    pvCurveMul uR.Item(0), uT, uDen
    pvCurveSqr uChk, uR.Item(0)
    pvCurveMul uChk, uChk, uDen
    If pvCurveNeq(uChk, uNum) Then
        pvCurveMul uR.Item(0), uR.Item(0), m_uGfI
    End If
    pvCurveSqr uChk, uR.Item(0)
    pvCurveMul uChk, uChk, uDen
    If pvCurveNeq(uChk, uNum) Then
        GoTo QH
    End If
    pvCurvePack baTemp, uR.Item(0)
    If (baTemp(0) And 1) = (baKey(31) \ &H80) Then
        pvCurveSub uR.Item(0), m_uGf0, uR.Item(0) '-- X = -X
    End If
    pvCurveMul uR.Item(3), uR.Item(0), uR.Item(1)
    '--- success
    pvEdDsaUnpackNeg = True
QH:
End Function

Private Function pvEdDsaHash(baOutput() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    #If HasSha512 Then
        CryptoSha512 512, baOutput, baInput, Pos, Size
        Debug.Assert UBound(baOutput) + 1 >= LNG_HASHSZ
    #Else
        Err.Raise vbObjectError, , "SHA-512 not compiled (use CRYPT_HAS_SHA512 = 1)"
    #End If
End Function

Public Sub pvEdDsaPublicKey(baRetVal() As Byte, ByVal lOutPos As Long, baPriv() As Byte)
    Dim baD()          As Byte
    Dim uP              As XyztPoint
   
    pvEdDsaHash baD, baPriv
    pvCurveClampKey baD
    pvEdDsaScalarBase uP, baD
    pvEdDsaPack baRetVal, lOutPos, uP
End Sub

Public Sub CryptoEd25519PrivateKey(baRetVal() As Byte, Optional Seed As Variant)
    If Not IsMissing(Seed) Then
        baRetVal = Seed
        ReDim Preserve baRetVal(0 To LNG_KEYSZ - 1) As Byte
    Else
        ReDim baRetVal(0 To LNG_KEYSZ - 1) As Byte
        Call RtlGenRandom(baRetVal(0), UBound(baRetVal) + 1)
    End If
End Sub

Public Sub CryptoEd25519PublicKey(baRetVal() As Byte, baPriv() As Byte)
    Debug.Assert UBound(baPriv) + 1 >= LNG_KEYSZ
    pvInit
    ReDim baRetVal(0 To LNG_KEYSZ - 1) As Byte
    pvEdDsaPublicKey baRetVal, 0, baPriv
End Sub

Public Sub CryptoEd25519Sign(baRetVal() As Byte, baPriv() As Byte, baMsg() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Dim baDelta()      As Byte
    Dim baHash()        As Byte
    Dim baR()          As Byte
    Dim uP              As XyztPoint
    Dim uX              As Array64
    Dim lIdx            As Long
    Dim lJdx            As Long
   
    Debug.Assert UBound(baPriv) + 1 >= LNG_KEYSZ
    pvInit
    pvEdDsaHash baDelta, baPriv
    pvCurveClampKey baDelta
    If Size < 0 Then
        Size = UBound(baMsg) + 1 - Pos
    End If
    ReDim baRetVal(0 To LNG_HASHSZ + Size - 1) As Byte
    Call CopyMemory(baRetVal(LNG_HALFHASHSZ), baDelta(LNG_HALFHASHSZ), LNG_HALFHASHSZ)
    If Size > 0 Then
        Call CopyMemory(baRetVal(LNG_HASHSZ), baMsg(Pos), Size)
    End If
    pvEdDsaHash baR, baRetVal, Pos:=LNG_HALFHASHSZ
    pvEdDsaReduce baR
    pvEdDsaScalarBase uP, baR
    pvEdDsaPack baRetVal, 0, uP
    pvEdDsaPublicKey baRetVal, LNG_HALFHASHSZ, baPriv
    pvEdDsaHash baHash, baRetVal
    pvEdDsaReduce baHash
    For lIdx = 0 To LNG_HALFHASHSZ - 1
        uX.Item(lIdx) = baR(lIdx)
    Next
    For lIdx = 0 To LNG_HALFHASHSZ - 1
        For lJdx = 0 To LNG_HALFHASHSZ - 1
            uX.Item(lIdx + lJdx) = uX.Item(lIdx + lJdx) + (m_lZero + baHash(lIdx)) * baDelta(lJdx)
        Next
    Next
    pvEdDsaModL baRetVal, LNG_HALFHASHSZ, uX
End Sub

Public Function CryptoEd25519Open(baRetVal() As Byte, baPub() As Byte, baSigMsg() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Boolean
    Dim uP              As XyztPoint
    Dim uQ              As XyztPoint
    Dim baHash()        As Byte
    Dim baTemp(0 To LNG_KEYSZ - 1) As Byte
    Dim lIdx            As Long
   
    Debug.Assert UBound(baPub) + 1 >= LNG_KEYSZ
    pvInit
    If Size < 0 Then
        Size = UBound(baSigMsg) + 1 - Pos
    End If
    If Size < LNG_HASHSZ Then
        GoTo QH
    End If
    If Not pvEdDsaUnpackNeg(uQ, baPub) Then
        GoTo QH
    End If
    ReDim baRetVal(0 To Size - 1) As Byte
    Debug.Assert UBound(baSigMsg) + 1 >= Pos + Size
    Call CopyMemory(baRetVal(0), baSigMsg(Pos), Size)
    Call CopyMemory(baRetVal(LNG_HALFHASHSZ), baPub(0), LNG_HALFHASHSZ)
    pvEdDsaHash baHash, baRetVal
    pvEdDsaReduce baHash
    pvEdDsaScalarMult uP, uQ, baHash
    pvEdDsaScalarBase uQ, baSigMsg, LNG_HALFHASHSZ
    pvEdDsaAdd uP, uQ
    pvEdDsaPack baTemp, 0, uP
    For lIdx = 0 To LNG_HALFHASHSZ - 1
        If baTemp(lIdx) <> baSigMsg(lIdx) Then
            GoTo QH
        End If
    Next
    If UBound(baSigMsg) + 1 > LNG_HASHSZ Then
        ReDim baRetVal(0 To UBound(baSigMsg) - LNG_HASHSZ) As Byte
        Call CopyMemory(baRetVal(0), baSigMsg(LNG_HASHSZ), UBound(baRetVal) + 1)
    Else
        baRetVal = vbNullString
    End If
    '--- success
    CryptoEd25519Open = True
QH:
End Function

Public Sub CryptoEd25519SignDetached(baRetVal() As Byte, baPriv() As Byte, baMsg() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    CryptoEd25519Sign baRetVal, baPriv, baMsg, Pos, Size
    ReDim Preserve baRetVal(0 To LNG_HASHSZ - 1) As Byte
End Sub

Public Function CryptoEd25519VerifyDetached(baSig() As Byte, baPub() As Byte, baMsg() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Boolean
    Dim baSigMsg()          As Byte
    Dim baTemp()            As Byte
   
    If UBound(baSig) + 1 < LNG_HASHSZ Then
        GoTo QH
    End If
    If Size < 0 Then
        Size = UBound(baMsg) + 1 - Pos
    End If
    ReDim baSigMsg(0 To LNG_HASHSZ + UBound(baMsg)) As Byte
    Call CopyMemory(baSigMsg(0), baSig(0), LNG_HASHSZ)
    If UBound(baMsg) >= 0 Then
        Call CopyMemory(baSigMsg(LNG_HASHSZ), baMsg(0), UBound(baMsg) + 1)
    End If
    CryptoEd25519VerifyDetached = CryptoEd25519Open(baTemp, baPub, baSigMsg)
QH:
End Function

cheers,
</wqw>

[VB6/VBA7] CNamespaceWalk (Using the INamespaceWalk interface)

$
0
0
This project is intended to demonstrate how to implement the INamespaceWalk interface.

It uses lightweight COM and no .tlb is required and no VTable subclassing is used.
This means that the source files are self-sufficient.

Also everything is PtrSafe so it can work in VB6 or VBA7 in 32-bit or 64-bit environment.

The INamespaceWalk interface is a fast approach to enumerate folders and files.

CNamespaceWalk
The main creatable class.
Object: Returns the own instance.
RootFolder: Returns/sets the root folder from which to begin the namespace walk. (Default)
Flags: Returns/sets the options for a namespace walk.
Levels: Returns/sets the maximum depth to descend through the namespace hierarchy.
Walk(Optional ByVal Callback As INamespaceWalkCB) As Boolean: Initiates a recursive walk of the namespace from the specified root folder.
GetIDArrayResult() As CNSWIDArrayResult: Gets an array of PIDL objects found during a namespace walk.

CNSWIDArrayResult
Helper class object to hold PIDL (PCIDLIST_ABSOLUTE) objects from calling GetIDArrayResult in CNamespaceWalk.
All objects will be freed automatically upon Class_Terminate.
The Count property will be 0 if the flag 'NSWDontAccumulateResult' was set prior to the Walk.
Object: Returns the own instance.
LpIDList: Returns a pointer to a PIDL object given its index. (Default)
GetPathFromIDList(ByVal Index As Long) As String: Converts a PIDL object to a file system path given its index.
Count: Returns the number of PIDL objects.

INamespaceWalkCB
Optional callback interface which needs to be implemented on the object that will be passed to the Walk method in CNamespaceWalk as an optional argument.
FoundItem(ByVal Item As INSWCBObject): Interface method when an object is found during a namespace walk.
EnterFolder(ByVal Folder As INSWCBObject, ByRef Result As NSWCBResultConstants): Interface method when a folder is about to be entered during a namespace walk.
LeaveFolder(ByVal Folder As INSWCBObject): Interface method after a namespace walk through a folder.
InitializeProgressDialog(ByRef DialogTitle As String): Interface method to initializes the caption of the progress dialog box displayed during a namespace walk.
WalkComplete(ByVal HResult As Long): Interface method when a namespace walk has been completed or canceled. Use this method to perform any necessary cleanup.

INSWCBObject
Helper interface to get the current IShellFolder and PIDL (PCUITEMID_CHILD) object during a callback at INamespaceWalkCB.
LpIShellFolder: Interface method to return a pointer to an IShellFolder object.
LpIDList: Interface method to return a pointer to a PIDL object.
GetDisplayNameOf() As String: Support IShellFolder::GetDisplayNameOf (Using SHGDN_FORPARSING)

In the attachment is the demo project included.

The source code of the project can also be viewed on GitHub.
Attached Files

Add-In to change the "default" size of code windows while in IDE design mode

$
0
0
Ok, this is a VB6 Add-In to change the default size of Code windows. On my computer, I always delete the VBW files. So, when I open code windows, their width is some "default" size. On my computer, this is 477 pixels. I'm not positive that this number is the same for everyone. If it's not the same for you, you will need to change that constant in the source code. The following is the line of code you'll need to change:

Code:


Private Const VB6_IDE_Default_Code_Window_Width As Long = 447&

When opening a Code window, if it's that width, it'll be changed to 1200 pixels. If you want a different number for the new width, you'll need to change the following line of code:

Code:


Private Const Desired_Code_Window_Width As Long = 1200&

There's also a timer that monitors for newly opened code windows. The timer is set to raise its event at every 250 milliseconds. I felt that this was slow enough to not affect anything else, but fast enough to not really be noticeable for any Code window user interface. (Sometimes, you can "just" see it, but it's no big deal, especially considering it's just for developers, not end-users.)

That's about it.

Just download it, and re-compile it, saving the DLL wherever you place your other VB6 IDE Add-Ins.

I've also included a DllReg.vbs and DllUnreg.vbs, but you don't need them. The Add-In's DLL is automatically registered when you (re)compile it. If you wish to use these VB_Script files, just drag any DLL onto them and they'll do what they say.

Enjoy.
Attached Files

(VB6) ColorDialog: a color dialog replacement

$
0
0
The Windows color dialog seems a bit outdated to me. Here is a new one that can replace it.

Current limitations are: since it is a dialog that has some captions, it needs translations to different languages. For now only English, Spanish and French (thanks Crapahute) are supported.
To include some other non-Unicode languages will be relatively easy, to add languages that use Unicode will require to change the controls to Krool's common controls.
To add right-to-left language would require more effort.

Download from GitHub.

Some screen shots:

Name:  ColorDialog_scr1.png
Views: 113
Size:  120.0 KB

Name:  ColorDialog_scr2.png
Views: 111
Size:  91.4 KB

Name:  ColorDialog_scr3.png
Views: 110
Size:  127.4 KB

Name:  ColorDialog_scr4.png
Views: 113
Size:  171.7 KB

Download from GitHub.

Help file online.

Last release: 2022-09-05
Attached Images
    

Clear Immediate Window

$
0
0
This has probably been posted before, but I thought I'd do "my version" of this.

Compile the Add-In and save the DLL to wherever your Add-Ins are, and then load it (via your Add-Ins Manager) and you'll get a small button in the top-left of your desktop. If you move that form, it'll return to where you positioned it the next time.

If you close that form, the whole Add-In is unloaded. Just re-load it to get the form/button back. It's your choice as to whether you keep it loaded.

Also, I specifically look for the window titled "Immediate". Basically, this makes it work only when the IDE is set for English. You'll have to patch this if you want it for another language.

I've tried hard to make sure it ONLY deletes the Immediate window. Here's the code (all in the form except for actually loading the form), but please just use the project. I'm showing it here so you can peruse the primary code to do this:

Code:


Option Explicit
'
Private Type RECT
    Left  As Long
    Top  As Long
    Right As Long ' This is +1 (right - left = width)
    Bottom As Long ' This is +1 (bottom - top = height)
End Type
Private Type MONITORINFO
    cbSize As Long
    rcMonitor As RECT
    rcWork As RECT
    dwFlags As Long
End Type
Private Type KeyboardInput
    dwType As Long
    wVK As Integer
    wScan As Integer
    dwFlags As Long
    dwTime As Long
    dwExtraInfo As Long
    dwPadding As Currency
End Type
'
Private Declare Function SendInput Lib "user32" (ByVal nInputs As Long, pInputs As Any, ByVal cbSize As Long) As Long
Private Declare Function EbMode Lib "vba6" () As Long ' 0=Design, 1=Run, 2=Break.
Private Declare Function GetFocus Lib "user32" () As Long ' Retrieves the handle to the window that has the keyboard focus, if the window is attached to the calling thread's message queue.
Private Declare Function GetWindowTextLengthW Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowTextW Lib "user32" (ByVal hWnd As Long, ByVal lpString As Long, ByVal cch As Long) As Long
Private Declare Function MonitorFromWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, ByRef lpmi As MONITORINFO) As Long
'
Public AppInst      As VBIDE.VBE
Public AddInInst    As VBIDE.AddIn
'

Private Sub Form_Load()
    '
    ' Scrub off the width that the IDE wouldn't let us scrub off.
    Me.Width = Me.Width - 285!
    '
    ' Put position where it last was.
    Me.Top = GetSetting(App.Title, "Settings", "ClearImmediateTop", 60)
    Me.Left = GetSetting(App.Title, "Settings", "ClearImmediateLeft", 60)
    If Not FormIsFullyOnMonitor Then
        Me.Top = 60!
        Me.Left = 60!
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If EbMode <> 0& Then
        MsgBox "Sorry, but you can't unload this Add-In unless you're in design-mode.", vbInformation
        Cancel = True
        Exit Sub
    End If
    '
    ' Save our position for next time.
    SaveSetting App.Title, "Settings", "ClearImmediateTop", Me.Top
    SaveSetting App.Title, "Settings", "ClearImmediateLeft", Me.Left
    '
    ' We just unload the Add-In so it can be re-loaded (and show this form again) if desired.
    AddInInst.Connect = False
    '
    ' Make sure COM object is uninstantiated.
    Set frmClearImmediateWindow = Nothing
End Sub

Private Sub cmdClearImmediate_Click()
    '
    ' Make sure the IDE isn't running the code.
    If EbMode = 1& Then ' EbMode actually works as expected in Add-Ins.
        MsgBox "You can't clear ""Immediate"" window while running your code!  It can only be cleared while in design-mode or while in break-mode.", vbInformation
        Exit Sub
    End If
    '
    ' Get reference to Immediate window.
    Dim TheWindow As VBIDE.Window
    Set TheWindow = AppInst.Windows("Immediate")
    '
    ' Make sure we found it.
    If TheWindow Is Nothing Then Exit Sub
    '
    ' Make sure it's visible.
    If Not TheWindow.Visible Then TheWindow.Visible = True
    '
    ' Make sure it's got the focus.
    TheWindow.SetFocus
    Dim sTitle As String
    sTitle = WindowText(GetFocus)
    If sTitle <> "Immediate" Then
        MsgBox "For some reason, the focus of the ""Immediate"" window couldn't be set, so this ""Clear"" operation can't be performed.  You may possibly be set to another language.", vbInformation
        Exit Sub
    End If
    '
    ' We're ready to clear.
    SendKeysSpecial "^{HOME}"
    SendKeysSpecial "^+{END}"
    SendKeysSpecial "{DEL}"
End Sub

Private Function WindowText(hWndOfInterest As Long) As String
    WindowText = Space$(GetWindowTextLengthW(hWndOfInterest))
    WindowText = Left$(WindowText, GetWindowTextW(hWndOfInterest, StrPtr(WindowText), Len(WindowText) + 1&))
End Function

Private Sub SendKeysSpecial(Data As String)
    Dim KeyEvents()  As KeyboardInput
    ReDim KeyEvents(15&)
    Dim DatPtr As Long
    Dim EvtPtr As Long
    Do While DatPtr < Len(Data)
        DoNextChr Data, DatPtr, EvtPtr, KeyEvents
    Loop
    '
    SendInput EvtPtr, KeyEvents(0&), Len(KeyEvents(0&))
End Sub

Private Sub DoNextChr(Data As String, DatPtr As Long, EvtPtr As Long, KeyEvents() As KeyboardInput)
    Const INPUT_KEYBOARD          As Long = 1&
    Const KEYEVENTF_EXTENDEDKEY    As Long = 1&
    Const KEYEVENTF_KEYUP          As Long = 2&
    '
    DatPtr = DatPtr + 1&
    Dim This As String
    This = Mid$(Data, DatPtr, 1&)
    '
    Select Case This
    Case "+", "^"
        Select Case This
        Case "+":  KeyEvents(EvtPtr).wVK = vbKeyShift
        Case "^":  KeyEvents(EvtPtr).wVK = vbKeyControl
        End Select
        KeyEvents(EvtPtr).dwType = INPUT_KEYBOARD
        EvtPtr = EvtPtr + 1&
        '
        DoNextChr Data, DatPtr, EvtPtr, KeyEvents  ' Recursion.
        '
        Select Case This
        Case "+":  KeyEvents(EvtPtr).wVK = vbKeyShift
        Case "^":  KeyEvents(EvtPtr).wVK = vbKeyControl
        End Select
        KeyEvents(EvtPtr).dwFlags = KEYEVENTF_KEYUP
        KeyEvents(EvtPtr).dwType = INPUT_KEYBOARD
        EvtPtr = EvtPtr + 1&
    Case "{"
        Dim EndPtr As Long
        EndPtr = InStr(DatPtr, Data, "}")
        '
        Dim vk As Integer
        Select Case Mid$(Data, DatPtr + 1&, EndPtr - DatPtr - 1&)
        Case "DEL":    vk = vbKeyDelete
        Case "END":    vk = vbKeyEnd
        Case "HOME":    vk = vbKeyHome
        End Select
        '
        KeyEvents(EvtPtr).wVK = vk
        KeyEvents(EvtPtr).dwFlags = KEYEVENTF_EXTENDEDKEY
        KeyEvents(EvtPtr).dwType = INPUT_KEYBOARD
        EvtPtr = EvtPtr + 1&
        '
        KeyEvents(EvtPtr).wVK = vk
        KeyEvents(EvtPtr).dwFlags = KEYEVENTF_KEYUP
        KeyEvents(EvtPtr).dwType = INPUT_KEYBOARD
        EvtPtr = EvtPtr + 1&
        '
        DatPtr = EndPtr
    End Select
End Sub

Private Function FormIsFullyOnMonitor() As Boolean
    ' This tells us whether or not form is FULLY visible on its monitor.
    '
    Dim r1 As RECT
    Dim r2 As RECT
    Dim uMonInfo As MONITORINFO
    '
    GetWindowRect Me.hWnd, r1
    uMonInfo.cbSize = LenB(uMonInfo)
    GetMonitorInfo MonitorFromWindow(Me.hWnd, 0&), uMonInfo
    r2 = uMonInfo.rcWork
    '
    FormIsFullyOnMonitor = (r1.Top >= r2.Top) And (r1.Left >= r2.Left) And (r1.Bottom <= r2.Bottom) And (r1.Right <= r2.Right)
End Function



Two points, one I knew and one I discovered:

  • You can't clear the Immediate window while running in the IDE. You must either be in design-mode or break-mode.
  • You can't unload an Add-In unless you're in design-mode.


Enjoy

ALSO: Before someone requests it, I thought about a toolbar button, but I don't like the fact that the clipboard gets deleted/corrupted when you do that. I sometimes have stuff in my clipboard before I fire up the IDE. So, if you want this, you're on your own.

(VB6) Virtual LED control

$
0
0
It simulates a LED (light emitting diode).

Properties:

Color: Red/Green/yellow/Blue/White/Custom (the Custom color is defined from properties BorderColor, ColorOn and ColorOff)

State: On/Off/Blinking

BlinkType: Shorter/Short/Medium/Long/Twice

BlinkPeriod: in milliseconds

Shape: Round/Square/Rectangle/RoundedSquare/RoundedRectangle

ToggleOnClick: the control changes On/Off on click (not while blinking)

BorderWidth: in pixels, the default is 1.

Style: 2D or 3D.

Events: Click, DblClick, MouseDown/MouseMove/MouseUp

It can be used as a toggle control, like a switch, when property ToggleOnClick is set to True.
You can get the state change from the Click event.

Download from GitHub.

Name:  LED_Scr1_3D.png
Views: 88
Size:  8.1 KB


Name:  LED_Scr2_3D.png
Views: 87
Size:  9.3 KB


Name:  LED_Scr3.png
Views: 114
Size:  7.2 KB


Name:  LED_Scr4.png
Views: 113
Size:  6.3 KB


Download from GitHub.
Attached Images
    

Open module with text editor from Project Window's context menu

$
0
0
This is an add-in I've wanted for a long time. It opens modules (or the VBP file if that's what you're on) from the context menus within the VB6 IDE's Project Explorer Window.

Just compile it, save the DLL wherever you save your VB6 Add-Ins, then it'll appear in your Add-In list. Just load it, and the new item will be on the bottom of the context menus.

Enjoy

Name:  OpenWithTextEditor.png
Views: 9
Size:  15.7 KB
Attached Images
 
Attached Files

Open module with text editor from Project Window's context menu (Add-In)

$
0
0
This is an add-in I've wanted for a long time. It opens modules (or the VBP file if that's what you're on) from the context menus within the VB6 IDE's Project Explorer Window.

Just compile it, save the DLL wherever you save your VB6 Add-Ins, then it'll appear in your Add-In list. Just load it, and the new item will be on the bottom of the context menus.

Enjoy

Name:  OpenWithTextEditor.png
Views: 52
Size:  15.7 KB
Attached Images
 
Attached Files
Viewing all 1487 articles
Browse latest View live


<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>