VB6 API Viewer Database Editor

February 26, 2018, 7:21 am

≫ Next: Simple Statistics

≪ Previous: SuperTrim Function for strings

$

0

0

Here is a small utility i wrote that allows you to edit the api files that come with the API Viewer 2004.

The APIViewer2004 is a nice upgrade from MS's old api viewer made by Christoph Von Wittich, but both are getting long in the tooth. I still use APIViewer2004 to this day but it hasnt been updated since 2008 (that i know of). Many new api calls, constants, enums, and types have been added to the Win32 API since that time. However, the APIViewer2004 has no ability to edit or add to the existing file databases. I decided to write this small utility to be able to add functions, types, consts, and enums to the existing APIViewer2004 files. So i sat down and reverse-engineered that database format and cobbled together this little utility. It only uses Intrinsic VB controls and could use some help on the GUI design. But as this was intended originally just for my own use so i wasnt that worried about the looks. I thought others might find it useful so i went through, tidied up the code a bit and decided to release it. After figuring out the database format, i think i will come up with a better database format and perhaps a new Add-In unless someone else beats me to it, it is not high on the list of priorities but i may do it sometime.

What this code can help you with:

1. Show how to load and save the api databases
2. Add more API calls to your own api viewer
3. how not to design a GUI




If any bugs are found, improvements made etc, i would appreciate a heads up! enjoy...

Attached Images

 

Attached Files

• apiedit.zip (47.4 KB)

---

Simple Statistics

March 1, 2018, 4:56 pm

≫ Next: URLEncode in UTF-8 with Visual Basic 6 (Sending Unicode SMS message)

≪ Previous: VB6 API Viewer Database Editor

$

0

0

Mar 03, 2018 Added more features. And continued polishing.
Mar 05, 2018 Added the Mode calculation.

----

I've started a similar CodeBank thread before, but I'm now thinking I went too complex, as there was no interest. Just looking around earlier today, I saw a request under a CodeBank entry by The Trick. At this point, I've addressed all the requests made by CreativeDreamer.

Basically, I've just provided some one-sample statistical functions. I've also made a decision on how to handle missing values. I've struggled with this in VB6. One option is certainly the use of Variant. However, I've never been terribly happy with that option. Therefore, I've decided on sticking with Double arrays for my data, and using the IEEE Double NaN value to denote missing values. This can be seen in the code.

Now, for the uninitiated, NaN values can be a bit tricky. They're somewhat similar to the Null value, but even more restrictive. Once you get a NaN, you can continue to do math with it, but the results will be NaN (similar to Null in Variants). However, you can't do Boolean comparisons with a NaN. In other words, they'll crash if used in an If statement. Therefore, anyone using these functions, needs to develop a practice of checking return values with the IsNan() function. This will keep you out of trouble.

Now, most of what I did is straight-forward. However, I did dip into calculating a p-value (and confidence intervals), which requires "distributions". I've leaned on the ALGLIB project to derive my PDF (probability distribution function [not portable document format]) and CDF (cumulative distrubution function) values.

The first part doesn't require this though. I've attached a complete project. If you're interested, focus first on the modSimpleStats module. Here's the part of that module that doesn't use distributions. It's stand-alone:

Code:

---

Option Explicit
'
' List of "helper" procedures:
'  NaN
'  IsNaN
'  ChangeMissingToNaN
'  DblDims
'  SortData
'  FilterNaNs
'
' List is statistics procedures:
'  Min
'  Max
'  Count
'  Sum
'  Mean
'  Mode
'  SumSq
'  SumSqDiff
'  VariancePop or MeanSqPop
'  VarianceSamp or MeanSqSamp
'  StDevPop
'  StDevSamp
'  StErr
'  OneSampleStudentT
'  OneSampleTTestPValue
'  OneSampleConfInt
'
'  Quantile
'  Percentile
'  Quartile
'  Median
'  Range
'  InterQuartileRange
'
'
Private Declare Sub GetMem1 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any)
Private Declare Sub GetMem2 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any)
Private Declare Sub GetMem4 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any)
Private Declare Sub GetMem8 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any)
Private Declare Function ArrPtr Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) As Long
'

' *******************************************
' *******************************************
'
' We start with some "helper" functions.
'
' *******************************************
' *******************************************

Public Function NaN() As Double
    ' Math can be done on these, but nothing changes.
    ' They can NOT be used in "if NaN = NaN Then", or an overflow will result.  Use IsNaN().
    '
    Const bb7 As Byte = &HF8
    Const bb8 As Byte = &HFF
    '
    GetMem1 bb7, ByVal VarPtr(NaN) + 6&
    GetMem1 bb8, ByVal VarPtr(NaN) + 7&
End Function

Public Function IsNaN(D As Double) As Boolean
    ' Infinity also returns TRUE, but we shouldn't be running across infinities.
    '
    Static bb(1 To 8) As Byte
    Const bb7 As Byte = &HF0    ' High 4 bits of byte #7. \
    Const bb8 As Byte = &H7F    ' Low  7 bits of byte #8. /  If all on, it's NaN (or Inf if all other non-sign bits are zero).
    '
    GetMem8 D, bb(1)
    IsNaN = ((bb(7) And bb7) = bb7) And ((bb(8) And bb8) = bb8)
End Function

Public Sub FilterNaNs(dIn() As Double, dOut() As Double)
    ' Done as a SUB to reduce memory load.
    '
    Dim i As Long
    Dim ptr As Long
    '
    Erase dOut                                                          ' Make sure we start clean.
    If DblDims(dIn) <> 1 Then Exit Sub
    ReDim dOut(LBound(dIn) To UBound(dIn))
    ptr = LBound(dIn) - 1&
    For i = LBound(dIn) To UBound(dIn)
        If Not IsNaN(dIn(i)) Then
            ptr = ptr + 1&
            dOut(ptr) = dIn(i)
        End If
    Next i
    If ptr < LBound(dIn) Then Erase dOut: Exit Sub                      ' No valid data.
    If ptr <> UBound(dOut) Then ReDim Preserve dOut(LBound(dOut) To ptr)
End Sub

Public Sub ChangeMissingToNaN(D() As Double, Optional MissingValue As Double = 0&)
    ' This changes the array "in place" to save memory.
    ' Just call:    ChangeMissingToNaN YourArray
    ' Or:          Call ChangeMissingToNaN(YourArray, MissingValue)
    '
    Dim i As Long
    '
    If DblDims(D) <> 1 Then Exit Sub
    For i = LBound(D) To UBound(D)
        If Not IsNaN(D(i)) Then If D(i) = MissingValue Then D(i) = NaN
    Next i
End Sub

Public Function DblDims(D() As Double) As Integer
    ' Returns the number of dimensions in an array, or 0 if not dimmed.
    ' Works on both Static and Dynamic arrays.
    Dim pSA As Long
    '
    GetMem4 ByVal ArrPtr(D), pSA
    If pSA <> 0& Then GetMem2 ByVal pSA, DblDims
End Function
     
Public Sub SortData(D() As Double, Optional Descending As Boolean = False)
    ' This sort is performed "in place" with d() to preserve memory usage, so be sure to make a copy if you want to save the original order.
    ' Also, this sort algorithm is not designed to work with NaNs in the data, so be sure to filter them before using.
    '
    Dim dComp As Double
    Dim dSwap As Double
    '
    Dim iJumps() As Long
    Dim iMkr As Long
    Dim iLp1 As Long
    Dim iLp2 As Long
    Dim iTmp As Long
    Dim iJmp As Long
    Dim iCnt As Long
    Dim iLbd As Long
    '
    If DblDims(D) <> 1 Then Exit Sub        ' Must be a one-dimensional array.
    iCnt = UBound(D) - LBound(D) + 1&
    If iCnt < 2& Then Exit Sub              ' Must have something to sort.
    ' Setup.
    iLbd = LBound(D)
    ReDim iJumps(99&)
    iJumps(0&) = 1&: iJumps(1&) = 4&: iJumps(2&) = 13&
    iMkr = 0&
    Do While iJumps(iMkr + 2&) < iCnt
        iMkr = iMkr + 1&
        If iMkr + 2& > UBound(iJumps) Then ReDim Preserve iJumps(LBound(iJumps) To UBound(iJumps) + 100&)
        iJumps(iMkr + 2&) = 3& * iJumps(iMkr + 1&) + 1&
    Loop
    ' We do this test here to keep speed up (not doing test in the loop).
    If Descending Then
        For iLp1 = iMkr To 0& Step -1&
            iJmp = iJumps(iLp1)
            For iLp2 = iJmp To iCnt - 1&
                iTmp = iLp2 - iJmp
                dComp = D(iLp2 + iLbd)
                Do While dComp > D(iTmp + iLbd)
                    dSwap = D(iTmp + iJmp + iLbd): D(iTmp + iJmp + iLbd) = D(iTmp + iLbd): D(iTmp + iLbd) = dSwap
                    iTmp = iTmp - iJmp: If iTmp < 0& Then Exit Do
                Loop
                D(iTmp + iJmp + iLbd) = dComp
            Next iLp2
        Next iLp1
    Else
        For iLp1 = iMkr To 0& Step -1&
            iJmp = iJumps(iLp1)
            For iLp2 = iJmp To iCnt - 1&
                iTmp = iLp2 - iJmp
                dComp = D(iLp2 + iLbd)
                Do While dComp < D(iTmp + iLbd)
                    dSwap = D(iTmp + iJmp + iLbd): D(iTmp + iJmp + iLbd) = D(iTmp + iLbd): D(iTmp + iLbd) = dSwap
                    iTmp = iTmp - iJmp: If iTmp < 0& Then Exit Do
                Loop
                D(iTmp + iJmp + iLbd) = dComp
            Next iLp2
        Next iLp1
    End If
End Sub

' *******************************************
' *******************************************
'
' And now, just some simple statistics.
'
' *******************************************
' *******************************************

Public Function Mode(D() As Double, Optional BracketWidth As Double = 1#, Optional ModeCountOut As Long) As Double
    ' In some sense, the Mode is the most complex of the measures of central tendency, especially when dealing with continuous data.
    ' The BracketWidth is effectively a rounding directive.
    ' The bracket width will be the center of the bracket.  For instance, with BracketWidth = 1#, brackets would be:
    '  -.5 to .5 : .5 to 1.5 : 1.5 to 2.5 : etcetera.
    ' When the mode is found, the return value will be some multiple of ModeCountOut.
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    ' If the distribution is bi-modal (or more), NaN is returned.
    '
    ' The Optional ModeCountOut is an output with the number of values having the value of the mode.
    ' If multi-modal, this number is still returned with the count.  This provides a way to see if the distribution is multi-modal.
    '
    Dim d2() As Double
    Dim i As Long
    Dim iCntNew As Double
    Dim bMultiModal As Boolean
    Dim dPrev As Double
    '
    If BracketWidth <= 0# Then Error 6
    Mode = NaN
    ModeCountOut = 0&
    FilterNaNs D, d2
    If DblDims(d2) <> 1 Then Exit Function
    ' Round all to bracket centers.
    For i = LBound(d2) To UBound(d2)
        d2(i) = Round(d2(i) / BracketWidth) * BracketWidth
    Next i
    SortData d2
    ' Find the mode.
    dPrev = d2(LBound(d2))
    ModeCountOut = 0&
    iCntNew = 1&
    For i = LBound(d2) + 1 To UBound(d2)
        If d2(i) = dPrev Then
            iCntNew = iCntNew + 1&
        Else
            Select Case iCntNew
            Case Is < ModeCountOut  ' We found a bracket with fewer than the previous, so reset and start again.
                iCntNew = 1&
            Case Is = ModeCountOut  ' Might be bi-modal.  Set flag and start again.
                bMultiModal = True
                iCntNew = 1&
            Case Is > ModeCountOut  ' Found a new mode.  Not bi-modal.  Save, and start again.
                bMultiModal = False
                ModeCountOut = iCntNew
                iCntNew = 1&
                Mode = dPrev
            End Select
            dPrev = d2(i)
        End If
    Next i
    ' Be sure to process the last bracket.
    Select Case iCntNew
    Case Is = ModeCountOut  ' Bi-modal.  Set flag.
        bMultiModal = True
    Case Is > ModeCountOut  ' Found a new mode.
        bMultiModal = False
        ModeCountOut = iCntNew
        Mode = dPrev
    End Select              ' If iCntNew < ModeCountOut Then we don't mess with this last bracket.
    ' Check for multi-modal and get out.
    If bMultiModal Then Mode = NaN
End Function

Public Function Range(D() As Double) As Double
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim t As Double
    '
    t = Min(D)
    If IsNaN(t) Then Range = NaN: Exit Function
    Range = Max(D) - t  ' If there's a Min, there has to be a Max.
End Function

Public Function InterQuartileRange(D() As Double) As Double
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim t As Double
    '
    t = Quartile(D, 1&)
    If IsNaN(t) Then InterQuartileRange = NaN: Exit Function
    InterQuartileRange = Quartile(D, 3&) - t    ' If there's a first-quartile, there'll always be a third quartile.
End Function

Public Function Min(D() As Double) As Double
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim i As Long, j As Long
    '
    Min = NaN
    If DblDims(D) <> 1 Then Exit Function
    ' Find a number to start with.
    For i = LBound(D) To UBound(D)
        If Not IsNaN(D(i)) Then Min = D(i): Exit For
    Next i
    If i > UBound(D) Then Exit Function    ' If we ran off the loop, there were no valid numbers.
    ' Now we must check the rest to make sure we've got the min.
    For j = i + 1& To UBound(D)
        If Not IsNaN(D(j)) Then If Min > D(j) Then Min = D(j)
    Next j
End Function

Public Function Max(D() As Double) As Double
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim i As Long, j As Long
    '
    Max = NaN
    If DblDims(D) <> 1 Then Exit Function
    ' Find a number to start with.
    For i = LBound(D) To UBound(D)
        If Not IsNaN(D(i)) Then Max = D(i): Exit For
    Next i
    If i > UBound(D) Then Exit Function    ' If we ran off the loop, there were no valid numbers.
    ' Now we must check the rest to make sure we've got the min.
    For j = i + 1& To UBound(D)
        If Not IsNaN(D(j)) Then If Max < D(j) Then Max = D(j)
    Next j
End Function

Public Function ValidCount(D() As Double) As Long
    ' Returns 0 if not dimensioned.
    ' Skips any NaNs and INFs in the array.
    '
    Dim i As Long
    '
    If DblDims(D) <> 1 Then Exit Function
    For i = LBound(D) To UBound(D)
        If Not IsNaN(D(i)) Then ValidCount = ValidCount + 1&
    Next i
End Function

Public Function Sum(D() As Double) As Double
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim i As Long
    Dim cnt As Long
    '
    If DblDims(D) <> 1 Then Sum = NaN: Exit Function
    For i = LBound(D) To UBound(D)
        If Not IsNaN(D(i)) Then
            cnt = cnt + 1
            Sum = Sum + D(i)
        End If
    Next i
    If cnt = 0& Then Sum = NaN
End Function

Public Function Mean(D() As Double) As Double
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim cnt As Long
    '
    cnt = ValidCount(D)
    If cnt = 0& Then Mean = NaN: Exit Function
    Mean = Sum(D) / cnt
End Function

Public Function Quartile(D() As Double, TheQuartile As Long) As Double
    ' There are three quartile cuts: 1st, 2nd (Median), and 3rd.
    ' Therefore, TheQuartile must = 1, 2, or 3.
    '
    If TheQuartile < 1& Or TheQuartile > 3& Then Error 6
    Quartile = Quantile(D, TheQuartile / 4#)
End Function

Public Function Median(D() As Double) As Double
    ' The median is just the 50th percentile.
    '
    Median = Quantile(D, 0.5)
End Function

Public Function Percentile(D() As Double, Optional ThePercentile As Long = 0.5) As Double
    ' This is essentially the same as a Quantile, but percentages are used instead of proportions.
    ' Also, only integers are allowed for the percentages.
    ' ThePercentile must be:    0 <= CutProportion <= 100.
    '
    Percentile = Quantile(D, ThePercentile / 100#)
End Function

Public Function Quantile(D() As Double, Optional CutProportion As Double = 0.5) As Double
    ' This is essentially the same as a percentile, but it allows for any floating-point cut.
    ' This uses a distribution-free approach, and linear interpolation between two closest points.
    ' The CutProportion must be:    0 <= CutProportion <= 1.
    '
    Dim ds() As Double  ' Don't tamper with original data sorting, so we make a copy.
    Dim cnt As Long
    Dim lo As Long
    Dim hi As Long
    Dim ptr As Double
    '
    If CutProportion < 0# Or CutProportion > 1# Then Error 6
    FilterNaNs D, ds
    If DblDims(ds) <> 1 Then Quantile = NaN: Exit Function
    cnt = UBound(ds) - LBound(ds) + 1
    If cnt = 1 Then Quantile = ds(LBound(ds)): Exit Function    ' If cnt=1 then all quantiles are that single value.
    SortData ds
    '
    ptr = CutProportion * (cnt - 1)
    lo = Int(ptr) + LBound(ds)
    hi = -Int(-ptr) + LBound(ds)
    ' Interpolate.  This works, even if lo=hi.
    Quantile = ds(lo) + (ds(hi) - ds(lo)) * (ptr + LBound(ds) - lo)
End Function

Public Function SumSq(D() As Double) As Double
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim i As Long
    Dim cnt As Long
    '
    If DblDims(D) <> 1 Then SumSq = NaN: Exit Function
    For i = LBound(D) To UBound(D)
        If Not IsNaN(D(i)) Then
            cnt = cnt + 1&
            SumSq = SumSq + D(i) * D(i)
        End If
    Next i
    If cnt <> 0 Then SumSq = NaN
End Function

Public Function SumSqDiff(D() As Double) As Double
    ' This one is the sum-of-squared-differences-from-the-mean.
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim i As Long
    Dim M As Double
    '
    M = Mean(D)
    If IsNaN(M) Then SumSqDiff = NaN: Return
    For i = LBound(D) To UBound(D)
        If Not IsNaN(D(i)) Then
            SumSqDiff = SumSqDiff + (D(i) - M) * (D(i) - M)
        End If
    Next i
End Function

Public Function VariancePop(D() As Double) As Double
    ' See MeanSqPop for notes.
    VariancePop = MeanSqPop(D)
End Function

Public Function MeanSqPop(D() As Double) As Double
    ' Mean of squared differences based on POPULATION of numbers.
    ' This is also know as the VARIANCE.
    ' This one is for population (all items counted).
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim cnt As Long
    '
    cnt = ValidCount(D)
    If cnt = 0& Then MeanSqPop = NaN: Exit Function
    MeanSqPop = SumSqDiff(D) / cnt
End Function

Public Function VarianceSamp(D() As Double) As Double
    ' See MeanSqSamp for notes.
    VarianceSamp = MeanSqSamp(D)
End Function

Public Function MeanSqSamp(D() As Double) As Double
    ' Mean of squared differences based on SAMPLE of numbers.
    ' This is also know as the VARIANCE.
    ' This one is for sample of items (sampled from some population).
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are less than 2 valid numbers, NaN is returned.  Valid N must be > 1 to calculate for SAMPLE.
    '
    Dim cnt As Long
    '
    cnt = ValidCount(D)
    If cnt < 2& Then MeanSqSamp = NaN: Exit Function
    MeanSqSamp = SumSqDiff(D) / (cnt - 1&)
End Function

Public Function StDevPop(D() As Double) As Double
    ' Standard deviation based on POPULATION of numbers.
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    StDevPop = MeanSqPop(D)
    If IsNaN(StDevPop) Then Exit Function
    StDevPop = Sqr(StDevPop)
End Function

Public Function StDevSamp(D() As Double) As Double
    ' Standard deviation based on SAMPLE of numbers.
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are less than 2 valid numbers, NaN is returned.  Valid N must be > 1 to calculate for SAMPLE.
    '
    StDevSamp = MeanSqSamp(D)
    If IsNaN(StDevSamp) Then Exit Function
    StDevSamp = Sqr(StDevSamp)
End Function

Public Function StErr(D() As Double) As Double
    ' Standard error of the mean (aka, standard error).
    ' This has no population equivalent.
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are less than 2 valid numbers, NaN is returned.  Valid N must be > 1 to calculate.
    '
    StErr = MeanSqSamp(D)
    If IsNaN(StErr) Then Exit Function
    StErr = Sqr(StErr / ValidCount(D))
End Function

Public Function OneSampleStudentT(D() As Double, Optional TestVal As Double = 0&) As Double
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are less than 2 valid numbers, NaN is returned.  Valid N must be > 1 to calculate.
    '
    Dim se As Double
    '
    se = StErr(D)
    If IsNaN(se) Then OneSampleStudentT = NaN: Exit Function
    OneSampleStudentT = (Mean(D) - TestVal) / se
End Function

---

And here's a continuation of that module, but this part does require distributions:

Code:

---

' *******************************************
' *******************************************
'
' From here down requires the distributions.
' Most of which were developed from the ALGLIB project.
'
' *******************************************
' *******************************************

Public Function OneSampleTTestPValue(d() As Double, Optional TestVal As Double = 0&, Optional Tails As Long = 2&) As Double
    ' A T-test can be performed either ONE-tailed or TWO-tailed.
    ' This returns the p value, the probability of observing these data if the null hypothesis is true.
    ' If you specify ONE-tailed, you should evaluate the mean, and only consider changes in ONE-DIRECTION from your TestVal as statistically significant.
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are less than 2 valid numbers, NaN is returned.  Valid N must be > 1 to calculate.
    '
    Dim t As Double
    '
    If Tails < 1& Or Tails > 2& Then Error 6
    t = OneSampleStudentT(d, TestVal)
    If IsNaN(t) Then OneSampleTTestPValue = NaN: Exit Function
    OneSampleTTestPValue = (1# - StudentTCdf(t, CountN(d) - 1&)) * Tails
End Function

Public Sub OneSampleConfInt(d() As Double, LoValOut As Double, HiValOut As Double, Optional pCrit As Double = 0.05, Optional Tails As Long = 2&)
    ' As with a T-test, confidence intervals can be constructed either ONE-tailed or TWO-tailed.
    ' However, if you specify ONE-tailed, you should either use LoValOut or HiValOut, but not both.
    ' If TWO-tailed is specified, you would use both LoValOut and HiValOut to construct your confidence interval.
    '
    ' pCrit is the equivalent p-value for your confidence intervals.
    ' For instance, for a 95% CI, we'd specify pCrit = .05.
    '              for a 90% CI, we'd specify pCrit = .10.
    ' pCrit must be in the range of 0 < pCrit < .5 for TWO-tailed; and 0 < pCrit < 1 for ONE-Tailed.
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are less than 2 valid numbers, NaN is returned.  Valid N must be > 1 to calculate.
    '
    Dim cnt As Long
    Dim tCrit As Double
    Dim se As Double
    Dim M As Double
    '
    ' Validations.
    If Tails < 1& Or Tails > 2& Then Error 6
    If pCrit <= 0# Then Error 6
    If pCrit >= 1# Then Error 6
    If Tails = 2& And pCrit >= 0.5 Then Error 6
    '
    cnt = CountN(d)
    If cnt < 2& Then LoValOut = NaN: HiValOut = NaN: Exit Sub
    tCrit = StudentTCdfInv(1# - (pCrit / Tails), cnt - 1&)
    se = StErr(d)
    M = Mean(d)
    '
    LoValOut = M - tCrit * se
    HiValOut = M + tCrit * se
End Sub

---

And, as stated, complete "run-able" project is attached. I've also designed a bit of a user-interface just for testing. Here's a sample of that:



Please feel free to make additional requests, and I'll possibly add them.

Take Care,
Elroy

Attached Images

 

Attached Files

• Simple Stats.zip (18.4 KB)

URLEncode in UTF-8 with Visual Basic 6 (Sending Unicode SMS message)

March 3, 2018, 12:04 am

≫ Next: Round Function

≪ Previous: Simple Statistics

$

0

0

After searching this forum and the internet for a few days and did not get what I am looking for I stumbled upon this and tweaked it a little bit because it had a problem with encoding vbCrLf.

It all started when I tried to add SMS capability to an old VB6 application using ClickaTell service but unfortunately it only uses CURL or JavaScript!
Sending Unicode SMS from VB6 app wasn't possible till I found this and I thought I'd share as it may come handy to others.

Code:

---

Private Declare Sub CopyToMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Public Function URLEncode_UTF8( _
      ByVal Text As String _
  ) As String
 
  Dim Index1 As Long
  Dim Index2 As Long
  Dim Result As String
  Dim Chars() As Byte
  Dim Char As String
  Dim Byte1 As Byte
  Dim Byte2 As Byte
  Dim UTF16 As Long
 
  For Index1 = 1 To Len(Text)
      CopyToMemory Byte1, ByVal StrPtr(Text) + ((Index1 - 1) * 2), 1
      CopyToMemory Byte2, ByVal StrPtr(Text) + ((Index1 - 1) * 2) + 1, 1
 
      UTF16 = Byte2
      UTF16 = UTF16 * 256 + Byte1
      Chars = GetUTF8FromUTF16(UTF16)
      For Index2 = LBound(Chars) To UBound(Chars)
        Char = Chr(Chars(Index2))
        If Char Like "[0-9A-Za-z]" Then
            Result = Result & Char
        Else
            If Asc(Char) < 16 Then
                Result = Result & "%0" & Hex(Asc(Char))
            Else
                Result = Result & "%" & Hex(Asc(Char))
            End If
        End If
      Next
  Next
 
  URLEncode_UTF8 = Result
 
End Function
 
Private Function GetUTF8FromUTF16( _
      ByVal UTF16 As Long _
  ) As Byte()
 
  Dim Result() As Byte
  If UTF16 < &H80 Then
      ReDim Result(0 To 0)
      Result(0) = UTF16
  ElseIf UTF16 < &H800 Then
      ReDim Result(0 To 1)
      Result(1) = &H80 + (UTF16 And &H3F)
      UTF16 = UTF16 \ &H40
      Result(0) = &HC0 + (UTF16 And &H1F)
  Else
      ReDim Result(0 To 2)
      Result(2) = &H80 + (UTF16 And &H3F)
      UTF16 = UTF16 \ &H40
      Result(1) = &H80 + (UTF16 And &H3F)
      UTF16 = UTF16 \ &H40
      Result(0) = &HE0 + (UTF16 And &HF)
  End If
  GetUTF8FromUTF16 = Result
End Function

---

VB6 code to use CURL is as follow after adding a reference to Microsoft Internet Controls :

Code:

---

Inet1.Execute "https://platform.clickatell.com/messages/http/send?apiKey=YourKey&to=MobileNo&content=" & URLEncode_UTF8(YourMessage)

---

Enjoy!

Round Function

March 9, 2018, 5:29 am

≫ Next: Copy data from external Listview/Treeview/Listbox/ComboBox/IE Window

≪ Previous: URLEncode in UTF-8 with Visual Basic 6 (Sending Unicode SMS message)

$

0

0

This round function round at 0 to 13 places, and a -1.5 turn to -2 and 1.5 to 2
While upgrading M2000 Interpreter to work with Currency and Decimals, I make this function to work with decimals, currency and doubles. The problem with old code was the automatic convertion of all to double.
To eliminate this problem, i thought to place an expression which the biggest number has to be the type of interest. The most problematic type is the Currency, because it has automatic convertion to double. So here is a Testnow sub to show that. Expression Fix(pos * v3 + v4) / v3 has all members as Currency, and return Double. Expression MyRound = Fix(x) + Fix((x - Fix(x)) * 10 + N) / 10 has members as variants, and constant 10, which is as vb want to be as a value, and the return is Currency.

Code:

---

Sub testnow()
Dim pos As Currency, v As Variant, v1 As Variant, v3 As Currency, v4 As Currency
v3 = 10
v4 = 0.5
pos = 33123.25
v = Fix(pos * v3 + v4) / v3
Debug.Print Typename(v), v  ' Double  33123.3
v1 = MyRound(pos, 1)
Debug.Print Typename(v1), v1 ' Currency 33123.3
End Sub


Function MyRound(ByVal x, Optional d As Variant = 0#) As Variant
Dim i, N
  i = Abs(Int(d)): If i > 13 Then i = 13
  N = Sgn(x) * 0.5
On Error GoTo there
Select Case i
Case 0
MyRound = Fix(x + N)
Case 1
MyRound = Fix(x) + Fix((x - Fix(x)) * 10 + N) / 10
Case 2
MyRound = Fix(x) + Fix((x - Fix(x)) * 100 + N) / 100
Case 3
MyRound = Fix(x) + Fix((x - Fix(x)) * 1000 + N) / 1000
Case 4
MyRound = Fix(x) + Fix((x - Fix(x)) * 10000 + N) / 10000
Case 5
MyRound = Fix(x) + Fix((x - Fix(x)) * 100000 + N) / 100000
Case 6
MyRound = Fix(x) + Fix((x - Fix(x)) * 1000000 + N) / 1000000
Case 7
MyRound = Fix(x) + Fix((x - Fix(x)) * 10000000 + N) / 10000000
Case 8
MyRound = Fix(x) + Fix((x - Fix(x)) * 100000000 + N) / 100000000
Case 9
MyRound = Fix(x) + Fix((x - Fix(x)) * 1000000000 + N) / 1000000000
Case 10
MyRound = Fix(x) + Fix((x - Fix(x)) * 10000000000# + N) / 10000000000#
Case 11
MyRound = Fix(x) + Fix((x - Fix(x)) * 100000000000# + N) / 100000000000#
Case 12
MyRound = Fix(x) + Fix((x - Fix(x)) * 1000000000000# + N) / 1000000000000#
Case 13
MyRound = Fix(x) + Fix((x - Fix(x)) * 10000000000000# + N) / 10000000000000#
End Select

Exit Function
there:
Err.Clear
MyRound = x

End Function

---

Copy data from external Listview/Treeview/Listbox/ComboBox/IE Window

March 10, 2018, 3:47 am

≫ Next: VB6 - Personal Chat

≪ Previous: Round Function

$

0

0

This is handy code to have around in case you have to scrape data from an external application for some reason.

Drag the cross hairs over the target window in an external application (or in the demo controls on the main form). You will see the window class name in the title bar to confirm type, then you can clone it. It will also dump it as text to the lower textbox.

The IE window dump can even nab the source for things like the XP add remove programs interface or embedded browser panes like skype advertisements (used to anyway)

Everything is easily accessible from the CWindow class

This pulls in code from various authors:
Jim White, t/as MathImagical Systems,
Dr Memory,
Arkadiy Olovyannikov,
Eduardo A. Morcillo

Attached Files

• CopyRemoteText.zip (56.5 KB)

VB6 - Personal Chat

March 10, 2018, 9:44 pm

≫ Next: Round Colorful Forms

≪ Previous: Copy data from external Listview/Treeview/Listbox/ComboBox/IE Window

$

0

0

PChat is a 2 part program consisting of a server component and a client component. The client component (PChat.vbp) runs as a Desktop Application, whereas the Server component can run as a Service or a Desktop Application.

PChat is short for Personal Chat, as it provides for a single connection between two independent parties. Each client must have a UserID, but the UserID is not password protected and the messages are not encrypted. The Client component utilizes SimpleSock acting either as a listening socket, or as a connecting socket. The Server component utilizes SimpleServer acting as a single listening socket open to as many clients as the user chooses to support. It also utilizes NTSVC.OCX to support operating as a service. The server component is open to anyone, and only serves to allow the two independent parties to connect. Each party logs into the server and stays connected. A Heart Beat signal is periodically sent to the server to maintain the connection. If the server fails to receive the Heart Beat, the user is removed from the Connect list.

The first time the Client program is run, there are enough defaults to allow the program to start, but "Setup" from the menu needs to be run. You will be prompted to enter a UserID of 3 to 10 characters. Any UserID can be used, but if it conflicts with another user, it will have to be changed. Next, you will be asked for a "Server". The server can be a properly registered Domain Name, or an IP address. Although the program is capable of handling IPv6, it is currently only configured for IPv4. Next you will be asked for a "Server Port number". Any port number can be used, but it has to be the same as the server (default is 259). Next you will be asked for an "External Port number". This one is slightly more complex. More on that later. Next you will be asked if you want to activate Spell Check (Yes or No). Both components utilize the Microsoft InkEdit Control 1.0, which provides support for Spell Check and Unicode wide characters. That's it for the Setup.

In order for 2 parties to connect, one of them has to have an open port listening for a connection. Most IPv4 clients are sitting behind a NAT router, and an internal Firewall. Therefore, you must configure your router to either forward the connection request on the External Port number you entered in the "Setup" process, or configure it to use Port Triggering on that Port number. Port Triggering does not require fixed IP addressing, but Port Forwarding does. Fixed IP addressing can be accomplished by configuring your network adapter, or in most modern routers, by using DHCP to provide the same function. You can still use Personal Chat without setting up your router, but you will not be able to initiate the connection. To initiate the connection, you click on the "Get Connected Users" button. This will recover the currently connected users from the server.

Note: The address to connect to is supplied by the server. That is how the External IP address is recovered. As long as the server is operating on a network separate from either client, that address will be the Public IP address of the client. If a client is operating on the same network as the server, the server will only see the Private IP address. If both clients are on the same network as the server, those 2 clients will be able to connect to each other, but neither will be able to connect to an outside client. However, if you choose to provide the server setup with an External IP address, and the requesting client is on the same network as the server, the External IP address will be supplied to the requested client.

Clicking on one of the User Names will send that User Name, your External IP Address, and your External Port number to the server, and open the chat socket in the listening mode. The server will then forward that Address and Port information to the selected user. The selected user will receive this information and display it in several boxes. If PChat is minimized when the request is received, it will be restored to a normal window. Clicking on the green User Name box will attempt to establish a connection with the user at the Address and Port displayed. The Client receiving the connection request is given 5 minutes to respond to the request. At the end of that period, the request is withdrawn and the listening socket closed.

Note: The party listening for the connection must allow that connection through the Firewall. If the Microsoft Firewall is being used, on the first connection attempt you will be asked if you want to allow that connection. Responding to that question may cause the first attempt to time out.

The two sides can then carry on a conversation.

The server component (PChatS.vbp) runs as a Service, and must be accessible from the WAN (Wide Area Network, aka Internet) on a listening port of your choosing (default 259). The service has no visible components and operates with system privileges in Session 0. It comes with a small management program (prjInterface.vbp) to provide the necessary interface between the Service Manager (services.msc) and the service itself. The server component will compile as a Desktop Application as supplied. To compile as a Service, change "frmHidden.Visible" to "False", and the "IsService" flag to "True". I used "PChatS.exe" for the Desktop version, and "PChatSvc.exe" for the Service version. The server component requires "NTSVC.OCX" and a location for the log files. The "Desktop" uses a sub directory of the application directory called "Logs", and the Service uses "\Windows\System32\Logfiles\PChat\".

Attached Images

  

Attached Files

• PChat.zip (29.4 KB)
• PChatSvc.zip (33.0 KB)

Round Colorful Forms

March 14, 2018, 3:14 am

≫ Next: IEEE Doubles: NaN, Infinity, etc.

≪ Previous: VB6 - Personal Chat

$

0

0

Ok in its raw form this is really quite useless but it contains several interesting parts that can be put to greater use

With this code you can create a round, color changing form that can be moved freely.

Thank you SamOscarBrown for your circle code and Microsoft for helping me get the form movable

you will need a form with a text box and a timer. I named the form frmRound

seeing it work really blew my mind!

PHP Code:

---

Private Declare Function SendMessage Lib "User32" _
                         Alias "SendMessageA" (ByVal hWnd As Long, _
                                               ByVal wMsg As Long, _
                                               ByVal wParam As Long, _
                                               lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "User32" ()

      Const WM_NCLBUTTONDOWN = &HA1
      Const HTCAPTION = 2

    Option Explicit
    Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function SetWindowRgn Lib "User32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
   

    
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
                                 X As Single, Y As Single)
         Dim lngReturnValue As Long

         If Button = 1 Then
            Call ReleaseCapture
            lngReturnValue = SendMessage(frmRound.hWnd, WM_NCLBUTTONDOWN, _
                                         HTCAPTION, 0&)
         End If
      End Sub

    Private Sub Form_DblClick()
       Unload Me
    End Sub
    Private Sub Form_Load()
        Dim lngRegion As Long
        Dim lngReturn As Long
        Dim lngFormWidth As Long
        Dim lngFormHeight As Long
        Me.Width = Me.Height
        
        lngFormWidth = Me.Width / Screen.TwipsPerPixelX
        lngFormHeight = Me.Height / Screen.TwipsPerPixelY
        lngRegion = CreateEllipticRgn(0, 0, lngFormWidth, lngFormHeight)
        lngReturn = SetWindowRgn(Me.hWnd, lngRegion, True)
Label1.Left = (Me.Width / 2) - (Label1.Width / 2)
Label1.Top = (Me.Height / 2) - (Label1.Height / 2)
    End Sub
    Private Sub Label1_Click()
       Unload frmRound
    End Sub
    Private Sub Timer1_Timer()
  Static iColor As Integer
  Select Case iColor
  Case 0: Me.BackColor = RGB(255, 0, 0)   ' Red
  Case 1: Me.BackColor = RGB(255, 165, 0) ' Orange
  Case 2: Me.BackColor = RGB(255, 255, 0) ' Yellow
  Case 3: Me.BackColor = RGB(0, 128, 0)   ' Green
  Case 4: Me.BackColor = RGB(0, 0, 255)   ' Blue
  Case 5: Me.BackColor = RGB(128, 0, 128) ' Purple
  End Select
  iColor = iColor + 1
  If iColor > 5 Then iColor = 0
End Sub 


---

IEEE Doubles: NaN, Infinity, etc.

March 14, 2018, 8:20 am

≫ Next: VB6 Select list item

≪ Previous: Round Colorful Forms

$

0

0

When doing math that may have problems, I've traditionally resorted to Variants and returned a Null or Empty when things didn't go correctly. However, that's never felt totally clean. Lately, I've been relying on the NaN of an IEEE Double (and forgoing any use of Variants).

Basically, to summarize, I can think of five different "states" an IEEE Double may be in:

• Zero
• A typical floating point number.
• A sub-normal floating point number.
• A NaN
• Infinity

And, there's also the sign-bit. However, the way IEEE Doubles are specified, the sign-bit is independent of all five of those "states". In other words, we can have -NaN or +NaN, -Inf, or +Inf. We can even have -0 or +0.

Also, just to quickly define them, the sub-normal numbers are numbers very close to zero. With the typical 11-bit exponent, this exponent can range from approximately 10⁺³⁰⁸ to 10^-308. However, with a bit of trickery (i.e., using the mantissa as more exponent, and sacrificing mantissa precision), we can push on the negative exponent side, making it go to approximately 10^-324 (the sub-normals). These sub-normal numbers are always very close to zero. I don't do anything special with these sub-normal numbers herein, but I just wanted to be complete.

Also, I list "Zero" separately from "A typical floating point number". This is because Zero is not handled (i.e., binary coded) the same way as other numbers. Zero just has all the bits off (with the possible exception of the sign bit).

Now, NaN is a special value that means "not-a-number". It's what you get when you try to divide 0#/0# (with error trapping turned on so you don't crash). There are also other ways to get it.

Infinity (or just Inf) is another one of these special values. You can get it by dividing any non-zero number by zero, such as 1#/0# (again, with error trapping).

There's a good Wikipedia page about these IEEE Doubles (which is just a Double type in VB6).

It's mostly these NaN and Inf values about which I post this entry. I've begun using them (instead of Variant) to handle special situations, and I thought I'd share. Also, the way I did things, there's no need for error trapping, which should keep things very fast.

Here's the code (possibly best in a BAS module):

Code:

---


Option Explicit
'
Public Declare Function GetMem2 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
Public Declare Function GetMem4 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
Public Declare Function GetMem8 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
'

Public Function NaN() As Double
    ' Math (add, subtract, multiply, divide) can be done on these, but nothing changes.
    ' They can NOT be used in "if NaN = NaN Then", or an overflow will result.  Use IsNaN().
    ' Also, most math-with-functions (Sin(), Round(), etc) causes overflow error.
    '
    GetMem2 &HFFF8, ByVal PtrAdd(VarPtr(NaN), 6&)
End Function

Public Function Inf() As Double
    GetMem2 &HFFF0, ByVal PtrAdd(VarPtr(Inf), 6&)
End Function

Public Function IsNaN(d As Double) As Boolean
    IsNaN = IsNanOrInf(d) And Not IsInf(d)
End Function

Public Function IsInf(d As Double) As Boolean
    Const ii As Integer = &H7FF0    ' High 4 bits of byte #7 (F0), Low 7 bits of byte #8 (7F). If all on, it's NaN (or Inf if all other non-sign bits are zero).
    Static i(1 To 4) As Integer
    GetMem8 d, i(1)
    IsInf = (i(4) And ii) = ii And i(1) = &H0 And i(2) = &H0 And i(3) = &H0 And (i(4) And &HF) = &H0
End Function

Public Function IsNeg(d As Double) As Boolean
    ' This works even on NaN and Inf.
    Static i(1 To 4) As Integer
    GetMem8 d, i(1)
    IsNeg = i(4) < 0    ' The sign bit will be the same sign bit for i(4).
End Function

Public Function IsNanOrInf(d As Double) As Boolean
    Const ii As Integer = &H7FF0    ' High 4 bits of byte #7 (F0), Low 7 bits of byte #8 (7F). If all on, it's NaN (or Inf if all other non-sign bits are zero).
    Static i(1 To 4) As Integer
    GetMem8 d, i(1)
    IsNanOrInf = (i(4) And ii) = ii
End Function

Public Function PtrAdd(ByVal Pointer As Long, ByVal Offset As Long) As Long
    ' For adding (or subtracting) a small number from a pointer.
    ' Use PtrAddEx for adding (or subtracting) large numbers from a pointer.
    Const SIGN_BIT As Long = &H80000000
    PtrAdd = (Pointer Xor SIGN_BIT) + Offset Xor SIGN_BIT
End Function


---

Just as an example of one place you may use these ... let's say you want to average a set of numbers. However, there may be cases where there are no numbers to average. What do you return? It's a problem, but returning a NaN can solve it so long as we remember to test for NaN before using it.

The following isn't complete code, but it's an example of where I'm using it. The caller then uses the IsNaN() function:

Code:

---


Private Function ParamSideAvg(iRow As Long, sSideLetter As String) As Double
    ' Returns NaN if nothing to average.
    Dim n As Double
    Dim iCnt As Long
    Dim iCol As Long
    '
    Select Case sSideLetter
    Case "L": iCol = ColNumberFromLetter("H")  ' This is the MEAN column.  Subtractions are made to get cycle data.
    Case "R": iCol = ColNumberFromLetter("N")  ' This is the MEAN column.  Subtractions are made to get cycle data.
    Case Else:  Exit Function
    End Select
    '
    If Len(Trim$(wsh.Cells(iRow, iCol - 3))) > 0 Then n = n + val(wsh.Cells(iRow, iCol - 3)): iCnt = iCnt + 1
    If Len(Trim$(wsh.Cells(iRow, iCol - 2))) > 0 Then n = n + val(wsh.Cells(iRow, iCol - 2)): iCnt = iCnt + 1
    If Len(Trim$(wsh.Cells(iRow, iCol - 1))) > 0 Then n = n + val(wsh.Cells(iRow, iCol - 1)): iCnt = iCnt + 1
    If iCnt > 0 Then
        ParamSideAvg = n / iCnt
    Else
        ParamSideAvg = NaN
    End If
End Function



---

Also, I suppose I could have also done all this for IEEE Singles, but I don't currently have the need.

Enjoy,
Elroy

---

VB6 Select list item

March 18, 2018, 4:54 am

≫ Next: [vb6] Enhancing VB's StdPicture Object to Support GDI+

≪ Previous: IEEE Doubles: NaN, Infinity, etc.

$

0

0

Hi. To begin with let me tell you that I'm using VB6. So here's my question. I have a list and a button, When I click the button it removes the top most entry in the list, how do I get it to select and highlight the next item in the list? By the way I'm new to this.

Thanks in advance.

[vb6] Enhancing VB's StdPicture Object to Support GDI+

March 19, 2018, 10:05 am

≫ Next: VB6 - Elliptical Curve Diffie Hellman (ECDH) Demo

≪ Previous: VB6 Select list item

$

0

0

This is my second version of the logic first introduced here. That version will no longer be supported.

This version offers so much more:
1. GDI+ can be used for improved scaling for all image formats
2. Better (far more complex) thunk used for managing stdPictures
3. Callbacks can be requested so you can respond to the entire rendering process
4. Can attach GDI+ image attributes (grayscaling/blending) to managed images
5. Can modify GDI+ graphics object during callbacks, i.e., rotation (sample in attached zip)
6. Can cache original image format and retrieve for saving to file
7. Can return embedded image DPI value
8. Written to address backward and future version compatibility
9. Only affects those stdPicture objects that are managed

As with the previous version of this class, many image formats are supported:
- BMP. Those with valid alpha channels can be rendered with transparency. VB-unsupported formats are supported and include: those with v4/v5 bitmap headers and those with JPG/PNG compression
- JPG. CMYK color-space supported via GDI+. Camera-orientation correction supported
- ICO. Alphablended and PNG-encoded icons are supported
- CUR. Same as icons and also color cursors can be returned while in IDE, unlike VB
- WMF/EMF. Not directly managed, no need. Non-placeable WMFs are supported
- PNG. Supported via GDI+, APNG is not
- TIF. Supported via GDI+, multi-page navigation supported
- GIF. Rendering of individual frames (animated GIF) supported via GDI+
- For any other format, if you can convert it to bitmap (alpha channel or not), then supported

The enclosed class offers several methods for managing stdPictures, among those:
- LoadPictureEx creates a new stdPicture object by file, array or handle and supports unicode file names
- LoadResPictureEx is a slightly extended version of VB's LoadResPicture function
- ManageStdPicture manages/un-manages existing stdPicture objects
- CopyStdPicture can copy/create/convert icons and bitmaps with/without alpha channels
- PaintPictureEx is a substitute for VB's PaintPicture based on the stdPicture.Render method
- SetCallBacks enables receiving one or more of the 4 available callbacks
- SetImageAttributesHandle associates user-provided GDI+ attributes with a managed image
- PictureTypeEx can return the actual image format, i.e., PNG, JPG, TIF, etc
- SetFrameGIF/GetGifAnimationInfo applies for animated GIFs when managed
- SetPageTIF applies for muliti-page TIFs when managed
- GetFramePageCount will return count for managed GIF/TIF
- several other methods are available for optional settings

--------------------------------------------------------------------------
The attachments below are the sample project (all in one zip is over 500k & forum rejected it). The 1st three below must be unzipped in same folder. The stdPicEx2 class is a stand-alone class. The rest of the files are to show-off some of its capabilities. The 4th one below is documentation that you may be interested in. It also includes the thunk raw source before I compiled it with NASM.

Project not guaranteed to be compatible with systems lower than XP, but XP/Win2K and above should be supported.

The sample project includes GIF animation, PNG/TIF support, alphablended icon support, JPG camera-orientation correction and more. Just FYI: If the StdPicEx2 class is ever included as its own attachment below, it will be an updated version that may not be in the sample project.

Latest changes...
Found minor bug when owner-drawn style attempted to be unmanaged. Fixed and updated the testProject.zip.

Attached Files

• testProject.zip (416.7 KB)
• project_Res.zip (133.7 KB)
• sample_tiff.zip (418.3 KB)
• documentation.zip (52.6 KB)

VB6 - Elliptical Curve Diffie Hellman (ECDH) Demo

March 19, 2018, 11:21 am

≫ Next: Remember Form's Position for Next Execution, Multi-Monitor

≪ Previous: [vb6] Enhancing VB's StdPicture Object to Support GDI+

$

0

0

The heart of this demo is the "GetECCKey" function. It is a dual purpose function, requiring 4 supplied variables (pAlg, KeyLen, bPublicECCKey, & bPrivateECCKey). "pAlg" is a pointer to the wide string descriptor of the algorithm used ("SHA256"). "KeyLen" is self explanatary (256), and "bPublicECCKey" & "bPrivateECCKey" are the Public\Private key pair. If the key fields are empty, the function generates and returns a new key pair. If the Private key, and the Public key from the other end are supplied, then the function returns the Agreed Secret.

So how do we know if it is returning the correct information? For this, we look to RFC 5903. It supplies 2 key pairs and the Agreed Secret they should return.
--------------------------------------------------------------------------
We suppose that the initiator's Diffie-Hellman private key is:
i: C88F01F5 10D9AC3F 70A292DA A2316DE5 44E9AAB8 AFE84049 C62A9C57 862D1433
Then the public key is given by g^i=(gix,giy) where:
gix: DAD0B653 94221CF9 B051E1FE CA5787D0 98DFE637 FC90B9EF 945D0C37 72581180
giy: 5271A046 1CDB8252 D61F1C45 6FA3E59A B1F45B33 ACCF5F58 389E0577 B8990BB3
The KEi payload is as follows.
00000048 00130000 DAD0B653 94221CF9 B051E1FE CA5787D0 98DFE637 FC90B9EF
945D0C37 72581180 5271A046 1CDB8252 D61F1C45 6FA3E59A B1F45B33 ACCF5F58
389E0577 B8990BB3
--------------------------------------------------------------------------
But that doesn't exactly describe how Microsoft wants the information. CNG requires the Private key to include the Public key, and the "Magic" description in the first 8 bytes is different.

Code:

---

Public Key A
45 43 4B 31 20 00 00 00 (ECK1 )
DA D0 B6 53 94 22 1C F9 B0 51 E1 FE CA 57 87 D0
98 DF E6 37 FC 90 B9 EF 94 5D 0C 37 72 58 11 80
52 71 A0 46 1C DB 82 52 D6 1F 1C 45 6F A3 E5 9A
B1 F4 5B 33 AC CF 5F 58 38 9E 05 77 B8 99 0B B3
Private Key A
45 43 4B 32 20 00 00 00 (ECK2 )
DA D0 B6 53 94 22 1C F9 B0 51 E1 FE CA 57 87 D0
98 DF E6 37 FC 90 B9 EF 94 5D 0C 37 72 58 11 80
52 71 A0 46 1C DB 82 52 D6 1F 1C 45 6F A3 E5 9A
B1 F4 5B 33 AC CF 5F 58 38 9E 05 77 B8 99 0B B3
C8 8F 01 F5 10 D9 AC 3F 70 A2 92 DA A2 31 6D E5
44 E9 AA B8 AF E8 40 49 C6 2A 9C 57 86 2D 14 33

---

--------------------------------------------------------------------------
We suppose that the response Diffie-Hellman private key is:
r: C6EF9C5D 78AE012A 011164AC B397CE20 88685D8F 06BF9BE0 B283AB46 476BEE53
Then the public key is given by g^r=(grx,gry) where:
grx: D12DFB52 89C8D4F8 1208B702 70398C34 2296970A 0BCCB74C 736FC755 4494BF63
gry: 56FBF3CA 366CC23E 8157854C 13C58D6A AC23F046 ADA30F83 53E74F33 039872AB
The KEr payload is as follows.
00000048 00130000 D12DFB52 89C8D4F8 1208B702 70398C34 2296970A 0BCCB74C
736FC755 4494BF63 56FBF3CA 366CC23E 8157854C 13C58D6A AC23F046 ADA30F83
53E74F33 039872AB
The Diffie-Hellman common value (girx,giry) is:
girx: D6840F6B 42F6EDAF D13116E0 E1256520 2FEF8E9E CE7DCE03 812464D0 4B9442DE
giry: 522BDE0A F0D8585B 8DEF9C18 3B5AE38F 50235206 A8674ECB 5D98EDB2 0EB153A2
The Diffie-Hellman shared secret value is girx.
--------------------------------------------------------------------------

Code:

---

Public Key B
45 43 4B 31 20 00 00 00 (ECK1 )
D1 2D FB 52 89 C8 D4 F8 12 08 B7 02 70 39 8C 34
22 96 97 0A 0B CC B7 4C 73 6F C7 55 44 94 BF 63
56 FB F3 CA 36 6C C2 3E 81 57 85 4C 13 C5 8D 6A
AC 23 F0 46 AD A3 0F 83 53 E7 4F 33 03 98 72 AB
Private Key B
45 43 4B 32 20 00 00 00 (ECK2 )
D1 2D FB 52 89 C8 D4 F8 12 08 B7 02 70 39 8C 34
22 96 97 0A 0B CC B7 4C 73 6F C7 55 44 94 BF 63
56 FB F3 CA 36 6C C2 3E 81 57 85 4C 13 C5 8D 6A
AC 23 F0 46 AD A3 0F 83 53 E7 4F 33 03 98 72 AB
C6 EF 9C 5D 78 AE 01 2A 01 11 64 AC B3 97 CE 20
88 68 5D 8F 06 BF 9B E0 B2 83 AB 46 47 6B EE 53

---

When Private Key A and Public Key B are supplied to "GetECCKey", it returns:

Code:

---

D6 84 0F 6B 42 F6 ED AF D1 31 16 E0 E1 25 65 20
2F EF 8E 9E CE 7D CE 03 81 24 64 D0 4B 94 42 DE

---

And when Private Key B and Public Key A are supplied to "GetECCKey", it also returns:

Code:

---

D6 84 0F 6B 42 F6 ED AF D1 31 16 E0 E1 25 65 20
2F EF 8E 9E CE 7D CE 03 81 24 64 D0 4B 94 42 DE

---

But the program returns a different key:
Key

Code:

---

05 19 DC 09 B3 6E FA D1 D0 0A EF 1D 5B 53 B1 00
20 2E B9 10 B5 DE 0D ED E7 5F 19 0A 35 7A 36 7D

---

Therein lies one of the major problems with CNG. The only way to recover the Agreed Secret is as a hashed value, and Microsoft does not supply a NULL hash. If we click the Hash button, it uses an SHA256 hash on the value supplied by RFC 5903.
Hashed Secret

Code:

---

05 19 DC 09 B3 6E FA D1 D0 0A EF 1D 5B 53 B1 00
20 2E B9 10 B5 DE 0D ED E7 5F 19 0A 35 7A 36 7D

---

J.A. Coutts

Attached Images

 

Attached Files

• ECDH.zip (109.3 KB)

Remember Form's Position for Next Execution, Multi-Monitor

March 22, 2018, 3:53 pm

≫ Next: VB6 - Remember App window Position and Size

≪ Previous: VB6 - Elliptical Curve Diffie Hellman (ECDH) Demo

$

0

0

Here's something I just cobbled together for a project I'm working on, and this occasionally comes up in these forums.

It's a couple of procedures (with support procedures) for saving the last position of a form, and putting it back there the next time it's shown. Now, this is easy so long as we only have one monitor. However, things get a bit tricky when we're on a multi-monitor system, and especially if that system may often have different monitor configurations (such as my laptop I haul around with me all over the place).

These procedures should be robust to changes in configurations. Furthermore, they make sure the form will always be fully shown on some monitor the next time it's shown.

The registry is used to store last position, so it'll be machine/user specific.

It's very easy to use. Here's an example in a form:

Code:

---


Option Explicit

Private Sub Form_Load()
    FetchAndSetFormPos Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SaveFormPos Me
End Sub



---

And here's code for it that you can throw into a BAS module:

Code:

---


Option Explicit
'
Private Type POINTAPI
    X As Long
    Y As Long
End Type
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 Declare Function EnumDisplayMonitors Lib "user32" (ByVal hdc As Long, lprcClip As Any, ByVal lpfnEnum As Long, dwData As Long) As Long
Private Declare Function MonitorFromWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal dwFlags As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint 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 Sub FetchAndSetFormPos(frm As Form, Optional TopPixelsAdd As Long, Optional LeftPixelsAdd As Long)
    ' Initial (default) position is in center, biased toward top.
    ' The TopPixelsAdd and LeftPixelsAdd can be used to move from the center (top biased) default position.  They can be negative.
    '
    Dim iMon As Long
    Dim iTop As Long
    Dim iLeft As Long
    Dim hMonitor As Long
    Dim iFrmHeight As Long
    Dim iFrmWidth As Long
    Dim iMonHeight As Long
    Dim iMonWidth As Long
    '
    iFrmHeight = WindowHeightPx(frm.hWnd)
    iFrmWidth = WindowWidthPx(frm.hWnd)
    '
    iMon = GetSetting(App.Title, "Settings", frm.Name & "Mon", 1&)
    If iMon < 1& Then iMon = 1&
    If iMon > MonitorCount Then iMon = 1&
    hMonitor = MonitorHandle(iMon)
    iMonHeight = MonitorHeightPx(hMonitor)
    iMonWidth = MonitorWidthPx(hMonitor)
    '
    iTop = GetSetting(App.Title, "Settings", frm.Name & "Top", (iMonHeight - iFrmHeight) \ 3 + TopPixelsAdd)
    iLeft = GetSetting(App.Title, "Settings", frm.Name & "Left", (iMonWidth - iFrmWidth) \ 2 + LeftPixelsAdd)
    If iTop + iFrmHeight > iMonHeight Then iTop = iMonHeight - iFrmHeight
    If iLeft + iFrmWidth > iMonWidth Then iLeft = iMonWidth - iFrmWidth
    If iTop < 0 Then iTop = 0
    If iLeft < 0 Then iLeft = 0
    '
    PositionWindowOnMonitor frm.hWnd, hMonitor, iLeft, iTop
End Sub

Public Sub SaveFormPos(frm As Form)
    SaveSetting App.Title, "Settings", frm.Name & "Top", WindowTopPx(frm.hWnd)
    SaveSetting App.Title, "Settings", frm.Name & "Left", WindowLeftPx(frm.hWnd)
    SaveSetting App.Title, "Settings", frm.Name & "Mon", MonitorNumForHwnd(frm.hWnd)
End Sub

Public Function MonitorCount() As Long
    EnumDisplayMonitors 0&, ByVal 0&, AddressOf MonitorCountEnum, MonitorCount
End Function

Private Function MonitorCountEnum(ByVal hMonitor As Long, ByVal hdcMonitor As Long, uRect As RECT, dwData As Long) As Long
    dwData = dwData + 1
    MonitorCountEnum = 1 ' Count them all.
End Function

Public Function MonitorNumForHwnd(hWnd As Long) As Long
    MonitorNumForHwnd = MonitorNum(MonitorHandleForHwnd(hWnd))
End Function

Public Function MonitorHandleForHwnd(hWnd As Long) As Long
    Const MONITOR_DEFAULTTONULL = &H0
    MonitorHandleForHwnd = MonitorFromWindow(hWnd, MONITOR_DEFAULTTONULL)
End Function

Public Function MonitorNum(hMonitor As Long) As Long
    ' This one returns the monitor number from the monitor's handle.
    ' ZERO is returned if not found.
    ' Monitors are ONE based when counted, no holes.
    ' These numbers do NOT necessarily match numbers in control panel.
    Dim dwData As Long
    dwData = -hMonitor  ' Send it in negative to indicate first iteration.
    EnumDisplayMonitors 0&, ByVal 0&, AddressOf MonitorNumEnum, dwData
    If Abs(dwData) <> hMonitor Then MonitorNum = dwData                          ' The number is returned in dwData if found.
End Function

Private Function MonitorNumEnum(ByVal hMonitor As Long, ByVal hdcMonitor As Long, uRect As RECT, dwData As Long) As Long
    Static iCount As Long
    If dwData < 0 Then
        iCount = 1
        dwData = -dwData
    Else
        iCount = iCount + 1
    End If
    If dwData = hMonitor Then
        dwData = iCount
        MonitorNumEnum = 0 ' Found it.
    Else
        MonitorNumEnum = 1 ' Keep looking.
    End If
End Function

Public Sub PositionWindowOnMonitor(hWnd As Long, hMonitor As Long, ByVal lLeftPixel As Long, ByVal lTopPixel As Long)
    ' This can be used to position windows on other programs so long as you have the hWnd.
    Dim lHeight As Long
    Dim lWidth As Long
    '
    lHeight = WindowHeightPx(hWnd)
    lWidth = WindowWidthPx(hWnd)
    '
    lLeftPixel = lLeftPixel + MonitorLeftPx(hMonitor)
    lTopPixel = lTopPixel + MonitorTopPx(hMonitor)
    '
    MoveWindow hWnd, lLeftPixel, lTopPixel, lWidth, lHeight, 1&
End Sub

Public Function WindowHeightPx(hWnd As Long) As Long
    Dim r As RECT
    GetWindowRect hWnd, r
    WindowHeightPx = r.Bottom - r.Top
End Function

Public Function WindowWidthPx(hWnd As Long) As Long
    Dim r As RECT
    GetWindowRect hWnd, r
    WindowWidthPx = r.Right - r.Left
End Function

Public Function WindowTopPx(hWnd As Long) As Long
    ' This adjusts for the monitor the window is on.
    Dim r As RECT
    GetWindowRect hWnd, r
    WindowTopPx = r.Top - MonitorTopPx(MonitorHandleForHwnd(hWnd))
End Function

Public Function WindowLeftPx(hWnd As Long) As Long
    ' This adjusts for the monitor the window is on.
    Dim r As RECT
    GetWindowRect hWnd, r
    WindowLeftPx = r.Left - MonitorLeftPx(MonitorHandleForHwnd(hWnd))
End Function

Public Function MonitorLeftPx(hMonitor As Long) As Long
    ' If you just have the number, do: MonitorLeftPx(MonitorHandle(MonitorNum))
    Dim uMonInfo As MONITORINFO
    uMonInfo.cbSize = LenB(uMonInfo)
    If GetMonitorInfo(hMonitor, uMonInfo) = 0 Then Exit Function
    MonitorLeftPx = uMonInfo.rcMonitor.Left
End Function

Public Function MonitorTopPx(hMonitor As Long) As Long
    ' If you just have the number, do: MonitorTopPx(MonitorHandle(MonitorNum))
    Dim uMonInfo As MONITORINFO
    uMonInfo.cbSize = LenB(uMonInfo)
    If GetMonitorInfo(hMonitor, uMonInfo) = 0 Then Exit Function
    MonitorTopPx = uMonInfo.rcMonitor.Top
End Function

Public Function MonitorHandle(ByVal MonitorNum As Long) As Long
    ' Monitors are ONE based when counted, no holes.
    ' These numbers do NOT necessarily match numbers in control panel.
    Dim dwData As Long
    dwData = -MonitorNum  ' Send it in negative.
    EnumDisplayMonitors 0&, ByVal 0&, AddressOf MonitorHandleEnum, dwData
    If dwData > 0 Then MonitorHandle = dwData                          ' The handle is returned in dwData if found.
End Function

Private Function MonitorHandleEnum(ByVal hMonitor As Long, ByVal hdcMonitor As Long, uRect As RECT, dwData As Long) As Long
    dwData = dwData + 1 ' They come in negative to stay out of the way of handles.
    If dwData = 0 Then ' We're at the one we want.
        dwData = hMonitor
        MonitorHandleEnum = 0
    Else
        MonitorHandleEnum = 1
    End If
End Function

Public Function MonitorWidthPx(hMonitor As Long) As Long
    ' If you just have the number, do: MonitorWidthPx(MonitorWidthPx(MonitorNum))
    Dim uMonInfo As MONITORINFO
    uMonInfo.cbSize = LenB(uMonInfo)
    If GetMonitorInfo(hMonitor, uMonInfo) = 0 Then Exit Function
    MonitorWidthPx = uMonInfo.rcMonitor.Right - uMonInfo.rcMonitor.Left
End Function

Public Function MonitorHeightPx(hMonitor As Long) As Long
    ' If you just have the number, do: MonitorHeightPx(MonitorWidthPx(MonitorNum))
    Dim uMonInfo As MONITORINFO
    uMonInfo.cbSize = LenB(uMonInfo)
    If GetMonitorInfo(hMonitor, uMonInfo) = 0 Then Exit Function
    MonitorHeightPx = uMonInfo.rcMonitor.Bottom - uMonInfo.rcMonitor.Top
End Function



---

All will work fine in the IDE. However, the last form position won't be saved if you use the IDE's stop button. I didn't want to use sub-classing, so I don't have any way to track form movement, other than querying it when the form closes.

Enjoy,
Elroy

EDIT1: Also, it should work just fine for as many forms as you'd like to use it for in a project.

VB6 - Remember App window Position and Size

March 24, 2018, 2:27 pm

≫ Next: [VB6] Neural Network

≪ Previous: Remember Form's Position for Next Execution, Multi-Monitor

$

0

0

Attached is a demo of saving and restoring an application position and size. Rather than hijacking Elroy's thread, I decided to create a new one. This code is further simplified from the code that I supplied there, in that it eliminates the need for the SysInfo control and doesn't account for the Taskbar. It also demonstrates how the onboard controls are adjusted when the form size is adjusted. This is a fairly simple demonstration, and more complex forms will take quite a bit more work. The "EXIT" button is there simply to allow the form to be unloaded when the right side is off the screen. The "InitFlg" in the "Resize" event simply prevents the controls from being adjusted on the intial activation.

The InkEdit control used as "Text1" should allow for the use of Unicode characters.

J.A. Coutts

Attached Images

 

Attached Files

• Demofrm.zip (2.7 KB)

[VB6] Neural Network

March 29, 2018, 10:11 am

≫ Next: PNG (specifically 32-bit RGBA type PNG) Editing Tool

≪ Previous: VB6 - Remember App window Position and Size

$

0

0

Since a neural network is missing in the codebank
here is my version:

It's very simple.

It initializes with "CREATE"

Code:

---

  NN.CREATE Array (2, 2, 1), 0.25, 4

---

-Where Array indicates the NN topology
Array (N of Inputs, Hidden layer neurons, ..., Hidden layer neurons, N of outputs)
-The second term is the Learning Rate.
-The third is the initial range of connections. (this value, together with the Learning Rate is very important and can drastically change the learning outcomes)

To get the output just call RUN with an array of inputs as arguments,
Return the Outputs Array

For learning (which is supervided) just call TRAIN.
The arguments are an array of Inputs and an array of expected Outputs
The learning process is done by backpropagation, the code is taken (and modified) by an article by Paras Chopra.

Neurons Index "Zero" [0] of each Layer is used for Bias. It is always 1 (The Biases are the weights of connections from 0-indexs neurons to next layer neurons) [Still not sure this way is correct tough]

Inputs and outputs range is from -1 to 1
the Activation function used is TANH.

Probably I'll put it on Github.

Enjoy

And, as always, anyone has ideas to improve it, is welcome

Attached Files

• NNstd.zip (12.8 KB)

PNG (specifically 32-bit RGBA type PNG) Editing Tool

March 30, 2018, 10:12 am

≫ Next: [vb6] GDI+ Image Attributes Intro & Usage

≪ Previous: [VB6] Neural Network

$

0

0

Note, this project uses mscomctl.ocx version 2.2. If you have an older version, the project may not load correctly for you. To fix this problem, you will need to update your mscomctl.ocx. Here's a link to a post by LaVolpe that explains the issue more fully, and provides links for the updates. Also, mscomct2.ocx version 2.0 is used for the status bar. If you have an older version of that, you may need to update it as well (or remove the status bar, which wouldn't be difficult).

Hi All,

This was a request and I thought it would be fun. It turned out to be quite the learning experience.

Basically, I've developed a tool for editing the Gamma, Brightness, or Contrast of a 32-bit RGBA type PNG image. Sorry, but it's specifically limited to that type of an image file.

Here's a screen-shot of the main form:


Basically, when you open a PNG file, it loads it (via GDI+), displays it on a form, splits it into four channels (Red, Green, Blue, & Alpha), displays each of these on separate forms, and then displays one last form that shows modifications to the image. Here's a reduced screen-shot of how it looks:



A couple of caveats: I do use SaveSettings to save a few things to the registry. I know that some people are concerned about this. Therefore, if you're running in the IDE, upon normal exit, I ask if you'd like to delete all of these settings.

Also, to try and keep things speedy, I startup the GDI+ upon opening the app, and don't shut it down until you're exiting. I didn't have any problems with the IDE stop button, but I'm not totally clear on whether or not an IDE stop is totally safe here. I'm hoping that the worst case is a memory leak (that's cleared up when you exit the IDE).

The entire project is in the attachment to this post. A PNG file has also been supplied for you to play with (same one shown).

Now, I'd also like to take this opportunity to outline how I did things. Basically (because I want to handle PNG files with an active Alpha channel), I used the GDI+ to load the image. And then I immediately use the GDI+ to show this original image. Next, I get the image's RgbQuad() data, and then split that into its separate channels, creating separate arrays for Red, Green, Blue, & Alpha. And then I use the regular GDI32's SetDIBits to show these channels on the separate forms. And then, I take the four RgbQuad() channel arrays, re-combine them, and then show them on a Modifications form (using GDI+ and the still open hBitmap to do this).

Just as an FYI, the individual RgbQuad() channel arrays have no Alpha in them (it's always zero). The original image's Alpha channel is copied into the Red, Green, & Blue channels of the Alpha's RgbQuad() array, effectively creating a gray-scale image to show the Alpha channel.

I also "save in memory" all kinds of information (thinking that this would keep things speedy). Therefore, this thing is not memory efficient. Here's a list of what I maintain in memory:

1. I keep the original file open (hBitmat) with the GDI+.
2. I keep the original RgbQuad().
3. I keep each channel's original RgbQuad() (four of them).
4. I keep each channel's modified RgbQuad() (four of them).
5. I keep a modified RgbQuad() of the full modified image.

Some of the things I learned during all of this:

• When leaving a PNG file open (active hBitmap) with GDI+, somehow, GDI+ keeps its hooks into that file until you execute a GdipDisposeImage (or something similar).

• These PNG files can have a DPI scaling factor embedded in them that makes using GdipDrawImage a bit dubious. If you want to "think" in pixels, this will get fouled up. To "think" in pixels, you must use GdipDrawImageRectI.

• The GDI+ seems to prefer scanning images from top-down, whereas the GDI32 prefers seeing them as bottom-up. That just caused me to jump through a few hoops to tell the GDI+ that I want them bottom-up so that I'm not constantly flipping them.

• As I got into it, it dawned on me that the order in which Gamma, Brightness, & Contrast are applied might matter. The approach I took was to always go back to the original image when making changes (and hence saving all those RgbQuad() arrays). Always going back to the original allows me to return to that original while editing, if I so desire. Rather than get overly complicated, I just decided on a Gamma(first), Brightness(second), & Contrast(last) approach to applying things.

• I also learned that Contrast can be complicated. There are several theories/ideas on how this should be done. I'm not entirely happy with my approach, but it works. I save the mean value (as a Single) of each of the channels upon load. And then, pixels are either stretched away from (or pushed toward) this mean to achieve contrast changes. Other approaches would be to go toward or away from 128 (middle value). Yet another approach would be to calculate the mean each time (thereby accounting for brightness and gamma changes) but this could have speed consequences.

• I also learned that, with larger images, my approach can bog down. At first, I was showing all changes "in real time" on each click of a control. However, it quickly became apparent that this wasn't going to work. Therefore, I implemented a timer that fires every 200ms. If a bIsModDirty flag is true and if the mouse button isn't down, it calculates and shows the changes. This allows the interface to work much more smoothly, although you don't see changes until you release the mouse button.

And, here's a list of things I may want to consider for the future:

• Possibly exploring (learning more about) how to use the GDI+ to do my Gamma, Brightness, Contrast changes. I feel certain it's capable of this, and it may make the entire project more memory efficient, and possibly more speedy as well.

• Possibly learn how to read a TGA (Targa) file as well. This was actually part of the original request, but I had to start somewhere. If I do this, I'd probably want my SaveAs... to be able to convert between the two.

• Think more about the order in which the effects are applied (especially since I'm always going back to the original). I might let that be user-specified, just to see what difference it makes.

• Possibly consider additional effects (soften, sharpen, etc.).

I've done my level-headed best to keep this code as organized as possible. However, I do use somewhat deeply nested UDTs to keep track of everything. However, for a somewhat seasoned VB6 programmer, that shouldn't be a huge deal.

If you're interested in studying this code for purposes of how to manipulate images, the place to start is the code in frmMain. And then, you'll want to get into the modPng code, and then the modGdip code. I've tried to make the modGdip code as generic as possible (i.e., not really tied to the specifics of this project). The code in modPng is rather specific to this project. You'll see all the stuff that's maintained in memory in the ThePng UDT variable that's in the modPng file. There's also a touch of GDI32 stuff in the modPng file.

Version 1.03 (original release)

Enjoy,
Elroy

p.s. Please stay focused and please don't be upset if I don't respond to all of these, but critiques and suggestions for improvement are welcomed and encouraged.

Attached Images

  

Attached Files

• PngEditor.zip (181.8 KB)

---

[vb6] GDI+ Image Attributes Intro & Usage

April 1, 2018, 2:41 pm

≫ Next: VB6 - Sort Routine

≪ Previous: PNG (specifically 32-bit RGBA type PNG) Editing Tool

$

0

0

Thought it would be worthwhile sharing some information regarding GDI+ and its Image Attributes object. Specifically, we are going to discuss the color matrix. This is a 5x5 matrix/grid, variable type: Single.

GDI+ uses this matrix to change image color values, on-the-fly. This prevents you from having to manipulate and change individual color values by hand. Since the matrix is basically a batch, of sorts, of formulas applied to each pixel value, there is little that cannot be done and limited only by imagination or creativity.

The project included below is provided to get your feet wet. There exists on many sites sample matrices you can use to achieve many different color transformations. Wouldn't be a bad idea to start collecting these and storing away for future use. This project, though truly a demo, offers a method to save and load your personal collections of matrices (assuming they were saved while using the demo).

The project is also designed to punch in any matrix values you want and see the results with a click of a button. Like what you see after your changes? Save the matrix or copy the matrix to the clipboard and paste into your project.

I've included a sample PNG in the file, but the project allows you to select images from your computer. I'm sure some of you will ask questions, but let's not discuss modifying the demo project... let's talk about GDI+ image attributes.

This is a good link to read a bit more about GDI+ color matrices. The link starts at page 7 at that site, be sure to browse some of the other pages too.

Screenshot below is a more complex matrix. Most matrices are just 3-5 non-zero entries.



Note for non-US locales, use US decimals. The project expects that format in the textboxes.

Attached Images

 

Attached Files

• GDIpAttrs.zip (113.8 KB)

VB6 - Sort Routine

April 4, 2018, 9:29 am

≫ Next: PNG/TGA (specifically 32-bpp type files) Editing Tool

≪ Previous: [vb6] GDI+ Image Attributes Intro & Usage

$

0

0

Shown here is a sort routine that utilizes the built in Command Line sort function. Outside of this routine, a file is loaded into a Textbox and the file name is saved in "m_Filename". The user is first asked where in each line the sort is to start. I use this routine to sort log files, which often begin with a time stamp. The file is appended chronologically, so it is already sorted by time. For example:

00:03:14 Request from 74.125.80.70 for TXT-record for _adsp._domainkey.yellowhead.com.
00:03:15 Sending reply to 74.125.80.70 about TXT-record for _adsp._domainkey.yellowhead.com.:
00:03:16 -> Header: Name does not exist!

I am only interested in the "Request" part of it, so I would start at position 25. I can then easily delete the unwanted portions.

The sorted file is temporarily stored in the users "Temp" directory. You will probably find lots of junk in that directory, as many programs are not very good at cleaning up after themselves. We will attempt not to be one of those, and "Kill" off the file after we are done with it.

The heart of the routine is the "Shell" function. In that I use the seldom used "Environ" function to recover the "COMSPEC" string from the Environment. Environment variables will vary with the individual computer, and can be viewed from the Command Prompt with the "Set" command. To this I add "/c" to concatenate, the "type" command, the file name to sort, the pipe option (|), the "sort" command, and the name of the file to direct the output to. I also add a "vbHide" option, since we are not interested in displaying the results in a Command Prompt window.

We then enter a loop waiting for the directory to be updated. To prevent getting stuck in an endless loop, a counter is implemented. Since file I/O is a buffered operation, an additional 100 ms delay is added to allow for the write operation to complete. The "Loadfile" routine loads the newly sorted file back into the Textbox. We use another 100 ms delay to allow that operation to complete before we delete the temporary file. We then restore the App.Path and the original file name.

Code:

---

Private Sub mnuSort_Click()
    Dim sTmp As String
    Dim lCntr As Long
    Dim SortStart As Long
    Dim SortCmd As String
    If Len(m_Filename) = 0 Then
        MsgBox "Text must be saved as a file before it can be sorted!", vbExclamation
        Exit Sub
    End If
    SortStart = InputBox("Enter character count to start at - ", "Start", 0)
    If SortStart = 0 Then
        SortCmd = "|sort>tmpsort.txt" 'Default starts at beginning of line
    Else
        SortCmd = "|sort /+" & CStr(SortStart) & ">tmpsort.txt"
    End If
    ChDir TmpPath 'Sorted file is output to temp path
    sTmp = m_Filename 'Save current file location
    Debug.Print Timer
    Call Shell(Environ("COMSPEC") & " /c type " & m_Filename & SortCmd, vbHide)
    m_Filename = "tmpsort.txt" 'Change filename to sorted file
    Do Until Dir(m_Filename) = m_Filename 'Wait for directory to be updated
        DoEvents
        Sleep 10
        lCntr = lCntr + 1
        If lCntr > 100 Then GoTo SortErr
    Loop
    Debug.Print lCntr
    Sleep 100 'Wait an additional 100 ms for file write to complete
    Debug.Print Timer
    LoadFile 'Load sorted file to Textbox
    Sleep 100 'Wait an additional 100 ms for sorted file to load
    Kill m_Filename
    Debug.Print Timer
    m_Filename = sTmp 'Restore original filename
    ChDir App.Path 'Restore Application path
    m_Flg1 = True 'Set change flag
    Exit Sub
SortErr:
    MsgBox "Sort Timed out!"
End Sub

Private Const MAX_PATH = 260
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Function GetTmpPath() As String
    Dim sFolder As String ' Name of the folder
    Dim lRet As Long ' Return Value
    sFolder = String(MAX_PATH, 0)
    lRet = GetTempPath(MAX_PATH, sFolder)
    If lRet <> 0 Then
        GetTmpPath = Left(sFolder, InStr(sFolder, Chr(0)) - 1)
    Else
        GetTmpPath = vbNullString
    End If
End Function

---

I have found this routine to be a lot faster than any algorithm I could put together in VB6, especially for large text files. For the most part it is an in-memory sort, but for very large files it will temporarily store the first run to the disk before attempting the second run. An example of how to use this routine will be forthcoming in the near future.

J.A. Coutts

PNG/TGA (specifically 32-bpp type files) Editing Tool

March 30, 2018, 10:12 am

≫ Next: Standard API Color Picker

≪ Previous: VB6 - Sort Routine

$

0

0

Note, this project uses mscomctl.ocx version 2.2. If you have an older version, the project may not load correctly for you. To fix this problem, you will need to update your mscomctl.ocx. Here's a link to a post by LaVolpe that explains the issue more fully, and provides links for the updates. Also, mscomct2.ocx version 2.0 is used for the status bar. If you have an older version of that, you may need to update it as well (or remove the status bar, which wouldn't be difficult).

Version 1.03 (original release, attached to this OP)
Version 1.04 released in post #16
Version 1.05 released in post #17
Version 1.06 released in post #18

Hi All,

This was a request and I thought it would be fun. It turned out to be quite the learning experience.

Basically, I've developed a tool for editing the Gamma, Brightness, or Contrast of a 32-bit RGBA type PNG or TGA image. Sorry, but it's specifically limited to that type of an image file.

Here's a screen-shot of the main form:


Basically, when you open a PNG file, it loads it (via GDI+), displays it on a form, splits it into four channels (Red, Green, Blue, & Alpha), displays each of these on separate forms, and then displays one last form that shows modifications to the image. Here's a reduced screen-shot of how it looks:



A couple of caveats: I do use SaveSettings to save a few things to the registry. I know that some people are concerned about this. Therefore, if you're running in the IDE, upon normal exit, I ask if you'd like to delete all of these settings.

Also, to try and keep things speedy, I startup the GDI+ upon opening the app, and don't shut it down until you're exiting. I didn't have any problems with the IDE stop button, but I'm not totally clear on whether or not an IDE stop is totally safe here. I'm hoping that the worst case is a memory leak (that's cleared up when you exit the IDE).

The entire project is in the attachment to this post. A PNG file has also been supplied for you to play with (same one shown).

Now, I'd also like to take this opportunity to outline how I did things. Basically (because I want to handle PNG files with an active Alpha channel), I used the GDI+ to load the image. And then I immediately use the GDI+ to show this original image. Next, I get the image's RgbQuad() data, and then split that into its separate channels, creating separate arrays for Red, Green, Blue, & Alpha. And then I use the regular GDI32's SetDIBits to show these channels on the separate forms. And then, I take the four RgbQuad() channel arrays, re-combine them, and then show them on a Modifications form (using GDI+ and the still open hBitmap to do this).

Just as an FYI, the individual RgbQuad() channel arrays have no Alpha in them (it's always zero). The original image's Alpha channel is copied into the Red, Green, & Blue channels of the Alpha's RgbQuad() array, effectively creating a gray-scale image to show the Alpha channel.

I also "save in memory" all kinds of information (thinking that this would keep things speedy). Therefore, this thing is not memory efficient. Here's a list of what I maintain in memory:

1. I keep the original file open (hBitmat) with the GDI+.
2. I keep the original RgbQuad().
3. I keep each channel's original RgbQuad() (four of them).
4. I keep each channel's modified RgbQuad() (four of them).
5. I keep a modified RgbQuad() of the full modified image.

Some of the things I learned during all of this:

• When leaving a PNG file open (active hBitmap) with GDI+, somehow, GDI+ keeps its hooks into that file until you execute a GdipDisposeImage (or something similar).

• These PNG files can have a DPI scaling factor embedded in them that makes using GdipDrawImage a bit dubious. If you want to "think" in pixels, this will get fouled up. To "think" in pixels, you must use GdipDrawImageRectI.

• The GDI+ seems to prefer scanning images from top-down, whereas the GDI32 prefers seeing them as bottom-up. That just caused me to jump through a few hoops to tell the GDI+ that I want them bottom-up so that I'm not constantly flipping them.

• As I got into it, it dawned on me that the order in which Gamma, Brightness, & Contrast are applied might matter. The approach I took was to always go back to the original image when making changes (and hence saving all those RgbQuad() arrays). Always going back to the original allows me to return to that original while editing, if I so desire. Rather than get overly complicated, I just decided on a Gamma(first), Brightness(second), & Contrast(last) approach to applying things.

• I also learned that Contrast can be complicated. There are several theories/ideas on how this should be done. I'm not entirely happy with my approach, but it works. I save the mean value (as a Single) of each of the channels upon load. And then, pixels are either stretched away from (or pushed toward) this mean to achieve contrast changes. Other approaches would be to go toward or away from 128 (middle value). Yet another approach would be to calculate the mean each time (thereby accounting for brightness and gamma changes) but this could have speed consequences.

• I also learned that, with larger images, my approach can bog down. At first, I was showing all changes "in real time" on each click of a control. However, it quickly became apparent that this wasn't going to work. Therefore, I implemented a timer that fires every 200ms. If a bIsModDirty flag is true and if the mouse button isn't down, it calculates and shows the changes. This allows the interface to work much more smoothly, although you don't see changes until you release the mouse button.

And, here's a list of things I may want to consider for the future:

• Possibly exploring (learning more about) how to use the GDI+ to do my Gamma, Brightness, Contrast changes. I feel certain it's capable of this, and it may make the entire project more memory efficient, and possibly more speedy as well.

• Possibly learn how to read a TGA (Targa) file as well. This was actually part of the original request, but I had to start somewhere. If I do this, I'd probably want my SaveAs... to be able to convert between the two.

• Think more about the order in which the effects are applied (especially since I'm always going back to the original). I might let that be user-specified, just to see what difference it makes.

• Possibly consider additional effects (soften, sharpen, etc.).

I've done my level-headed best to keep this code as organized as possible. However, I do use somewhat deeply nested UDTs to keep track of everything. However, for a somewhat seasoned VB6 programmer, that shouldn't be a huge deal.

If you're interested in studying this code for purposes of how to manipulate images, the place to start is the code in frmMain. And then, you'll want to get into the modPng code, and then the modGdip code. I've tried to make the modGdip code as generic as possible (i.e., not really tied to the specifics of this project). The code in modPng is rather specific to this project. You'll see all the stuff that's maintained in memory in the ThePng UDT variable that's in the modPng file. There's also a touch of GDI32 stuff in the modPng file.

Enjoy,
Elroy

p.s. Please stay focused and please don't be upset if I don't respond to all of these, but critiques and suggestions for improvement are welcomed and encouraged.

Attached Images

  

Attached Files

• PngEditor.zip (181.8 KB)

Standard API Color Picker

April 6, 2018, 4:43 pm

≫ Next: [VB6] BatchRtb 2

≪ Previous: PNG/TGA (specifically 32-bpp type files) Editing Tool

$

0

0

It's strange that this doesn't have more of a presence on these forums than it does, but hey ho.

Attached is the my ChooseColorAPI wrapper that I've just polished up. Here are its features:

• It just always opens allowing you to select custom colors.
• You can save the user-specified custom colors if you so choose (your application specific).
• It has the ability of allowing you to specify your own dialog title.
• You can double-click on the colors and they will auto-select and be returned to you.

Beyond that, it's pretty much the standard ChooseColorAPI function.

More could be done with this thing, but this is precisely what I needed, and I thought I'd share.

Here's code for a standard BAS module (everything needed, just focus on the ShowColorDialog procedure):

Code:

---


Option Explicit
'
' These are used to get information about how the dialog went.
Public ColorDialogSuccessful As Boolean
Public ColorDialogColor As Long
'
Private Type ChooseColorType
    lStructSize        As Long
    hWndOwner          As Long
    hInstance          As Long
    rgbResult          As Long
    lpCustColors      As Long
    flags              As Long
    lCustData          As Long
    lpfnHook          As Long
    lpTemplateName    As String
End Type
Private Enum ChooseColorFlagsEnum
    CC_RGBINIT = &H1                  ' Make the color specified by rgbResult be the initially selected color.
    CC_FULLOPEN = &H2                ' Automatically display the Define Custom Colors half of the dialog box.
    CC_PREVENTFULLOPEN = &H4          ' Disable the button that displays the Define Custom Colors half of the dialog box.
    CC_SHOWHELP = &H8                ' Display the Help button.
    CC_ENABLEHOOK = &H10              ' Use the hook function specified by lpfnHook to process the Choose Color box's messages.
    CC_ENABLETEMPLATE = &H20          ' Use the dialog box template identified by hInstance and lpTemplateName.
    CC_ENABLETEMPLATEHANDLE = &H40    ' Use the preloaded dialog box template identified by hInstance, ignoring lpTemplateName.
    CC_SOLIDCOLOR = &H80              ' Only allow the user to select solid colors. If the user attempts to select a non-solid color, convert it to the closest solid color.
    CC_ANYCOLOR = &H100              ' Allow the user to select any color.
End Enum
#If False Then ' Intellisense fix.
    Public CC_RGBINIT, CC_FULLOPEN, CC_PREVENTFULLOPEN, CC_SHOWHELP, CC_ENABLEHOOK, CC_ENABLETEMPLATE, CC_ENABLETEMPLATEHANDLE, CC_SOLIDCOLOR, CC_ANYCOLOR
#End If
Private Type KeyboardInput        '
    dwType As Long                ' Set to INPUT_KEYBOARD.
    wVK As Integer                ' shift, ctrl, menukey, or the key itself.
    wScan As Integer              ' Not being used.
    dwFlags As Long              '            HARDWAREINPUT hi;
    dwTime As Long                ' Not being used.
    dwExtraInfo As Long          ' Not being used.
    dwPadding As Currency        ' Not being used.
End Type
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Const WM_LBUTTONDBLCLK As Long = 515&
Private Const WM_SHOWWINDOW    As Long = 24&
Private Const WM_SETTEXT      As Long = &HC&
Private Const INPUT_KEYBOARD  As Long = 1&
Private Const KEYEVENTF_KEYUP  As Long = 2&
Private Const KEYEVENTF_KEYDOWN As Long = 0&
'
Private muEvents(1) As KeyboardInput    ' Just used to emulate "Enter" key.
Private pt32 As POINTAPI
Private msColorTitle As String
'
Private Declare Function ChooseColorAPI Lib "comdlg32" Alias "ChooseColorA" (pChoosecolor As ChooseColorType) As Long
Private Declare Function SendInput Lib "user32" (ByVal nInputs As Long, pInputs As Any, ByVal cbSize As Long) As Long
Private Declare Function SetFocusTo Lib "user32" Alias "SetFocus" (Optional ByVal hWnd As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ChildWindowFromPointEx Lib "user32" (ByVal hWnd As Long, ByVal xPoint As Long, ByVal yPoint As Long, ByVal uFlags As Long) As Long
Private Declare Function SendMessageWLong Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'

Public Function ShowColorDialog(hWndOwner As Long, Optional NewColor As Long, Optional Title As String = "Select Color", Optional CustomColorsHex As String) As Boolean
    ' You can optionally use ColorDialogSuccessful & ColorDialogColor or the return of ShowColorDialog and NewColor.  They will be the same.
    '
    ' CustomColorHex is a comma separated hex string of 16 custom colors.  It's best to just let the user specify these, starting out with all black.
    ' If this CustomColorHex string doesn't separate into precisely 16 values, it's ignored, resulting with all black custom colors.
    ' The string is returned, and it's up to you to save it if you wish to save your user-specified custom colors.
    ' These will be specific to this program, because this is your CustomColorsHex string.
    '
    Dim uChooseColor As ChooseColorType
    Dim CustomColors(15) As Long
    Dim sArray() As String
    Dim i As Long
    '
    msColorTitle = Title
    '
    ' Setup custom colors.
    sArray = Split(CustomColorsHex, ",")
    If UBound(sArray) = 15 Then
        For i = 0 To 15
            CustomColors(i) = Val("&h" & sArray(i))
        Next i
    End If
    '
    uChooseColor.hWndOwner = hWndOwner
    uChooseColor.lpCustColors = VarPtr(CustomColors(0))
    uChooseColor.flags = CC_ENABLEHOOK Or CC_FULLOPEN
    uChooseColor.hInstance = App.hInstance
    uChooseColor.lStructSize = LenB(uChooseColor)
    uChooseColor.lpfnHook = ProcedureAddress(AddressOf ColorHookProc)
    '
    ColorDialogSuccessful = False
    If ChooseColorAPI(uChooseColor) = 0 Then
        Exit Function
    End If
    If uChooseColor.rgbResult > &HFFFFFF Then Exit Function
    '
    ColorDialogColor = uChooseColor.rgbResult
    NewColor = uChooseColor.rgbResult
    ColorDialogSuccessful = True
    ShowColorDialog = True
    '
    ' Return custom colors.
    ReDim sArray(15)
    For i = 0 To 15
        sArray(i) = Hex$(CustomColors(i))
    Next i
    CustomColorsHex = Join(sArray, ",")
End Function

Private Function ColorHookProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If uMsg = WM_SHOWWINDOW Then
        SetWindowText hWnd, msColorTitle
        ColorHookProc = 1&
    End If
    '
    If uMsg = WM_LBUTTONDBLCLK Then
        '
        ' If we're on a hWnd with text, we probably should ignore the double-click.
        GetCursorPos pt32
        ScreenToClient hWnd, pt32
        '
        If WindowText(ChildWindowFromPointEx(hWnd, pt32.X, pt32.Y, 0&)) = vbNullString Then
            ' For some reason, this SetFocus is necessary for the dialog to receive keyboard input under certain circumstances.
            SetFocusTo hWnd
            ' Build EnterKeyDown & EnterKeyDown events.
            muEvents(0).wVK = vbKeyReturn: muEvents(0).dwFlags = KEYEVENTF_KEYDOWN: muEvents(0).dwType = INPUT_KEYBOARD
            muEvents(1).wVK = vbKeyReturn: muEvents(1).dwFlags = KEYEVENTF_KEYUP:  muEvents(1).dwType = INPUT_KEYBOARD
            ' Put it on buffer.
            SendInput 2&, muEvents(0), Len(muEvents(0))
            ColorHookProc = 1&
        End If
    End If
End Function

Private Function ProcedureAddress(AddressOf_TheProc As Long)
    ProcedureAddress = AddressOf_TheProc
End Function

Private Function WindowText(hWnd As Long) As String
    WindowText = Space$(GetWindowTextLength(hWnd) + 1)
    WindowText = Left$(WindowText, GetWindowText(hWnd, WindowText, Len(WindowText)))
End Function

Public Sub SetWindowText(hWnd As Long, sText As String)
    SendMessageWLong hWnd, WM_SETTEXT, 0&, StrPtr(sText)
End Sub



---

And, if you wish to just test/play, here's a bit of code for a Form1:

Code:

---


Option Explicit
'
Dim msOurCustomColors As String
'

Private Sub Form_Click()
    ShowColorDialog Me.hWnd, , "Pick a color for background", msOurCustomColors
    If ColorDialogSuccessful Then Me.BackColor = ColorDialogColor
End Sub


---

Enjoy,
Elroy

[VB6] BatchRtb 2

April 8, 2018, 9:13 am

≫ Next: VB6 - Multiline Textbox Printer

≪ Previous: Standard API Color Picker

$

0

0

Since I am almost 100% retired now and doing a lot less VB6 programming I have been looking for things in my toolkit that might be worth sharing with the remaining VB6 community.

I have done a big rewrite of my BatchRtb Class. Here is the main ReadMe:

Code:

---

========
BatchRtb Version 2.0
========

BatchRtb is a VB6 class for working with RTF data in batch programs.

Instead of a RichTextBox control it creates an invisible RichEdit
control and exposes its Text Object Model (TOM) ITextDocument
interface.  A few additional methods and properties are provided for
opening, saving, and clearing RTF data.

Open and save operations accept:

    o A file name.
    o A Byte array.
    o An IStream object.
    o A ShStream object (another provided class also used internally).
    o An ADODB.Stream object.

These should all contain raw RTF data.


Notes:

    Edanmo's olelib.tlb is required for compiling, but is of course
    not needed at run time and does not need to be deployed.  A recent
    copy has been included.

    If necessary you could even create and compile an ActiveX DLL
    Project exposing the BatchRtb class and perhaps the ShStream class.
    Then this can be used from VBScript in WSH scripts, IIS ASP
    scripts, etc. (anywhere a 32-bit ActiveX DLL can be used).

    Several demo/test Projects using BatchRtb are included.


Some uses:

    o Command line programs.  Local, via PsExec.exe, etc.
    o Batch unattended scheduled tasks.
    o Services.
    o Or anywhere that you don't have a Form or UserControl you can
      site a RichTextBox or InkEdit control on.

---

This isn't for everyone. Few people are doing Service development, ASP scripting, etc. Most don't even have a clue how to use a CLI (cmd.exe) window, let alone schedule a non-interactive batch task using Task Scheduler any more.

But this code may contain techniques you could employ in your own programs.


BatchRtb 2.0 has been tested on Windows 10 Fall Creator's Update but not on anything else yet. It should work on anything from Windows Vista on up. I'm not sure it could be made to work on Win9x but I think it could be reworked to run on NT 4.0 on up by rewriting the ShStream class - as long as a recent version of ADO (2.5 or later) is installed. The ADO requirement could also be stripped out if necessary.

I haven't done exhaustive testing so bugs may remain in this release. But the attachment contains a number of test case Projects that exercise most of its operations.

Attached Files

• BatchRtb 2.zip (265.8 KB)