Skip to content

Instantly share code, notes, and snippets.

@iso2022jp

iso2022jp/sprintf.bas

Created May 28, 2014 04:27
Show Gist options
  • Save iso2022jp/ed493ed1952679eb54c8 to your computer and use it in GitHub Desktop.
Save iso2022jp/ed493ed1952679eb54c8 to your computer and use it in GitHub Desktop.
Download ZIP
sprintf for VB6: 若かりし頃のコード発掘
Raw
sprintf.bas
Option Explicit
Public Declare Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)
Public Function sprintf(ByRef FormatString As String, ParamArray Arguments() As Variant) As String
Dim h As OLE_HANDLE
Dim hTerm As OLE_HANDLE
Dim ch As Integer ' Unicode character
Dim sOutput As String
Dim lOut As Long
Dim s As String
Dim l As Long
Dim d As Double
Dim lPrefix As Long
Dim lLastArg As Long
Dim lArg As Long
Dim lState As Long
Dim fm_hOrigin As OLE_HANDLE
Dim fm_lSizeFilled As Long
Dim fm_fLeftAlign As Boolean
Dim fm_fSign As Boolean
Dim fm_fPadZero As Boolean ' ignore if '-' specified or format with iuxXod
Dim fm_fPadSign As Boolean ' ignore if '+' specified
Dim fm_fNoAbbr As Boolean ' ignore with cdius
Dim fm_lWidth As Long
Dim fm_lPrecision As Long
Dim fm_fLongInteger As Boolean
Dim fm_fLongDecimal As Boolean
lLastArg = UBound(Arguments)
h = StrPtr(FormatString)
hTerm = h + Len(FormatString) * 2
' sOutput = vbNullString
' lOut = 0
'
' lState = 0
Do While h < hTerm
Call MoveMemory(ch, ByVal h, 2)
redo:
Select Case lState
Case 0: ' format
If ch = 37 Then '%'
fm_hOrigin = h
fm_lSizeFilled = 0
fm_fLeftAlign = False
fm_fSign = False
fm_fPadZero = False
fm_fPadSign = False
fm_fNoAbbr = False
fm_lWidth = 0
fm_lPrecision = -1 'auto
fm_fLongInteger = True ' 32 bit
fm_fLongDecimal = False ' 32 bit
lState = 1
Else
Call GrowConcat(sOutput, lOut, VarPtr(ch), 1)
End If
Case 1: ' directive
Select Case ch
Case 45: fm_fLeftAlign = True '-'
Case 43: fm_fSign = True '+'
Case 48: fm_fPadZero = True '0'
Case 32: fm_fPadSign = True ' '
Case 35: fm_fNoAbbr = True '#'
Case 42, 49 To 57: lState = 2: GoTo redo '*', '1' - '9'
Case 46: lState = 3: fm_lPrecision = 0 '.'
Case 104, 108, 76: lState = 4: GoTo redo 'hlL
Case 99, 100, 105, 111, 117, 120, 88, 101, 69, 102, 103, 71, 110, 112, 115:
lState = 5: GoTo redo 'cdiouxXeEfgGnps
Case Else: lState = -1: If h = fm_hOrigin + 2 Then fm_hOrigin = fm_hOrigin + 2 ' escape charactor (%?)
End Select
Case 2: ' width
Select Case ch
Case 42: '*'
If fm_lSizeFilled <> 0 Or lArg > lLastArg Then
lState = -1 ' invalid format descriptor
Else
On Error GoTo TypeMismatch
fm_lWidth = CLng(Arguments(lArg))
On Error GoTo 0
If fm_lWidth < 0 Then
fm_fLeftAlign = True
fm_lWidth = -fm_lWidth
End If
lArg = lArg + 1
fm_lSizeFilled = 2 ' force next
End If
Case 48 To 57: '0' - '9'
If fm_lSizeFilled = 2 Then lState = -1
fm_lWidth = fm_lWidth * 10 + (ch - 48)
fm_lSizeFilled = 1 ' size specified
Case 46: lState = 3: fm_lSizeFilled = 0: fm_lPrecision = 0 '.'
Case 104, 108, 76: lState = 4: GoTo redo 'hlL
Case 99, 100, 105, 111, 117, 120, 88, 101, 69, 102, 103, 71, 110, 112, 115:
lState = 5: GoTo redo 'cdiouxXeEfgGnps
Case Else: lState = -1 ' invalid format descriptor
End Select
Case 3: ' precision
Select Case ch
Case 42: '*'
If fm_lSizeFilled <> 0 Or lArg > lLastArg Then 'ex 1*
lState = -1 ' invalid format descriptor
Else
On Error GoTo TypeMismatch
fm_lPrecision = CLng(Arguments(lArg))
On Error GoTo 0
If fm_lPrecision < 0 Then fm_lPrecision = -1
lArg = lArg + 1
fm_lSizeFilled = 2 ' force next
End If
Case 48 To 57: '0' - '9'
If fm_lSizeFilled = 2 Then lState = -1
fm_lPrecision = fm_lPrecision * 10 + (ch - 48)
fm_lSizeFilled = 1 ' size specified
Case 104, 108, 76: lState = 4: GoTo redo 'hlL
Case 99, 100, 105, 111, 117, 120, 88, 101, 69, 102, 103, 71, 110, 112, 115:
lState = 5: GoTo redo 'cdiouxXeEfgGnps
Case Else: lState = -1 ' invalid format descriptor
End Select
Case 4: ' size
Select Case ch
Case 104: lState = 5: fm_fLongInteger = False 'h'
Case 108: lState = 5: fm_fLongInteger = True 'l'
Case 76: lState = 5: fm_fLongDecimal = True 'L'
Case 99, 100, 105, 111, 117, 120, 88, 101, 69, 102, 103, 71, 110, 112, 115:
lState = 5: GoTo redo 'cdiouxXeEfgGnps
Case Else: lState = -1 ' invalid format descriptor
End Select
Case 5: ' type
If lArg > lLastArg Then
lState = -1
GoTo continue:
End If
s = vbNullString
l = 0
lPrefix = 0
Select Case ch
Case 100, 105, 111, 117, 120, 88: 'd', 'i', 'o', 'u', 'x', 'X'
If fm_lPrecision = -1 Then fm_lPrecision = 1
On Error GoTo TypeMismatch
If fm_fLongInteger _
Then l = CLng(Arguments(lArg)) _
Else l = CLng(CInt(Arguments(lArg)))
On Error GoTo 0
If l <> 0 Then
Select Case ch
Case 100, 105: s = CStr(l)
Case 111: s = LCase$(Oct$(l))
Case 117: 'u'
If l >= 0 Then
s = CStr(l)
Else
If fm_fLongInteger _
Then s = CStr(CCur(l) + 4294967296@) _
Else s = CStr(l + 65536)
l = &H7FFFFFFF ' it means positive value
End If
Case 120: s = LCase$(Hex$(l))
Case 88: s = Hex$(l)
End Select
End If
If Len(s) < fm_lPrecision Then s = String$(fm_lPrecision - Len(s), "0") & s
Select Case ch
Case 100, 105: 'di'
If l >= 0 Then
If fm_fSign Then
s = "+" & s: lPrefix = 1
ElseIf fm_fPadSign Then
s = " " & s: lPrefix = 1
End If
Else
lPrefix = 1
End If
Case 111: If fm_fNoAbbr And l <> 0 Then s = "0" & s: lPrefix = 1
Case 120: If fm_fNoAbbr And l <> 0 Then s = "0x" & s: lPrefix = 2
Case 88: If fm_fNoAbbr And l <> 0 Then s = "0X" & s: lPrefix = 2
End Select
Case 102, 101, 69, 103, 71: 'eEfgG'
On Error GoTo TypeMismatch
d = CDbl(Arguments(lArg))
On Error GoTo 0
Select Case ch
Case 101, 69: 'eE'
s = FormatExponentialDouble(d, fm_lPrecision, fm_fNoAbbr)
If ch = 101 Then s = LCase$(s)
Case 102: 'f'
s = FormatDecimalDouble(d, fm_lPrecision, fm_fNoAbbr)
Case 103, 71 'gG'
s = FormatGenericDouble(d, fm_lPrecision, fm_fNoAbbr)
If ch = 103 Then s = LCase$(s)
End Select
If d >= 0 Then
If fm_fSign Then
s = "+" & s: lPrefix = 1
ElseIf fm_fPadSign Then
s = " " & s: lPrefix = 1
End If
Else
lPrefix = 1
End If
Case 112: '9'
' unimplemented
lState = -1
GoTo continue 'special
Case 110: 'n'
Arguments(lArg) = lOut ' can be modify because the ParamArray stores references to variables
lArg = lArg + 1
lState = 0
GoTo continue 'special
Case 99, 115: 'cs'
On Error GoTo TypeMismatch
If ch = 99 Then
s = Chr$(CInt(Arguments(lArg)))
Else
s = CStr(Arguments(lArg))
If fm_lPrecision > -1 Then s = Left$(s, fm_lPrecision)
End If
On Error GoTo 0
Case Else: lState = -1: GoTo continue ' invalid format descriptor
End Select
If fm_fLeftAlign Then
If Len(s) < fm_lWidth Then s = s & Space$(fm_lWidth - Len(s))
ElseIf fm_fPadZero Then
If Len(s) < fm_lWidth Then s = Left$(s, lPrefix) & String$(fm_lWidth - Len(s), "0") & Mid$(s, lPrefix + 1)
Else
If Len(s) < fm_lWidth Then s = Space$(fm_lWidth - Len(s)) & s
End If
Call GrowConcat(sOutput, lOut, StrPtr(s), Len(s))
lArg = lArg + 1
lState = 0
End Select
continue:
If lState = -1 Then
Call GrowConcat(sOutput, lOut, fm_hOrigin, (h - fm_hOrigin + 2) \ 2)
lState = 0
End If
h = h + 2
Loop
If lState <> 0 Then
Call GrowConcat(sOutput, lOut, fm_hOrigin, (h - fm_hOrigin + 2) \ 2)
End If
sprintf = Left$(sOutput, lOut)
Exit Function
TypeMismatch:
lState = -1
GoTo continue
End Function
Private Function FormatExponentialDouble(ByVal Number As Double, ByVal DecimalFractionPrecision As Long, _
ByVal ForceOutDecimalPoint As Boolean) As String
Dim lExp As Long
lExp = StripDoubleExponent(Number)
FormatExponentialDouble = FormatDecimalFraction(Number, DecimalFractionPrecision, ForceOutDecimalPoint, True) _
& FormatExponentSpecifier(lExp)
End Function
Private Function FormatDecimalDouble(ByVal Number As Double, ByVal DecimalFractionPrecision As Long, _
ByVal ForceOutDecimalPoint As Boolean) As String
FormatDecimalDouble = FormatDecimalFraction(Number, DecimalFractionPrecision, ForceOutDecimalPoint, True)
End Function
Private Function FormatGenericDouble(ByVal Number As Double, ByVal SignificantPrecision As Long, _
ByVal ForceOutDecimalPointAndFollowingZeroes As Boolean) As String
Dim dMan As Double
Dim lExp As Long
If SignificantPrecision < 0 Then SignificantPrecision = 6
If SignificantPrecision = 0 Then SignificantPrecision = 1
dMan = Number
lExp = StripDoubleExponent(dMan)
If lExp < -4 Or lExp >= SignificantPrecision Then
' exponential notation
FormatGenericDouble = FormatDecimalFraction(dMan, SignificantPrecision - 1, ForceOutDecimalPointAndFollowingZeroes, ForceOutDecimalPointAndFollowingZeroes) _
& FormatExponentSpecifier(lExp)
Else
' decimal notation
FormatGenericDouble = FormatDecimalFraction(Number, SignificantPrecision - lExp - 1, ForceOutDecimalPointAndFollowingZeroes, ForceOutDecimalPointAndFollowingZeroes)
End If
End Function
Private Function FormatDecimalFraction(ByVal Number As Double, ByVal Precision As Long, _
ByVal ForceOutDecimalPoint As Boolean, ByVal PadZeroes As Boolean) As String
Dim s As String
If Precision < 0 Then Precision = 6
If Precision = 0 Then
If ForceOutDecimalPoint _
Then s = "0." _
Else s = "0"
Else
If PadZeroes _
Then s = "0." & String$(Precision, "0") _
Else s = "0." & String$(Precision, "#")
End If
FormatDecimalFraction = Format$(Number, s)
End Function
Private Function FormatExponentSpecifier(ByVal Exponent As Long) As String
If Exponent >= 0 Then FormatExponentSpecifier = "E+" _
Else FormatExponentSpecifier = "E-"
FormatExponentSpecifier = FormatExponentSpecifier & Format$(Abs(Exponent), "000")
End Function
Private Function StripDoubleExponent(ByRef Number As Double, Optional ByVal System As Long = 10) As Long ' mantissa decimal (10^n)
Dim lExp As Long
Dim fNeg As Boolean
'lExp = Int(Log(Abs(Number)) / Log(System))
If Number = 0 Then Exit Function
If Number < 0 Then
fNeg = True
Number = -Number
End If
If Number < 1 Then
Do
Number = Number * System
lExp = lExp - 1
Loop While Number < 1 And Number <> 0
ElseIf Number >= System Then
Do
Number = Number / System
lExp = lExp + 1
Loop While Number >= System And Number <> 0
End If
If fNeg Then Number = -Number
StripDoubleExponent = lExp
End Function
Private Sub GrowConcatB(ByRef Buffer As String, ByRef Offset As Long, ByRef Text As String)
Call GrowConcat(Buffer, Offset, StrPtr(Text), Len(Text))
End Sub
Private Sub GrowConcat(ByRef Buffer As String, ByRef Offset As Long, ByRef lpsz As OLE_HANDLE, ByVal cch As Long)
Dim lLen As Long
Dim lNew As Long
If cch = 0 Then Exit Sub
lLen = Len(Buffer)
lNew = Offset + cch
If lNew > lLen Then
Do
lLen = lLen + 256
Loop While lNew > lLen
Buffer = Buffer & String$(lLen - Len(Buffer), vbNullChar)
End If
Call MoveMemory(ByVal StrPtr(Buffer) + Offset * 2, ByVal lpsz, cch * 2)
' Mid$(Buffer, Offset + 1, Len(Out)) = Out
Offset = Offset + cch
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment