Sirik писал(а):или бинарных файлах?
Sirik писал(а):на каждую комбинаци есть вероятность что она встретиться в файле, если комниция не большая. с другой стороны - мне не большая и не нужна, так как размер для меня главное
Sirik писал(а):вот такой формат:
строка(произвольная длина)ключ(произвольная длина)
Sirik писал(а):во, блин.
если бы я знал заранее что в строке не будет vbNullChar задавал бы я этот вопрос? наверное нет!
Sirik писал(а):короче понял одно, лучше брать любой символ, котрый не втсречается в строке
Option Explicit
Private m_intDecTab(255) As Integer
Private Const m_strEncTabConst As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Public Function EncodeStr64(ByRef strInput As String) As String
Dim i As Long
Dim j As Integer
Dim lngLen As Long
Dim lngQuants As Long
Dim intIndex As Long
Dim strOutput As String
Dim strLast As String
Dim b(2) As Byte
lngLen = Len(strInput)
lngQuants = lngLen \ 3
strOutput = String(lngQuants * 4, " ")
For i = 0 To lngQuants - vbNull
For j = 0 To 2
b(j) = VBA.Asc(VBA.Mid$(strInput, (i * 3) + j + vbNull, vbNull))
Next
Mid(strOutput, intIndex + vbNull, 4) = EncodeQuantum(b)
intIndex = intIndex + 4
Next
Select Case lngLen Mod 3
Case 0
strLast = vbNullString
Case 1
b(0) = VBA.Asc(VBA.Mid$(strInput, lngLen, vbNull))
b(1) = 0&
b(2) = 0&
strLast = EncodeQuantum(b)
strLast = VBA.Left$(strLast, 2) & "=="
Case 2
b(0) = VBA.Asc(VBA.Mid$(strInput, lngLen - vbNull, vbNull))
b(1) = VBA.Asc(VBA.Mid$(strInput, lngLen, vbNull))
b(2) = 0&
strLast = EncodeQuantum(b)
strLast = VBA.Left(strLast, 3) & "="
End Select
EncodeStr64 = strOutput & strLast
End Function
Public Function DecodeStr64(ByRef strEncoded As String) As String
Dim d(3) As Byte
Dim c As Byte
Dim di As Integer
Dim i As Long
Dim lngLen As Long
Dim intIndex As Long
lngLen = Len(strEncoded)
DecodeStr64 = String((lngLen \ 4) * 3, " ")
Call MakeDecTab
For i = vbNull To Len(strEncoded)
c = VBA.CByte(VBA.Asc(VBA.Mid$(strEncoded, i, vbNull)))
c = m_intDecTab(c)
If c >= 0& Then
d(di) = c
di = di + vbNull
If di = 4 Then
Mid$(DecodeStr64, intIndex + vbNull, 3) = DecodeQuantum(d)
intIndex = intIndex + 3
If d(3) = 64 Then
DecodeStr64 = VBA.Left(DecodeStr64, VBA.Len(DecodeStr64) - vbNull)
intIndex = intIndex - vbNull
End If
If d(2) = 64 Then
DecodeStr64 = VBA.Left(DecodeStr64, VBA.Len(DecodeStr64) - vbNull)
intIndex = intIndex - vbNull
End If
di = 0&
End If
End If
Next
End Function
Private Function EncodeQuantum(ByRef b() As Byte) As String
Dim c As Integer
c = SHR2(b(0)) And &H3F
EncodeQuantum = EncodeQuantum & VBA.Mid$(m_strEncTabConst, c + vbNull, vbNull)
c = SHL4(b(0) And &H3) Or (SHR4(b(1)) And &HF)
EncodeQuantum = EncodeQuantum & VBA.Mid$(m_strEncTabConst, c + vbNull, vbNull)
c = SHL2(b(1) And &HF) Or (SHR6(b(2)) And &H3)
EncodeQuantum = EncodeQuantum & VBA.Mid$(m_strEncTabConst, c + vbNull, vbNull)
c = b(2) And &H3F
EncodeQuantum = EncodeQuantum & VBA.Mid$(m_strEncTabConst, c + vbNull, vbNull)
End Function
Private Function DecodeQuantum(ByRef d() As Byte) As String
Dim c As Long
c = SHL2(d(0)) Or (SHR4(d(1)) And &H3)
DecodeQuantum = DecodeQuantum & VBA.Chr$(c)
c = SHL4(d(1) And &HF) Or (SHR2(d(2)) And &HF)
DecodeQuantum = DecodeQuantum & VBA.Chr$(c)
c = SHL6(d(2) And &H3) Or d(3)
DecodeQuantum = DecodeQuantum & VBA.Chr$(c)
End Function
Private Function MakeDecTab()
Dim t As Integer
Dim c As Integer
For c = 0 To 255
m_intDecTab(c) = &HFFF
Next
For c = VBA.Asc("A") To VBA.Asc("Z")
m_intDecTab(c) = t
t = t + vbNull
Next
For c = VBA.Asc("a") To VBA.Asc("z")
m_intDecTab(c) = t
t = t + vbNull
Next
For c = VBA.Asc("0") To VBA.Asc("9")
m_intDecTab(c) = t
t = t + vbNull
Next
c = Asc("+")
m_intDecTab(c) = t
t = t + vbNull
c = Asc("/")
m_intDecTab(c) = t
t = t + vbNull
c = Asc("=")
m_intDecTab(c) = t
End Function
Private Function SHL2(ByVal bytValue As Byte) As Byte
SHL2 = (bytValue * &H4) And &HFF
End Function
Private Function SHL4(ByVal bytValue As Byte) As Byte
SHL4 = (bytValue * &H10) And &HFF
End Function
Private Function SHL6(ByVal bytValue As Byte) As Byte
SHL6 = (bytValue * &H40) And &HFF
End Function
Private Function SHR2(ByVal bytValue As Byte) As Byte
SHR2 = bytValue \ &H4
End Function
Private Function SHR4(ByVal bytValue As Byte) As Byte
SHR4 = bytValue \ &H10
End Function
Private Function SHR6(ByVal bytValue As Byte) As Byte
SHR6 = bytValue \ &H40
End Function
'допустим, что в s - наш текст.
b_ok = 0
For i=0 to 255 'по кодировке ASCII.
For j=1 to i_max 'i_max - мыслимый предел, до которого есть смысл просчитывать..
s_buf=String(j, chr$(i))
if Instr(1, s, s_buf) = 0 then
b_ok = 1
exit for
end if
Next
Next
if b_ok = 0 then
msgbox "это бессмысленно... файл получится очень большим"
exit sub
end if
Сейчас этот форум просматривают: SemrushBot, Yandex-бот и гости: 114