1999: Первоначальные банковские утилиты

BASE36.BAS

@@ -0,0 +1,104 @@
+Attribute VB_Name = "Base36"
+Option Explicit
+Option Compare Text
+Option Base 1
+DefLng A-Z
+
+Public Function To36(Value As Variant) As String
+    Dim n, v
+
+    On Error GoTo ErrHandler
+    If Value < 36 Then
+        If Value < 10 Then '0..9
+            To36 = Chr(48 + Value) '"0"+x
+        Else 'A..Z
+            To36 = Chr(55 + Value) '"A"-10+x
+        End If
+    Else
+        To36 = ""
+        n = Value
+        Do While n > 0
+            v = n Mod 36
+            If v < 10 Then v = v + 48 Else v = v + 55
+            To36 = Chr(v) & To36
+            n = n \ 36
+        Loop
+    End If
+    Exit Function
+
+ErrHandler:
+    To36 = "-1" 'Overflow!
+End Function
+
+Public Function Ot36(Value As String) As Long 'Integer for Asc(), Long for Win32
+    Dim i, n, v
+
+    On Error GoTo ErrHandler
+    n = Len(Value)
+    If n = 1 Then '1 digit only
+        Ot36 = Asc(Value)
+        Select Case Ot36
+            Case 48 To 57 '0..9
+                Ot36 = Ot36 - 48
+            Case 65 To 90 'A..Z
+                Ot36 = Ot36 - 55
+            Case 97 To 122 'a..z
+                Ot36 = Ot36 - 87
+            Case Else
+                GoTo ErrHandler
+        End Select
+    Else
+        Ot36 = 0
+        For i = 1 To n
+            v = Asc(Mid(Value, i, 1))
+            Select Case v
+                Case 48 To 57 '0..9
+                    v = v - 48
+                Case 65 To 90 'A..Z
+                    v = v - 55
+                Case 97 To 122 'a..z
+                    v = v - 87
+                Case Else
+                    GoTo ErrHandler
+            End Select
+            Ot36 = Ot36 + v * (36 ^ (n - i))
+        Next
+    End If
+    Exit Function
+
+ErrHandler:
+    Ot36 = -1 'Overflow!
+End Function
+
+Public Function DateTo36(Optional Value As Variant) As String
+    If IsMissing(Value) Then Value = Now
+
+    DateTo36 = To36(Year(Value) - 1990) 'äî 2026 ãîäà
+    DateTo36 = DateTo36 & To36(Month(Value))
+    DateTo36 = DateTo36 & To36(Day(Value))
+    DateTo36 = DateTo36 & To36(Hour(Value))
+
+    'Òî÷íîñòü äî äåñÿòûõ ñåêóíäû (îò íà÷àëà òåêóùåãî ÷àñà)
+    DateTo36 = DateTo36 & PadL(To36((Timer - Hour(Value) * 3600) * 10), 3, "0")
+End Function
+
+Public Function DateOt36(Value As String, Optional vFormat As String = "dd.mm.yyyy hh:mm:ss") As String
+    Dim n, yy, mm, dd, h, m, s
+
+    n = Len(Value) 'ymdhxxx(36), xxx=s*10
+    If n = 7 Then
+        yy = Ot36(Left(Value, 1)) + 1990
+    Else
+        '2000 äëÿ ó÷åòà âèñîêîñíîãî ãîäà, if any
+        yy = 2000
+    End If
+    mm = Ot36(Mid(Value, n - 5, 1))
+    dd = Ot36(Mid(Value, n - 4, 1))
+    h = Ot36(Mid(Value, n - 3, 1))
+    m = Ot36(Right(Value, 3)) \ 10
+    s = m Mod 60
+    m = m \ 60
+    DateOt36 = Format(DateSerial(yy, mm, dd) + CDate(h & ":" & m & ":" & s), vFormat)
+End Function
+
+

BNKFORMS.BAS

@@ -0,0 +1,35 @@
+Attribute VB_Name = "BnkForms"
+Option Explicit
+Option Base 1
+DefLng A-Z
+
+Public Function FileEnterByMask(Optional FileMask As String = "*.*", Optional MaskEdit As Boolean = False) As String
+    Load FileEnter
+    With FileEnter
+        .FileMask = FileMask
+        .MaskEdit = MaskEdit
+        .FillList
+        .Show
+        FileEnterByMask = .FileMask
+    End With
+    Unload FileEnter
+End Function
+
+Public Function DateByCalendar(Optional StartDate As Variant) As Variant
+    Load Calendar
+    With Calendar
+        If IsMissing(StartDate) Then
+            StartDate = Date
+        End If
+        .DateEntered = StartDate
+        .Show
+        DateByCalendar = .DateEntered
+    End With
+    Unload Calendar
+End Function
+
+Public Sub CalendarShow()
+    Calendar.Show
+    Unload Calendar
+End Sub
+

BYTES.BAS

@@ -0,0 +1,167 @@
+Attribute VB_Name = "Bytes"
+Option Explicit
+Option Base 0 'Binary bytes like the C language!!!
+DefLng A-Z
+
+Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
+    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
+
+Sub StrToBytes(ab() As Byte, s As String)
+    If IsArrayEmpty(ab) Then If Len(s) > 0 Then ReDim ab(0 To Len(s) - 1) Else ReDim ab(0)
+    Dim cab ' As SysInt
+    ' Copy to existing array, padding or truncating if needed
+    cab = UBound(ab) - LBound(ab) + 1
+    If Len(s) < cab Then s = s & String(cab - Len(s), 0)
+    CopyMemory ab(LBound(ab)), ByVal s, cab
+
+    'If IsArrayEmpty(ab) Then
+    '    ' Just assign to empty array
+    '    ab = StrConv(s, vbFromUnicode)
+    'Else
+    '    Dim cab ' As SysInt
+    '    ' Copy to existing array, padding or truncating if needed
+    '    cab = UBound(ab) - LBound(ab) + 1
+    '    If Len(s) < cab Then s = s & String(cab - Len(s), 0)
+    '    CopyMemory ab(LBound(ab)), ByVal s, cab
+    'End If
+End Sub
+
+Function BytesToStr(ab() As Byte) As String
+    'BytesToStr = StrConv(ab(), vbUnicode)
+    BytesToStr = String(LenBytes(ab), 0)
+    CopyMemory ByVal BytesToStr, ab(LBound(ab)), LenBytes(ab)
+End Function
+
+' Read string with length in first byte
+Function BytesToPStr(ab() As Byte, Optional iOffset As Long = 0) As String
+    BytesToPStr = MidBytes(ab, iOffset + 1, ab(iOffset))
+End Function
+
+Function BytesToWord(abBuf() As Byte, Optional iOffset As Long = 0) As Integer
+    Dim w As Integer
+    CopyMemory w, abBuf(iOffset), 2
+    BytesToWord = w
+End Function
+
+Function BytesToDWord(abBuf() As Byte, Optional iOffset As Long = 0) As Long
+    Dim dw As Long
+    CopyMemory dw, abBuf(iOffset), 4
+    BytesToDWord = dw
+End Function
+
+Sub BytesFromWord(w As Long, abBuf() As Byte, Optional iOffset As Long = 0)
+    CopyMemory abBuf(iOffset), w, 2
+End Sub
+
+Sub BytesFromDWord(dw As Long, abBuf() As Byte, Optional iOffset As Long = 0)
+    CopyMemory abBuf(iOffset), dw, 4
+End Sub
+
+'' Emulate relevant Basic string functions for arrays of bytes:
+''     Len$             LenBytes
+''     Mid$ function    MidBytes
+''     Mid$ statement   InsBytes sub
+''     Left$            LeftBytes
+''     Right$           RightBytes
+
+' LenBytes - Emulates Len for array of bytes
+Function LenBytes(ab() As Byte) As Long
+    LenBytes = UBound(ab) - LBound(ab) + 1
+End Function
+
+' MidBytes - emulates Mid$ function for array of bytes
+' (Note that MidBytes does not emulate Mid$ exactly--string fields
+' in byte arrays are often null-padded, and MidBytes can extract
+' non-null portion.)
+Function MidBytes(ab() As Byte, iOffset, Optional vLen As Variant, _
+                  Optional vToNull As Variant) As String
+    Dim s As String, fToNull As Boolean, cab ' As SysInt
+    If Not IsMissing(vToNull) Then fToNull = vToNull
+    ' Calculate length
+    If IsMissing(vLen) Then
+        cab = LenBytes(ab) - iOffset
+    Else
+        cab = vLen
+    End If
+    ' Assign and return string
+    s = String$(cab, 0)
+    CopyMemory ByVal s, ab(iOffset), cab
+    If fToNull Then
+        cab = InStr(s & vbNullChar, vbNullChar)
+        MidBytes = Left$(s, cab - 1)
+    Else
+        MidBytes = s
+    End If
+End Function
+
+' InsBytes - Emulates Mid$ statement for array of bytes
+' (Note that InsBytes does not emulate Mid$ exactly--it inserts
+' a null-padded string into a fixed-size field in order to work
+' better with common use of byte arrays.)
+Sub InsBytes(sIns As String, ab() As Byte, iOffset, _
+             Optional vLen As Variant, Optional sPad As Byte = 0)
+    Dim cab ' As SysInt
+    ' Calculate length
+    If IsMissing(vLen) Then
+        cab = Len(sIns)
+    Else
+        cab = vLen
+        ' Null-pad insertion string if too short
+        If (Len(sIns) < cab) Then
+            sIns = sIns & String$(cab - Len(sIns), sPad)
+        End If
+    End If
+    ' Insert string
+    CopyMemory ab(iOffset), ByVal sIns, cab
+End Sub
+
+' LeftBytes - Emulates Left$ function for array of bytes
+Function LeftBytes(ab() As Byte, iLen) As String
+    Dim s As String
+    s = String$(iLen, 0)
+    CopyMemory ByVal s, ab(LBound(ab)), iLen
+    LeftBytes = s
+End Function
+
+' RightBytes - Emulates Right$ function for array of bytes
+Function RightBytes(ab() As Byte, iLen) As String
+    Dim s As String
+    s = String$(iLen, 0)
+    CopyMemory ByVal s, ab(UBound(ab) - iLen + 1), iLen
+    RightBytes = s
+End Function
+
+' FillBytes - Fills field in array of bytes with given byte
+Sub FillBytes(ab() As Byte, Optional b As Byte = 0, Optional iOffset As Long = 0, Optional iLen As Long)
+    Dim i ' As SysInt
+    If IsArrayEmpty(ab) Then ReDim ab(iLen)
+    If IsMissing(iLen) Then iLen = UBound(ab) - iOffset + 1
+    For i = iOffset To iOffset + iLen - 1
+        ab(i) = b
+    Next
+End Sub
+
+' InStrBytes is not implemented because a simple version would
+' simply be equivalent to InStr(ab(), s). This creates a temporary
+' string for ab() on every call. An efficient version that works
+' directly on arrays of bytes could be written in C.
+
+'However here is my release
+Function InStrBytes(ab() As Byte, b As Byte, Optional iOffset As Long = 0) As Long
+    Dim i ' As SysInt
+    For i = iOffset To UBound(ab)
+        If ab(i) = b Then
+            InStrBytes = i
+            Exit Function
+        End If
+    Next
+    InStrBytes = -1 'Not found
+End Function
+
+Function IsArrayEmpty(ab() As Byte) As Boolean
+    Dim v As Variant
+    On Error Resume Next
+    v = ab(LBound(ab))
+    IsArrayEmpty = (Err <> 0)
+End Function
+