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

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: 110
Size:  120.0 KB

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

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

Name:  ColorDialog_scr4.png
Views: 110
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: 51
Size:  8.1 KB


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


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


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


Download from GitHub.
Attached Images
    

Clear Immediate Window (Add-In)

$
0
0
EDIT1: I added the option to "Clear" to the Immediate Window's context menu. It's probably more useful there than as a separate button anyway.

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.
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.
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: 71
Size:  15.7 KB
Attached Images
 
Attached Files

Right-click Type (UDT) usage in code and go to its Declaration (Add-In)

$
0
0
IMHO, this was a major oversight in the VB6 IDE that should have been included.

We can right-click in code (getting context menu and selecting "Definition") and go to the declarations of about everything else. But the ability to do this within the IDE for Type (UDT) declarations was overlooked.

This Add-In fixes that.

Just compile it to wherever you keep your VB6 IDE Add-Ins, load it within the IDE, and the new option will be on the code window context-menu:

Name:  TypeDefinition.png
Views: 55
Size:  10.8 KB

Enjoy
Attached Images
 
Attached Files

Registry Free Object Instantiation using DirectCOM & RC6

$
0
0
There are a few variations of this kind of reg-free "bootstrapping" module already circulating, but I wanted to write one that was highly commented in the hope that it will help some newcomers better understand how to write their VB6/RC6 apps in a way that works without requiring their DLLs to be registered, and also how to package their app & DLLs so that everything will work smoothly when deployed on a user's computer without registration.

Source Code - Download here: MRC6Base.zip

NOTE: This is a work in progress - if there are any parts of the code or comments that you still find confusing, please ask! I'll try my best to clarify and update the comments so that we have a comprehensive document that will be easily understood by newcomers to RC6.

Things are described in much more detail in the module comments, so I suggest you read them all. Here are the basics:

THE PRIMARY GOAL OF THIS MODULE is to be universal and foundational code for VB6 apps using DirectCOM.dll and RC6.dll to instantiate ActiveX objects without requiring the use of regsvr32/installers on your application's end users' computers. This approach will be called "DirectCOM reg-free" or simply "reg-free" for the rest of this post.

By "Universal" I mean that this module should be added to EVERY VB6/RC6 project.
By "Foundational" I mean that this module should be the FIRST THING that you add to every project you create that will be using RC6/DirectCOM reg-free.

TO USE THIS MODULE

When you start writing a new app, add MRC6Base.bas to your project via the Project > Add Module menu.
Next, add a reference to RC6.dll via the Project > References menu.

You will now have everything you need to start writing a reg-free VB6/RC6 application. The main thing to understand is that there are now 5 ways to instantiate new objects in your code instead of only the regular 2 ways (New keyword and CreateObject function). The choice of which method to use depends on the type of object you want to create.

Using the New Keyword
Use the built-in VB6 New keyword to instantiate objects that you know will be registered on the user's computer, or that are built-in to the VB6 runtime or STDOLE. For example, VB6 Collections, StdFont objects, StdPicture objects, etc... should always be instantiated via the New keyword.

Using the CreateObject Method
Use the built-in VB6 CreateObject method to instantiate objects that you know will be registered on the end user's computer late-bound. This would include things like Excel.Application, Word.Application, Shell objects, etc...

Using the New_C Method
Use the New_C method to instantiate all RC6 objects excluding Cairo objects. This instantiation will occur without touching the registry, so RC6.dll does not need to be registered on your end user's computer. Example:

Code:

Dim RS As RC6.cRecordset

Set RS = New_C.Recordset    ' Instead of the more familiar "Set RS = New Recordset" which would require a trip to the registry

Using the Cairo Method
Use the Cairo method to create new RC6 Cairo objects (amongst other Cairo features). This instantiation will occur without touching the registry. For example, to create a new image surface to draw against:

Code:

Dim Srf As RC6.cCairoSurface

Set Srf = Cairo.CreateSurface(100, 100)  ' Create  100x100 pixels image surface and store the reference in the Srf variable.

Using the CreateObjectRegfree Method
Use the CreateObjectRegfree method to create objects from DLLs that you will distribute with your application (that is, DLLs that aren't distributed by Microsoft with Windows), but that you don't want to register on the user's computer. For example, if you have created your own DLL called MyDll.dll with a class called MyClass, and a method call MySub, you can use it reg-free as follows (make sure you have added a reference to MyDll.dll in the VB6 Project > References menu):

Code:

Dim MC As MyDll.MyClass

Set MC = CreateObjectRegfree("MyDll.dll", "MyClass")

MC.MySub

If you stick to the above rules when writing your code, you will be able to distribute your application and all related DLLs without requiring the DLLs to be registered on your end user's computer.

Packaging & Distributing Your Application

This topic is also discussed in more detail in the source comments, but the basics are:

Your main application folder should contain the following:

  • The EXE that your users will launch to use your app.
  • A folder called System.
  • Other folders that you want to include with your app, such as a Help (for your documentation).


The System folder should contain the following:

  • RC6.dll (available from t
  • cairo_sqlite.dll
  • DirectCOM.dll
  • RC6Widgets.dll (optional - only needed for apps that use RC6 Forms instead of VB6 Forms).
  • Any of your own DLLs that your app references.
  • Any satellite/helper EXEs that your main app shells out to for any purpose.
  • Any third-party DLLs that your main app references, and that aren't already distributed by Microsoft with Windows.
  • A folder named RPCDlls - this is optional, and only needed for client-server applications that use remote procedure calls (RPC) with the RC6 cRpcListener and cRpcConnection classes.


Your main application folder can then be compressed into a ZIP archive, or packaged into a self-extracting executable for distribution to end users. Users can extract the contents anywhere they like, and launch the main application EXE to start using your software immediately - no registration of components required.

I hope this code proves useful to someone out there. Questions and comments are always welcome!
Attached Files

LOGIC_GATES in VB6

$
0
0
Dear All

Just recently I have developed a code on Logic Gates in VB6.

Hope it will be helpful to some of them here.

The Original code belongs to Use Adlib Logic,
I don't know the name of the Original developer but found something on Github with the same name, may be he/ she is the one.

http://freesourcecode.net/vbprojects/25651/Logic-in-Visual-Basic#.YyX0tFzMLIU

https://github.com/Planet-Source-Cod...-game__1-62423

But I must acknowledge him/ her.


I have updated it to new features....


Regards
Steve
Attached Files

VB6 - GetFile

$
0
0
Attached are sample programs that facilitate downloading a file from a remote server using encryption. It was adapted from SendFile.
https://www.vbforums.com/showthread....-File-Transfer

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 TLS 1.3 to establish the network connection. The Agreed Secret calculated by each party is then used as the key for the file transfer.

The server program (FileServer.exe) listens on port 1159. Modify the SharePath to reflect the location you wish to share files from. The client program (GetFile.exe) currently defaults to the loopback address. Change the server location to an IP address or a domain name. A domain name must be DNS hosted or configured in the "HOSTS" file. The Path reflects where you want to download files to. Click the "Connect" button, and if successful the files available on the server will be listed in the ListBox. Clicking on a file in that list will download and store the file with a MsgBox relecting that information.

This Version uses TLS 1.3 protocols to establish the connection. By default ECDH_P256 is used, but ECDH_P384 or ECDH_P521 can also be used. Normally, the server program would run as a service. If there is sufficient interest, I can add that feature. Authentication via UserID/Password can also be added.

J.A. Coutts
Attached Files

Function for checking if a property or method exists inside a object

$
0
0
After searching for different ways to check if a method exists, i found that most of them were either slow (using TLI objects) or used error handling while also calling the method, then after some search about VB6 internals, found out that all VB6 objects have a IDispatch interface, which implements a method called "GetIdsOfNames", which is able to check if a method/property name exists and returns an ID used internally to call that method
So i made a function that uses DispCallFunc to call "GetIdsOfNames" of any VB6 object, so you can check if a method exists even without calling it (that also means you can check if a form has a method without even loading it!) while also being a little faster than the usual error handling way

The internal structure of all VB6 objects uses these interfaces :
IUNKNOWN
->QueryInterface
->AddRef
->ReleaseRef
IDISPATCH
-> GetTypeInfoCount
-> GetTypeInfo
-> GetIDsOfNames
which from what i searched are supposed to be exactly like that in memory, so if you call
DispCallFunc with offset 0, means you are calling QueryInterface
and DispCallFunc with offset 20 is calling GetIdsOfNames

I debugged this approach by using API Monitor, it shows me exactly what function DispCallFunc is calling and what
parameters are going to the function, mostly things you won't know normally because VB6 IDE would just crash if you make a mistake with function pointers and parameters

Code:

Enum tagCALLCONV
    CC_FASTCALL = 0
    CC_CDECL = 1
    CC_MSCPASCAL = CC_CDECL + 1
    CC_PASCAL = CC_MSCPASCAL
    CC_MACPASCAL = CC_PASCAL + 1
    CC_STDCALL = CC_MACPASCAL + 1
    CC_FPFASTCALL = CC_STDCALL + 1
    CC_SYSCALL = CC_FPFASTCALL + 1
    CC_MPWCDECL = CC_SYSCALL + 1
    CC_MPWPASCAL = CC_MPWCDECL + 1
    CC_MAX = CC_MPWPASCAL
End Enum

Private Const GET_IDS_OF_NAMES_VTABLE_OFFSET As Long = 20

Private Const LOCALE_USER_DEFAULT = &H400
 

Private Declare Function DispCallFunc Lib "OleAut32.dll" _
(ByVal pvInstance As Long, _
  ByVal oVft As Long, _
  ByVal cc As tagCALLCONV, _
  ByVal vtReturn As VbVarType, _
  ByVal cActuals As Long, _
  ByRef prgvt As Integer, _
  ByRef prgpvarg As Long, _
  ByRef pvargResult As Variant) As Long
 
Private Type VariantIdsOfNames
    GUID As Variant
    Name As Variant
    cName As Variant
    LCID As Variant
    DISPID As Variant
End Type

Code:

Public Function HasMethod(ByRef ObjectTest As Object, ByRef MethodName As String) As Boolean
Static VarTypes(4) As Integer
Static VariantPtr(4) As Long
Static IDispatchChecker As VariantIdsOfNames
Static ResultID As Long
Static Initialized As Boolean
Dim Result As Variant

'Check if the object is a null pointer, otherwise this would crash VB
If ObjPtr(ObjectTest) = 0 Then Exit Function
If Initialized = False Then
    With IDispatchChecker
   
        '8 characters BSTR = 16 bytes = 128 bits  = IID_NULL (Empty GUID)
        .GUID = String$(8, vbNullChar)
        .cName = 1& 'Checks only one name
        .LCID = LOCALE_USER_DEFAULT  'Default locale ID
        .DISPID = VarPtr(ResultID)
        VarTypes(0) = vbString
        VarTypes(1) = vbLong
        VarTypes(2) = vbLong
        VarTypes(3) = vbLong
        VarTypes(4) = vbLong
        VariantPtr(0) = VarPtr(.GUID)
        VariantPtr(1) = VarPtr(.Name)
        VariantPtr(2) = VarPtr(.cName)
        VariantPtr(3) = VarPtr(.LCID)
        VariantPtr(4) = VarPtr(.DISPID)
    End With
    Initialized = True
End If
IDispatchChecker.Name = VarPtr(MethodName) 'Uses a BSTR pointer
DispCallFunc ObjPtr(ObjectTest), GET_IDS_OF_NAMES_VTABLE_OFFSET, CC_STDCALL, _
            vbLong, 5, VarTypes(0), VariantPtr(0), Result
           
'Result is non-zero when function fails
If Result = 0 Then HasMethod = True
End Function

VB6 MSHFlexGrid & MSFlexGrid vertical & horizontal scroll MouseWheel Roll and Tilt

$
0
0
Many modern mice have scroll wheels which can tilt left or right to allow for horizontal scrolling of wide documents like spreadsheets and web pages.

The attached program demos a module that allows you to add horizontal scroll capability to MSHFlexGrid and MSFlexGrid.

SeabrookStan

[VB6/VBA] QR Code generator library

[VB6/VBA] Pure VB6 implementation of ChaCha20-Poly1305 authenticated encryption

$
0
0
mdChaCha20Poly1305.bas is a pure VB6 implementation of ChaCha20 stream cipher, Poly1305 hash for MAC and combining these finally we get the ChaCha20-Poly1305 AEAD implemented in less than 400 lines of code.

Public procedures CryptoChaCha20Init and CryptoChaCha20Cipher can be used to encrypt and the same to decrypt by XOR-ing plaintext or cyphertext byte-array with ChaCha20 key stream.

Public procedures CryptoPoly1305Init, CryptoPoly1305Update and CryptoPoly1305Finish implement the Poly1305 MAC interface allowing incremental updates to hash internal state.

Public procedures CryptoChaCha20Poly1305Encrypt and CryptoChaCha20Poly1305Decrypt implement the authenticated encryption with additional data (AEAD) algorithm as described in RFC 8439.

Code:

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

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

#If HasPtrSafe Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If

Private LNG_POW2(0 To 31)  As Long

Public Type CryptoChaCha20Context
    Constant(0 To 3)    As Long
    Key(0 To 7)        As Long
    Nonce(0 To 3)      As Long
    Block(0 To 63)      As Byte
    NBlock              As Long
    NCounter            As Long
End Type

Private Type FieldElement
    Item(0 To 16)      As Long
End Type

Public Type CryptoPoly1305Context
    H                  As FieldElement
    R                  As FieldElement
    S(0 To 15)          As Byte
    Partial(0 To 15)    As Byte
    NPartial            As Long
End Type

Private Function ROTL32(ByVal lX As Long, ByVal lN As Long) As Long
    '--- ROTL32 = LShift(X, n) Or RShift(X, 32 - n)
    Debug.Assert lN <> 0
    ROTL32 = ((lX And (LNG_POW2(31 - lN) - 1)) * LNG_POW2(lN) Or -((lX And LNG_POW2(31 - lN)) <> 0) * LNG_POW2(31)) Or _
        ((lX And (LNG_POW2(31) Xor -1)) \ LNG_POW2(32 - lN) Or -(lX < 0) * LNG_POW2(lN - 1))
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 Sub pvInit()
    Dim lIdx            As Long
   
    If LNG_POW2(0) = 0 Then
        LNG_POW2(0) = 1
        For lIdx = 1 To 30
            LNG_POW2(lIdx) = LNG_POW2(lIdx - 1) * 2
        Next
        LNG_POW2(31) = &H80000000
    End If
End Sub

Private Sub pvChaCha20Quarter(lA As Long, lB As Long, lC As Long, lD As Long)
    lA = UADD(lA, lB): lD = ROTL32(lD Xor lA, 16)
    lC = UADD(lC, lD): lB = ROTL32(lB Xor lC, 12)
    lA = UADD(lA, lB): lD = ROTL32(lD Xor lA, 8)
    lC = UADD(lC, lD): lB = ROTL32(lB Xor lC, 7)
End Sub

Private Sub pvChaCha20Core(uCtx As CryptoChaCha20Context, baOutput() As Byte)
    Static lZ(0 To 15)  As Long
    Static lX(0 To 15)  As Long
    Dim lIdx            As Long
   
    Call CopyMemory(lZ(0), uCtx.Constant(0), 16 * 4)
    Call CopyMemory(lX(0), uCtx.Constant(0), 16 * 4)
    For lIdx = 0 To 9
        pvChaCha20Quarter lZ(0), lZ(4), lZ(8), lZ(12)
        pvChaCha20Quarter lZ(1), lZ(5), lZ(9), lZ(13)
        pvChaCha20Quarter lZ(2), lZ(6), lZ(10), lZ(14)
        pvChaCha20Quarter lZ(3), lZ(7), lZ(11), lZ(15)
        pvChaCha20Quarter lZ(0), lZ(5), lZ(10), lZ(15)
        pvChaCha20Quarter lZ(1), lZ(6), lZ(11), lZ(12)
        pvChaCha20Quarter lZ(2), lZ(7), lZ(8), lZ(13)
        pvChaCha20Quarter lZ(3), lZ(4), lZ(9), lZ(14)
    Next
    For lIdx = 0 To 15
        lX(lIdx) = UADD(lX(lIdx), lZ(lIdx))
    Next
    Call CopyMemory(baOutput(0), lX(0), 16 * 4)
End Sub

Public Sub CryptoChaCha20Init(uCtx As CryptoChaCha20Context, baKey() As Byte, baNonce() As Byte, Optional ByVal NCounter As Long = 4)
    Dim sConstant      As String
    Dim baFull(0 To 15) As Byte
   
    Debug.Assert UBound(baKey) + 1 = 16 Or UBound(baKey) + 1 = 32
    With uCtx
        pvInit
        If UBound(baKey) = 31 Then
            Call CopyMemory(.Key(0), baKey(0), 32)
            sConstant = "expand 32-byte k"
        Else
            Call CopyMemory(.Key(0), baKey(0), 16)
            Call CopyMemory(.Key(4), baKey(0), 16)
            sConstant = "expand 16-byte k"
        End If
        Call CopyMemory(.Constant(0), ByVal sConstant, Len(sConstant))
        If UBound(baNonce) >= UBound(baFull) Then
            Call CopyMemory(baFull(0), baNonce(0), UBound(baFull) + 1)
        ElseIf UBound(baNonce) >= 0 Then
            Call CopyMemory(baFull(15 - UBound(baNonce)), baNonce(0), UBound(baNonce) + 1)
        End If
        Call CopyMemory(.Nonce(0), baFull(0), 16)
        .NBlock = 0
        .NCounter = NCounter '--- part of Nonce that get incremented after pvChaCha20Core (in DWORDs)
    End With
End Sub

Public Sub CryptoChaCha20Cipher(uCtx As CryptoChaCha20Context, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Dim lOffset        As Long
    Dim lTaken          As Long
    Dim lIdx            As Long
   
    With uCtx
        If Size < 0 Then
            Size = UBound(baInput) + 1 - Pos
        End If
        Do While Size > 0
            If .NBlock = 0 Then
                pvChaCha20Core uCtx, .Block
                For lIdx = 0 To .NCounter - 1
                    uCtx.Nonce(lIdx) = UADD(uCtx.Nonce(lIdx), 1)
                    If uCtx.Nonce(lIdx) <> 0 Then
                        Exit For
                    End If
                Next
                .NBlock = 64
            End If
            lOffset = 64 - .NBlock
            lTaken = .NBlock
            If Size < lTaken Then
                lTaken = Size
            End If
            For lIdx = 0 To lTaken - 1
                baInput(Pos) = baInput(Pos) Xor .Block(lOffset)
                Pos = Pos + 1
                lOffset = lOffset + 1
            Next
            .NBlock = .NBlock - lTaken
            Size = Size - lTaken
        Loop
    End With
End Sub

'= Poly1305 ==============================================================

Private Sub pvPoly1305Add(uX As FieldElement, uY As FieldElement)
    Dim lIdx            As Long
    Dim lCarry          As Long
   
    For lIdx = 0 To 16
        lCarry = lCarry + uX.Item(lIdx) + uY.Item(lIdx)
        uX.Item(lIdx) = lCarry And &HFF
        lCarry = lCarry \ &H100
    Next
End Sub

Private Sub pvPoly1305Mul(uX As FieldElement, uY As FieldElement)
    Dim lIdx            As Long
    Dim lJdx            As Long
    Dim lAccum          As Long
    Dim uR              As FieldElement
   
    For lIdx = 0 To 16
        For lJdx = 0 To 16
            If lJdx <= lIdx Then
                lAccum = lAccum + uX.Item(lJdx) * uY.Item(lIdx - lJdx)
            Else
                lAccum = lAccum + 320 * uX.Item(lJdx) * uY.Item(lIdx - lJdx + 17)
            End If
        Next
        uR.Item(lIdx) = lAccum
        lAccum = 0
    Next
    pvPoly1305MinReduce uR
    uX = uR
End Sub

Private Sub pvPoly1305MinReduce(uX As FieldElement)
    Dim lIdx            As Long
    Dim lCarry          As Long
   
    For lIdx = 0 To 15
        lCarry = lCarry + uX.Item(lIdx)
        uX.Item(lIdx) = lCarry And &HFF
        lCarry = lCarry \ &H100
    Next
    lCarry = lCarry + uX.Item(16)
    uX.Item(16) = lCarry And 3
    lCarry = 5 * (lCarry \ 4)
    For lIdx = 0 To 15
        lCarry = lCarry + uX.Item(lIdx)
        uX.Item(lIdx) = lCarry And &HFF
        lCarry = lCarry \ &H100
    Next
    uX.Item(16) = lCarry + uX.Item(16)
End Sub

Private Sub pvPoly1305FullReduce(uX As FieldElement)
    Dim lIdx            As Long
    Dim uSub            As FieldElement
    Dim uNeg            As FieldElement '-> -(2^130-5)
    Dim lMask          As Long
   
    uSub = uX
    uNeg.Item(0) = 5
    uNeg.Item(16) = &HFC
    pvPoly1305Add uSub, uNeg
    lMask = (uSub.Item(16) And &H80) <> 0
    For lIdx = 0 To 16
        uX.Item(lIdx) = (uX.Item(lIdx) And lMask) Or (uSub.Item(lIdx) And Not lMask)
    Next
End Sub

Private Sub pvPoly1305Block(uCtx As CryptoPoly1305Context, baBuffer() As Byte, ByVal lPos As Long, ByVal lSize As Long)
    Dim lIdx            As Long
    Dim uX              As FieldElement
   
    For lIdx = 0 To lSize - 1
        uX.Item(lIdx) = baBuffer(lPos + lIdx)
    Next
    uX.Item(lSize) = 1
    pvPoly1305Add uCtx.H, uX
    pvPoly1305Mul uCtx.H, uCtx.R
End Sub

Public Sub CryptoPoly1305Init(uCtx As CryptoPoly1305Context, baKey() As Byte)
    Const KEYSZ        As Long = 32
    Dim lIdx            As Long
   
    Debug.Assert UBound(baKey) + 1 = KEYSZ
    With uCtx
        For lIdx = 0 To UBound(.H.Item)
            .H.Item(lIdx) = 0
            Select Case lIdx
            Case 3, 7, 11, 15
                .R.Item(lIdx) = baKey(lIdx) And &HF
            Case 4, 8, 12
                .R.Item(lIdx) = baKey(lIdx) And &HFC
            Case 16
                .R.Item(lIdx) = 0
            Case Else
                .R.Item(lIdx) = baKey(lIdx)
            End Select
        Next
        Call CopyMemory(.S(0), baKey(KEYSZ \ 2), KEYSZ \ 2)
        .NPartial = 0
    End With
End Sub

Public Sub CryptoPoly1305Update(uCtx As CryptoPoly1305Context, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Const BLOCKSZ      As Long = 16
    Dim lTaken          As Long
   
    With uCtx
        If Size < 0 Then
            Size = UBound(baInput) + 1 - Pos
        End If
        If .NPartial > 0 Then
            lTaken = BLOCKSZ - .NPartial
            If lTaken > Size Then
                lTaken = Size
            End If
            Call CopyMemory(.Partial(.NPartial), baInput(Pos), lTaken)
            Pos = Pos + lTaken
            Size = Size - lTaken
            .NPartial = .NPartial + lTaken
            If .NPartial = BLOCKSZ Then
                pvPoly1305Block uCtx, .Partial, 0, .NPartial
                .NPartial = 0
            End If
        End If
        Do While Size >= BLOCKSZ
            Debug.Assert .NPartial = 0
            pvPoly1305Block uCtx, baInput, Pos, BLOCKSZ
            Pos = Pos + BLOCKSZ
            Size = Size - BLOCKSZ
        Loop
        If Size > 0 Then
            lTaken = BLOCKSZ - .NPartial
            If lTaken > Size Then
                lTaken = Size
            End If
            Call CopyMemory(.Partial(.NPartial), baInput(Pos), lTaken)
            .NPartial = .NPartial + lTaken
            Debug.Assert .NPartial < BLOCKSZ
        End If
    End With
End Sub

Public Sub CryptoPoly1305Finish(uCtx As CryptoPoly1305Context, baOutput() As Byte)
    Const BLOCKSZ      As Long = 16
    Dim lIdx            As Long
    Dim uX              As FieldElement
   
    With uCtx
        If .NPartial > 0 Then
            pvPoly1305Block uCtx, .Partial, 0, .NPartial
        End If
        For lIdx = 0 To BLOCKSZ - 1
            uX.Item(lIdx) = .S(lIdx)
        Next
        pvPoly1305FullReduce .H
        pvPoly1305Add .H, uX
        ReDim baOutput(0 To BLOCKSZ - 1) As Byte
        For lIdx = 0 To BLOCKSZ - 1
            baOutput(lIdx) = .H.Item(lIdx)
        Next
    End With
End Sub

'= ChaCha20Poly130 =======================================================

Private Function Process(baKey() As Byte, baNonce() As Byte, baAad() As Byte, baTag() As Byte, baBuffer() As Byte, ByVal lPos As Long, ByVal lSize As Long, ByVal Encrypt As Boolean) As Boolean
    Dim uChaCha        As CryptoChaCha20Context
    Dim uPoly          As CryptoPoly1305Context
    Dim baPolyKey(0 To 31) As Byte
    Dim baPad(0 To 15)  As Byte
    Dim baTemp()        As Byte
   
    If UBound(baNonce) + 1 <> 12 Then
        GoTo QH
    End If
    If lSize < 0 Then
        lSize = UBound(baBuffer) + 1 - lPos
    End If
    CryptoChaCha20Init uChaCha, baKey, baNonce, 1
    CryptoChaCha20Cipher uChaCha, baPolyKey
    CryptoPoly1305Init uPoly, baPolyKey
    '--- discard 32 bytes from chacha20 key stream
    CryptoChaCha20Cipher uChaCha, baPolyKey
    If Encrypt Then
        '--- encrypt then MAC
        CryptoChaCha20Cipher uChaCha, baBuffer, Pos:=lPos, Size:=lSize
    End If
    '--- ADD || pad(AAD)
    CryptoPoly1305Update uPoly, baAad
    CryptoPoly1305Update uPoly, baPad, Size:=(16 - (UBound(baAad) + 1) And 15) And 15
    '--- cipher || pad(cipher)
    CryptoPoly1305Update uPoly, baBuffer, Pos:=lPos, Size:=lSize
    CryptoPoly1305Update uPoly, baPad, Size:=(16 - lSize And 15) And 15
    '--- len_64(aad) || len_64(cipher)
    Call CopyMemory(baPad(0), UBound(baAad) + 1, 4)
    Call CopyMemory(baPad(8), lSize, 4)
    CryptoPoly1305Update uPoly, baPad
    '--- MAC complete
    If Encrypt Then
        CryptoPoly1305Finish uPoly, baTag
    Else
        CryptoPoly1305Finish uPoly, baTemp
        '--- decrypt only if tag matches
        If UBound(baTag) <> UBound(baTemp) Or InStrB(baTag, baTemp) <> 1 Then
            GoTo QH
        End If
        CryptoChaCha20Cipher uChaCha, baBuffer, Pos:=lPos, Size:=lSize
    End If
    '--- success
    Process = True
QH:
End Function

Public Function CryptoChaCha20Poly1305Encrypt(baKey() As Byte, baNonce() As Byte, baAad() As Byte, baTag() As Byte, _
            baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Boolean
    CryptoChaCha20Poly1305Encrypt = Process(baKey, baNonce, baAad, baTag, baBuffer, Pos, Size, Encrypt:=True)
End Function

Public Function CryptoChaCha20Poly1305Decrypt(baKey() As Byte, baNonce() As Byte, baAad() As Byte, baTag() As Byte, _
            baBuffer() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Boolean
    CryptoChaCha20Poly1305Decrypt = Process(baKey, baNonce, baAad, baTag, baBuffer, Pos, Size, Encrypt:=False)
End Function

Note that ChaCha20 is implemented in the first ~150 lines of code in the module which can be used separately as a stream cipher if authenticated encryption is not required.

cheers,
</wqw>

[VB6/VBA] Pure VB6 implementation of MD5 hash for the grins :-))

$
0
0
md5.bas is a 120 lines of code implementation of MD5 message digest as specified in RFC 1321.

Code:

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

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

#If HasPtrSafe Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If

Private LNG_POW2(0 To 31)  As Long
Private S(0 To 15)          As Long
Private K(0 To 63)          As Long

Private Function ROTL32(ByVal lX As Long, ByVal lN As Long) As Long
    '--- ROTL32 = LShift(X, n) Or RShift(X, 32 - n)
    Debug.Assert lN <> 0
    ROTL32 = ((lX And (LNG_POW2(31 - lN) - 1)) * LNG_POW2(lN) Or -((lX And LNG_POW2(31 - lN)) <> 0) * LNG_POW2(31)) Or _
        ((lX And (LNG_POW2(31) Xor -1)) \ LNG_POW2(32 - lN) Or -(lX < 0) * LNG_POW2(lN - 1))
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

Public Sub CryptoMd5(baOutput() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Dim vElem          As Variant
    Dim lIdx            As Long
    Dim lA              As Long
    Dim lB              As Long
    Dim lC              As Long
    Dim lD              As Long
    Dim lA2            As Long
    Dim lB2            As Long
    Dim lC2            As Long
    Dim lD2            As Long
    Dim lR              As Long
    Dim lE              As Long
    Dim lTemp          As Long
    Dim aBuffer()      As Long
    Dim lBufPos        As Long
    Dim lBufIdx        As Long
   
    If LNG_POW2(0) = 0 Then
        LNG_POW2(0) = 1
        For lIdx = 1 To 30
            LNG_POW2(lIdx) = LNG_POW2(lIdx - 1) * 2
        Next
        LNG_POW2(31) = &H80000000
        lIdx = 0
        For Each vElem In Split("7 12 17 22 5 9 14 20 4 11 16 23 6 10 15 21")
            S(lIdx) = vElem
            lIdx = lIdx + 1
        Next
        For lIdx = 0 To 63
            vElem = Abs(Sin(lIdx + 1)) * 4294967296#
            K(lIdx) = Int(IIf(vElem > 2147483648#, vElem - 4294967296#, vElem))
        Next
    End If
    If Size < 0 Then
        Size = UBound(baInput) + 1 - Pos
    End If
    '--- pad input buffer to 64 bytes
    lIdx = 64 - (Size Mod 64)
    If lIdx < 9 Then
        lIdx = lIdx + 64
    End If
    ReDim aBuffer(0 To (Size + lIdx) \ 4 - 1) As Long
    If Size > 0 Then
        Call CopyMemory(aBuffer(0), baInput(Pos), Size)
    End If
    Call CopyMemory(ByVal VarPtr(aBuffer(0)) + Size, &H80, 1)
    aBuffer(UBound(aBuffer) - 1) = Size * 8
    '--- md5 step
    lA = &H67452301: lB = &HEFCDAB89: lC = &H98BADCFE: lD = &H10325476
    Do While lBufPos < UBound(aBuffer)
        lA2 = lA: lB2 = lB: lC2 = lC: lD2 = lD
        For lIdx = 0 To 63
            lR = lIdx \ 16
            Select Case lR
            Case 0
                lE = (lB2 And lC2) Or (Not lB2 And lD2)
                lBufIdx = lIdx
            Case 1
                lE = (lB2 And lD2) Or (lC2 And Not lD2)
                lBufIdx = (lIdx * 5 + 1) And 15
            Case 2
                lE = lB2 Xor lC2 Xor lD2
                lBufIdx = (lIdx * 3 + 5) And 15
            Case 3
                lE = lC2 Xor (lB2 Or Not lD2)
                lBufIdx = (lIdx * 7) And 15
            End Select
            lTemp = lD2
            lD2 = lC2
            lC2 = lB2
            lB2 = UAdd(lB2, ROTL32(UAdd(UAdd(UAdd(lA2, lE), K(lIdx)), aBuffer(lBufPos + lBufIdx)), S((lR * 4) Or (lIdx And 3))))
            lA2 = lTemp
        Next
        lA = UAdd(lA, lA2): lB = UAdd(lB, lB2): lC = UAdd(lC, lC2): lD = UAdd(lD, lD2)
        lBufPos = lBufPos + 16
    Loop
    '--- complete output
    aBuffer(0) = lA: aBuffer(1) = lB: aBuffer(2) = lC: aBuffer(3) = lD
    ReDim baOutput(0 To 15) As Byte
    Call CopyMemory(baOutput(0), aBuffer(0), 16)
End Sub

cheers,
</wqw>

Typelib to add LongPtr type to VB6 for universal codebases

$
0
0
VB6LongPtr.tlb - Add LongPtr to VB6


This is just a dead simple typedef but I didn't see anything like it readily available, so thought I'd post the one I made.

While you can (and must) use compiler constants to declare APIs differently, it gets to be unwieldy fast when you want to have the rest of your code be compatible when you have variables and Type members that also must be LongPtr. So to create universal codebases, I made a simple typelib that adds a LongPtr alias for Long in VB6. You can declare variables, Type members, arguments, etc, as LongPtr, and VB6 will treat them identically to a Long, with which they're also interchangeable- you can pass a LongPtr variable to a function expecting a Long, and a Long to a function expecting a LongPtr.

Add this only to your VB6 projects, not to VBA or twinBASIC projects.


Code:

//VB6LongPtr by fafalone
//Simply uses an alias to make LongPtr a usable type in VB6 in order
//to create universal codebases for VB6/VBA/twinBASIC. Include this
//typelib **only** with VB6 projects, as VBA/tB have a native LongPtr.
//(Since VB6 is 32bit only, LongPtr *always* would resolve to Long)
[
    uuid(D8EE61B0-8778-4A43-8F98-E7E1C2C08AD4),
    version(1.00),
    helpstring("VB6 LongPtr Support"),
    lcid(0x0)
]
library VB6LongPtr {

importlib("stdole2.tlb");

typedef [public] long LongPtr;
};

Attached Files

VB6 Cairo-Paths and Projections

$
0
0
The Demo shows, how to create Path-Objects via simple helper-functions (of return-type cCairoPath) -
and how to "Append" and then "Stroke" these Paths via similar named methods on a cCairoContext.

I guess, this is also a topic for "Makers" (Laser-Cutting, 3D-Printing)...

Simple Path-construction-functions as e.g.:
- a path for a single tooth of a gear (or its horizontal expansion via loop)
- or a single path for a curve, or a circle
are relatively easy to "code by hand".

But what if e.g. a "horizontal line of teeth" (as used on a "rack") needs to follow a curved- or circular track?
Such "combined complex paths" are difficult to "define by hand" -
and that's where the second part of the Demo comes into play:
showing how one can project one path in a way, so that it "follows" another Path.

E.g. if you look at the 1st ScreenShot here, which shows the Demo after it was just starting up:
(showing the "yet un-projected two Paths" which we've generated, a "horizontal line of teeths" and "a circle"):
Name:  PathProjection1.png
Views: 36
Size:  43.3 KB

Ok, now - with a single Method-call (ProjectPathData) on the cairo-context, we can combine the two paths
(producing a combined path for a "42-teeth-gear"):
Name:  PathProjection2.png
Views: 32
Size:  39.1 KB

Third and last image is just showing, that any (horizontally designed) Path-Renderings -
can be projected onto any other (arbitrary) path or curve.
Name:  PathProjection3.jpg
Views: 32
Size:  42.7 KB

Here is the code for a single (empty) Form-Project (which needs a reference to RC6):
Code:

Option Explicit

Const TeethCount = 42, TeethHeight = 5, SinglePeriodDistance = 12

Private CC As cCairoContext, WithEvents Btn As VB.CommandButton
 
Private Sub Form_Load()
  Set Btn = Controls.Add("VB.CommandButton", "Btn") 'add a checkbox dynamically
      Btn.Caption = "Project teeth to circular Path": Btn.Visible = 1
     
  Move Left, Top, ScaleX(590, vbPixels, vbTwips), ScaleY(320, vbPixels, vbTwips)
End Sub

Private Sub Form_Resize() 'the usual lines, to keep CC as a "Form-covering-context
  ScaleMode = vbPixels: Set CC = Cairo.CreateSurface(ScaleWidth, ScaleHeight).CreateContext
  RefreshDrawings False
End Sub

Private Sub Btn_Click()
  RefreshDrawings
  Btn.Caption = "Project teeth to " & IIf(InStr(Btn.Caption, "curved"), "circular Path", "curved Path")
End Sub

Private Sub RefreshDrawings(Optional ByVal UseProjection As Boolean = True)
  CC.Paint 1, Cairo.CreateCheckerPattern
 
  Dim PPath As cCairoPath: Set PPath = CreateProjectionPath()
  Dim TPath As cCairoPath: Set TPath = CreateTeethPath()
 
  If UseProjection Then TPath.ProjectPathData_Using PPath '<- here's where the magic happens (TPath will now "follow along" PPath)

  CC.Save '<- isolates the render-output of our two paths...
    CC.TranslateDrawings 55, 55 '...because we use a transform (here only, to provide some shifting)
   
    RenderStrokedPath PPath, 1, vbBlue
    RenderStrokedPath TPath, 2, vbRed
  CC.Restore
 
  Set Picture = CC.Surface.Picture
End Sub

Sub RenderStrokedPath(Path As cCairoPath, Optional ByVal LineWidth& = 1, Optional ByVal Color&)
  CC.AppendPath Path 'add the Projection-Path to the context
  CC.SetLineWidth LineWidth
  CC.Stroke , Cairo.CreateSolidPatternLng(Color)
End Sub

Function CreateProjectionPath() As cCairoPath
  Dim PC As cCairoContext
  Set PC = Cairo.CreateSurface(1, 1).CreateContext 'ensure a "Projection-Context"
 
  If InStr(Btn.Caption, "curved") Then
    PC.CurveTo 0, 0, 90, 0, 190, 120
    PC.RelCurveTo 120, 150, 90, 0, 190, -66
  Else
    PC.Arc 80, 100, (TeethCount * SinglePeriodDistance) / (2 * Cairo.PI)
  End If

  Set CreateProjectionPath = PC.CopyPath(True) 'return the resulting path
End Function

Function CreateTeethPath(Optional ByVal StepsPerToothPeriod& = 32) As cCairoPath
  Dim PC As cCairoContext, i As Long, j As Long, x As Double, y As Double
  Set PC = Cairo.CreateSurface(1, 1).CreateContext 'ensure a "Projection-Context"
 
  PC.MoveTo 0, 0 'ensure a valid starting-point for the (horizontal to the right) teeth-renderings
 
  For i = 1 To TeethCount 'repeat the whole thing, according to our TeethCount-constant
      AddSingleToothTo PC, x, y, StepsPerToothPeriod
  Next
 
  Set CreateTeethPath = PC.CopyPath(True) 'return the resulting path
End Function

Sub AddSingleToothTo(PC As cCairoContext, x, y, StepsPerToothPeriod)
  Dim i As Long
  For i = 1 To StepsPerToothPeriod 'this loop is a generator for a simpe, single "SinusTooth"
      x = x + SinglePeriodDistance / StepsPerToothPeriod
      y = Sin(i / StepsPerToothPeriod * 2 * Cairo.PI) * TeethHeight
      PC.LineTo x, -y
  Next
End Sub

Have fun,

Olaf
Attached Images
   

VB6 Stock-Data-Rendering via RC6 cChart-Class

$
0
0
The Demo shows, how one can use the built-in cChart-HelperClass of the RC6, to "ease the pain" with:
- correct handling of ChartArea-Offsets
- rendering of x- and y-Axis-Ticks and -Texts at the correct (offset) positions
- and last but not least: "reverse Mouse-Interaction" (resolving to the right Data-Values from Mouse-Coords)

The Project needs only a reference to RC6 - and should only contain...
an empty Form with this code:
Code:

Option Explicit

Private SDD As cStockDataDays

Private Sub Form_Load()
  Caption = "Resize Me": AutoRedraw = True
  Set SDD = New cStockDataDays
  LoadNewDataInto SDD
End Sub

Sub LoadNewDataInto(SDD As cStockDataDays)  'simulate "recent week-data"... (7 added records)
  SDD.ClearData 'reset the SDD-internal Data-Buffers
 
  SDD.AddRecord Date - 6, 115, 125, 110, 135 'Params: xDay, yOpen, yClose, yLow, yHigh
  SDD.AddRecord Date - 5, 135, 155, 130, 160
  SDD.AddRecord Date - 4, 150, 165, 150, 175
  SDD.AddRecord Date - 3, 170, 175, 160, 185
 
  SDD.AddRecord Date - 2, 165, 155, 155, 175 'the last 3 records fullfill a "OpenPrice>ClosePrice"-condition
  SDD.AddRecord Date - 1, 150, 145, 140, 155
  SDD.AddRecord Date - 0, 135, 125, 120, 150 'the last added "Date - 0"-term resolves to "today"
End Sub

Private Sub Form_Resize()
  RefreshChartOn Me 're-render the whole chart in case of a change in Canvas-Size (works with Form or PictureBox)
End Sub

Sub RefreshChartOn(VBCanvas As Object)
  SDD.Chart.OffsL = 50 'change the Values of two ChartArea-Offset-Props from their defaults...
  SDD.Chart.OffsB = 55 '...OffsT and OffsR are available as well of course
 
  'if we have records, then refresh the underlying Chart-Surface (also updating our Form-Canvas)
  If SDD.RecordCount Then SDD.RefreshOn VBCanvas, "Some Chart-Title"
End Sub

'demonstrates reverse-transformation from device-space (xPxl/yPxl MouseCoords), to user-space (time/price Coords)
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  If SDD.RecordCount = 0 Then Exit Sub  '<- do nothing, when the chart doesn't hold any data yet
 
  Dim xPxlChart, yPxlChart, xDataValue, yDataValue 'ByRef-Var definitions (filled in the next line)
  SDD.Chart.MouseCoordsToChartCoords x, y, xPxlChart, yPxlChart, xDataValue, yDataValue
  Caption = Format$(xDataValue + 0.5, "yyyy-mm-dd hh:nn") & "  " & Format$(yDataValue, "$0.00")
End Sub

and a single Drawing-Helper-Class, named cStockDataDays:
Code:

Option Explicit

Public WithEvents Chart As cChart

Private mData(), mRecordCount As Long, mYMin As Double, mYMax As Double

Private Sub Class_Initialize()
  Set Chart = New_c.Chart 'initialize the internal Public Chart-Variable to a new helper-instance
  ClearData 'init the internal Private-Vars to their default-state
End Sub

Public Sub ClearData() 'implemented as a Public Method, to allow a "reset for new Data" also from the outside
  ReDim mData(4, 0): mRecordCount = 0: mYMin = 1E+35: mYMax = -1E+35
End Sub

Public Sub AddRecord(ByVal xDay As Date, ByVal yOpen#, ByVal yClose#, ByVal yLow#, ByVal yHigh#)
  ReDim Preserve mData(0 To 4, mRecordCount) 'prolong our 2D-Array by a "new Row"...
        mData(0, mRecordCount) = xDay '... and copy the incoming params over
        mData(1, mRecordCount) = yOpen
        mData(2, mRecordCount) = yClose
        mData(3, mRecordCount) = yLow
        mData(4, mRecordCount) = yHigh

        Dim i As Long
        For i = 1 To 4 'determine the total y-Min/Max across all Y-Columns (which start at Index 1)
            If mYMin > mData(i, mRecordCount) Then mYMin = mData(i, mRecordCount)
            If mYMax < mData(i, mRecordCount) Then mYMax = mData(i, mRecordCount)
        Next
  mRecordCount = mRecordCount + 1 'increase this for the next round
End Sub

Public Property Get RecordCount() As Long
  RecordCount = mRecordCount
End Property

Public Function RefreshOn(VBCanvas As Object, Optional Title As String) As cCairoSurface 'return the used Surface as well
  VBCanvas.ScaleMode = vbPixels
  Set RefreshOn = Chart.Render(mData, VBCanvas.ScaleWidth, VBCanvas.ScaleHeight, Title) 'the Render-call returns a cCairoSurface
      RefreshOn.DrawToDC VBCanvas.hDC 'Blit the generated content of the returned Surface to the VBCanvas-Obj (a Form or PictureBox)
  If VBCanvas.AutoRedraw Then VBCanvas.Refresh 'call the Refresh-method on the Canvas, in case AutoRedraw is "On"
End Function

'------------------ Event-interface-implementation of cChart -----------------------------
Private Sub Chart_DrawChartBackGroundAndTitle(CC As RC6.cCairoContext, ByVal Title As String)
  CC.Paint 1, Cairo.CreateSolidPatternLng(&H888888)
  CC.SelectFont "Arial", 13, vbBlue, True, True
  CC.DrawText 0, 5, CC.Surface.Width, Chart.OffsT, Title, True, vbCenter, 0, 1
End Sub

Private Sub Chart_DrawChartAreaRect(CC As cCairoContext, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long)
  CC.Rectangle x, y, dx, dy: CC.Fill , Cairo.CreateSolidPatternLng(vbBlack)
End Sub

Private Sub Chart_OverrideAxisProps(Axis As cChartAxis, ByVal CurrentMin As Double, ByVal CurrentMax As Double, ByVal CurrentTickIntervals As Long)
  If mRecordCount = 0 Then Exit Sub 'nothing to do here
  Select Case Axis.Name
    Case "X" 're-adjust the Min/Max-DayValues of the X-Axis to "one day more"
        Axis.Min = mData(0, 0) - 0.5 '...by shifting our Min-DayValue "half a day to the left"
        Axis.Max = mData(0, mRecordCount - 1) + 0.5 '...and the Max-DayValue "half a day to the right"
        Axis.TickIntervals = mRecordCount

    Case "Y" 're-adjust the Y-Axis to the "total Min/Max" we found across all "Y-Fields"
        Axis.Min = mYMin
        Axis.Max = mYMax
  End Select
End Sub

Private Sub Chart_DrawSingleTickForAxis(Axis As cChartAxis, CC As cCairoContext, ByVal TickValue As Variant, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long)
  Select Case Axis.Name
    Case "X"
        If x > Chart.OffsL Then x = x - Axis.TickDistPxl / 2 Else Exit Sub
        CC.DrawLine x, y + dy, x, y + dy + 5, True, 1, vbMagenta
        Axis.DrawTickText CC, x, y + 10, Format$(TickValue, "mmm-dd")
        Axis.DrawTickText CC, x, y + 23, Format$(TickValue, "yyyy")

    Case "Y"
        CC.DrawLine x - 5, y, x, y, True, 1, vbYellow
        Axis.DrawTickText CC, x - 3, y, Format$(TickValue, "0.0")
  End Select
'  Debug.Print Axis.Name, x, y, TickValue, Axis.TickDist, Axis.TickDistPxl
End Sub

Private Sub Chart_DrawData(CC As cCairoContext, DataArr() As Variant, ByVal dx As Long, ByVal dy As Long)
  Dim xPxlSC As Double, yPxlSC As Double, dstPxl As Double, i As Long
      xPxlSC = Chart.AxisCol("X").PxlScaleFac 'get the Axis-ScaleFactors into local Vars, before entering the Loop at the end
      yPxlSC = Chart.AxisCol("Y").PxlScaleFac
      dstPxl = Chart.AxisCol("X").TickDistPxl / 5: If dstPxl > 15 Then dstPxl = 15

  For i = 0 To mRecordCount - 1
      RenderCandleOn CC, i, xPxlSC, yPxlSC, dstPxl, False 'delegate to a helper-routine
  Next
End Sub

Private Sub RenderCandleOn(CC As cCairoContext, ByVal RecIdx&, ByVal xPxlSC#, ByVal yPxlSC#, ByVal dstPxl#, Optional ByVal FillIt As Boolean)
  Dim xDay#:  xDay = mData(0, RecIdx) * xPxlSC
  Dim yOpen#:  yOpen = mData(1, RecIdx) * yPxlSC
  Dim yClose#: yClose = mData(2, RecIdx) * yPxlSC
  Dim yLow#:  yLow = mData(3, RecIdx) * yPxlSC
  Dim yHigh#:  yHigh = mData(4, RecIdx) * yPxlSC
  Dim Color&:  Color = IIf(yClose < yOpen, vbRed, vbGreen)

  If yClose < yOpen And yLow < yHigh Then '<- in this case...
    Dim yTmp#: yTmp = yLow: yLow = yHigh: yHigh = yTmp '...swap yLow and yHigh (for correct "Path-rendering-order")
  End If

  CC.Save 'buffer the prior TransForm-Matrix (the prior Coord-Sys)
    CC.TranslateDrawings xDay, 0 'to be able, to leave out the xDay(Offs) in all x-Params of the following block

    CC.MoveTo 0, yLow
    CC.LineTo 0, yOpen
    CC.LineTo -dstPxl, yOpen: CC.LineTo -dstPxl, yClose
    CC.LineTo 0, yClose
    CC.LineTo 0, yHigh
    CC.LineTo 0, yClose
    CC.LineTo dstPxl, yClose: CC.LineTo dstPxl, yOpen
    CC.LineTo 0, yOpen
  CC.Restore 'restore the prior TransForm-Matrix

  CC.SetSourceColor Color
  CC.SetLineWidth 1
  If FillIt Then CC.Fill True
  CC.Stroke
End Sub

These two code-modules will then produce:
Name:  CandleChart.png
Views: 45
Size:  34.3 KB

Have fun,

Olaf
Attached Images
 

[VB6/VBA] Pure VB6 implementation or SHA-1 hash

$
0
0
This mdSha1.bas is a pure VB6 implementation of the venerable SHA-1 message digest algorithm.

Code:

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

#Const HasPtrSafe = (VBA7 <> 0)
#Const HasOperators = (TWINBASIC <> 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 WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar 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 WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
#End If

Private Const LNG_BLOCKSZ              As Long = 64
Private Const LNG_ROUNDS                As Long = 80

Public Type CryptoSha1Context
    H0                  As Long
    H1                  As Long
    H2                  As Long
    H3                  As Long
    H4                  As Long
    Partial(0 To LNG_BLOCKSZ - 1) As Byte
    NPartial            As Long
    NInput              As Currency
End Type

#If Not HasOperators Then
Private LNG_POW2(0 To 31)          As Long

Private Function ROTL32(ByVal lX As Long, ByVal lN As Long) As Long
    '--- ROTL32 = LShift(X, n) Or RShift(X, 32 - n)
    Debug.Assert lN <> 0
    ROTL32 = ((lX And (LNG_POW2(31 - lN) - 1)) * LNG_POW2(lN) Or -((lX And LNG_POW2(31 - lN)) <> 0) * LNG_POW2(31)) Or _
        ((lX And (LNG_POW2(31) Xor -1)) \ LNG_POW2(32 - lN) Or -(lX < 0) * LNG_POW2(lN - 1))
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
#End If

Private Function ByteSwap(ByVal lX As Long) As Long
    ByteSwap = (lX And &H7F) * &H1000000 Or (lX And &HFF00&) * &H100 Or (lX And &HFF0000) \ &H100 Or (lX And &H7F000000) \ &H1000000 Or _
                -((lX And &H80) <> 0) * &H80000000 Or -((lX And &H80000000) <> 0) * &H80
End Function

Public Sub CryptoSha1Init(uCtx As CryptoSha1Context)
    #If Not HasOperators Then
        Dim lIdx            As Long
       
        If LNG_POW2(0) = 0 Then
            LNG_POW2(0) = 1
            For lIdx = 1 To 30
                LNG_POW2(lIdx) = LNG_POW2(lIdx - 1) * 2
            Next
            LNG_POW2(31) = &H80000000
        End If
    #End If
    With uCtx
        .H0 = &H67452301: .H1 = &HEFCDAB89: .H2 = &H98BADCFE: .H3 = &H10325476: .H4 = &HC3D2E1F0
        .NPartial = 0
        .NInput = 0
    End With
End Sub

#If HasOperators Then
[ IntegerOverflowChecks (False) ]
#End If
Public Sub CryptoSha1Update(uCtx As CryptoSha1Context, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
    Static W(0 To LNG_ROUNDS - 1) As Long
    Static B(0 To 15)  As Long
    Dim lIdx            As Long
    Dim lA              As Long
    Dim lB              As Long
    Dim lC              As Long
    Dim lD              As Long
    Dim lE              As Long
    Dim lTemp          As Long
    Dim lK              As Long
   
    With uCtx
        If Size < 0 Then
            Size = UBound(baInput) + 1 - Pos
        End If
        .NInput = .NInput + Size
        If .NPartial > 0 Then
            lTemp = LNG_BLOCKSZ - .NPartial
            If lTemp > Size Then
                lTemp = Size
            End If
            Call CopyMemory(.Partial(.NPartial), baInput(Pos), lTemp)
            .NPartial = .NPartial + lTemp
            Pos = Pos + lTemp
            Size = Size - lTemp
        End If
        Do While Size > 0 Or .NPartial = LNG_BLOCKSZ
            If .NPartial <> 0 Then
                Call CopyMemory(B(0), .Partial(0), LNG_BLOCKSZ)
                .NPartial = 0
            ElseIf Size >= LNG_BLOCKSZ Then
                Call CopyMemory(B(0), baInput(Pos), LNG_BLOCKSZ)
                Pos = Pos + LNG_BLOCKSZ
                Size = Size - LNG_BLOCKSZ
            Else
                Call CopyMemory(.Partial(0), baInput(Pos), Size)
                .NPartial = Size
                Exit Do
            End If
            '--- sha1 step
            lA = .H0: lB = .H1: lC = .H2: lD = .H3: lE = .H4
            For lIdx = 0 To LNG_ROUNDS - 1
                If lIdx < 16 Then
                    W(lIdx) = ByteSwap(B(lIdx))
                Else
                    #If HasOperators Then
                        lTemp = W(lIdx - 3) Xor W(lIdx - 8) Xor W(lIdx - 14) Xor W(lIdx - 16)
                        W(lIdx) = (lTemp << 1 Or lTemp >> 31)
                    #Else
                        W(lIdx) = ROTL32(W(lIdx - 3) Xor W(lIdx - 8) Xor W(lIdx - 14) Xor W(lIdx - 16), 1)
                    #End If
                End If
                Select Case lIdx
                Case 0 To 19
                    lTemp = (lB And lC) Or ((Not lB) And lD)
                    lK = &H5A827999
                Case 20 To 39
                    lTemp = lB Xor lC Xor lD
                    lK = &H6ED9EBA1
                Case 40 To 59
                    lTemp = (lB And lC) Or (lB And lD) Or (lC And lD)
                    lK = &H8F1BBCDC
                Case 60 To 79
                    lTemp = lB Xor lC Xor lD
                    lK = &HCA62C1D6
                End Select
                #If HasOperators Then
                    lTemp += (lA << 5 or lA >> 27) + lE + lK + W(lIdx)
                #Else
                    lTemp = UAdd(UAdd(UAdd(UAdd(lTemp, ROTL32(lA, 5)), lE), lK), W(lIdx))
                #End If
                lE = lD
                lD = lC
                #If HasOperators Then
                    lC = (lB << 30 Or lB >> 2)
                #Else
                    lC = ROTL32(lB, 30)
                #End If
                lB = lA
                lA = lTemp
            Next
            #If HasOperators Then
                .H0 += lA: .H1 += lB: .H2 += lC: .H3 += lD: .H4 += lE
            #Else
                .H0 = UAdd(.H0, lA): .H1 = UAdd(.H1, lB): .H2 = UAdd(.H2, lC): .H3 = UAdd(.H3, lD): .H4 = UAdd(.H4, lE)
            #End If
        Loop
    End With
End Sub

Public Sub CryptoSha1Finalize(uCtx As CryptoSha1Context, baOutput() As Byte)
    Static B(0 To 4)    As Long
    Dim P(0 To LNG_BLOCKSZ + 9) As Byte
    Dim lSize          As Long
   
    With uCtx
        lSize = LNG_BLOCKSZ - .NPartial
        If lSize < 9 Then
            lSize = lSize + LNG_BLOCKSZ
        End If
        P(0) = &H80
        .NInput = .NInput / 10000@ * 8
        Call CopyMemory(B(0), .NInput, 8)
        Call CopyMemory(P(lSize - 4), ByteSwap(B(0)), 4)
        Call CopyMemory(P(lSize - 8), ByteSwap(B(1)), 4)
        CryptoSha1Update uCtx, P, Size:=lSize
        Debug.Assert .NPartial = 0
        B(0) = ByteSwap(.H0): B(1) = ByteSwap(.H1): B(2) = ByteSwap(.H2): B(3) = ByteSwap(.H3): B(4) = ByteSwap(.H4)
        ReDim baOutput(0 To 19) As Byte
        Call CopyMemory(baOutput(0), B(0), UBound(baOutput) + 1)
    End With
End Sub

Public Function CryptoSha1ByteArray(baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Byte()
    Dim uCtx            As CryptoSha1Context
   
    CryptoSha1Init uCtx
    CryptoSha1Update uCtx, baInput, Pos, Size
    CryptoSha1Finalize uCtx, CryptoSha1ByteArray
End Function

Public Function CryptoSha1Text(sText As String) As String
    Const CP_UTF8      As Long = 65001
    Dim uCtx            As CryptoSha1Context
    Dim lSize          As Long
    Dim baInput()      As Byte
    Dim baOutput()      As Byte
    Dim aSplit(0 To 19) As String
   
    lSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), ByVal 0, 0, 0, 0)
    If lSize > 0 Then
        ReDim baInput(0 To lSize - 1) As Byte
        Call WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), baInput(0), lSize, 0, 0)
    Else
        baInput = vbNullString
    End If
    CryptoSha1Init uCtx
    CryptoSha1Update uCtx, baInput
    CryptoSha1Finalize uCtx, baOutput
    For lSize = 0 To UBound(aSplit)
        aSplit(lSize) = Right$("0" & Hex$(baOutput(lSize)), 2)
    Next
    CryptoSha1Text = LCase$(Join(aSplit, vbNullString))
End Function

cheers,
</wqw>

ADMIN please delete - My bad sorry.

Viewing all 1484 articles
Browse latest View live


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