Option Explicit
' constants
Global Const gksWS = "Hoja1"
Global Const gksBaseN = "BaseNCell"
Global Const gksAlphabet = "AlphabetCell"
Global Const gksSeparatorNo = "SeparatorNoCell"
Global Const gksSeparatorChar = "SeparatorCharCell"
Global Const gksZero = "0"
Public Function sBaseNCode(psInput As String, piBase As Integer) As String
'
' constants
'
' declarations
Dim sAlphabet() As String
Dim iSeparatorNo As Integer, sSeparatorChar As String
Dim sText As String, sBinary As String, sBase As String, iChunk As Integer
Dim I As Integer, J As Integer, K As Integer, A As String
'
' start
' params
sText = psInput
With Worksheets(gksWS)
A = .Range(gksAlphabet)
iSeparatorNo = .Range(gksSeparatorNo)
sSeparatorChar = .Range(gksSeparatorChar)
End With
' alphabet
ReDim sAlphabet(piBase)
For I = 1 To piBase
sAlphabet(I) = Mid(A, I, 1)
Next I
' chunk
iChunk = Round(Log(piBase) / Log(2), 0)
'
' process
' build binary
sBinary = ""
For I = 1 To Len(sText)
A = ""
K = Asc(Mid(sText, I, 1))
For J = 7 To 0 Step -1
A = A & Sgn(K And 2 ^ J)
Next J
sBinary = sBinary & A
Next I
K = (Len(sBinary) Mod iChunk)
If K <> 0 Then sBinary = sBinary & String(iChunk - K, gksZero)
' chunk each N
sBase = ""
For I = 1 To Len(sBinary) Step iChunk
A = String(8 - iChunk, gksZero) & Mid(sBinary, I, iChunk)
K = 0
For J = 7 To 0 Step -1
K = K + Val(Mid(A, 8 - J, 1)) * 2 ^ J
Next J
sBase = sBase & sAlphabet(K + 1)
Next I
' format
If iSeparatorNo <> 0 Then
A = ""
K = Int((Len(sBase) + iSeparatorNo - 1) / iSeparatorNo)
For I = 1 To K
If I <> 1 Then A = A & sSeparatorChar
A = A & Mid(sBase, (I - 1) * iSeparatorNo + 1, iSeparatorNo)
Next I
sBase = A
End If
'
' end
sBaseNCode = sBase
'
End Function
Public Function sBaseNDecode(psInput As String, piBase As Integer) As String
'
' constants
'
' declarations
Dim sAlphabet() As String
Dim iSeparatorNo As Integer, sSeparatorChar As String
Dim sText As String, sBinary As String, sBase As String, sWork As String, iChunk As Integer
Dim I As Integer, J As Integer, K As Integer, A As String
'
' start
' params
sBase = psInput
With Worksheets(gksWS)
A = .Range(gksAlphabet)
iSeparatorNo = .Range(gksSeparatorNo)
sSeparatorChar = .Range(gksSeparatorChar)
End With
' alphabet
ReDim sAlphabet(piBase)
For I = 1 To piBase
sAlphabet(I) = Mid(A, I, 1)
Next I
' chunk
iChunk = Round(Log(piBase) / Log(2), 0)
'
' process
' unformat
If iSeparatorNo <> 0 Then
A = ""
K = Int((Len(sBase) + iSeparatorNo - 1) / iSeparatorNo)
J = Len(sSeparatorChar)
For I = 1 To K
A = A & Mid(sBase, (I - 1) * (iSeparatorNo + J) + 1, iSeparatorNo)
Next I
sBase = A
End If
' build binary
sBinary = ""
For I = 1 To Len(sBase)
A = Mid(sBase, I, 1)
For J = 1 To piBase
If sAlphabet(J) = A Then Exit For
Next J
K = J - 1
A = ""
For J = iChunk - 1 To 0 Step -1
A = A & Sgn(K And 2 ^ J)
Next J
sBinary = sBinary & Left(A, iChunk)
Next I
sBinary = Left(sBinary, Int(Len(sBinary) / 8) * 8)
' build text
sText = ""
For I = 1 To Len(sBinary) Step 8
A = Mid(sBinary, I, 8)
K = 0
For J = 7 To 0 Step -1
K = K + Val(Mid(A, 8 - J, 1)) * 2 ^ J
Next J
sText = sText & Chr(K)
Next I
'
' end
sBaseNDecode = sText
'
End Function