Convert a Number from a certain base to a different one

April 2, 2024, 12:55 pm

≫ Next: Lots of Functions to Deal with Controls

$

0

0

I share my Code, as anticipated in the following thread:
https://www.vbforums.com/showthread....imal-to-binary

Code:

---

Function Convert•Num‹Num(Number As String, BaseNew_2Binary_8Octal_10Decimal_16Hexadecimal As Integer, BaseOld_2Binary_8Octal_10Decimal_16Hexadecimal As Integer, Optional QuantityDigitsToReturn As Integer) As String
  'Pass a Number, from a certain Base, to another different Base
  'The Number Parameter is actually a String that represents the input Number
  'QuantityDigitsToReturn completes with 0 on the left so that the total number of digits of the number is as requested. If 0 is passed there will be no modifications
  'Be careful: this amount cannot be less than the number of digits in the result, otherwise it will be truncated.
    Dim Cad As String, BV As Integer, BN As Integer, DC As Integer
    BV = BaseOld_2Binary_8Octal_10Decimal_16Hexadecimal
    BN = BaseNew_2Binary_8Octal_10Decimal_16Hexadecimal
    DC = QuantityDigitsToReturn
    Cad = Convert•Num‹Dec(Convert•Dec‹Num(Number, BV), BN)
    If DC > 0 Then Cad = Right(String(64, "0") & Cad, DC)
    Convert•Num‹Num = Cad
End Function

 Function Convert•Dec‹Num(Number As String, BaseOld_2Binary_8Octal_16Hexadecimal As Integer) As String
  'Go to Decimal (Base 10), a Number that is originally Binary (Base 2), Octal (Base 8) or Hexadecimal (Base 16)
    Dim Ptr As Integer, DA As String, CD As Integer, B10 As Long, CA As Integer, Base As Integer
    Base = BaseOld_2Binary_8Octal_16Hexadecimal
    CD = Len(Trim(Number))
    For Ptr = 1 To CD
        DA = Mid(Number, Ptr, 1)
        DA = UCase(DA)
        CA = Asc(DA)
        Select Case Base
            Case 2:  If CA < 48 Or CA > 49 Then MsgBox ("Number specification error, if its base is binary"): Exit Function
            Case 8:  If CA < 48 Or CA > 56 Then MsgBox ("Number specification error, if its base is octal"): Exit Function
            Case 16: If CA < 48 Or (CA > 57 And CA < 65) Or (CA > 70) Then MsgBox ("Number specification error, if its base is hexadecimal"): Exit Function
        End Select
        If CA > 64 Then DA = "&H" & DA
        B10 = B10 + Val(DA) * Base ^ (CD - Ptr)
    Next
    Convert•Dec‹Num = B10
End Function

Function Convert•Num‹Dec(Number As String, BaseNew_2Binary_8Octal_16Hexadecimal As Integer) As String
  'Go to Binary (Base 2), Octal (Base 8) or Hexadecimal (Base 16), a Number that is originally Decimal (Base 10)
    Dim DA As Integer, Cad As String, DR As Long, Base As Integer
    Base = BaseNew_2Binary_8Octal_16Hexadecimal
    DR = CLng(Trim(Number))
    Do While DR > 0
        DA = DR Mod Base
        If Not DA > 9 Then Cad = Format(DA) & Cad Else Cad = Chr(55 + DA) & Cad
        DR = DR \ Base
        Loop
    Convert•Num‹Dec = Cad
End Function

---

---

Lots of Functions to Deal with Controls

April 3, 2024, 4:54 pm

≫ Next: Some of the most concise, best code I've ever written

≪ Previous: Convert a Number from a certain base to a different one

$

0

0

Finding the widest, right-aligning, changing their size to fit the contents of their caption or text, making comboboxes as wide as their widest list entry, etc.

bControls.zip

This has some dependencies. Other than the CallStack and ErrorHandler stuff, if you find something in there that has a dependency that's not included then let me know and I'll upload it.

This is the only one I saw immediately but there may be others.

Code:

---

Public Function MaxValue(ParamArray Values() As Variant) As Variant
Dim m_CallStacker As New cCallStacker
Dim n As Long
Dim nMax As Long

' Returns the Greatest Value.

m_CallStacker.Add NAME & ".MaxValue(Public Function)"

For n = LBound(Values) To UBound(Values)

  If Values(n) > nMax Then nMax = Values(n)

Next n

MaxValue = nMax

End Function

---

Attached Files

• bControls.zip (8.6 KB)

Some of the most concise, best code I've ever written

April 3, 2024, 6:52 pm

≫ Next: All My DB Utilities (for DAO)

≪ Previous: Lots of Functions to Deal with Controls

$

0

0

It's very simple and nothing ground-breaking or anything like that. It's basically search behavior.

So the way it works is that there are four locations - country, state, city and postal code.

I can't use an Array of ComboBoxes because I use WithEvents in the cLocationManager class. What I did in the class was create an Array of ComboBoxes and then set each one equal to one of the comboboxes passed to it.

Thus:

Code:

---

' Declarations

dim m_LocationComboBox(MAX_LOCATIONS) as VB.ComboBox

Public Property Set LocationComboBox(ByRef ComboBoxControl as VB.ComboBox, ByRef Index as LOCATION)

Set m_LocationComboBox(Index) = ComboBoxControl

End Property

---

This makes it easy to loop through the ComboBoxes to do whatever while still being able to use WithEvents.




If you type something into the Search box and then click the binoculars next to the location you're searching it will try to find it. If it finds it, it does what you'd expect if you click search again - it goes and looks for the next one.

If you type something into the textbox for a location (any of the four above) then that will take precedence over what is in the Search box.

If it doesn't find it then it starts over at the beginning. Again, standard behavior.

The part where some people might want different behavior is that if you type in something different, the application knows it and starts over from the beginning instead of searching from wherever it is now.

That's not the behavior I'd want in a word processor but I do like it here.

And it saves all that per location. So it only resets the box you're searching but not the others.

Code:

---

Private Sub cmdSearch_Click(Index As Integer)

SearchForLocation Index

End Sub


Private Sub SearchForLocation(ByRef Index As Integer)
Static nLastIndex(MAX_LOCATIONS) As Long          ' ListIndex (per LocationComboBox) where SearchToken was last found or -1 (FAILED) if not found.
Static sLastSearchToken(MAX_LOCATIONS) As String  ' Last string searched for per LocationComboBox.
Dim sSearchToken As String                        ' The Text being searched for.


' Searches a LocationComboBox for Text entered by User.
' When FAILED is returned the search starts from the Top of the ComboBox unless the ComboBox is unpopulated.


' Check that there is something to search for and the LocationComboBox being searched is populated.
' ValidSearch chooses the Token to search if Text is entered in either the Search or Location Textbox.
' Location Textbox has Priority.

If ValidSearch(Index, sSearchToken) = FAILED Then GoTo CleanUp

' Search Term was changed so start over at top of List.
If sLastSearchToken(Index) <> sSearchToken Then nLastIndex(Index) = FAILED

' Save the SearchToken to compare in subsequent searches to determine if it has changed and to start over from the top of the LocationComboBox.
sLastSearchToken(Index) = sSearchToken

' Begin searching LocationComboBox from the next element after last found.
nLastIndex(Index) = FindPartialStringInList(LocationComboBox(Index), nLastIndex(Index) + 1, sSearchToken)

' Don't change the ListIndex of the LocationComboBox if the SearchToken wasn't found.
If nLastIndex(Index) = FAILED Then GoTo CleanUp

LocationComboBox(Index).ListIndex = nLastIndex(Index) ' Display the found item in the LocationComboBox.

End Sub

Private Function ValidSearch(ByRef Index As Integer, ByRef SearchToken As String) As Long
Dim sSearchToken1 As String ' Search Textbox.
Dim sSearchToken2 As String ' Location being searched Textbox.

' Returns 0 if Search is valid.  E.g. there is text to search for and the ComboBox being searched is populated with at least one entry.
' Returns FAILED (-1) if the Search Textbox is empty AND the Location Textbox is empty OR if the ComboBox has one or fewer entries.
' Provides Appropriate Message to User if Search is not Valid.


ValidSearch = FAILED ' FAILED = -1. There are fewer cases where the Search is Valid than not so assume Failure.

sSearchToken1 = Trim$(txtLocation(Index).Text) ' Textbox for Location has priority.
sSearchToken2 = Trim$(txtSearch.Text)          ' Proper Search Textbox is second.

If (Len(sSearchToken1) = 0) And (Len(sSearchToken2) = 0) Then ' No text in either Textbox.

  MsgBoxA "Please enter text to search for a " & LocationName(Index) & CHAR_DOT, vbInformation, App.Title

  Exit Function

End If

If LocationComboBox(Index).ListCount = 0 Then ' ComboBox has no entries.

  MsgBoxA "There is nothing to search in the " & LocationName(Index) & " Dropdown.", vbInformation, App.Title

  Exit Function

End If

SearchToken = IIf(Len(sSearchToken1) > 0, sSearchToken1, sSearchToken2)

ValidSearch = 0

End Function

---

All My DB Utilities (for DAO)

April 3, 2024, 8:52 pm

≫ Next: How I enable Cut, Copy and Paste buttons and menu items

≪ Previous: Some of the most concise, best code I've ever written

$

0

0

I love this file. I will marry this file if it will have me. I will be buried with this file. This file should have my babies.

DAO Utilities.zip


Edit: Of course you'll have to remove all the callstack and errorhandler stuff unless you have all that already set up and it's compatible which is about 100% not going to be.

Just get the meat of what you need out of it.

I posted some of the dependencies below.

Attached Files

• DAO Utilities.zip (12.4 KB)

How I enable Cut, Copy and Paste buttons and menu items

April 4, 2024, 2:47 am

≫ Next: I *REALLY* don't like the maskededitbox. So I rolled my own.

≪ Previous: All My DB Utilities (for DAO)

$

0

0

I like the way I did this. Basically it's set up on a Timer set to 250 milliseconds. So every quarter second it's getting checked. You can see the slight delay but I don't want to make the Timer too frequent for fear of making the program sluggish doing that kind of thing.

Code:

---

Private Sub Timer1()

If Not Visible Then Exit Sub

With tbrCustomers

  .Buttons("Cut").Enabled = CanCut(ActiveControl)
  .Buttons("Copy").Enabled = CanCopy(ActiveControl)
  .Buttons("Paste").Enabled = CanPaste(ActiveControl)

End With

End Sub

Public Function CanCopy(ByRef Control As Control) As Boolean
Dim f As Boolean

' Determines if text can be Copied from a Control.
' ComboBoxes must have their Style set to 0 (DropDownCombo)

On Error GoTo errHandler

CanCopy = False

If Control Is Nothing Then Exit Function

f = TypeName(Control) = "ComboBox"

If f Then

  If Control.Style <> 0 Then f = False

End If

If Control.Enabled Then

  If Not IsTextControl(Control) And Not f Then Exit Function
  If Not TextSelected(Control) Then Exit Function
 
  CanCopy = True

End If

Exit Function


errHandler:
Dim nErrorHandlerResult As Long

nErrorHandlerResult = ErrorHandler(Error, Err, "Control.Name = " & Control.NAME, NAME & ".CanCopy(Public Function)")

End Function
Public Function CanCut(ByRef Control As Control) As Boolean
Dim f As Boolean

' Determines if text can be Cut from a Control.
' ComboBoxes must have their Style set to 0 (DropDownCombo)

On Error GoTo errHandler

CanCut = False

If Control Is Nothing Then Exit Function

f = TypeName(Control) = "ComboBox"

If f Then

  If Control.Style <> 0 Then f = False

End If

If Control.Enabled Then

  If Not IsTextControl(Control) And Not f Then Exit Function

  If Not TextSelected(Control) Then Exit Function

  If TypeName(Control) = "TextBox" Or TypeName(Control) = "RichTextBox" Then

    If Control.Locked Then Exit Function

  End If

  CanCut = True

End If

Exit Function


errHandler:
Dim nErrorHandlerResult As Long

nErrorHandlerResult = ErrorHandler(Error, Err, "Control.Name = " & Control.NAME, NAME & ".CanCut(Public Function)")

End Function
Public Function CanPaste(ByRef Control As Control) As Boolean
Dim f As Boolean

' Determines if text can be Pasted into a Control.
' ComboBoxes must have their Style set to 0 (DropDownCombo)

On Error GoTo errHandler

CanPaste = False

If Control Is Nothing Then Exit Function

If Control.Enabled = False Then Exit Function

If Len(Clipboard.GetText) = 0 Then Exit Function

If TypeName(Control) = "ComboBox" Then

  f = (Control.Style = 0)

End If

If Not IsTextControl(Control) And Not f Then Exit Function

If TypeName(Control) = "TextBox" Or TypeName(Control) = "RichTextBox" Then

  If Control.Locked Then Exit Function

End If

CanPaste = True

Exit Function


errHandler:
Dim nErrorHandlerResult As Long

If Err = 521 Then Exit Function ' "Another application is using the Clipboard and won't release it to your application."

nErrorHandlerResult = ErrorHandler(Error, Err, "Control.Name = " & Control.NAME, NAME & ".CanPaste(Public Function)")

End Function

Public Function IsTextControl(ByRef Control As Control) As Boolean

On Error Resume Next

IsTextControl = False

If TypeName(Control) = "TextBox" Or TypeName(Control) = "RichTextBox" Then

  IsTextControl = True

End If

End Function

Public Function TextSelected(ByRef Control As Control) As Boolean

' Returns whether Text is Selected or not.

On Error GoTo errHandler

TextSelected = Len(Control.SelText)

Exit Function


errHandler:

TextSelected = False

End Function

---

I *REALLY* don't like the maskededitbox. So I rolled my own.

April 4, 2024, 11:27 am

≫ Next: My CallStack Class (Working Demo - Updated code (again))

≪ Previous: How I enable Cut, Copy and Paste buttons and menu items

$

0

0

It's not nearly as functional but it does what I need it to do without having to deal with mask, format and I don't remember what else. I stopped using them long ago and don't remember all the ways maskededitboxes frustrated the hell out of me in use.

If you have a moment then please try it in something and tell me what you think please.

Also too, I removed my cChanged Class and just air-coded in notepad a Boolean instead. It might not work properly as I haven't tested it that way so if it doesn't work right then I can post the original class with the cchanged class and it should be fine.

Also, I removed all the callstack stuff (I think).

This could stand some improvement. I was having problems populating the textbox without triggering changed events (loading saved data) and landed on having a Value property that doesn't raise a changed event and a NewValue property that does raise the changed event so that's kind of awkward.

You populate existing values using the Value property and you change the value using the NewValue property.

Usage:

Code:

---

' Declarations.

Private WithEvents mw_MaximumFontSize As cNumericTextBox      ' Maximum Font size User may select for Control Fonts (Form Font Settings).

Private Sub Form_Load()

Set MaximumFontSize = New cNumericTextBox

End Sub

Friend Property Set MaximumFontSize(ByRef objNumericTextBox As cNumericTextBox)

On Error GoTo errHandler

Set mw_MaximumFontSize = objNumericTextBox


With MaximumFontSize

  Set .TextBox = txtMaxFontSize
  .Initialize idx_NumericTextBoxType_Decimal, 6, 20, 18, "0.0", 2

End With

Exit Property

errHandler:
Dim nErrorHandlerResult As Long

nErrorHandlerResult = ErrorHandler(Error, Err, vbNullString, Me.NAME & ".MaximumFontSize(Friend Property Set)")

End Property

---

cNumericTextBox:

Code:

---

Option Explicit


' Let the Value Property (Default) to populate a Value without raising a Changed Event.

' Let the NewValue Property to change the Value AND raise a Changed Event.

' When the User types in a value it is not set until the User presses the Enter Key or Tabs out of the TextBox.
' A Changed Event will be raised only if the NewValue Property differs from the existing Value Property.

' Example.

' A cNumericTextBox Object is Named 'AmountPaid'.
' Populating a form from a Record:  AmountPaid = $19.95. (Currency symbols are stripped before the value is set).
' No Changed Event is raised because Value is the default property and does not raise events.

' Next, the user Clicks a button that automatically enters the AmountPaid as the Amount Due (in this case that's 29.95).

' Private Sub Button_Click()
'
'  AmountPaid.NewValue = 19.95 ' This sets the Value but DOES NOT raise a Changed Event because the NewValue is the same as the old value.
'  AmountPaid.NewValue = 29.95 ' This sets the value and raises a Changed Event.
'
' End Sub


' // Constants, Types and Enums.

Private Const NAME As String = "cNumericTextbox"


Private Enum GOT_FOCUS ' User option to select text when a TextBox receives focus.

  idx_GotFocus_LastPosition = 0
  idx_GotFocus_FieldBeginning
  idx_GotFocus_FieldEnd
  idx_GotFocus_FieldAll

End Enum

' / Constants, Types and Enums.


' // Objects.


  ' / Controls.

Private WithEvents mw_TextBox As VB.TextBox

  ' / Controls.


' // Objects.


' // Events.

Public Event Changed() ' Event raised when the value of the field changes. Inactive when Changed Object is disabled.

' // Events.


' // Constants, Types and Enums.

Public Enum NUMERIC_TEXTBOX_NUMBER_TYPE

  idx_NumericTextBoxType_Currency = 0
  idx_NumericTextBoxType_Decimal
  idx_NumericTextBoxType_Integer ' In this case, "Integer" means Whole Number, NOT Integer Data Type.  I changed it in my code to reflect that.  E.g.
                                                  ' idx_NumericTextBoxType_Integer was changed to idx_NumericTextBoxType_WholeNumber

End Enum

Private Const DEFAULT_NUMBER_FORMAT As String = "#0.000"

' // Constants, Types and Enums.


' // Properties.

private fChanged as Boolean
Private nDecimalPlaces As Long
Private rMaximumValue As Double
Private rMinimumValue As Double
Private rNewValue As Double
Private sNumberFormat As String
Private nNumberType As NUMERIC_TEXTBOX_NUMBER_TYPE
Private nOnEnterSelection As GOT_FOCUS
Private nValidationFailBackcolor As Long
Private rValue As Double

' // Properties.


Public Property Get Alignment() As Long

Alignment = TextBox.Alignment

End Property
Public Property Let Alignment(ByVal TextAlignment As Long)

TextBox.Alignment = TextAlignment

End Property
Public Property Get BackColor() As Long

BackColor = TextBox.BackColor

End Property
Public Property Let BackColor(ByVal Color As Long)

TextBox.BackColor = Color

End Property
Public Property Get BorderStyle() As Long

BorderStyle = TextBox.BorderStyle

End Property
Public Property Let BorderStyle(ByVal Style As Long)

TextBox.BorderStyle = Style

End Property
Public Property Get Changed() As Boolean

Changed = fChanged

End Property
Private Property Let Changed (ByRef IsChanged As Boolean)

fChanged = IsChanged

RaiseEvent Changed

End Property
Private Function CreateMinMaxValue() As Long

' Returns Error Code.
On Error GoTo errHandler

' Creates the largest and smallest possible values.  Anything outside this range will raise an error.

MaximumValue = 922337203685477#
MinimumValue = -MaximumValue

Exit Function

errHandler:
Dim nErrorHandlerResult As Long

CreateMinMaxValue = Err

nErrorHandlerResult = ErrorHandler(Error, Err, vbNullString, NAME & ".CreateMinMaxValue(Private Function)")

End Function
Public Property Get DecimalPlaces() As Long

DecimalPlaces = nDecimalPlaces

End Property
Public Property Let DecimalPlaces(ByVal NumberOfDecimals As Long)

nDecimalPlaces = NumberOfDecimals

End Property
Public Property Get Enabled() As Boolean

CallStack.Add NAME & ".Enabled(Public Property Get)"

Enabled = TextBox.Enabled

CallStack.DeleteProcedureCall

End Property
Public Property Let Enabled(ByVal TextBoxEnabled As Boolean)

TextBox.Enabled = TextBoxEnabled

End Property
Public Property Get Font() As StdFont

Set Font = TextBox.Font

End Property
Public Property Set Font(ByRef m_Font As StdFont)

CallStack.Add NAME & ".Font(Public Property Set)"

Set TextBox.Font = m_Font

CallStack.DeleteProcedureCall

End Property
Private Function ForceDecimalNumber(ByRef ctlTextBox As VB.TextBox, ByRef KeyAscii As Integer, ByRef AllowDecimal As Boolean, ByRef AllowMinus As Boolean) As Integer

' Called from mw_TextBox_KeyPress.
' Returns KeyAscii.
' Return of 0 Voids the key input when the key entered isn't valid.

On Error Resume Next

' If it's not a number, decimal or minus sign then void character.
If Not IsNumeric(Chr(KeyAscii)) And (KeyAscii <> 45) And (KeyAscii <> 46) And (KeyAscii <> vbKeyBack) Then Exit Function ' Return 0

' If user entered a decimal and decimals are not allowed then void character.
If (KeyAscii = 46) And (AllowDecimal = False) Then Exit Function ' Return 0

If KeyAscii = 45 Then ' Minus Sign.

  ' If minus signs aren't allowed then void character.
  If AllowMinus = False Then Exit Function ' Return 0

  ' If there is an existing minus sign then void character.
  If InStr(1, ctlTextBox.Text, "-", vbTextCompare) Then Exit Function  ' Return 0

  ' If user attempts to add a minus sign anywhere except the beginning a string then void character.
  If (ctlTextBox.SelStart > 0) Then Exit Function  ' Return 0

End If

' If it's a decimal then make sure it's the only one.
If KeyAscii = 46 Then ' Decimal Point.

  If InStr(1, ctlTextBox.SelText, CHAR_DOT, vbTextCompare) Then ' Replace selected text with decimal point.

    ctlTextBox.SelText = vbNullString

  ElseIf InStr(1, ctlTextBox.Text, CHAR_DOT, vbTextCompare) Then ' Void second decimal point if one already exists.

    Exit Function ' Return 0

  End If

End If

' Do not allow any characters before a Minus Sign.
If Left$(ctlTextBox.Text, 1) = "-" And ctlTextBox.SelStart = 0 Then Exit Function ' Return 0

' Do not allow any characters before a Dollar Sign.
If Left$(ctlTextBox.Text, 1) = "$" And ctlTextBox.SelStart = 0 Then Exit Function ' Return 0

' Our Text ran the gauntlet and survived.  Yay!

ForceDecimalNumber = KeyAscii ' Return KeyAscii

End Function
Public Property Get ForeColor() As Long

ForeColor = TextBox.ForeColor

End Property
Public Property Let ForeColor(ByVal TextBoxForecolor As Long)

TextBox.ForeColor = TextBoxForecolor

End Property
Private Function FormatValue(ByVal Value As Double) As String
Dim s As String
Dim sFormat As String

On Error GoTo errHandler

If mw_TextBox Is Nothing Then Exit Function

s = CStr(Value)

With TextBox

  Select Case NumberType

    Case idx_NumericTextBoxType_Currency

      sFormat = CURRENCY_SYMBOL & "0." & String$(DecimalPlaces, "0")

      .Text = Format$(s, sFormat)

    Case Else

      .Text = Format$(s, NumberFormat)

  End Select

End With

Exit Function


errHandler:
Dim nErrorHandlerResult As Long

nErrorHandlerResult = ErrorHandler(Error, Err, vbNullString, NAME & ".FormatValue(Private Function)")

End Function
Public Property Get Height() As Long

Height = TextBox.Height

End Property
Public Property Let Height(ByVal TextBoxHeight As Long)

On Error Resume Next

TextBox.Height = TextBoxHeight

End Property
Public Function Initialize(ByVal NumType As NUMERIC_TEXTBOX_NUMBER_TYPE, ByVal MinValue As Double, ByVal MaxValue As Double, ByVal InitValue As Double, _
                          Optional NumFormat As String = vbNullString, Optional ByVal Decimals As Long = 3) As Long

' Returns Error Code.
On Error GoTo errHandler

NumberType = NumType

MinimumValue = MinValue ' Set Minimum and Maximum Values allowed to be entered.
MaximumValue = MaxValue

If NumFormat <> vbNullString Then NumberFormat = NumFormat ' DEFAULT_NUMBER_FORMAT

If NumType = idx_NumericTextBoxType_Decimal Then

  If NumFormat = vbNullString Then

    If Decimals > 0 Then

      NumberFormat = "#0." & String$(Decimals, "0")

    Else ' User specified Decimal Number type but allowed no digits after decimal.

      NumberFormat = "#0"

    End If

  End If

End If

DecimalPlaces = Decimals

Value = InitValue

Exit Function


errHandler:
Dim nErrorHandlerResult As Long

Initialize = Err

nErrorHandlerResult = ErrorHandler(Error, Err, vbNullString, NAME & ".Initialize(Public Function)")

End Function
Public Property Get Left() As Long

Left = TextBox.Left

End Property
Public Property Let Left(ByVal TextBoxLeft As Long)

TextBox.Left = TextBoxLeft

End Property
Public Property Get Locked() As Boolean

Locked = TextBox.Locked

End Property
Public Property Let Locked(ByVal TextBoxLocked As Boolean)

TextBox.Locked = TextBoxLocked

End Property
Public Property Get MaximumValue() As Double

MaximumValue = rMaximumValue

End Property
Public Property Let MaximumValue(ByVal MaximumValueAllowed As Double)

rMaximumValue = MaximumValueAllowed

End Property
Public Property Get MaxLength() As Long

MaxLength = TextBox.MaxLength

End Property
Public Property Let MaxLength(ByVal TextBoxMaxLength As Long)

TextBox.MaxLength = TextBoxMaxLength

End Property
Public Property Get MinimumValue() As Double

MinimumValue = rMinimumValue

End Property
Public Property Let MinimumValue(ByVal MinimumValueAllowed As Double)

rMinimumValue = MinimumValueAllowed

End Property
Public Property Get MultiLine() As Boolean

MultiLine = TextBox.MultiLine

End Property

Private Property Get NewValue() As Double

NewValue = rNewValue

End Property
Public Property Let NewValue(ByVal Number As Double)
Dim r As Double

r = Value

rNewValue = Validate(Number)

Value = NewValue

If r <> NewValue Then Changed = True

End Property
Public Property Get NumberFormat() As String

NumberFormat = sNumberFormat

End Property
Public Property Let NumberFormat(ByVal TextFormat As String)

sNumberFormat = TextFormat

End Property
Public Property Get NumberType() As NUMERIC_TEXTBOX_NUMBER_TYPE

NumberType = nNumberType

End Property
Public Property Let NumberType(ByVal NumType As NUMERIC_TEXTBOX_NUMBER_TYPE)

nNumberType = NumType

End Property
Public Property Get OnEnterSelection() As GOT_FOCUS

OnEnterSelection = nOnEnterSelection

End Property
Public Property Let OnEnterSelection(ByVal SelectTextOnEntry As GOT_FOCUS)

nOnEnterSelection = SelectTextOnEntry

End Property
Public Property Get PasswordChar() As String

PasswordChar = TextBox.PasswordChar

End Property
Public Property Let PasswordChar(ByVal TextBoxPasswordChar As String)
Dim s As String

s = Trim$(TextBoxPasswordChar)

If s <> vbNullString Then

  s = Left$(s, 1)

End If

TextBox.PasswordChar = s

End Property
Public Property Get RightToLeft() As Boolean

RightToLeft = TextBox.RightToLeft

End Property
Public Property Let RightToLeft(ByVal TextBoxRightToLeft As Boolean)

TextBox.RightToLeft = TextBoxRightToLeft

End Property
Private Function SelectText(ByVal Selection As GOT_FOCUS, Optional SelStart As Long = 0) As Long

' Returns Error Code.
On Error GoTo errHandler

CallStack.Add NAME & ".SelectText(Private Function)"

' Positions carat and selects text per user option.

With TextBox

  Select Case Selection

    Case idx_GotFocus_LastPosition

      ' This is what happens by default. Carat is restored at last position.Selected text is restored as last selected.

    Case idx_GotFocus_FieldBeginning

      .SelStart = SelStart ' Carat is placed at beginning of field. No text is selected.

    Case idx_GotFocus_FieldEnd

      .SelStart = Len(TextBox.Text) ' Carat is placed at end of field. No text is selected.

    Case idx_GotFocus_FieldAll

      .SelStart = SelStart ' All text is selected.

      .SelLength = Len(TextBox.Text) - SelStart

  End Select

End With

Exit Function


errHandler:
Dim nErrorNumber As Long
Dim nErrorHandlerResult As Long
Dim sError As String
Dim Parameters(1) As String

SelectText = Err

nErrorNumber = Err
sError = Error

Parameters(0) = "TextBox.Name = " & TextBox.NAME
Parameters(1) = "Selection = " & CStr(Selection)

nErrorHandlerResult = ErrorHandler(sError, nErrorNumber, ParameterString(Parameters), NAME & ".SelectText(Private Function)")

End Function
Public Property Get TabIndex() As Integer

TabIndex = TextBox.TabIndex

End Property
Public Property Let TabIndex(ByVal Index As Integer)

TextBox.TabIndex = Index

End Property
Public Property Get TabStop() As Boolean

TabStop = TextBox.TabStop

End Property
Public Property Let TabStop(ByVal HasTabStop As Boolean)

TextBox.TabStop = HasTabStop

End Property
Public Property Get Tag() As String

Tag = TextBox.Tag

End Property
Public Property Let Tag(ByVal TextBoxTag As String)

TextBox.Tag = TextBoxTag

End Property
Public Property Get Text() As String

Text = TextBox.Text

End Property
Public Property Let Text(ByVal TextValue As String)

On Error GoTo errHandler

Value = Val(TextValue)

Exit Property


errHandler:
Dim nErrorHandlerResult As Long

nErrorHandlerResult = ErrorHandler(Error, Err, vbNullString, NAME & ".Text(Public Property Let)")

End Property
Public Property Get TextBox() As VB.TextBox

On Error GoTo errHandler

Set TextBox = mw_TextBox

Exit Property


errHandler:
Dim nErrorHandlerResult As Long

nErrorHandlerResult = ErrorHandler(Error, Err, vbNullString, NAME & ".TextBox(Public Property Get)")

End Property
Public Property Set TextBox(ByRef ctlTextBox As VB.TextBox)

On Error GoTo errHandler

Set mw_TextBox = ctlTextBox

Exit Property

errHandler:
Dim nErrorHandlerResult As Long

nErrorHandlerResult = ErrorHandler(Error, Err, vbNullString, NAME & ".TextBox(Public Property Set)")

End Property
Public Property Get ToolTipText() As String

ToolTipText = TextBox.ToolTipText

End Property
Public Property Let ToolTipText(ByVal TextBoxToolTipText As String)

TextBox.ToolTipText = TextBoxToolTipText

End Property
Public Property Get Top() As Long

Top = TextBox.Top

End Property
Public Property Let Top(ByVal TextBoxTop As Long)

Top = TextBoxTop

End Property
Private Function Validate(ByVal Value As Double) As Double
Dim r As Double

On Error GoTo errHandler

r = Value

If r > MaximumValue Then r = MaximumValue
If r < MinimumValue Then r = MinimumValue

Select Case NumberType

  Case idx_NumericTextBoxType_Integer

    Validate = Int(r)

  Case Else

    Validate = r

End Select

Exit Function

errHandler:
Dim nErrorHandlerResult As Long
Dim sError As String
Dim nErr As Long
Dim Parameters(4) As String

sError = Error
nErr = Err

Parameters(0) = "TextBox.Text = " & TextBox.Text
Parameters(1) = "Value = " & CStr(Value)
Parameters(2) = "r = " & CStr(r)
Parameters(3) = "MinimumValue = " & CStr(MinimumValue)
Parameters(4) = "MaximumValue = " & CStr(MaximumValue)

nErrorHandlerResult = ErrorHandler(sError, nErr, ParameterString(Parameters), NAME & ".Validate(Private Function)")

End Function
Public Property Get ValidationFailBackcolor() As Long

ValidationFailBackcolor = nValidationFailBackcolor

End Property
Public Property Let ValidationFailBackcolor(ByVal Color As Long)

nValidationFailBackcolor = Color

End Property
Public Property Get Value() As Double

Value = rValue

End Property
Public Property Let Value(ByVal Number As Double)
Dim f As Boolean

f = fChanged.Enabled = False

rValue = Number

rValue = Validate(Number)

FormatValue rValue

fChanged = f

End Property
Public Property Get Visible() As Boolean

Visible = TextBox.Visible

End Property
Public Property Let Visible(ByVal TextBoxVisible As Boolean)

TextBox.Visible = TextBoxVisible

End Property
Public Property Get Width() As Long

Width = TextBox.Width

End Property
Public Property Let Width(ByVal TextBoxWidth As Long)

TextBox.Width = TextBoxWidth

End Property
Private Sub mw_TextBox_GotFocus()
Dim s As String
Dim f As Boolean

f = fChanged
s = Trim$(TextBox.Text)

s = Replace(s, "$", vbNullString, 1, -1, vbTextCompare)

If Not TextBox.Locked Then TextBox.Text = s

fChanged = f

SelectText OnEnterSelection

End Sub
Private Sub mw_TextBox_KeyPress(KeyAscii As Integer)

' Prevent flickering if Type is Currency.

If NumberType = idx_NumericTextBoxType_Currency Then LockWindowUpdate mw_TextBox.hWnd

Select Case KeyAscii

  Case vbKeyReturn ' Set Value.

    KeyAscii = 0

    mw_TextBox_LostFocus ' On LostFocus the Value is formatted with a Currency symbol.

  Case vbKeyBack

    ' Accept Keystroke as-is.

  Case Else

    KeyAscii = ForceDecimalNumber(TextBox, KeyAscii, NumberType <> idx_NumericTextBoxType_Integer, MinimumValue < 0)

End Select

LockWindowUpdate False

End Sub
Private Sub mw_TextBox_LostFocus()
Dim s As String

On Error GoTo errHandler

s = Replace(TextBox.Text, "$", vbNullString, 1, -1, vbTextCompare)

NewValue = Val(s)

Exit Sub

errHandler:
Dim nErrorHandlerResult As Long

nErrorHandlerResult = ErrorHandler(Error, Err, vbNullString, NAME & ".TextBox_LostFocus(Private Sub)")

End Sub
Private Sub Class_Initialize()

CallStack.Add NAME & ".Class_Initialize(Private Sub)"

CreateMinMaxValue

NumberType = idx_NumericTextBoxType_Decimal
NumberFormat = DEFAULT_NUMBER_FORMAT

ValidationFailBackcolor = &HC0FFC0

OnEnterSelection = idx_GotFocus_FieldAll

End Sub

---

My CallStack Class (Working Demo - Updated code (again))

April 3, 2024, 7:39 pm

≫ Next: [VB6, twinBASIC] Code snippet: Toggle airplane mode

≪ Previous: I *REALLY* don't like the maskededitbox. So I rolled my own.

$

0

0

OK, I found a couple more small inconsistencies, a variable that's not being used and added some frivolity for fun. The upload below is good and complete (with the exception of a counter starting at 2 instead of 1 that doesn't really matter). So at some point I will post a final but in the interest of not annoying everyone with continual uploads and fixes I'm going to spend some time actually going through it all one final time and making sure it's as polished as I can make it (without turning it into a full-on app) and will upload again at some point soon.

But what's below works fine as it is. The final version will just be a little bit more refined.

=====================

CallStack Demo3.zip

=====================

OK, I think I'm done working on this demo. I've changed it so that it doesn't create an endless list of files. You can can specify a maximum number of callstack logs as well as number of callstacks per log.

So if you want you can specify a max of 1,000 logs with one call per log or one log with 10000 stacks in it or whatever you want as long as you stay within the limits of a long integer data type and system limitations (maximum file size your OS allows, disk space, memory, etc.).

A little more polishing was done.

If you have MZTools or something like it you can create a macro that automatically inserts the callstack stuff into any procedure with the correct information.

I really like MZTools.

=====================

When it's userful:

Normally it isn't. If you're having a problem during development then you use the built-in callstack viewer in the IDE.

It's useful when your app is crashing the IDE or when the compiled app is crashing for reasons unknown.

What it does:

It counts every call to every procedure that adds to the call stack. When the program exits (only if it's enabled at exit) it provides a list of every procedure called, how many times it was called and the deepest call stack.

Every single call is logged to file. The file is opened and when the max number of entries (specified in the cCallStack Initialize Sub) is reached it closes the file and opens a new one.

So if you look at one of the callstack files you see that the stack increases one call at a time.

When the program exits on purpose the current active callstack file is closed.

if the program crashes when a file is open then we count on Windows to close the file and hopefully you'll be able to look at the last callstack in the last file and see the stack that led up to the crash.

In my real app, all the totals are put into an application log file. In the demo it's put into the immediate window.

If you do too much with the demo then all the stats will be scrolled off the top of the immediate window so you just want to type a little bit, click a few things and then exit.

You could also just write that to the Windows Clipboard then paste it into a text document instead.

You will find that in the CloseLogFile Function in the ErrorHandler bas module.

Where this really shines is that if you're in the IDE and something is going on and you set a breakpoint AND you have some kind of API thing going on, such as changing the color of a toolbar or SSTab or whatever, the program might crash and bring down the entire IDE even if the API call wasn't the problem.

This allows you to keep running and figure out what's going on without hitting CTRL+ Break to pause program execution which can sometimes kill everything for reasons other than whatever actual problem you're trying to sort out.

I'd appreciate any feedback you can give me.


=====================

Attached Files

• CallStack Demo3.zip (17.9 KB)

[VB6, twinBASIC] Code snippet: Toggle airplane mode

April 6, 2024, 5:47 am

≫ Next: RCFlexGrid Control (vbRichClient)

≪ Previous: My CallStack Class (Working Demo - Updated code (again))

$

0

0

Newer versions of Windows have an 'Airplane mode' toggle like cell phones that turns off all the radios, which on a desktop might only be WiFi, but if you have a Surface tablet would also Bluetooth and possibly 4G. Microsoft doesn't really like you interacting with these yourself; it documents interfaces like IRadioInstance; but only for radio providers-- it doesn't disclose how you might go about obtaining them as a consumer to toggle them on your own.

Airplane mode is even more opaque. Disabling all the radios individually isn't enough for the little airplane to show up and the Settings indicate Airplane Mode is on. Turns out they have a very simple COM object to turn it on and off, but it's completely undocumented. user3296587 on StackOverflow reverse engineered it and posted some C++ code, which I first brought to twinBASIC and now to VB6 in the latest release of oleexp. VB6/tB of course make using COM interfaces a breeze, so toggling airplane mode is just a few simple lines:

Code:

---

Dim pRM As New RadioManagementAPI
Dim pbOld As Long, arg2 As Long, arg3 As Long
pRM.GetSystemRadioState pbOld, arg2, arg2
pRM.SetSystemRadioState IIf(pbOld, 0, 1)

---

Note this is retrieving whether any radio are active, so Airplane Mode is Enabled when pbOld is 0. See 'Interacting with individual radios' after the requirements for the app in the screenshot with the GUI for switching it on/off.

Requirements
VB6: A reference to oleexp.tlb, v6.5 or higher. IDE only, not needed for compiled exe.
twinBASIC: oleexp.tlb is 32bit only, so while you can use it, it's better to use Windows Development Library for twinBASIC (WinDevLib) which also supports 64bit and covers 100% of oleexp.tlb (+5500 more APIs). Added via the Package Manager (details).

---

Interacting with individual radios

If you want to list, query, and toggle system radios on an individual basis, check out my full RadioMan project. It's only for twinBASIC right now but would be trivial to port to VB6; oleexp has all the required interfaces. It's also very small thanks to these high level interfaces; the whole thing is under 500 lines (excluding the interface defs in WinDevLib/oleexp).

---

RCFlexGrid Control (vbRichClient)

April 10, 2024, 9:54 pm

≫ Next: Standard DLL Creation (and Usage) with VB6 (à la, The Trick)

≪ Previous: [VB6, twinBASIC] Code snippet: Toggle airplane mode

$

0

0

Krool wrote a really great control, VBFlexGrid. For vbRichClient users, we also really needed a component like VBFlexGrid, so I rewrote Krool's VBFlexGrid with RC6.

I developed RCFlexGrid (cwFlexGrid) for 3 purposes:

(1) With the help of vbForums' experts, RCFlexGrid can be optimized and transformed into a grid control that is comparable in performance to Farpoint-Spread.

(2) With the help of vbForums' experts, RCFlexGrid can provide very powerful and smooth input features/capabilities, so that the application scenarios of RCFlexGrid will be greatly expanded, for example, RCFlexGrid/VBFlexGrid can be used to simulate and replace RichTextBox and Excel.

(3) Provide an example for vbRichClient users to rewrite GDI controls. Since we can use RC6 to rewrite the extremely complex VBFlexGrid, we can also use RC6 to rewrite Krool's ComCtls, so that we can have two sets of components at the same time: GDI-ComCtls and RC6-ComCtls. My cloned VB6-IDE will use both sets of components.

At present, RCFlexGrid only implements 90% of the features of VBFlexGrid, and RCFlexGrid has not been rigorously tested, and there are still many bugs in the current version, which need to be tested and fixed by vbRichClient enthusiasts. Any feedback, suggestions and guidance would be greatly appreciated.

Note:
RCFlexGrid provides a solution to integrate and use WinTheme in RC6.Cairo (maybe Olaf has a better way).

Attached Images

 

Attached Files

• RCFlexGridDemo.zip (197.0 KB)

Standard DLL Creation (and Usage) with VB6 (à la, The Trick)

April 13, 2024, 10:52 am

≫ Next: Random-Depth Tree Creator/Editor

≪ Previous: RCFlexGrid Control (vbRichClient)

$

0

0

Let me say from the outset that it's The Trick who sorted the magic of doing this, and who seems to know all the compiled VB6 headers better than the back of his hand. He's done some work that allows us to create standard DLLs with pure VB6, and then subsequently use them with "Declare ..." API declarations (similar to the way we'd use the kernel32.dll, shell32.dll, msvbvm60.dll, or any other standard DLL). No AddIns, no dependencies (other than a TypeLib used just while compiling the DLL).

First, to use these standard DLLs, we must recognize that our VB6 program must be able to find them. This is typically done by searching our own folder (either the folder where our VBP is, or our compiled EXE is), or, if not found there, searching the environment path. Typically, we don't worry about this, as it's all automatic. But, when we start creating our own standard DLLs, we do have to make sure our program that uses them can find them.

Ok, I'm going to outline the steps to create a standard DLL with VB6, and then I'll go into more detail for those steps that aren't straightforward:

The Steps:

1. Download the attached MyStandardDll.zip file, and unzip it somewhere. It has five files: MyStandardDll.vbp, VBDll.tlb, MyDllFunctions.bas, DllInitialize.bas, & VBDll.idl. The VBDll.idl isn't really needed, as it's the source code for the VBDll.tlb. And also, the VBDll.tlb is no longer needed once our standard DLL is compiled.
2. Open the MyStandardDll.vbp in the VB6 IDE.
3. Open the MyDllFunctions.bas file for editing.
4. Write/create whatever functions you want in your DLL, making sure they're Public. You can have other Private ones for support if you so choose.
5. Make a note (using Notepad) of the names of all your Public DLL functions.
6. Close the MyStandardDll.vbp project (without compiling). If you like, you can execute it in the IDE, but it will immediately terminate, as it has an empty Sub Main (necessary for the VB6 compiler, when we get to that). But, executing it in the IDE is a good way to check for syntax errors.
7. Open the MyStandardDll.vbp project using Notepad.
8. Down at the bottom, you'll see a line starting with "LinkSwitches". In this line, make sure there's an -EXPORT argument for each of your Public DLL functions.
9. Save and close MyStandardDll.vbp from Notepad.
10. Re-open MyStandardDll.vbp with the VB6 IDE.
11. Compile it as a standard EXE to MyStandardDll.exe.
12. Close MyStandardDll.vbp in the VB6 IDE. We're done with this source code.
13. Rename the new MyStandardDll.exe to MyStandardDll.DLL. You can also rename the core name to anything you like, recognizing that this will affect how the "Declare..." statements reference it.
14. If we'll only be using our new standard DLL from other VB6 programs, we can delete the LIB & EXP files, as they won't be needed. If we'll be using our new DLL from C/C++, we may want to save them.

At this point, you are done creating your standard DLL.

Also attached is a ExampleUsingMyStandardDll.zip file. It just includes two files: ExampleUsingMyStandardDll.vbp & ExampleUsingMyStandardDll.bas. If you download and unzip these two files into the same folder as your compiled DLL, you can execute this example project directly in your VB6 IDE, and use your new DLL just like you use other standard DLLs. If you just use the MyStandardDll.DLL (created from the above steps) as it is (not expanding on it), it will immediately work.

Here's the "default" code in that MyDllFunctions.bas module:

Code:

---


Option Explicit

Private Declare Function MessageBoxTimeOut Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As VbMsgBoxStyle, ByVal wLanguageId As Long, ByVal dwMilliseconds As Long) As Long


' ***********************************************************************************
'
' Here is where we put our public functions that will be exposed in our standard DLL.
'
' ***********************************************************************************

'
' Two example functions.

Public Function ShowMsgBoxFor3Seconds(ByVal sText As String) As VbMsgBoxResult
    MessageBoxTimeOut 0, sText, "", vbInformation + vbOKOnly, 0&, 3000&
    ShowMsgBoxFor3Seconds = vbOK
End Function

Public Function ShowMsgBoxWithTimer(ByVal sText As String, ByVal iMilliseconds As Long) As VbMsgBoxResult
    MessageBoxTimeOut 0, sText, "", vbInformation + vbOKOnly, 0&, iMilliseconds
    ShowMsgBoxWithTimer = vbOK
End Function


---

And here's the code in that ExampleUsingMyStandardDll.bas module:

Code:

---


Option Explicit

Public Declare Function ShowMsgBoxFor3Seconds Lib "MyStandardDll" (ByVal bstrMsg As Long) As VbMsgBoxResult
Public Declare Function ShowMsgBoxWithTimer Lib "MyStandardDll" (ByVal bstrMsg As Long, ByVal iMilliseconds As Long) As VbMsgBoxResult


Sub Main()

    ShowMsgBoxFor3Seconds StrPtr("Hello from Dll!  I'll disappear in 3 seconds.")

    ShowMsgBoxWithTimer StrPtr("Hi there.  I'll display for however many milliseconds you specified."), 5000

End Sub


---

As we can see, we use our new DLL just like any other standard DLL.

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

Ok, just a bit more detail. At present, the only steps I feel needs any further explanation are step #7, #8, & #9 (where we're opening the VBP with Notepad, and editing the last line in it). I assume you can manage getting it opened in Notepad. Here's how it will initially look:

Code:

---

Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\..\..\..\..\..\Windows\SysWOW64\stdole2.tlb#OLE Automation
Reference=*\G{D560371E-24A7-49A2-A53C-D178815145C6}#1.0#0#VBDll.tlb#VB6 Native-DLL type library by The trick
Module=modMyDllFunctions; MyDllFunctions.bas
Module=modDllInitialize; DllInitialize.bas
Startup="Sub Main"
HelpFile=""
Title="MyStandardDll"
ExeName32="MyStandardDll.exe"
Command32=""
Name="MyStandardDll"
HelpContextID="0"
CompatibleMode="0"
CompatibleEXE32="MyStandardDll.dll"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Microsoft"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=-1
BoundsCheck=-1
OverflowCheck=-1
FlPointCheck=-1
FDIVCheck=-1
UnroundedFP=-1
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
DebugStartupOption=0

[TAT]
GlobalChecking=0

[VBCompiler]
LinkSwitches=-DLL -FIXED:NO -ENTRY:DllMain -EXPORT:ShowMsgBoxFor3Seconds -EXPORT:ShowMsgBoxWithTimer

---

We're only interested in the very last line of this file, which I've highlighted. And, more explicitly, we're interested in those -EXPORT arguments. You must take your list of Public functions you developed in the MyDllFunctions.bas module, and add an -EXPORT:... entry for each of them, and probably delete those example functions.

Again, be careful that this VBP is not open in the VB6 IDE, or you'll probably overwrite your Notepad work.

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

And that's about it. It all seems to work great from my pure VB6 testing.

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

Also, just as a note, all the "magic" is in that DllInitialize.bas file. But, under most circumstances, there shouldn't be any need at all to tamper with that file.

Attached Files

• MyStandardDll.zip (7.4 KB)
• ExampleUsingMyStandardDll.zip (1.0 KB)

Random-Depth Tree Creator/Editor

April 18, 2024, 5:18 am

≫ Next: Look what I found,City of Ages is a Published Visual Basic 6 game on Steampowered.com

≪ Previous: Standard DLL Creation (and Usage) with VB6 (à la, The Trick)

$

0

0

Edit (2024-04-18@2216ish)

I made a mistake. I've been running the Tree Creator over and over and it is *not* doing what I want. Essentially any Root Branch could branch differently from any other root branch but within any given branch all branches were the same.

In other words:

"You come to a Crossroad."

Now no matter what you do you have the same number of choices to get to an outcome.

If you go left you get three choices. If you turn back you get three choices. If you go right you get three choices. You get the point.

That's because I was generating the Random Number *outside* the loop.

Now I've moved it inside the loop so if you turn back that might be the final outcome. But if you turn right you might get four choices. If you turn left you might get two choices. If you go straight ahead you might get five choices.

I haven't uploaded it yet - the attached upload still contains the problem. I need to play with it some more.

Also, the whole Create Method in cNode is hack programming. I have no idea what I'm doing really. I just keep changing pluses to minuses and trying different things. As long as it exits without Stack Overflow I know I'm on the right track. Again, this is a one-time tool so it doesn't need to be perfect. It just has to give me a result I like eventually and it's doing that now.

I'll make another edit to this post with the updated source code after I play with it some more.

Made a few other small tweaks such as getting rid of the leading "000" in the textbox because that's the Mother of all Branches and isn't necessary.

Also too, the stuff I posted does work. There's nothing actually wrong with it except not being as random as I wanted.

============================

Original upload: Tree.zip

============================

This is a Tool I built to create random events in a game I'm writing.

The idea is to create a Tree having Random-Depth Branches.

Each Branch can branch off into different directions so that when an Event happens it can go multiple ways.

The "real" way to do this is to probably just create branches as you need them but I wanted something to kind of push me along.

Hopefully what I end up with content-wise isn't too contrived just to force-fill the Nodes.

It's a one-and-done kind of tool. Once the Tree is created that's it for that game. You never use it again.

Unless you want to create multiple databases or put multiple tables in the same database and each time you run the Tree Creator you have it fill a different table. You'll have to change the Table Name in the code every time you do this.

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

Edit: You could pretty easily add another textbox to the Tree Creator and have it create an empty copy of the Table with whatever name you enter into the textbox and then have the Tree fill that new table. I should have done that and probably will.

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

That would allow you to use the same game engine (you gotta write that) but have multiple versions of it: Steampunk, Cyberpunk, Post-Apocalypse, etc.

This applet is very bare-bones. It is fully functional though.

I added in the quality-of-life stuff I know I'll want. I'll probably make some tweaks to it here and there as I'm using it more extensively and find things I'd like to work better or easier or more efficiently or whatever.

But really it's just to get me the content for my game without spending any more time than necessary making the tools to make the game.

If you download the attached file then be sure to check out the Tree Editor *BEFORE* you create any Trees.

Every time you create a New Tree it wipes out the existing Tree. All of it.

So the first thing to do is fire it up, go to the Tree Editor, go to the "Branch to Node" Combobox and scroll down a few entries.

There are Nine entries filled in this so you can see how it works.

Also too, if there's an entry missing in the middle of a branch it will tell you. In fact, it will tell you ALL missing nodes.

But if you see something like:

"You walk into the forest."
"You see a bear."
"[Content is Missing]"
"YOU DIED!"

Then there's a missing bit that needs to be fixed.

Anyway, this is doing everything I need it to do (I think) and it doesn't choke.

I will caution you against putting in huge numbers for the Tree Creator.

I put in 999 for Starting Seed and 99 for Target Depth. Hours later it was in the 300's. That was when it was only writing to a text file. I hadn't done the db bit yet. That's on a Threadripper 3960x with very fast NVMe drives.

Because it's Random, you might end up with the largest tree possible for the numbers input or something very small.

For example, if you enter 50 for Starting Seed, that doesn't mean it won't roll a one and give you one branch with two nodes.

So you might have to do it a few times to get something you like which is exactly what I wanted.

I just roll until I get about the right balance between number of Branches and total number of Nodes.

I was looking for Nodes in the 3K to 5K range. Starting Seed of 75 with a Target Depth of 6 got me what I wanted after a couple rolls.

===============

About the game and why I'm doing it this way. And before I go there, this IS NOT the game. This is to create content for the game in case that wasn't clear.

This game isn't a "story". It picks Events at random and the player responds to them.

So one event might have the player in her office and the next Event might be the player in a dungeon with no coherant path from office to dungeon.

That's not driven by the Tree though. If you were to use this to build a game you could easily set it up so it doesn't pick events at random and events have to follow each other in a logical way.

I'm just having fun. :)

Lastly, I have "Tech Savvy" and "Booksmarts" that seem to be pretty much the same thing. I want six stats so before I go creating a bunch of content I need to think about that some more and figure out a stat that would be better to replace one of the two.

Attached Files

• Tree.zip (188.7 KB)

Look what I found,City of Ages is a Published Visual Basic 6 game on Steampowered.com

April 20, 2024, 1:51 pm

≫ Next: [VB6, twinBASIC] ucDriveCombo - A modern DriveList replacement

≪ Previous: Random-Depth Tree Creator/Editor

$

0

0

Look what I found !!!

Free in everyway to a programmer and player, thought you VB addicts can have a look!

https://store.steampowered.com/app/6...ient_included/

Github.com
https://github.com/TriskyTraer/CityO...OfficialPublic

[VB6, twinBASIC] ucDriveCombo - A modern DriveList replacement

April 22, 2024, 5:18 am

≫ Next: Random-Depth Tree Creator/Editor (Finished and MUCH better!)

≪ Previous: Look what I found,City of Ages is a Published Visual Basic 6 game on Steampowered.com

$

0

0

ucDriveCombo v1.0 - Modern DriveList Replacement

While my ucShellBrowse control is capable of displaying a drive list like this, it's really overkill if that's all you need. I thought VB6 and twinBASIC could use a simple but modernized replacement of just the DriveList control. This project is supplied as a VB6 .ctl that has code which runs unmodified in twinBASIC, with 64bit support. Project files for both are provided. For VB6, you must include mUCDCHelper.bas in your projects. In twinBASIC, this module is combined in the same .twin file as the control.

**No typelib or package dependency!** Just need the .ctl/.ctx/.bas for VB6 or the .tbcontrol/.twin for twinBASIC; doesn't require oleexp, WinDevLib, or any similar dependencies.

Full readme:

Code:

---

'********************************************************************
' ucDriveCombo v1.0
' by Jon Johnson
'
' Provides a modernized option for a Drive Combo without the extra
' complexity of a full blown ucShellBrowse control.
'
' Requirements: VB6 or twinBASIC Beta 515
'    Note: This file combines the mUCDCHelper module; in VB6 that
'          must be in its own .bas.
'
' Features:
'  -Same codebase for VB6 and twinBASIC
'  -64bit compatible
'  -Filter drives shown by type
'  -Uses same friendly name and icon as Explorer
'  -Monitors for drive add/remove (optional)
'  -Supports both dropdown list and standard dropdown styles
'  -Drive selection can be get/set by path, letter, or name.
'  -SelectionChanged event
'  -Can provide list of drives
'  -Can optionally classify USB hard drives as removable.
'
' Changelog:
'  Version 1.0 (Released 22 Apr 2024)
'  -Add Property Lets for SelectedDrive_____
'  -Add device add/remove monitoring via RegisterDeviceNotification
'  -Add DPI aware support
'  -Add DropdownWidth option
'
'********************************************************************

---

Download From GitHub

Attached Images

 

Random-Depth Tree Creator/Editor (Finished and MUCH better!)

April 23, 2024, 9:36 pm

≫ Next: Copy Files using API

≪ Previous: [VB6, twinBASIC] ucDriveCombo - A modern DriveList replacement

$

0

0

This code is Significantly revised - cleaner, better, much faster, many more features than the previous upload a couple weeks ago. I think it deserves it's own thread. Let me know if I'm wrong about that please.

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

******** Tree Generator v1.02.zip ********

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


=================================================================
There are no Revision Notes prior to v1.02. (A copy of these Notes and a ReadMe is included in the .zip)
=================================================================

Extensive Revision Notes to follow...

If you download this, I again strongly encourage you to play around with the application *before* you Generate any new Trees.

The provided Database includes a Tree with some Data filled in. If you create a New Tree then all Data in the Existing Tree will be Empty (unless you select the option to fill Random Sample Points). But there won't be any Text with the Nodes in the Tree Editor.

A copy of the Database is included in the Backup Folder in case you wipe out the provided Tree and want to see it with data.

This is now a finished product pending any fixes that may be necessary. The code has been tested extensively.

Any new features added will be part of a future version. That includes *probably, but not promising...* changing the Storage from an Access Db to a Binary File.


===========================================================
v1.02 Revision Notes:
===========================================================


* Multiple optimizations were made that increase efficiency and code-speed dramatically.

* The Tree Creator/Editor is now dependent on the Database. (See Game Notes below).

* The Text File being generated has been rem'd out but is still integrated. Check the cmdCreateTree_Click Event in frmTree for instructions to re-enable saving to a Text File. The Text File has not been updated to include new Node Data being saved in the Database.

* The Number of Roots specified in the Tree Generator Window is now the number being generated. Previously it Generated a Random Number of Roots in the range of 1 to the Number Specified.

* The Probability of each Node being Rolled is Calculated when it is Created. The Value is Stored with each Node in the Database.

* Added an Option to include Random Sample Data to Nodes when they're being Created. The percent of Nodes having Sample Data can Range from 1 to 99% (0% if the Option is not Selected).

* Fixed an issue of the entire Contents of the Textbox being refilled every time a new Node was Created during Tree Generation. It now adds the new Node String to the end of the existing text in the Textbox.

* Textbox Updates can be turned off when Generating a new Tree. This *dramatically* decreases the time required to create a Tree.

* Several fields on frmTree are now filled from the database when the application starts *if* a tree has already been generated and saved.

*A Combobox on frmTree lists all Branches that are the Maximum Length generated for the Current Tree.

* Added a simple Search feature to the Tree Editor Window.

* Added a Probability Textbox to the Tree Editor Window that displays the Probability of the Selected Node being Rolled. This is a Raw Number, not a Percent (move the Decimal right two places per usual to get the Percent).

* Added cNumericTextbox.cls Class to project. An Instance is Created for all Textboxes that are Numeric-only. Go to the CreateObjects Procedure in frmTree to see how the Class is Implemented.

* Optimized the Create Procedure in cNode.cls. Several Conditional Statements were being checked every time a new Node was created even though the Conditions being checked for were only true for the First Node created. The Public Create Procedure now checks those items and calls an internal procedure to continue the Recursion with no further checks.

* Removed colChildNodes from cNode.cls because it was not being used. It can be reimplemented in the future if needed.

* Added a Recordset Property to cNode.cls to eliminate the need to pass the Recordset between Procedures.

* Updated several other Procedures to Pass and Receive fewer Variables.

* Added an Expected Value Window that displays the Expected Value of Points added, Subtracted (and Attribute Multipliers) to or from an Attribute. The Window Updates when a New Tree is Generated or a Node is Edited and Saved.

* Various Procedures were sub-divided to make their tasks more specific.

* Fixed a Bug that prevented Trees from being as Random as intended. Branch numbers from Roots were being Randomly Generated outside the Loop which made every Branch under a Root identical. Branches from different Roots could be different but the Branches under a Root were all the same.

* Fixed a Bug in the Tree Editor that updated the Associated Attribute and Points from the wrong Combobox.

* Fixed a Bug in cNumericTextbox.cls that would not allow the user to input anything into a Textbox that contained a Minus Sign when a Minus Sign is included in the Seltext. (Notes about cNumericTextbox.cls are at the end).

* Updated cNumericTextbox.cls to allow a Comma or Decimal point (if the NumberType set allows non-whole numbers). Then fixed a Bug that would allow one Comma and one Decimal in the same Texbox.

* Removed various Dead Code.

* Fixed a Variable that was being Set and then Changed without the Intermediate Value being used.

===========================================================

Application Notes:

I adjusted my attitude about this application. At first I wanted something quick and dirty so I could get on to developing the Game Engine. I think I said 'It doesn't have to be perfect. It just needs to work.'

But I realized quickly that this application will be foundational to the Game so I began taking it a lot more seriously.

The Node System is simple to read and easy to figure out how it works. If you need a Deeper Branch at some point you can manually add to a Branch in the Database. You will have to calculate the Probability yourself.

If you type in Large Numbers of Roots and Target Depth it can take hours. I tried 999 for Roots and 99 for Target Depth (Max Numbers allowed). Hours later it was nowhere close to being finished AND it overflowed the database (over 2 gb).

So don't do things like that. If you want 999 Roots then do something like 4 Target Depth.

Or find a super-computer and a storage solution that can handle data that large. Maybe go on a cruise while you wait for it to finish.

My approach is to decide the Number of Nodes I want in advance and then play with the numbers to get approximately that number while striking a good balance between number of Roots (more Variety for Players) and Target Depth (more Choices for Players).

===========================================================

Game Notes:

The Database is not intended to be a part of the real final product (this application and any Games that utilized it). Instead a Binary Access file containing game data will be created. This is very low priority because it will also require building an engine to handle the data.

I'm not sure that I'm doing the Math properly when calculating Expected Values.

The intent of Expected Values is to ensure the game is balanced properly.

Values closer to zero will skew the game less. Values less than zero skew the game against the player. Positive values skew the game for the player.

===========================================================

cNumericTextbox.cls is intended to be much simpler than Controls like the MaskedEditBox which is a pain to use in practice.

It has many fewer features that aren't normally needed. If you need more then this class isn't for you.

It specifies three Numeric types: Integer (which means 'Whole Numbers' in this case, not Integer data type. It's actually a Long), Decimal and Currency (internally saved as Doubles).

Other than standard Textbox properties, the Class has these:

---------

*NumberType (one of the three types mentioned above).

*Min Value ' By default this precludes needing to have an Allow Negative Property).

*Max Value

*Format

*Decimal Places ' By default this precludes needing to have an Allow Decimal Property).

---------

And that's about it. It's super-easy to use. See the cmdCreateTree_Click Event in frmTree to see how to use it.

There is nothing more you need to do with cNumericTextbox.cls after it is Initialized. You always reference the Class Object you created and never directly reference the actual textbox.

All other properties (Font, Height, Width, etc.) are set via the Class. If a Property you want to use is missing from the Class it's simple to add as you're just Passing the Value to the Internal Reference to the Textbox.

Attached Files

• Tree Generator v1.02.zip (269.3 KB)

Copy Files using API

April 25, 2024, 8:13 am

≪ Previous: Random-Depth Tree Creator/Editor (Finished and MUCH better!)

$

0

0

In my previous post:
https://www.vbforums.com/showthread....using-File-API
I had mentioned encountering an Error: 1784 when attempting to use a standard DLL. In that attempt I was using a variable length byte array. Because I was passing the length as well, I tried using a fixed length byte array instead, and that appears to have resolved the issue. From that I assume that memory allocation was the issue.

J.A. Coutts

Attached Files

• FCopy.zip (2.7 KB)
• FCopyDLL.zip (1.5 KB)

---