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

Discrete Probability Detector in [VB6, VBA, JS]

$
0
0
These applications use an algorithm called DPD (Discrete Probability Detector) that transforms any sequence of symbols into a transition matrix. The algorithm may receive special characters from the entire ASCII range. These characters can be letters, numbers or special characters (ie. `7Eu9f$*"). The number of symbol/character types that make up a string, represent the number of states in a Markov chain. Thus, DPD is able to detect the number of states from the sequence and calculate the transition probabilities between these states. The final result of the algorithm is represented by a transition matrix (square matrix) which contains the transition probabilities between these symbol types (or states). The transition matrix can be further used for different prediction methods, such as Markov chains or Hidden Markov Models. This version of DPD is made in HTML/JavaScript/CSS, VB6, VBA (Excel).


Download: Discrete Probability Detector in [VB6, VBA, JS]


Name:  DPD.jpg
Views: 39
Size:  40.3 KB


Code:


Function Discrete_Probability_Detector(ByVal S As String)
 
 
    Dim e() As String

    Dim m() As String

    Dim l(0 To 1) As String
 
 
    k = Len(S)

    w = 1
 
 
    For i = 1 To k

        q = 1

        For j = 0 To Len(a)

            x = Mid(S, i, 1)

            y = Mid(a, j + 1, 1)

            If x = y Then q = 0

        Next j

        If q = 1 Then a = a & x

    Next i


    d = Len(a)

    ReDim e(w To d, 0 To 1) As String

    ReDim m(w To d, w To d) As String

 
    For i = w To d

        For j = w To d

          m(i, j) = 0

          If j = w Then

            e(i, 0) = Mid(a, i, 1)

            e(i, 1) = 0

          End If

        Next j

    Next i
 
 
    For i = 1 To k - 1

        l(0) = Mid(S, i, 1)

        l(1) = Mid(S, i + 1, 1)

        For j = w To d

            If l(0) = e(j, 0) Then

              e(j, 1) = Val(e(j, 1)) + 1

              r = j

            End If

            If l(1) = e(j, 0) Then c = j

        Next j

        m(r, c) = Val(m(r, c)) + 1

    Next i
 
 
    For i = w To d

        For j = w To d

            If Val(e(i, 1)) > 0 Then

                m(i, j) = Val(m(i, j)) / Val(e(i, 1))

            End If

        Next j

    Next i
 
 
End Function

Attached Images
 

Weather forecast with Markov Chains in VB6

$
0
0
These applications use transition matrices to make predictions by using a Markov chain. For exemplification, the values from the transition matrix, in any of the three applications, represent the transition probabilities between two states found in a sequence of observations (ex. s=SRSSSRRRSRRSRRRS). These two states are: Sunny and Rainy, or R and S. Based on the initial probability vector, the application calculates how the weather may be on a number of days. More in-depth information on these matters can be found in the primary source.


Download: Weather forecast with Markov Chains in VB6


Name:  Markov Chains VB6 (1).jpg
Views: 45
Size:  35.6 KB

Name:  Markov Chains VB6 (2).jpg
Views: 41
Size:  36.8 KB

Name:  Markov Chains VB6 (3).jpg
Views: 40
Size:  36.9 KB
Attached Images
   

Genomin

$
0
0
Genomin is an implementation for large-scale genomic analysis. It is made in Visual Basic 6.0 (VB6). It uses the seek method to generate buffers from large FASTA files (over 8 Gb). The screenshot shows the analysis of a ~ 250 MB FASTA file (representing chromosome 1 from Homo Sapiens).


Download: Genomin


Name:  Genomin 1.jpg
Views: 36
Size:  53.4 KB
Attached Images
 

A Markov Chains framework for simulation of behaviour

$
0
0
About Markov Chain Generators. A transition matrix can be calculated based on a training sequence (ex. 1, 2, 3). A Markov Chain Generator (MCG) is a prediction machine that uses a transition matrix to generate sequences that are similar to the training sequence. Thus, the output of a MCG mimics the training sequence that led to the values from the transition matrix and the process itself represents a prediction. Moreover, the MCG can also be used to verify the correct operation of the DPD algorithm. Once the DPD algorithm produces a transition matrix (called here the “original” transition matrix) using a training sequence, that transition matrix can be used by the MCG to predict a similar sequence. In turn, the sequence produced by the MCG can be used by the DPD algorithm to produce a new transition matrix. If the original transition matrix and the transition matrix of the predicted sequence contain close transition probability values, then the DPD algorithm and the MCG machine work as expected.

Markov Chains Simulation framework. The application from below is a MCG that uses probability values from a transition matrix to generate text sequences of 10000 letters in length. At each step a new text sequence is analyzed and the letter frequencies are computed. These frequencies are displayed as signals on a graph at each step in order to capture the overall behavior of the MCG. Note that Markov Chains - Simulation framework is made in Visual Basic 6.0 (VB6).


Download: Markov Chains Simulation framework


Name:  Markov Chains - Simulation framework.jpg
Views: 32
Size:  34.0 KB
Attached Images
 

Markov Chains - Prediction framework

$
0
0
The application multiplies a probability vector with a transition matrix multiple times (n steps - user defined). On each step, the values from the resulting probability vectors are plotted on a chart. The resulting curves on the chart indicate the behavior of the system over n steps. Note that the application allows a prediction for systems with a maximum of four states.


Download: Markov Chains - Prediction framework


Name:  Markov Chains - Prediction framework (new setup).jpg
Views: 41
Size:  28.8 KB

Name:  Markov Chains - Prediction framework.jpg
Views: 41
Size:  26.0 KB

This version in JS can also be of use: Predictions with Markov Chains
Attached Images
  

Markov Chains scanner in VB6

$
0
0
The current VB6 application is a detector that uses two models, a model "+" that is associated with what we are looking for, and a model "-" that is associated with the background. Both models are represented by a transition matrix that is calculated or trained by using two sequences of observations. Namely, a sequence of observations that is known to belong to a region of interest (model "+") and a sequence of observations that may represent either a random sequence or a sequence other than the sequence "+". Once the model sequences have been used to construct the transition matrices for the two models, they are merged into a single matrix, namely into a log-likelihood matrix (LLM). The log-likelihood matrix represents "the memory", a kind of signature that can be used in some detections. But how? A scanner can use this LLM to search for model-like "+" regions inside a longer sequence called z (the target). To search for such regions of interest, sliding windows are used. The content of a sliding window is examined by verifying each transition with the values from the LLM. Once a transition is associated with a value, it is added to the previous result until all transitions in the content of the sliding window are verified. This results in a main score for each sliding window over z. The positive scores (red) indicate the regions that resemble the "+" model, and the negative scores indicate that the content of the sliding window is different from the "+" model.


Download: Markov Chains scanner in VB6


Name:  Markov Chains detector in VB6 (1).jpg
Views: 52
Size:  39.1 KB
Attached Images
 

Markov Chains The weather

$
0
0
This application uses a 2X2 transition matrix to make predictions by using a Markov chain. For exemplification, the values from the transition matrix represent the transition probabilities between two states found in a sequence of observations (ex. s=RSRRSRRSRRRRSRRRSSSRRSRRRS). These two states are: Sunny and Rainy, or R and S. Based on the initial probability vector, the application calculates how the weather may be on a number of days (steps). Note that a transition matrix can be obtained from a series of observations by using the DPD algorithm. Note that Markov Chains - The weather is desidned in Visual Basic 6.0 (VB6), thus, the VB6 IDE is needed.


Download: Markov Chains The weather


Name:  Markov Chains - The weather.jpg
Views: 43
Size:  38.6 KB
Attached Images
 

Simple sequence alignment in VB6

$
0
0
This highly responsive VB6 application is an implementation of the global sequence alignment algorithm. It allows the modification of the alignment parameters (match, mismatch, gap), and it shows the pairwise alignment as well as the score matrix in real time. The purpose of it is to seeks the optimal alignment between two text sequences. Why is this optimal alignment so important? To find similarities between two words, a manual comparison is required. For words between 4 and 8 letters, such a task can be performed by any of us without the use of a computer. However, what if the objects of comparison are entire phrases/sequences/files? Then the number of possibilities for different matches increases exponentially and nobody can do it by paper computing (to my knowledge). Computational solutions for these problems exist, such as different implementations of sequence alignment algorithms. Here, the implementation of global sequence alignment is shown in detail. Note that the implementation si designed in Visual Basic 6.0.


Download: Simple sequence alignment in VB6


Name:  TextAlignDNA (2).jpg
Views: 32
Size:  57.8 KB

Name:  TextAlignDNA (1).jpg
Views: 31
Size:  56.7 KB
Attached Images
  

Visual Sequence Alignment in VB6

$
0
0
This highly visual and responsive VB6 application is an implementation of the global sequence alignment algorithm. It allows the modification of the alignment parameters (match, mismatch, gap), and it shows the pairwise alignment as well as the score matrix in real time. Moreover, it shows the score matrix values as a heatmap and the traceback path of the current alignment. Many predefined experiments are available to the user for certain observations related to the global sequence alignment algorithm. Also, changes to either of the two sequences lead to a real-time pairwise alignment. The purpose of the algorithm is to seeks the optimal alignment between two text sequences. Why is this optimal alignment so important? To find similarities between two words, a manual comparison is required. For words between 4 and 8 letters, such a task can be performed by any of us without the use of a computer. However, what if the objects of comparison are entire phrases/sequences/files? Then the number of possibilities for different matches increases exponentially and nobody can do it by paper computing (to my knowledge). Computational solutions for these problems exist, such as different implementations of sequence alignment algorithms. Here, the implementation of global sequence alignment is shown in detail. Note that the implementation si designed in Visual Basic 6.0. Note: This VB6 application has a child in javascript that can be opened directly in the browser here.


Download: Visual Sequence Alignment in VB6


Name:  AlignDNA in VB6 (2).jpg
Views: 47
Size:  43.5 KB

Name:  AlignDNA in VB6 (1).jpg
Views: 43
Size:  45.5 KB

Name:  AlignDNA in VB6 (3).jpg
Views: 43
Size:  39.6 KB
Attached Images
   

Markov Chains step-by-step algorithms in VBA

$
0
0
This repository includes the ".bas" implementations for Markov Chains that accompany the book entitled: Markov Chains: From Theory to Implementation and Experimentation. These ".bas" files can be used in various VBA Excel applications. This repository also includes an EXCEL file that supports VBA. This file is called "MarkovChainsApp.xlsm" and incorporates all VB ".bas" files with some experimental approaches and textual explanations in regard to these algorithms.

Download: Markov Chains step-by-step algorithms in VBA


Name:  MC.jpg
Views: 36
Size:  32.1 KB
Attached Images
 

[VB6] Undocumented API: SHLimitInputEditWithFlags - Easy input filtering

$
0
0
Name:  inputlim.jpg
Views: 20
Size:  81.0 KB
UNDOCUMENTED API: SHLimitInputEditWithFlags
Easily apply category filters, paste handling, and automated tooltips to an edit control.

Microsoft being Microsoft, they only begrudgingly documented a function called SHLimitInputEdit for the DOJ settlement, and did so poorly. This is a weird function; it takes an edit hwnd, and an object that implements IShellFolder and IItemNameLimits. The former doesn't even matter (unless it's been implemented in newer versions of Windows; I haven't checked). When you implement IItemNameLimits, you get a single call to GetValidCharacters, where you can supply a string of either included or excluded characters (only 1 can be used, so if you specify any excluded characters, included becomes null). It's an odd way of doing things.

But it turns out, that's a front end for an actually much more interesting and useful but completely undocumented, SHLimitInputEditWithFlags, an API Geoff Chappell found as exported at ordinal #754 in shell32.dll (it's still ordinal only in Windows 10, even though it's been kicking around since Windows XP).

This function allows a wide variety of options. Instead of just being able to specify an exact string, you can use CT_TYPE1 categories, which in addition to the standard upper, lower, digits... has some handy options like categories for hexadecimal, punctuation, or control characters. It also implements custom categories; binary, octal, and ASCII a-z/A-Z. It also provides control over the tooltip-- you can have no tooltip, or specify the title, message, and icon (a TTI_* default icon or custom hIcon), and set alignment, width, and timeout (including timing out immediately if a valid input is received). It also handles pasting in several different ways; filtering in the valid chars, pasting until the 1st invalid char, or canceling the paste. If the paste is modified, it puts what was pasted on the clipboard (optionally). The pasting options and automatic control over the tooltip is what really makes this worthwhile over just manually checking KeyPress events or WM_CHAR messages.

Requirements
-No dependencies.
-Function present on Windows XP through at least Windows 10 (I haven't checked 11).

Details

Code:

Public Declare Function SHLimitInputEditWithFlags Lib "shell32" Alias "#754" (ByVal hwndEdit As Long, pil As LIMITINPUTSTRUCT) As Long
SHLimitInputEditWithFlags takes two arguments, an hWnd for an edit control, and an (until this post) undocumented structure. Here's the members and a description:

Code:

Public Type LIMITINPUTSTRUCT
    cbSize As Long      'Size of structure. Must set.
    dwMask As LI_Mask    'LIM_* values.
    dwFlags As LI_Flags  'LIF_* values.
    hInst As Long        'App.hInstance or loaded module hInstance.
    pszFilter As Long    'String via StrPtr, LICF_* category, LPSTR_TEXTCALLBACK to set via LIN_GETDISPINFO, or resource id in .hInst.
    pszTitle As Long    'Optional. String via StrPtr, LPSTR_TEXTCALLBACK to set via LIN_GETDISPINFO, or resource id in .hInst.
    pszMessage As Long  'Ignore if tooltip disabled. String via StrPtr, LPSTR_TEXTCALLBACK to set via LIN_GETDISPINFO, or resource id in .hInst.
    hIcon As Long        'See TTM_SETTITLE. Can be TTI_* default icon, hIcon, or I_ICONCALLBACK to set via LIN_GETDISPINFO.
    hwndNotify As Long  'Window to send notifications to. Must specify if any callbacks used or bad character notifications enabled.
    iTimeout As Long    'Timeout in milliseconds. Defaults to 10000 if not set.
    cxTipWidth As Long  'Tooltip width. Default 500px.
End Type

dwMask is just a list of which of the remaining members should be used:
Code:

'Values for LIMITINPUTSTRUCT.dwMask
Public Enum LI_Mask
    LIM_FLAGS = &H1      'dwFlags used
    LIM_FILTER = &H2    'pszFilter used
    LIM_HINST = &H8      'hinst contains valid data. Generally must be set.
    LIM_TITLE = &H10    'pszTitle used. Tooltip title.
    LIM_MESSAGE = &H20  'pszMessage used. Tooltip main message.
    LIM_ICON = &H40      'hicon used. Can use default icons e.g. IDI_HAND. Loaded from .hInst.
    LIM_NOTIFY = &H80    'hwndNotify used. NOTE: Must be set to receive notifications. Automatic finding of parent broken.
    LIM_TIMEOUT = &H100  'iTimeout used. Default timeout=10000.
    LIM_TIPWIDTH = &H200 'cxTipWidth used. Default 500px.
End Enum

Now we'll get into the core of it with the flags for dwFlags:

Code:

'Values for LIMITINPUTSTRUCT.dwFlags
Public Enum LI_Flags
    LIF_INCLUDEFILTER = &H0    'Default: pszFilter specifies what to include.
    LIF_EXCLUDEFILTER = &H1    'pszFilter specifies what to exclude.
    LIF_CATEGORYFILTER = &H2    'pszFilter uses LICF_* categories, not a string of chars.

    LIF_WARNINGBELOW = &H0      'Default: Tooltip below.
    LIF_WARNINGABOVE = &H4      'Tooltip above.
    LIF_WARNINGCENTERED = &H8  'Tooltip centered.
    LIF_WARNINGOFF = &H10      'Disable tooltip.

    LIF_FORCEUPPERCASE = &H20  'Makes chars uppercase.
    LIF_FORCELOWERCASE = &H40  'Makes chars lowercase. (This and forceupper mutually exclusive)

    LIF_MESSAGEBEEP = &H0      'Default: System default beep played.
    LIF_SILENT = &H80          'No beep.

    LIF_NOTIFYONBADCHAR = &H100 'Send WM_NOTIFY LIN_NOTIFYBADCHAR. NOTE: Must set LIM_NOTIFY flag and .hwndNotify member.
    LIF_HIDETIPONVALID = &H200  'Timeout tooltip early if valid char entered.

    LIF_PASTESKIP = &H0        'Default: Paste any allowed characters, skip disallowed.
    LIF_PASTESTOP = &H400      'Paste until first disallowed character encountered.
    LIF_PASTECANCEL = &H800    'Cancel paste entirely if any disallowed character.

    LIF_KEEPCLIPBOARD = &H1000  'If not set, modifies clipboard to what was pasted after paste flags executed.
End Enum

If you do not use the LIF_CATEGORYFILTER flag, the .pszFilter member must be set to StrPtr(value) where value is a non-delimited string of which characters to allow (by default) or disallow (if LIF_EXCLUDEFILTER flag is included). If you do use the flag, the following categories are valid:
Code:

'Filters support CT_TYPE1 categories:
Public Const LICF_UPPER = &H1
Public Const LICF_LOWER = &H2
Public Const LICF_DIGIT = &H4
Public Const LICF_SPACE = &H8
Public Const LICF_PUNCT = &H10  'Punctuation
Public Const LICF_CNTRL = &H20  'Control characters
Public Const LICF_BLANK = &H40
Public Const LICF_XDIGIT = &H80  'Hexadecimal values, 0-9 and A-F.
Public Const LICF_ALPHA = &H100  'Any CT_TYPE1 linguistic character. Includes non-Latin alphabets.
'Custom categories
Public Const LICF_BINARYDIGIT = &H10000
Public Const LICF_OCTALDIGIT = &H20000 'Base 8; 0-7.
Public Const LICF_ATOZUPPER = &H100000 'ASCII A to Z
Public Const LICF_ATOZLOWER = &H200000 'ASCII a to z
Public Const LICF_ATOZ = (LICF_ATOZUPPER Or LICF_ATOZLOWER)

From there, you're all set to apply basic input limits to an edit control. Remember, if you don't want a tooltip you don't need to set the title, message, and icon, but in that case you must include the LIF_WARNINGOFF flag, or the function will fail. If you are going to have a tooltip, you must as a minimum specify the message.

Advanced

There's a couple flags for advanced options. LIF_NOTIFYONBADCHAR will send hWnd specified by the .hwndNotify member a LIN_BADCHAR notification code in a WM_NOTIFY message. You must subclass the specified hWnd to receive the message (on Windows 10, it will not automatically send them to the parent, but directly to the provided hWnd. That automatic behavior may work on earlier versions, but manually specifying it works on all). From there it has it's own NM structure to copy:

Code:

Public Type NMLIBADCHAR
    hdr As NMHDR
    wParam As Long 'WM_CHAR wParam (Char code)
    lParam As Long 'WM_CHAR lParam (see MSDN for details)
End Type

That gives you the WM_CHAR message.

There's also special handling for WM_PASTE operations built in. The default behavior is to paste whatever characters from the clipboard are allowed, then set the contents of the clipboard to the filtered result. You can change that behavior to only pasting up until the first disallowed character with the LIF_PASTESTOP flag, or to cancel the paste entirely with LIF_PASTECANCEL.

Callbacks

I didn't implement this option in the demo because I don't see a lot of utility for it, but you can specify LPSTR_TEXTCALLBACK for the text fields, and I_ICONCALLBACK for the icon field, and the control will send a LIN_GETDISPINFO message for the tooltip text and LIN_GETFILTERINFO for the filter. I'm not going to detail it, but it works exactly like LVN_GETDISPINFO callbacks for the ListView control, and there's plenty of documentation for that. The constants and structure are included in the Demo if you did want to explore this.

Sample Project

The demo pictured at the top of this post implements a wide array of features, including subclassing for the bad character notifications, but also includes a simple 'Set to numbers only' to show how simple calls to this function can be:
Code:

Dim tli As LIMITINPUTSTRUCT
tli.cbSize = Len(tli)
tli.dwMask = LIM_FILTER Or LIM_FLAGS
tli.dwFlags = LIF_CATEGORYFILTER Or LIF_WARNINGOFF
tli.pszFilter = LICF_DIGIT

SHLimitInputEditWithFlags Text1.hWnd, tli

That's all you need to do to have a textbox take only numbers, with no tooltip.


And that's it! Enjoy this undocumented treasure from the Windows API.

IMPORTANT: This is an undocumented, internal API, with all the issues that involves. There may be small variations in functionality between Windows versions, stability is not guaranteed, and it may be removed at any time from future versions, or have it's ordinal changed.
Attached Images
 
Attached Files

Spectral Forecast equation for signals (VB6)

$
0
0
Intro
This project uses my own mathematical model published in the Chaos journal. The model is called Spectral Forecast. The Spectral Forecast equation is a part of the Spectral Forecast model. The Spectral Forecast equation was initially used on matrices and can be used on other multidimensional mathematical objects. Here, a new utility is demonstrated for signals by using the equation on vectors of the same size.

Spectral Forecast equation (VB6 app 1.0)
Spectral Forecast equation (VB6 app 1.0) - is a demo application designed in Visual Basic 6.0, that is able to mix two signals in arbitrary proportions. Different cases can be seen, with two different waveform signals that are combined depending on the value of a so-called distance d. This distance d is defined from zero to the maximum value found above the two vectors that represent these signals. Note that the implementation of Spectral Forecast equation (VB6 app 1.0) has an issue with the autoredraw setting in the case of Form1 (a VB6 specific issue). Thus, certain real-time processing delays can be observed. However, the version 2.0 that can be found here does not pose a problem with autoredraw.

Download: Spectral Forecast equation (VB6)

Name:  sf3.jpg
Views: 41
Size:  40.1 KB

Name:  sf4.jpg
Views: 43
Size:  22.2 KB
Attached Images
  

Mix two signals by using Spectral Forecast in VB6

$
0
0
This project uses my own mathematical model published in the journal Chaos. The model is called Spectral Forecast. The Spectral Forecast equation is a part of the Spectral Forecast model and it was initially used on matrices. It can also be used on other multidimensional mathematical objects. Here, a new utility is demonstrated for signals by using the equation on vectors of the same size. Spectral Forecast equation for signals (VB6 app 2.0) - is a demo application designed in Visual Basic 6.0, that is able to mix two signals in arbitrary proportions. Different cases can be seen, with two different waveform signals that are combined depending on the value of a parameter called distance d. This distance d may be set from zero to the maximum value (Max(d)) found above the two vectors that represent these signals.

Download: Mix two signals by using Spectral Forecast in VB6

Name:  sf6.jpg
Views: 41
Size:  37.9 KB

Name:  sf5.jpg
Views: 38
Size:  26.4 KB

Name:  sf4.jpg
Views: 40
Size:  22.2 KB
Attached Images
   

Liquidity planner: new WebView2 demo application

$
0
0
Like last year's "Vacation Planner" (https://www.vbforums.com/showthread....light=webview2), the "Liquidity Planner" is a small but complete VB6 application whose GUI is entirely based on the Microsoft Edge WebView2 runtime. The glue between the application and WebView2 is once again Olaf Schmidt's RC6 (vbrichclient.com).

Name:  LiqPlanS.jpg
Views: 23
Size:  36.8 KB

A few (german) explanations about the software, incl. a demo video can be found at http://www.ww-a.de/liqplaner.html

VB6-Sources: liqplaner_sources.zip
Attached Images
 
Attached Files

Small Collection of RC6 Helper Methods

$
0
0
In case they are of use to anyone else, I'm posting a few small RC6 helper methods that I use quite frequently alongside my RC6 apps. Nothing earth shaking here, but these methods can help reduce some lines of code and some are useful for things like caching recordsets and collections.

I'll likely add more to this thread as I create them, and I'd also be happy to see any methods you've created in the comments.

Notes:

Rc6CollectionHash - Takes an RC6 cCollection object or cCollection.Content byte array and returns a Hash (SHA256 Lowercase Hex string by default, but Uppercase Hex and ByteArray results are possible via the optional p_HashAlgorithm and p_HashFormat parameters).

Rc6RecordsetHash - Takes an RC6 cRecordset object and returns a Hash (SHA256 Lowercase Hex string by default, but Uppercase Hex and ByteArray results are possible via the optional p_HashAlgorithm and p_HashFormat parameters). Note that the cRecordset object must have been create via an SQL SELECT statement.

LZMADeCompInplace - Takes a byte array that was previously compressed via an LZMAComp method, and swaps it out for decompressed data in-place.

LZMADeCompReturn - Takes a byte array that was previously compressed via an LZMAComp method, and returns the decompressed data as a byte array.

LZMACompInplace - Takes a byte array of data and compresses it using the LZMA algorithm, swapping out the decompressed data for the compressed data in-place.

LZMACompReturn - Takes a byte array of data and compresses it using the LZMA algorithm, returning the compressed data as a byte array.


Code:

Code:

Option Explicit

Public Enum e_HashAlgorithm
  hashalgo_SHA256
  hashalgo_SHA1
  hashalgo_SHA384
  hashalgo_SHA512
  hashalgo_MD5
End Enum

Public Enum e_HashFormat
  hashformat_HexLowerCase
  hashformat_HexUpperCase
  hashformat_ByteArray
End Enum

Public Function Rc6CollectionHash(p_CollectionOrContentBytes As Variant, _
                                  Optional ByVal p_HashAlgorithm As e_HashAlgorithm = hashalgo_SHA256, _
                                  Optional ByVal p_HashFormat As e_HashFormat = hashformat_HexLowerCase) As Variant
  ' Returns a Hash string/byte-array (dependent on the p_HashFormat parameter value)
  ' Defaults to returning a SHA256 lower-case hex string
 
  Const c_SepSize As Long = 12  ' This is the length of the unique sequence that separates RC6 collection items
 
  Dim la_Content() As Byte  ' cCollection content
  Dim la_ZeroMem(65) As Byte ' An empty array for zeroing out unique separator sequences
  Dim la_Sep() As Byte ' The unique separator sequence
  Dim l_HashAsHex As Boolean ' When true, we will return the hash as a Hex string. When false, a Byte Array will be returned
  Dim l_Ubound As Long
  Dim ii As Long
  Dim jj As Long
 
  If IsObject(p_CollectionOrContentBytes) Then
      ' We have a cCollection object, so get the content from the object
      la_Content = p_CollectionOrContentBytes.Content
 
  Else
      If VarType(p_CollectionOrContentBytes) = vbByte Or vbArray Then
        ' We have a byte array (presumanly cCollection content)
        la_Content = p_CollectionOrContentBytes
      Else
        ' We have junk, raise an error
        Err.Raise 5, , "Byte array or cCollection class required."
      End If
  End If
 
  ReDim la_Sep(c_SepSize - 1)
 
  ' The unique separator is stored at the end of the collection content
  ' So we will get it from there
  l_Ubound = UBound(la_Content) - (c_SepSize - 1)
  New_c.MemCopy VarPtr(la_Sep(0)), VarPtr(la_Content(l_Ubound)), c_SepSize
 
  ' Loop through the collection to find the unique identifier
  ' Zero out all unique identifiers so that Collections with exact matching key/value content
  ' will always return the same hash (since the unique separators have been removed).
  For ii = 0 To UBound(la_Content) - 67
      For jj = 0 To c_SepSize - 1
        If la_Content(ii + jj) <> la_Sep(jj) Then
            ' This is not a unique separator, so exit the loop
            Exit For
        End If
      Next jj
     
      If jj = c_SepSize Then
        ' The previous loop ran until the end, so we have found a unique separator.
        ' Zero it out so that it won't be part of our hash calculation
        New_c.MemCopy VarPtr(la_Content(ii)), VarPtr(la_ZeroMem(0)), c_SepSize + 4
       
        ii = ii + c_SepSize + 3 ' Jump over the separator + 4 bytes (we use +3 because we will i+1 at the Next loop point)
      End If
  Next ii
     
  ' Zero out record keeping stuff from the end of the content
  ' that can change between otherwise identical key/value content collections
  ' So that we always generate the same hash for the same key/value content
  New_c.MemCopy VarPtr(la_Content(UBound(la_Content) - 66)), VarPtr(la_ZeroMem(0)), 66
 
  ' Hash the key/value content
  l_HashAsHex = (p_HashFormat <> hashformat_ByteArray)
 
  Select Case p_HashAlgorithm
  Case hashalgo_SHA256
      Rc6CollectionHash = New_c.Crypt.SHA256(la_Content, l_HashAsHex)
     
  Case hashalgo_SHA1
      Rc6CollectionHash = New_c.Crypt.SHA1(la_Content, l_HashAsHex)
 
  Case hashalgo_SHA384
      Rc6CollectionHash = New_c.Crypt.SHA384(la_Content, l_HashAsHex)
 
  Case hashalgo_SHA512
      Rc6CollectionHash = New_c.Crypt.SHA512(la_Content, l_HashAsHex)
 
  Case hashalgo_MD5
      Rc6CollectionHash = New_c.Crypt.MD5(la_Content, l_HashAsHex)
 
  Case Else
      Err.Raise 5, , "Unknown hash type: " & p_HashAlgorithm
  End Select
 
  If p_HashFormat = hashformat_HexUpperCase Then
      Rc6CollectionHash = UCase$(Rc6CollectionHash)
  End If
End Function

Public Function Rc6RecordsetHash(po_Recordset As RC6.cRecordset, _
                                Optional ByVal p_HashAlgorithm As e_HashAlgorithm = hashalgo_SHA256, _
                                Optional ByVal p_HashFormat As e_HashFormat = hashformat_HexLowerCase) As Variant
  Dim la_Sql() As Byte ' SQL statement that produce the recordset
  Dim la_Content() As Byte  ' RS content to hash
  Dim l_HashAsHex As Boolean ' When true, we will return the hash as a Hex string. When false, a Byte Array will be returned
  Dim l_Start As Long  ' Start of hashable array data
  Dim l_Len As Long ' Length of hashable array data
 
  ' Find the SQL statement in the recordset content.
  ' The bytes after the SQL statement will produce identical hashes
  ' for indentical RS content selected by any SQL statement
 
  ' Special thanks to Olaf Schmidt for the idea to search the RS for the SQL statement
  ' and begin hashing from after that point in order to ensure identical RS content produces an identical hash value
 
  la_Sql = po_Recordset.SQL
  If UBound(la_Sql) = -1 Then
      Err.Raise 5, , "This method requires a recordset that was created by an SQL statement."
  End If
 
  la_Content = po_Recordset.Content
 
  l_Start = InStrB(1, la_Content, la_Sql) + UBound(la_Sql) + 1
  l_Len = (UBound(la_Content) + 1) - l_Start + 1
 
  ' Remove everything before and including the SQL statement from the content array
  New_c.MemCopy VarPtr(la_Content(0)), VarPtr(la_Content(l_Start - 1)), l_Len
  ReDim Preserve la_Content(l_Len - 1)
 
  ' Hash the remaing byte array content
  l_HashAsHex = (p_HashFormat <> hashformat_ByteArray)
 
  Select Case p_HashAlgorithm
  Case hashalgo_SHA256
      Rc6RecordsetHash = New_c.Crypt.SHA256(la_Content, l_HashAsHex)
     
  Case hashalgo_SHA1
      Rc6RecordsetHash = New_c.Crypt.SHA1(la_Content, l_HashAsHex)
 
  Case hashalgo_SHA384
      Rc6RecordsetHash = New_c.Crypt.SHA384(la_Content, l_HashAsHex)
 
  Case hashalgo_SHA512
      Rc6RecordsetHash = New_c.Crypt.SHA512(la_Content, l_HashAsHex)
 
  Case hashalgo_MD5
      Rc6RecordsetHash = New_c.Crypt.MD5(la_Content, l_HashAsHex)
 
  Case Else
      Err.Raise 5, , "Unknown hash type: " & p_HashAlgorithm
  End Select
 
  If p_HashFormat = hashformat_HexUpperCase Then
      Rc6RecordsetHash = UCase$(Rc6RecordsetHash)
  End If
End Function

' LZMAComp/Decomp Helpers to make it possible to use less code/dims in certain scenarios.
' The "Inplace" versions overwrite the passed byte array with the resulting compressed/decompressed byte array
' The "Return" versions return an appropriately compressed/decompressed byte array.

Public Sub LZMADeCompInplace(pa_CompressedBytes() As Byte)
  Dim la_DecompressedBytes() As Byte
 
  New_c.Crypt.LZMADeComp pa_CompressedBytes, la_DecompressedBytes
  pa_CompressedBytes = la_DecompressedBytes
End Sub

Public Function LZMADeCompReturn(pa_CompressedBytes() As Byte) As Byte()
  Dim la_DecompressedBytes() As Byte
 
  New_c.Crypt.LZMADeComp pa_CompressedBytes, la_DecompressedBytes
  LZMADeCompReturn = la_DecompressedBytes
End Function

Public Sub LZMACompInplace(pa_UncompressedBytes() As Byte, Optional ByVal Level_0to9 As Long = 4, Optional ByVal DictSizePowerOfTwo As Long = 4194304)
  Dim la_CompressedBytes() As Byte
 
  New_c.Crypt.LZMAComp pa_UncompressedBytes, la_CompressedBytes, Level_0to9, DictSizePowerOfTwo
  pa_UncompressedBytes = la_CompressedBytes
End Sub

Public Function LZMACompReturn(pa_UncompressedBytes() As Byte, Optional ByVal Level_0to9 As Long = 4, Optional ByVal DictSizePowerOfTwo As Long = 4194304) As Byte()
  Dim la_CompressedBytes() As Byte
 
  New_c.Crypt.LZMAComp pa_UncompressedBytes, la_CompressedBytes, Level_0to9, DictSizePowerOfTwo
  LZMACompReturn = la_CompressedBytes
End Function

Enjoy!

Micro chart in VB

$
0
0
This compact chart takes into account both positive and negative values from an input. Thus, this VB chart takes into account a lower bound as well as an upper bound. The lower bound represents the lowest value whereas the upper bound represents the highest value over the input. The project in this repository shows two VB charts and both use the PictureBox object from VB6.

Download: Micro chart in VB

The first project found in folder src/chart_short contains the shortest source code for a chart. Basically the implementation is represented by a function named chart that draws on a PictureBox object based on some consecutive numeric values. The second chart found in folder src/chart contains an addition to the first, namely it draws the x-axis and y-axis, and the corresponding baseline ticks.

Name:  chart_short.jpg
Views: 45
Size:  11.5 KB

The second chart project shows an addition to the first, namely it draws the x-axis and y-axis, and the corresponding baseline ticks. Also, the position of the chart can be changed inside the object with the help of four variables responsible for the vertical position, the horizontal position, the width of the chart and the height of the chart. The screenshot below shows the output of the function:

Name:  chart (1).jpg
Views: 45
Size:  18.0 KB
Attached Images
  

FYI: Store many images as StdPicture without hitting the GDI objects limit

$
0
0
I recently had to store many images that are StdPicture objects.
The problem is that each one create a new GDI object, and the (default) limit of max GDI objects is 1000.
(It is set on the key HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows\GDIProcessHandleQuota)

One solution would be to store them in disk, but that would have been slow (to save and load), so I wanted to keep them on memory.

To convert StdPictures to byte arrays using API would have required a lot of work, since the pictures can be Icons, Bitmaps or Windows metafiles. Also if they were just bitmaps, they can be 8, 16, 32 bits, with palette or even monochrome.
To handle all possible formats would have required lot of code and testing.

But there is a very simple solution: use PropertyBags.

It is easy to store pictures into a PropertyBag object, and when needed back to StdPicture.

I had code like this (air code):

Code:

Private mPictures() as StdPicture

Private Sub StorePictures()
    Dim c As Long

    ReDim mPictures(12000)
    For c = 0 To 12000   
        Set mPictures(c) = [Some pic  in StdPicture format]
    Next
End Sub

Public Property Get MyPicture(Index As Long) As StdPicture
    Set MyPicture = mPictures(Index)
End Property

Turned to this:

Code:

Private mPictures() as PropertyBag

Private Sub StorePictures()
    Dim c As Long
    Dim pb As PropertyBag

    ReDim mPictures(12000)
    For c = 0 To 12000   
        Set pb = New PropertyBag
        pb.WriteProperty "i",  [Some pic  in StdPicture format]
        Set mPictures(c) = pb
    Next
End Sub

Public Property Get MyPicture(Index As Long) As StdPicture
    Set MyPicture = mPictures(Index).ReadProperty("i")
End Property

It does not use any system GDI object.
It is of course a bit slower, but not much.

Helper functions to avoid running out of resources

$
0
0
A process has limited resources available.
They can be of several kinds, here we cover GDI objects, RAM and Disk.

If your program must be able to handle, or at least not to crash with huge amounts of data, you'll probably will need to check resources to see if you can safely do something, or decide to use files over variables, or whatever.

The normal GDI object limit is of 10000. Each font, bitmap, pen, brush, metafile, etc consume GDI handles.
The actual value of GDI the handles limit can be found on the registry key
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows\GDIProcessHandleQuota

About the RAM memory, a 32 bits process can use as much as 2 GB.

And the disk, is the free space on the system unit.

Here are the functions:

Code:

Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long

Private Type PROCESS_MEMORY_COUNTERS_EX
    cb As Long
    PageFaultCount As Long
    PeakWorkingSetSize As Long
    WorkingSetSize As Long
    QuotaPeakPagedPoolUsage As Long
    QuotaPagedPoolUsage As Long
    QuotaPeakNonPagedPoolUsage As Long
    QuotaNonPagedPoolUsage As Long
    PagefileUsage As Long
    PeakPagefileUsage As Long
    PrivateUsage As Long
End Type

Private Declare Function GetProcessMemoryInfo Lib "PSAPI.DLL" (ByVal hProcess As Long, ppsmemCounters As PROCESS_MEMORY_COUNTERS_EX, ByVal cb As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetGuiResources Lib "user32.dll" (ByVal hProcess As Long, ByVal uiFlags As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long


Public Function FolderExists(ByVal nFolderPath As String) As Boolean
    On Error Resume Next

    FolderExists = (GetAttr(nFolderPath) And vbDirectory) = vbDirectory
    Err.Clear
End Function

Public Function GetTempFolder() As String
    Dim lChar As Long
    Static sValue As String
   
    If sValue = "" Then
        sValue = String$(255, 0)
        lChar = GetTempPath(255, sValue)
        sValue = Left$(sValue, lChar)
        If Right$(sValue, 1) <> "\" Then sValue = sValue & "\"
    End If
    GetTempFolder = sValue
End Function

Public Function GetProcessTempPath() As String
    Static sValue As String
   
    If sValue = "" Then
        sValue = GetTempFolder & "BSP_temp" & CStr(GetCurrentProcessId)
        If Right$(sValue, 1) <> "\" Then sValue = sValue & "\"
        If Not FolderExists(sValue) Then
            MkDir sValue
        End If
    End If
    GetProcessTempPath = sValue
End Function

Public Function GDIResourcesLow() As Boolean
    Static sMaxGDIObjects As Long
    Const GR_GDIOBJECTS = 0
    Const HKEY_LOCAL_MACHINE = &H80000002
    Dim iGDICount As Long
   
    If sMaxGDIObjects = 0 Then
        sMaxGDIObjects = QueryRegValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows", "GDIProcessHandleQuota")
        If sMaxGDIObjects = 0 Then
            sMaxGDIObjects = 9000
        Else
            sMaxGDIObjects = sMaxGDIObjects - 1000
        End If
        If sMaxGDIObjects < 100 Then sMaxGDIObjects = 100
    End If
   
    iGDICount = GetGuiResources(GetCurrentProcess, GR_GDIOBJECTS)
    GDIResourcesLow = (iGDICount >= sMaxGDIObjects)
End Function

Public Function GDIResourcesCritical() As Boolean
    Static sMaxGDIObjects As Long
    Const GR_GDIOBJECTS = 0
    Const HKEY_LOCAL_MACHINE = &H80000002
    Dim iGDICount As Long
   
    If sMaxGDIObjects = 0 Then
        sMaxGDIObjects = QueryRegValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows", "GDIProcessHandleQuota")
        If sMaxGDIObjects = 0 Then
            sMaxGDIObjects = 9500
        Else
            sMaxGDIObjects = sMaxGDIObjects - 500
        End If
        If sMaxGDIObjects < 150 Then sMaxGDIObjects = 150
    End If
   
    iGDICount = GetGuiResources(GetCurrentProcess, GR_GDIOBJECTS)
    GDIResourcesCritical = (iGDICount >= sMaxGDIObjects)
End Function

Public Function GetGDIUsedObjectsCount() As Long
    Const GR_GDIOBJECTS = 0
   
    GetGDIUsedObjectsCount = GetGuiResources(GetCurrentProcess, GR_GDIOBJECTS)
End Function

Public Function FreeMemoryAvailableIsLow() As Boolean
    Dim pmc As PROCESS_MEMORY_COUNTERS_EX
    Dim iProcessHandle As Long
    Dim LRet As Long
    Const PROCESS_QUERY_INFORMATION = 1024
    Const PROCESS_VM_READ = 16
   
    iProcessHandle = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, GetCurrentProcessId)
    If iProcessHandle = 0 Then Exit Function
   
    pmc.cb = LenB(pmc)
    LRet = GetProcessMemoryInfo(iProcessHandle, pmc, pmc.cb)
    If LRet = 0 Then Exit Function
    FreeMemoryAvailableIsLow = pmc.WorkingSetSize > 1600000000
    LRet = CloseHandle(iProcessHandle)
End Function

Public Function FreeMemoryAvailableIsCritical() As Boolean
    Dim pmc As PROCESS_MEMORY_COUNTERS_EX
    Dim iProcessHandle As Long
    Dim LRet As Long
    Const PROCESS_QUERY_INFORMATION = 1024
    Const PROCESS_VM_READ = 16
    iProcessHandle = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, GetCurrentProcessId)
    If iProcessHandle = 0 Then Exit Function
   
    pmc.cb = LenB(pmc)
    LRet = GetProcessMemoryInfo(iProcessHandle, pmc, pmc.cb)
    If LRet = 0 Then Exit Function
    FreeMemoryAvailableIsCritical = pmc.WorkingSetSize > 1700000000
    LRet = CloseHandle(iProcessHandle)
End Function

Public Function FreeDiscSpaceIsCritical() As Boolean
    Dim BytesFreeToCalller As Currency, TotalBytes As Currency
    Dim TotalFreeBytes As Currency, TotalBytesUsed As Currency
   
    If GetDiskFreeSpaceEx(GetTempFolder, BytesFreeToCalller, TotalBytes, TotalFreeBytes) Then
        FreeDiscSpaceIsCritical = (CCur(100) * BytesFreeToCalller \ TotalBytes < 1)
    End If
End Function

HTH.
Attached Files

Binary files inside EXCEL VBA

$
0
0
This application converts any executable file to VBA source code that can be included as a '.bas' module in an EXCEL file. Once inserted into the EXCEL file, the VBA code can be used to completely restore the executable file to disk in the same directory as the EXCEL file. Also, once recomposed on disk, the executable file can be executed automatically. Use the EXCEL file in the "test" directory for testing.


Download: Binary files inside EXCEL VBA


Name:  scr.jpg
Views: 91
Size:  52.3 KB

Name:  excel.jpg
Views: 161
Size:  34.1 KB

Name:  hex.jpg
Views: 88
Size:  17.6 KB
Attached Images
   

Binary metamorphosis

$
0
0
The VB6 applications shown here use the hexadecimal system to encode the binary content of an executable file. The point here is that one may compile an executable file that contains another executable file inside. Once the new executable file is executed, it is able to write the embedded executable file on disk as an independent executable file.


Download: Binary metamorphosis


Name:  2.jpg
Views: 32
Size:  59.7 KB


Name:  tini.jpg
Views: 31
Size:  15.1 KB
Attached Images
  
Viewing all 1484 articles
Browse latest View live


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