Rambler's Top100
Форум: MS ACCESSБолталкаVBVBA MS OfficeMS SQL server
Новые сообщения: 01000

Форум: MS ACCESS

Вопросы связанные с MS ACCESS

Обновить визитку
Участники «Online»
Все участники

 
 

Доброго времени суток, Посетитель!

вид форума:
Линейный форум Структурный форум

тема: Преобразование десятичного числа в двоичное
 
 автор: Alex   (19.08.2009 в 09:52)   личное сообщение
 
 

Как преобразовать десятичное число, например 1786 в двоичное? Причем нолики с единичками записать каждое в свое поле?

  Ответить  
 
 автор: Lukas   (19.08.2009 в 10:22)   личное сообщение
 
 

Можно так, например:

Public Function Двоичное(Число As Long, Знаков As Long) As Variant
    Dim i As Long
    Dim Остаток As Long
    Dim dv() As Long
    ReDim dv(Знаков)
    dv(Знаков) = Число Mod 2
    Остаток = Число
    For i = Знаков - 1 To 1 Step -1
        Остаток = Остаток \ 2
        dv(i) = Abs(Остаток Mod 2 > 0)
    Next i
    Двоичное = dv
End Function

или так:

Public Function Двоичное(Число As Long, Знаков As Integer) As String
    Dim i As Integer
    Dim Остаток As Long
    Dim dv() As Integer

    ReDim dv(Знаков)
    dv(Знаков) = Число Mod 2
    Остаток = Число
    For i = Знаков - 1 To 1 Step -1
        Остаток = Остаток \ 2
    dv(i) = Abs(Остаток Mod 2 > 0)
    Next i
    For i = 1 To Знаков
        Двоичное = Двоичное & dv(i)
    Next i
End Function

А уж по полям сами раскидайте.

  Ответить  
 
 автор: Alex   (19.08.2009 в 11:24)   личное сообщение
 
 

Спасибо!
А как вызывать?
Я в поле, где должно получиться двоичное число, написал так:
=Двоичное([ИмяПоляСДесятичнымЧислом])
Говорит: #ИМЯ?

  Ответить  
 
 автор: Гамлет   (19.08.2009 в 12:34)   личное сообщение
 
 

Вероятно нет 2-го аргумента Знаков As Integer

  Ответить  
 
 автор: Lukas   (19.08.2009 в 12:56)   личное сообщение
 
 


Придется обойтись без второго аргумента, если его не замечают:

Public Function ToBinary(ByVal Number As Long) As String
    ToBinary = Number Mod 2
    Do While Number > 0
        Number = Number \ 2
        ToBinary = ToBinary & Abs(Number Mod 2 > 0)
    Loop
    ToBinary = StrReverse(ToBinary)
    If Len(ToBinary) > 1 Then ToBinary = Mid(ToBinary, 2)
End Function

  Ответить  
 
 автор: Alex   (19.08.2009 в 12:58)   личное сообщение
 
 

Нет-нет замечают - очень нужная вещь, однако

  Ответить  
 
 автор: Alex   (19.08.2009 в 12:57)   личное сообщение
 
 

Разобрался - забыл количество знаков в аргументы подставить

А как это 00011011111010 по столбцам раскидать? Пробовал =Left$([ИмяПоляСДесятичнымЧислом];n) Так оно мне не n-й символ слева, а n символов слева возвращает...

  Ответить  
 
 автор: Lukas   (19.08.2009 в 13:02)   личное сообщение
 
 

Mid$

  Ответить  
 
 автор: osmor   (19.08.2009 в 13:23)   личное сообщение
 
 

зачем mid ? он у тебя в функции и так уже массив....
вернуть массив и все.

  Ответить  
 
 автор: Lukas   (19.08.2009 в 13:23)   личное сообщение
 
 

У меня да, а у Alex-a?
Он не кодом делает, а:

Я в поле, где должно получиться двоичное число, написал так:
=Двоичное([ИмяПоляСДесятичнымЧислом])

Интересно, в поле формы вернуть массив получится?

  Ответить  
 
 автор: osmor   (19.08.2009 в 13:36)   личное сообщение
 
 

ХЗ... но скорее всего нет.

  Ответить  
 
 автор: Lukas   (19.08.2009 в 13:37)   личное сообщение
 
 

Попробовал, не получилось.
И конструкция =Функция(...)(1) не прошла.

  Ответить  
 
 автор: Alex   (19.08.2009 в 13:33)   личное сообщение
 
 

Спасибо! Все получилось

  Ответить  
 
 автор: ShadowOfSun   (20.08.2009 в 00:12)   личное сообщение
 
 

Можно упростить
функция Oct$(число)-возвращает текстовую строку в восьмеричном виде
Каждый символ - цифра от 0 до 7 соответствует в двоичном виде трем цифрам


0    000
1    001
2    010
3    011
4    100
5    101
6    110
7    111



Пример

Public Function ToBinary(ByVal Number As Long) As String
    
    ToBinary = Oct$(Number)
    
    ToBinary = Replace(ToBinary, "0", "000")
    ToBinary = Replace(ToBinary, "1", "001")
    ToBinary = Replace(ToBinary, "2", "010")
    ToBinary = Replace(ToBinary, "3", "011")
    ToBinary = Replace(ToBinary, "4", "100")
    ToBinary = Replace(ToBinary, "5", "101")
    ToBinary = Replace(ToBinary, "6", "110")
    ToBinary = Replace(ToBinary, "7", "111")
    
End Function


по моему наглядней и быстрее

  Ответить  
 
 автор: Lukas   (20.08.2009 в 00:32)   личное сообщение
 
 

Проверим:

Public Declare Function apiTimeGetTime Lib "winmm.dll" Alias "timeGetTime" () As Long

Public Function ToBinary2(ByVal Number As Long) As String
    
    ToBinary2 = Oct$(Number)
    
    ToBinary2 = Replace(ToBinary2, "0", "000")
    ToBinary2 = Replace(ToBinary2, "1", "001")
    ToBinary2 = Replace(ToBinary2, "2", "010")
    ToBinary2 = Replace(ToBinary2, "3", "011")
    ToBinary2 = Replace(ToBinary2, "4", "100")
    ToBinary2 = Replace(ToBinary2, "5", "101")
    ToBinary2 = Replace(ToBinary2, "6", "110")
    ToBinary2 = Replace(ToBinary2, "7", "111")
    
End Function

Public Function ToBinary(ByVal Number As Long) As String
    ToBinary = Number Mod 2
    Do While Number > 0
        Number = Number \ 2
        ToBinary = ToBinary & Abs(Number Mod 2 > 0)
    Loop
    ToBinary = StrReverse(ToBinary)
    If Len(ToBinary) > 1 Then ToBinary = Mid(ToBinary, 2)
End Function

Public Function Test()
    Dim i As Long
    Dim j As Long
    Dim start As Long
    Dim str As String
    
    For i = 0 To 5000000 'Разгон процессора
        i = i
    Next i
    
    For j = 1 To 10
        str = ""
        start = apiTimeGetTime
        For i = 0 To 10000
            str = ToBinary2(i)
        Next i
       Debug.Print "ShadowOfSun=" & apiTimeGetTime - start & " ms", str
        
        str = ""
        start = apiTimeGetTime
        For i = 0 To 10000
            str = ToBinary(i)
        Next i
        Debug.Print "Lukas____(3)=" & apiTimeGetTime - start & " ms", str
        Debug.Print "-------------------------------------------"
    Next j
End Function

Результаты:

ShadowOfSun=265 ms          010011100010000
Lukas____(3)=94 ms          10011100010000
-------------------------------------------
ShadowOfSun=281 ms          010011100010000
Lukas____(3)=94 ms          10011100010000
-------------------------------------------
ShadowOfSun=281 ms          010011100010000
Lukas____(3)=94 ms          10011100010000
-------------------------------------------
ShadowOfSun=219 ms          010011100010000
Lukas____(3)=78 ms          10011100010000
-------------------------------------------
ShadowOfSun=219 ms          010011100010000
Lukas____(3)=78 ms          10011100010000
-------------------------------------------
ShadowOfSun=218 ms          010011100010000
Lukas____(3)=79 ms          10011100010000
-------------------------------------------
ShadowOfSun=234 ms          010011100010000
Lukas____(3)=78 ms          10011100010000
-------------------------------------------
ShadowOfSun=219 ms          010011100010000
Lukas____(3)=78 ms          10011100010000
-------------------------------------------
ShadowOfSun=219 ms          010011100010000
Lukas____(3)=78 ms          10011100010000
-------------------------------------------
ShadowOfSun=234 ms          010011100010000
Lukas____(3)=78 ms          10011100010000
-------------------------------------------

  Ответить  
 
 автор: ShadowOfSun   (20.08.2009 в 00:37)   личное сообщение
 
 

Что ж учтем
наглядность в три раза тормознутее
бум работать

  Ответить  
 
 автор: Lukas   (20.08.2009 в 00:41)   личное сообщение
 
 

Я думаю есть более правильное решение этой задачи, но пока не сообразю как.
Первая функция Двоичное, возвращающая массив, работает в 2 раза быстрее ToBinary

  Ответить  
 
 автор: ShadowOfSun   (20.08.2009 в 01:20)   личное сообщение
 
 

протестируй еще одну функцию, пожалуйста

Public Function DecToBin(DecNum As Long) As String
   Dim BinNum As String
   Dim i As Integer
   
   BinNum = ""
   i = 0
   Do
      If DecNum And 2 ^ i Then
         BinNum = "1" & BinNum
      Else
         BinNum = "0" & BinNum
      End If
      i = i + 1
   Loop Until 2 ^ i > DecNum
   DecToBin = BinNum
End Function



Да к сожалению нельзя в VBA вставить ассемблерную строчку как на Паскале и Си
приходится изгаляться
P.S.
не помогло


ShadowOfSun=204 ms          010011100010000
DecToBin=91 ms              10011100010000
Lukas____(3)=52 ms          10011100010000
-------------------------------------------
ShadowOfSun=205 ms          010011100010000
DecToBin=91 ms              10011100010000
Lukas____(3)=54 ms          10011100010000
-------------------------------------------
ShadowOfSun=205 ms          010011100010000
DecToBin=96 ms              10011100010000
Lukas____(3)=53 ms          10011100010000
-------------------------------------------
ShadowOfSun=204 ms          010011100010000
DecToBin=93 ms              10011100010000
Lukas____(3)=52 ms          10011100010000
-------------------------------------------
ShadowOfSun=204 ms          010011100010000
DecToBin=90 ms              10011100010000
Lukas____(3)=52 ms          10011100010000
-------------------------------------------
ShadowOfSun=204 ms          010011100010000
DecToBin=91 ms              10011100010000
Lukas____(3)=51 ms          10011100010000
-------------------------------------------
ShadowOfSun=205 ms          010011100010000
DecToBin=90 ms              10011100010000
Lukas____(3)=54 ms          10011100010000
-------------------------------------------
ShadowOfSun=204 ms          010011100010000
DecToBin=96 ms              10011100010000
Lukas____(3)=53 ms          10011100010000
-------------------------------------------
ShadowOfSun=204 ms          010011100010000
DecToBin=94 ms              10011100010000
Lukas____(3)=53 ms          10011100010000
-------------------------------------------
ShadowOfSun=204 ms          010011100010000
DecToBin=91 ms              10011100010000
Lukas____(3)=52 ms          10011100010000
-------------------------------------------

  Ответить  
 
 автор: ShadowOfSun   (20.08.2009 в 02:04)   личное сообщение
 
 

Ура нашелся победитель работает в 2 раза быстрее
Спасибо Lukas заставил пораскинуть мозгами
Быстрее только на ассемблере, хотя...


Public Function DecToBin(ByVal DecNum As Long) As String
DecToBin = ""
Do Until DecNum = 0
    If (DecNum Mod 2) Then DecToBin = "1" & DecToBin Else DecToBin = "0" & DecToBin
    DecNum = DecNum \ 2
Loop
End Function

  Ответить  
 
 автор: Lukas   (20.08.2009 в 13:35)   личное сообщение
 
 

?DecToBin(0)
Кукиш

  Ответить  
 
 автор: ShadowOfSun   (20.08.2009 в 16:45)   личное сообщение
 
 

добавляю обработку кукиша

Public Function DecToBin(ByVal DecNum As Long) As String
   If DecNum = 0 Then DecToBin = "0" Else DecToBin = ""
   Do Until DecNum = 0
      If (DecNum Mod 2) Then DecToBin = "1" & DecToBin Else DecToBin = "0" & DecToBin
      DecNum = DecNum \ 2
   Loop
End Function

  Ответить  
 
 автор: Lukas   (20.08.2009 в 16:59)   личное сообщение
 
 

Проверим, у меня тоже новая функция:

Public Declare Function apiTimeGetTime Lib "winmm.dll" Alias "timeGetTime" () As Long

Public Function ToBinary3(ByVal Number As Long, Optional Digits As Long = 24) As String
    Dim Ret As String
    Dim i As Long
    Const ZERO As String = "0"
    Const ONE As String = "1"
    Ret = String(Digits, ZERO)
    
    If Number Then
        For i = Digits To 0 Step -1
            If Number Mod 2 Then
                Mid$(Ret, i, 1) = ONE
            End If
            Number = Number \ 2
        Next i
    End If
    ToBinary3 = Ret
End Function

Public Function DecToBin(ByVal DecNum As Long) As String
   If DecNum = 0 Then DecToBin = "0" Else DecToBin = ""
   Do Until DecNum = 0
      If (DecNum Mod 2) Then DecToBin = "1" & DecToBin Else DecToBin = "0" & DecToBin
      DecNum = DecNum \ 2
   Loop
End Function

Public Function Test()
    Dim i As Long
    Dim j As Long
    Dim start As Long
    Dim str As String
    Dim var As Variant
    
    For i = 0 To 5000000 'разгоним процессор
        i = i
    Next i
    

    For j = 1 To 10
        DoEvents
        str = ""
        start = apiTimeGetTime
        For i = 0 To 100000
            str = ToBinary3(i, 17)
        Next i
        Debug.Print "ToBinary3___=" & apiTimeGetTime - start & " ms", str
        
        DoEvents
        str = ""
        start = apiTimeGetTime
        For i = 0 To 100000
            str = DecToBin(i)
        Next i
        Debug.Print "DecToBin____=" & apiTimeGetTime - start & " ms", str
        Debug.Print "-------------------------------------------"
        
    Next j
End Function

Результаты:
ToBinary3___=485 ms         11000011010100000
DecToBin____=687 ms         11000011010100000
-------------------------------------------
ToBinary3___=484 ms         11000011010100000
DecToBin____=688 ms         11000011010100000
-------------------------------------------
ToBinary3___=484 ms         11000011010100000
DecToBin____=703 ms         11000011010100000
-------------------------------------------
ToBinary3___=484 ms         11000011010100000
DecToBin____=688 ms         11000011010100000
-------------------------------------------
ToBinary3___=578 ms         11000011010100000
DecToBin____=828 ms         11000011010100000
-------------------------------------------
ToBinary3___=500 ms         11000011010100000
DecToBin____=672 ms         11000011010100000
-------------------------------------------
ToBinary3___=484 ms         11000011010100000
DecToBin____=688 ms         11000011010100000
-------------------------------------------
ToBinary3___=484 ms         11000011010100000
DecToBin____=687 ms         11000011010100000
-------------------------------------------
ToBinary3___=485 ms         11000011010100000
DecToBin____=687 ms         11000011010100000
-------------------------------------------
ToBinary3___=484 ms         11000011010100000
DecToBin____=688 ms         11000011010100000
-------------------------------------------

  Ответить  
 
 автор: Alex   (20.08.2009 в 17:04)   личное сообщение
 
 

Ну Вы, блин, даёте
Сорри за off !

  Ответить  
 
 автор: Lukas   (20.08.2009 в 17:11)   личное сообщение
 
 

Ищем сферического коня в вакууме.

  Ответить  
 
 автор: ShadowOfSun   (20.08.2009 в 18:31)   личное сообщение
 
 

Даа
больше никаких соображений не вырисовывается
поздравляю

  Ответить  
 
 автор: Lukas   (20.08.2009 в 18:49)   личное сообщение
 
 

Да не с чем поздравлять. Все-равно кривенько как-то.
К тому-же, представлению в виде строки практического применения не вижу.
Надо возвращать массив Long и для проверки глазом сделать функцию преобразования к строке.

  Ответить  
 
 автор: Кабан   (20.08.2009 в 19:00)   личное сообщение
 
 

а вот есть такое применение ;)
например для рисования штрихкодов на этикетках ;)

  Ответить  
 
 автор: Lukas   (20.08.2009 в 21:35)   личное сообщение
 
 

Вот и хорошо, не зря "коника искали".

  Ответить  
 
 автор: Кабан   (20.08.2009 в 18:59)   личное сообщение
 
 

ну что ты еще есть варианты! :))

'?dec2bin(19)
'11001
Function dec2bin$(a&)
    If a = 0 Then Exit Function
    dec2bin = (a Mod 2) & dec2bin((a \ 2))
End Function


dec2bin=1496 ms             00000101011000011
dec2bin=1492 ms             00000101011000011
dec2bin=1518 ms             00000101011000011
dec2bin=1516 ms             00000101011000011
dec2bin=1508 ms             00000101011000011
dec2bin=1494 ms             00000101011000011
dec2bin=1504 ms             00000101011000011
dec2bin=1503 ms             00000101011000011
dec2bin=1517 ms             00000101011000011
dec2bin=1493 ms             00000101011000011


правда я не понимаю - хороший это результат или нет?

  Ответить  
 
 автор: Lukas   (20.08.2009 в 21:11)   личное сообщение
 
 

Проверим:

Public Sub ftest()
    Dim i As Long
    For i = 0 To 10
        Debug.Print i, dec2bin$(i)
    Next i
End Sub
Рез-ты:
 0            
 1            1
 2            01
 3            11
 4            001
 5            101
 6            011
 7            111
 8            0001
 9            1001
 10           0101


Ладно, поправим так:

Function dec3bin$(a&)
    If a = 0 Then
        Exit Function
    End If
    dec3bin = dec3bin((a \ 2)) & (a Mod 2)
End Function
Рез-ты:
 0            
 1            1
 2            10
 3            11
 4            100
 5            101
 6            110
 7            111
 8            1000
 9            1001
 10           1010

Уже лучше.
Проверим скорость:

ToBinary3___=500 ms         11000011010100000
dec3bin$____=1000 ms        11000011010100000
-------------------------------------------
ToBinary3___=407 ms         11000011010100000
dec3bin$____=1015 ms        11000011010100000
-------------------------------------------
ToBinary3___=406 ms         11000011010100000
dec3bin$____=1000 ms        11000011010100000
-------------------------------------------
ToBinary3___=407 ms         11000011010100000
dec3bin$____=1000 ms        11000011010100000
-------------------------------------------
ToBinary3___=406 ms         11000011010100000
dec3bin$____=1000 ms        11000011010100000
-------------------------------------------
ToBinary3___=390 ms         11000011010100000
dec3bin$____=1000 ms        11000011010100000
-------------------------------------------
ToBinary3___=406 ms         11000011010100000
dec3bin$____=1000 ms        11000011010100000
-------------------------------------------
ToBinary3___=391 ms         11000011010100000
dec3bin$____=1000 ms        11000011010100000
-------------------------------------------
ToBinary3___=406 ms         11000011010100000
dec3bin$____=1016 ms        11000011010100000
-------------------------------------------
ToBinary3___=390 ms         11000011010100000
dec3bin$____=1000 ms        11000011010100000
-------------------------------------------

А идея хорошая.

  Ответить  
 
 автор: ShadowOfSun   (21.08.2009 в 02:00)   личное сообщение
 
 

Еще один вариант
Не фонтан, но забавный а хотел преобразовывать без цикла
Ускорял по методу Lukas'а константами

Public Function dec2bin(ByVal DecNum As Long, Optional Digits As Long = 24) As String
   Dim i As Long
   Const ZERO As String = "0"
   Const ONE As String = "1"
   Const LOG2 As Double = 0.693147180559945
   
   dec2bin = String(Digits, ZERO)
   
   Do Until DecNum = 0
      i = Fix(Log(DecNum) / LOG2)
      Mid$(dec2bin, Digits - i, 1) = ONE
      DecNum = DecNum - 2 ^ i
   Loop
End Function

  Ответить  
 
 автор: Кабан   (21.08.2009 в 09:51)   личное сообщение
 
 

а вот http://members.optusnet.com.au/~draw3d/assembly.html
, говорят, можно скрестить VB с Ассемблером :)

и вот покопацца в коде
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=42427&lngWId=1

  Ответить  
 
 автор: Кабан   (21.08.2009 в 10:34)   личное сообщение
 
 

чёта я устал?
вот ф-я

Function dec2bin_2(a As Long) As String
    Do While a > 0
        dec2bin_2 = a Mod 2 & dec2bin_2
        a = (a \ 2)
    Loop
End Function


в тесте в цикле

        For i = 0 To 100000
            str = dec2bin_2(i)
        Next i


счётчик i не увеличивается!
кде тупняк? только на моей машинке? или у всех? :)

з.ы. ByVal,сцуко :)

  Ответить  
 
 автор: Lukas   (21.08.2009 в 11:08)   личное сообщение
 
 

ByVal надо, потому как a = (a \ 2)
Добавлено:
Опоздал или не увидел зы.

  Ответить  
 
 автор: Кабан   (21.08.2009 в 11:12)   личное сообщение
 
 

ты молодец!

  Ответить  
 
 автор: osmor   (21.08.2009 в 11:27)   личное сообщение
 
 

так я тут потерялся, думаю функцию надо на сайт покласть, только резюмируйте вывод КАКУЮ?
а то все читать времени нет :-( а так боюсь вниз уползет и вообще забуду

  Ответить  
 
 автор: ShadowOfSun   (21.08.2009 в 11:41)   личное сообщение
 
 

Lucas
Выложи свою функцию на сайт, плиз

  Ответить  
 
 автор: Lukas   (21.08.2009 в 12:15)   личное сообщение
 
 

Есть новая идея, пока на 10% быстрее прежней. Пока тестю. По окончании покажу.

  Ответить  
 
 автор: Lukas   (21.08.2009 в 13:09)   личное сообщение
 
 

Наверное подведем временно итог:
В виду некоторой экзотичности новой функции и небольшим приростом скорости (13-15%),
предлагаю вернуться к этому варианту:

Public Function LongToBinStr(ByVal Number As Long, Optional Digits As Long = 32) As String
    Dim Ret As String
    Dim i As Long
    Const ZERO As String = "0"
    Const ONE As String = "1"
    Ret = String(Digits, ZERO)
    
    If Number Then
        For i = Digits To 0 Step -1
            If Number Mod 2 Then
                Mid$(Ret, i, 1) = ONE
            End If
            Number = Number \ 2
        Next i
    End If
    LongToBinStr = Ret
End Function

Хочется отметить, что знак числа эта функция не учитывает.

  Ответить  
 
 автор: osmor   (21.08.2009 в 15:04)   личное сообщение
 
 

Вопрос, почему не вот эту?

Public Function ToBinary(ByVal Number As Long) As String
    ToBinary = Number Mod 2
    Do While Number > 0
        Number = Number \ 2
        ToBinary = ToBinary & Abs(Number Mod 2 > 0)
    Loop
    ToBinary = StrReverse(ToBinary)
    If Len(ToBinary) > 1 Then ToBinary = Mid(ToBinary, 2)
End Function


? LongToBinStr(5)
00000000000000000000000000000101
? ToBinary(5)
101

  Ответить  
 
 автор: Lukas   (21.08.2009 в 16:08)   личное сообщение
 
 

Во первых LongToBinStr быстрее, во вторых ей можно задать количество разрядов, что мне кажется полезным.
Но можно и обе. Кому как нужно.

  Ответить  
 
 автор: osmor   (21.08.2009 в 16:21)   личное сообщение
 
 

ОК. понял

  Ответить  
 
 автор: Lukas   (21.08.2009 в 16:34)   личное сообщение
 
 

А здесь и без реверса можно обойтись

Public Function ToBinary(ByVal Number As Long) As String
    ToBinary = Number Mod 2
    Do While Number > 0
        Number = Number \ 2
        ToBinary = Abs(Number Mod 2 > 0) & ToBinary
    Loop
    If Len(ToBinary) > 1 Then ToBinary = Mid(ToBinary, 2)
End Function

Но все равно медленней.

  Ответить  
 
 автор: ShadowOfSun   (21.08.2009 в 16:52)   личное сообщение
 
 

А прирост скорости в 5-10 процентов можно добиться маленьким упрощением

Public Function ToBinary(ByVal Number As Long, Optional Digits As Long = 24) As String
'Created by Lukas
    Dim i As Long
    Const ZERO As String = "0"
    Const ONE As String = "1"
    ToBinary = String(Digits, ZERO)
    
    If Number Then
        For i = Digits To 0 Step -1
            If Number Mod 2 Then
                Mid$(ToBinary, i, 1) = ONE
            End If
            Number = Number \ 2
        Next i
    End If
End Function

  Ответить  
 
 автор: Кабан   (21.08.2009 в 17:10)   личное сообщение
 
 

а если еще и вместо ToBinary = String(Digits, "0")
ToBinary ="000000000000000000000000"
и
Mid$(ToBinary, i, 1) = "1"
?

з.ы. и Optional Digits As integer = 24

  Ответить  
 
 автор: Lukas   (21.08.2009 в 17:42)   личное сообщение
 
 

2 ShadowOfSun - быстрее на 4% (при 32 знаках)
2 Кабан:
ShadowOfSun + ToBinary ="00000000000000000000000000000000" - быстрее на 8 %, но нет возможности менять кол-во знаков.
Mid$(ToBinary, i, 1) = "1" - медленнее
As integer - медленнее

  Ответить  
 
 автор: Анатолий (Киев)   (21.08.2009 в 17:45)   личное сообщение
 
 

ToBinary ="000000000000000000000000" не годится, т.к. аргумент Digits может иметь и другое значение.
Mid$(ToBinary, i, 1) = "1" здесь VBA создает в памяти еще одну константу, поэтому - хуже. А если бы константа ONE использовалась в десяти местах, и вместо нее везде указать "1", то будет создано 10 констант.
Optional Digits As integer = 24. Как раз Long (4 байта) для 32 разрядных систем - самый любимый размер. Integer, а, тем более, Byte требуют от системы некоторого напряга.

Добавлено: На заметку - возведение в степень - самая медленная (ну очень) арифметическая операция в VBA.

Другое дело, что в аргументы функции лучше добавить ByVal. Это может и медленнее, зато - надежнее.

ЗЫ. С интнресом наблюдаю за изысканиями сообщества. Вот если бы еще тема была поважнее...

  Ответить  
 
 автор: Lukas   (21.08.2009 в 18:01)   личное сообщение
 
 

Вот если бы еще тема была поважнее...
Что может быть важнее "коня в вакууме"?
На самом деле пару раз понадобилась для расчетов оптимизации (перебор вариантов), но не строковая, а Long массив.

ps. Видел бы кто мой последний вариант, со стула бы упал.
Но пока самая быстрая.
ToBinary____=547 ms
LongToBinStr=578 ms
funLongToBin=516 ms (новая)

  Ответить  
 
 автор: Кабан   (21.08.2009 в 18:02)   личное сообщение
 
 

на работе, как раз, поважнее :)
а здесь - надо ж расслабляцца ;)

  Ответить  
 
 автор: Lukas   (22.08.2009 в 22:24)   личное сообщение
 
 

Новая версия (с учетом поправки ShadowOfSun), надеюсь последняя:

Public Function LongToBinStr(ByVal Number As Long, Optional Digits As Long = 32) As String
    Dim i As Long
    Const ZERO As String = "0"
    Const ONE As String = "1"
    LongToBinStr = String(Digits, ZERO)
    
    For i = Digits To 1 Step -1
        If Number Mod 2 Then
            Mid$(LongToBinStr, i, 1) = ONE
        End If
        Number = Number \ 2
        If Number = 0 Then Exit Function ' уменьшает время на 30% при 32 знаках  и 15% при 24 знаках
    Next i
End Function


Итого: по сравнению с первой строковой функцией (Двоичное) скорость выросла более чем в 5 раз.

  Ответить  
 
 автор: Lukas   (23.08.2009 в 20:49)   личное сообщение
 
 

Правка ToBinary:

Public Function ToBinary(ByVal Number As Long) As String
    ToBinary = Number Mod 2
    Do While Number > 1
        Number = Number \ 2
        ToBinary = Abs(Number Mod 2 > 0) & ToBinary
    Loop
End Function

  Ответить  
 
 автор: osmor   (24.08.2009 в 12:56)   личное сообщение
 
 

http://hiprog.com/index.php?option=com_content&task=view&id=251661634&Itemid=35

  Ответить  
 
 автор: Lukas   (24.08.2009 в 13:53)   личное сообщение
 
 

Спасибо Олег.
Еще не надоели мои мысли-скакуны?
Предлагаю экзотику, работает на 37% быстрее последней LongToBinStr и на 70% быстрее ToBinary:

Public Function LongToBinStr16(ByVal Number As Long, Optional Digits As Long = 32) As String
    Dim i As Long
    Const ZERO As String * 1 = "0"
    Const ONE As String * 4 = "0001"
    Const TWO As String * 4 = "0010"
    Const THREE As String * 4 = "0011"
    Const FOUR As String * 4 = "0100"
    Const FIVE As String * 4 = "0101"
    Const SIX As String * 4 = "0110"
    Const SEVEN As String * 4 = "0111"
    Const EIGHT As String * 4 = "1000"
    Const NINE As String * 4 = "1001"
    Const TEN As String * 4 = "1010"
    Const ELEVEN As String * 4 = "1011"
    Const TWELVE As String * 4 = "1100"
    Const THIRTEEN As String * 4 = "1101"
    Const FOURTEEN As String * 4 = "1110"
    Const FIFTEEN As String * 4 = "1111"

    LongToBinStr16 = String(Digits + 3, ZERO)

    For i = Digits To 1 Step -4
        Select Case Number Mod 16
            Case Is = 1: Mid$(LongToBinStr16, i, 4) = ONE
            Case Is = 2: Mid$(LongToBinStr16, i, 4) = TWO
            Case Is = 3: Mid$(LongToBinStr16, i, 4) = THREE
            Case Is = 4: Mid$(LongToBinStr16, i, 4) = FOUR
            Case Is = 5: Mid$(LongToBinStr16, i, 4) = FIVE
            Case Is = 6: Mid$(LongToBinStr16, i, 4) = SIX
            Case Is = 7: Mid$(LongToBinStr16, i, 4) = SEVEN
            Case Is = 8: Mid$(LongToBinStr16, i, 4) = EIGHT
            Case Is = 9: Mid$(LongToBinStr16, i, 4) = NINE
            Case Is = 10: Mid$(LongToBinStr16, i, 4) = TEN
            Case Is = 11: Mid$(LongToBinStr16, i, 4) = ELEVEN
            Case Is = 12: Mid$(LongToBinStr16, i, 4) = TWELVE
            Case Is = 13: Mid$(LongToBinStr16, i, 4) = THIRTEEN
            Case Is = 14: Mid$(LongToBinStr16, i, 4) = FOURTEEN
            Case Is = 15: Mid$(LongToBinStr16, i, 4) = FIFTEEN
        End Select
        Number = Number \ 16
        If Number = 0 Then GoTo ExitFunction
    Next i
ExitFunction:
    LongToBinStr16 = Mid$(LongToBinStr16, 4)
End Function

  Ответить  
 
 автор: ShadowOfSun   (24.08.2009 в 15:50)   личное сообщение
 
 

А можно и быстрее

Public Function LongToBin(ByVal Number As Long) As String
    Const ZERO As String * 4 = "0000"
    Const ONE As String * 4 = "0001"
    Const TWO As String * 4 = "0010"
    Const THREE As String * 4 = "0011"
    Const FOUR As String * 4 = "0100"
    Const FIVE As String * 4 = "0101"
    Const SIX As String * 4 = "0110"
    Const SEVEN As String * 4 = "0111"
    Const EIGHT As String * 4 = "1000"
    Const NINE As String * 4 = "1001"
    Const TEN As String * 4 = "1010"
    Const ELEVEN As String * 4 = "1011"
    Const TWELVE As String * 4 = "1100"
    Const THIRTEEN As String * 4 = "1101"
    Const FOURTEEN As String * 4 = "1110"
    Const FIFTEEN As String * 4 = "1111"
    
    LongToBin = ""
    Do
        Select Case Number Mod 16
            Case Is = 0: LongToBin = ZERO & LongToBin
            Case Is = 1: LongToBin = ONE & LongToBin
            Case Is = 2: LongToBin = TWO & LongToBin
            Case Is = 3: LongToBin = THREE & LongToBin
            Case Is = 4: LongToBin = FOUR & LongToBin
            Case Is = 5: LongToBin = FIVE & LongToBin
            Case Is = 6: LongToBin = SIX & LongToBin
            Case Is = 7: LongToBin = SEVEN & LongToBin
            Case Is = 8: LongToBin = EIGHT & LongToBin
            Case Is = 9: LongToBin = NINE & LongToBin
            Case Is = 10: LongToBin = TEN & LongToBin
            Case Is = 11: LongToBin = ELEVEN & LongToBin
            Case Is = 12: LongToBin = TWELVE & LongToBin
            Case Is = 13: LongToBin = THIRTEEN & LongToBin
            Case Is = 14: LongToBin = FOURTEEN & LongToBin
            Case Is = 15: LongToBin = FIFTEEN & LongToBin
        End Select
        Number = Number \ 16
   Loop Until Number = 0
End Function

  Ответить  
 
 автор: Lukas   (24.08.2009 в 16:00)   личное сообщение
 
 


 0            0000
 1            0001
 2            0010
 3            0011
 4            0100
 5            0101
 6            0110
 7            0111
 8            1000
 9            1001
 10           1010
 11           1011
 12           1100
 13           1101
 14           1110
 15           1111
 16           00010000
 17           00010001
 18           00010010
 19           00010011
 20           00010100
 21           00010101
 22           00010110
 23           00010111
 24           00011000
 25           00011001
 26           00011010
 27           00011011
 28           00011100
 29           00011101
 30           00011110
 31           00011111
 32           00100000

Это не есть гуд, когда прыгает разрядность.
Либо без нее, либо с фиксированной.

  Ответить  
 
 автор: ShadowOfSun   (24.08.2009 в 16:15)   личное сообщение
 
 

по моему на любителя
За то не потеряются первые цифры при неправильном указании разрядности
и +1,5% . Эх мне бы их с прибыли какого нибудь банка

  Ответить  
HiProg.com - Технологии программирования
Rambler's Top100 TopList