Visual Basic 6.0 - Размер формы

Здоровья тебе, #/Sergey/#.
XC: #RU.VISUAL.BASIC, #CC.MY.ECHOMAIL

05 Hоя 03, в 14:28, *Sergey Nikonov* писал я к _All_:





Ставь оработчик OnResize в форме. Imho, по другому никак.


Удачи, #*/Дмитрий/*#.
[SPBGPU 3083/1]
* Origin: It's all gone. What is left behind on the desert we (2:5030/1450.6)


Здоровья тебе, #/Dmitriy/#.
XC: #RU.VISUAL.BASIC, #CC.MY.ECHOMAIL

05 Hоя 03, в 14:44, *Dmitriy Kozyrev* писал я к _Сулейманов Тимур_:











СТ просил без раннего связывания, а это разве не оно?





Hу зачем же так радикально, вед есть объект Extender lля этих целей.

Удачи, #*/Дмитрий/*#.
[SPBGPU 3083/1]
* Origin: It's all gone. What is left behind on the desert we (2:5030/1450.6)


Мы где-то виделись, Alex_Chernyshov?






Для этого надо использовать не Call Absolute, а Call Interrupt. Его второй и
третий параметры - входные и выходные значения регистров соответственно.
Первый - номер прерывания.



Дык все уже написано. ;) Ищи в инете.



Извиняю.
А вообще, вопросы по досовскому бейсику надо задавать в RU.DOS.BASIC или в
RU.BASIC.

Всего хорошего!
Дмитрий Козырев aka Master

* Origin: Дорогу осилит идущий. (2:5023/11.148)


Мы где-то виделись, Dmitry?







Можешь привести пример? Я знаю только VBControlExtender, но он для классов не
подходит вообще.

Всего хорошего!
Дмитрий Козырев aka Master

* Origin: Дорогу осилит идущий. (2:5023/11.148)




Hello, Alex_Chernyshov!






Держи.

' ------------------------------------------------------------------------
' Visual Basic for MS-DOS Mouse Toolkit
'
' The Mouse Toolkit (MOUSE.BAS) provides mouse support
' for text-mode and graphics programs when Visual Basic
' forms are not showing. The Mouse Toolkit provides
' these procedures:
' MouseBorder - sets mouse movement boundaries.
' MouseDriver - checks for presence of mouse and
' provides access to mouse functions.
' MouseHide - hides mouse pointer.
' MouseInit - intializes mouse driver.
' MousePoll - get mouse pointer location and button
' status.
' MouseShow - displays mouse location.
' SetHigh - sets highest resolution video mode available.
' ScrSettings - gets current Basic screen mode and screen width.
'
' See the"Microsoft Mouse Programmer's Guide" (Microsoft Press) for
' extensive information on programming for the mouse in Basic and
' other languages.
'
' To use the Mouse ToolKit routines in your program,
' include MOUSE.BAS in your program and call the
' appropriate procedures. Note, if you use MOUSE.BAS
' in your program, you will also have to use VBDOS.LIB
' and VBDOS.QLB for the required CALL INTERRUPT support.
'
' A toolkit library (MOUSE.LIB) and Quick
' library (MOUSE.QLB) can be created from MOUSE.BAS
' as follows:
' BC mouse.bas /X;
' DEL mouse.lib
' LIB mouse.lib + mouse.obj + vbdos.lib;
' LINK /Q mouse.lib, mouse.qlb,,vbdosqlb.lib;
'
' MOUSE.COM or MOUSE.SYS must be loaded to access the
' mouse.
'
'
' Copyright (C) 1982-1992 Microsoft Corporation
'
' You have a royalty-free right to use, modify, reproduce
' and distribute the sample applications and toolkits provided with
' Visual Basic for MS-DOS (and/or any modified version)
' in any way you find useful, provided that you agree that
' Microsoft has no warranty, obligations or liability for
' any of the sample applications or toolkits.
' ------------------------------------------------------------------------

DEFINT A-Z

' Include files containing declarations for called procedures.
'$INCLUDE: 'MOUSE.BI'
'$INCLUDE: 'VBDOS.BI'
DIM CurrentPointer AS INTEGER
DIM SHARED Pointers(0 TO MaxPointer) AS GraphCur
DIM SHARED sMode AS INTEGER, sWidth AS INTEGER, sHeight AS INTEGER
DIM rIsDown AS INTEGER
DIM ourX AS INTEGER, ourY AS INTEGER

'--------------------------------------------------
' Sample usage of the mouse routines. This code is
' only executed if MOUSE.BAS is the start-up file.
' Parameter information for each mouse procedure
' appears in the header comments for the procedure.
' Note, to call mouse procedures, you should first
' hide all visible forms (SCREEN.HIDE) -- using the
' mouse procedures while forms are showing may
' yield unpredictable results.
'--------------------------------------------------

CLS

' Change to highest resolution graphics mode available.
' Note that the Mouse Toolkit works in text mode (SCREEN 0)
' as well as graphics modes.
SetHigh
LINE (10, 10)-(50, 50), 4, BF

' Check if mouse driver is installed.
CurrentPointer = 1
IF MouseInit = FALSE THEN END
InitPointers
MousePointer CurrentPointer

' Display mouse pointer.
MouseShow
MousePoll ourY, ourX, 0, 0
MouseMotion 0, 0

LOCATE 19, 1: PRINT "Press right mouse button to change cursor appearance "
LOCATE 20, 1: PRINT " or any key to end program."

DO WHILE INKEY$ = ""
' Get mouse location and button status.
MousePoll Row, Col, lButton, rButton
' Get mouse motion info
MouseMotion relX, relY
ourX = ourX + relX: ourY = ourY + relY

IF lButton THEN lState$ = "is" ELSE lState$ = "is not"
LOCATE 21, 1: PRINT "The left mouse button " + lState$ + " pressed. "
LOCATE 22, 1: PRINT "Mouse position: "; Col; ", "; Row; " "
LOCATE 23, 1: PRINT "Mouse position: "; ourX; ", "; ourY; " "
IF (rButton) AND (NOT rIsDown) THEN rIsDown = TRUE
IF (NOT rButton) AND (rIsDown) THEN
rIsDown = FALSE
CurrentPointer = CurrentPointer + 1

MousePointer CurrentPointer
END IF
LOOP


'Data for custom mouse pointers.
IDC_INVISIBLE:
DATA 255,255,255,255,255,255,255,255
DATA 255,255,255,255,255,255,255,255
DATA 255,255,255,255,255,255,255,255
DATA 255,255,255,255,255,255,255,255
DATA 0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0
IDC_ARROW:
DATA 255,63,255,31,255,15,255,7
DATA 255,3,255,1,255,0,127,0
DATA 63,0,31,0,255,1,255,16
DATA 255,48,127,248,127,248,127,252
DATA 0,0,0,64,0,96,0,112
DATA 0,120,0,124,0,126,0,127
DATA 128,127,0,124,0,108,0,70
DATA 0,6,0,3,0,3,0,0
DATA 0,0
IDC_APPSTART:
DATA 255,63,255,31,255,15,255,7
DATA 0,2,0,0,0,0,1,0
DATA 1,3,131,17,131,49,1,249
DATA 1,255,0,254,0,254,0,254
DATA 0,0,0,64,0,96,0,112
DATA 0,120,254,124,254,126,68,120
DATA 68,104,40,68,40,4,68,0
DATA 68,0,254,0,254,0,0,0
DATA 0,0
IDC_IBEAM:
DATA 143,248,7,240,15,248,63,254
DATA 63,254,63,254,63,254,63,254
DATA 63,254,63,254,63,254,63,254
DATA 63,254,15,248,7,240,143,248
DATA 0,0,112,7,128,0,128,0
DATA 128,0,128,0,128,0,128,0
DATA 128,0,128,0,128,0,128,0
DATA 128,0,128,0,112,7,0,0
DATA 8,10
IDC_WAIT:
DATA 7,192,7,192,7,192,7,192
DATA 15,224,15,224,31,240,63,248
DATA 63,248,31,240,15,224,15,224
DATA 7,192,7,192,7,192,7,192
DATA 0,0,240,31,16,16,240,31
DATA 32,8,32,9,64,4,128,2
DATA 128,2,64,4,32,9,32,8
DATA 240,31,16,16,240,31,0,0
DATA 7,8
IDC_SALL:
DATA 255,254,127,252,63,248,31,240
DATA 47,232,71,196,3,128,1,0
DATA 3,128,71,196,47,232,31,240
DATA 63,248,127,252,255,254,255,255
DATA 0,0,0,1,128,3,192,7
DATA 0,1,16,17,24,49,252,127
DATA 24,49,16,17,0,1,192,7
DATA 128,3,0,1,0,0,0,0
DATA 7,7
IDC_SNS:
DATA 255,254,127,252,63,248,31,240
DATA 31,240,127,252,127,252,127,252
DATA 127,252,127,252,31,240,31,240
DATA 63,248,127,252,255,254,255,255
DATA 0,0,0,1,128,3,192,7
DATA 0,1,0,1,0,1,0,1
DATA 0,1,0,1,0,1,192,7
DATA 128,3,0,1,0,0,0,0
DATA 7,7
IDC_SWE:
DATA 255,255,255,255,255,255,255,255
DATA 231,231,227,199,1,128,0,0
DATA 1,128,227,199,231,231,255,255
DATA 255,255,255,255,255,255,255,255
DATA 0,0,0,0,0,0,0,0
DATA 0,0,8,16,12,48,254,127
DATA 12,48,8,16,0,0,0,0
DATA 0,0,0,0,0,0,0,0
DATA 7,7
IDC_NESW:
DATA 128,255,128,255,192,255,224,255
DATA 192,255,136,255,28,255,63,254
DATA 127,252,255,56,255,17,255,3
DATA 255,7,255,3,255,1,255,1
DATA 0,0,62,0,30,0,14,0
DATA 22,0,34,0,64,0,128,0
DATA 0,1,0,2,0,68,0,104
DATA 0,112,0,120,0,124,0,0
DATA 8,7
IDC_NWSE:
DATA 255,1,255,1,255,3,255,7
DATA 255,3,255,17,255,56,127,252
DATA 63,254,28,255,136,255,192,255
DATA 224,255,192,255,128,255,128,255
DATA 0,0,0,124,0,120,0,112
DATA 0,104,0,68,0,2,0,1
DATA 128,0,64,0,34,0,22,0
DATA 14,0,30,0,62,0,0,0
DATA 7,7
'That's all folks!

SUB CustomPointer (Pointer AS GraphCur)
MouseHide
MouseDriver 9, Pointer.HotSpotX, Pointer.HotSpotY, VARPTR(Pointer.CurImage)
MouseShow
END SUB

SUB InitPointers ()
FOR i% = 0 TO MaxPointer
SELECT CASE i%
CASE 1: RESTORE IDC_ARROW
CASE 2: RESTORE IDC_APPSTART
CASE 3: RESTORE IDC_IBEAM
CASE 4: RESTORE IDC_WAIT
CASE 5: RESTORE IDC_SALL
CASE 6: RESTORE IDC_SNS
CASE 7: RESTORE IDC_SWE
CASE 8: RESTORE IDC_NESW
CASE 9: RESTORE IDC_NWSE
CASE 0: RESTORE IDC_INVISIBLE
END SELECT
FOR j% = 1 TO 64: READ Temp%
MID$(Pointers(i%).CurImage, j%, 1) = CHR$(Temp%): NEXT
READ Pointers(i%).HotSpotX, Pointers(i%).HotSpotY
NEXT
END SUB

' MouseBorder procedure.
'
' Sets vertical and horizontal boundaries for
' mouse pointer travel.
'
' Parameters:
' row1, row2 - begining and ending vertical
' boundaries.
' col1, col2 - beginning and ending horizontal
' boundaries.
'
' Row and column coordinates are determined by
' current screen mode and width -- returned by
' the ScrSettings procedure.
'
STATIC SUB MouseBorder (row1, col1, row2, col2)


SELECT CASE sMode
CASE 0 ' Text-mode coordinates
row1 = row1 - 1 * 8
col1 = col1 - 1 * 8
row2 = row2 - 1 * 8
col2 = col2 - 1 * 8
CASE 1, 7, 13 ' Graphic mode coordinates
col1 = col1 * 2
col2 = col2 * 2
CASE 2, 3, 4, 8, 9, 10, 11, 12
' No adjustment needed
END SELECT

MouseDriver 7, 0, col1, col2
MouseDriver 8, 0, row1, row2

END SUB

SUB MouseDeborder ()
DIM sRCol AS INTEGER, sBRow AS INTEGER
sRCol = sWidth
sBRow = sHeight
SELECT CASE sMode
CASE 0 ' Text-mode coordinates
sBRow = (sBRow - 1) * 8
sRCol = (sRCol - 1) * 8
CASE 1, 7, 13 ' Graphic mode coordinates
sRCol = sRCol * 2
CASE 2, 3, 4, 8, 9, 10, 11, 12
' No adjustment needed
END SELECT

MouseDriver 7, 0, 0, sRCol
MouseDriver 8, 0, 0, sBRow
END SUB

' MouseDriver procedure.
'
' Provides a Basic language interface to
' the mouse routines in MOUSE.COM or MOUSE.SYS.
'
' Parameters:
' m0 - mouse task to perform:
' 0 - initialize mouse routines.
' 1 - display mouse pointer.
' 2 - hide mouse pointer.
' 3 - poll mouse location and
' button status.
' 7 - set horizontal boundary for mouse
' travel.
' 8 - set vertical boundary for mouse
' travel.
'undocumented functions:
' 4 - set mouse location.
' 5 - get pressure info.
' 6 - get release info.
' 9 - set graphical pointer.
' 10 - set textmode pointer.
' 11 - get motion info.
' 12 - set custom event callback
' procedure.
' 15 - set mouse sensibility.
' 16 - set boundaries of region where
' mouse pointer is invisible.
' 19 - set mouse travel acceleration.
'
' m1, m2, - these vary for different mouse tasks.
' and m3 See MouseInit, MouseShow, MouseHide,
' MouseShow, MousePoll, and MouseBorder
' procedures for valid settings.
'
' The Mouse Toolkit provides access to the mouse routines
' listed above. For information on other mouse routines
' and other valid settings for m0, m1, m2, and m3, see
' the "Microsoft Mouse Programmer's Guide" (Microsoft
' Press).
'
STATIC SUB MouseDriver (m0, m1, m2, m3)

DIM regs AS RegTypeX

IF MouseChecked = FALSE THEN
DEF SEG = 0

MouseSegment& = 256& * PEEK(207) + PEEK(206)
MouseOffset& = 256& * PEEK(205) + PEEK(204)

DEF SEG = MouseSegment&

IF (MouseSegment& = 0 AND MouseOffset& = 0) OR PEEK(MouseOffset&) = 207 THEN
MousePresent = FALSE
MouseChecked = TRUE
DEF SEG
END IF
END IF

IF MousePresent = FALSE AND MouseChecked = TRUE THEN
EXIT SUB
END IF

' Calls interrupt 51 to invoke mouse functions in the MS Mouse Driver.

regs.ax = m0
regs.bx = m1
regs.cx = m2
regs.dx = m3
regs.es = VARSEG(MouseSegment&)
regs.ds = VARSEG(MouseSegment&)

INTERRUPTX 51, regs, regs

m0 = regs.ax
m1 = regs.bx
m2 = regs.cx
m3 = regs.dx

IF MouseChecked THEN EXIT SUB

' Check for successful mouse initialization

IF m0 AND NOT MouseChecked THEN
MousePresent = TRUE
DEF SEG
END IF

MouseChecked = TRUE

END SUB

' MouseHide procedure.
'
' Hides the mouse pointer.
'
SUB MouseHide ()

MouseDriver 2, 0, 0, 0

END SUB

' MouseInit procedure.
'
' Initializes the mouse driver.
'
FUNCTION MouseInit () AS INTEGER

MousePresent% = 0
MouseDriver MousePresent%, 0, 0, 0

IF MousePresent% = FALSE THEN
Action = MSGBOX("Mouse not present or mouse driver not installed. End program?", 4, "Error")
IF Action = 6 THEN
END
ELSE
MouseInit = FALSE
END IF
ELSE
MouseInit = TRUE
END IF
MouseDriver &HF, 0, 16, 16
ScrSettings
MouseDeborder
END FUNCTION

SUB MouseMotion (relX%, relY%)
STATIC lastX AS INTEGER, lastY AS INTEGER


'Everything is so simple!

MousePoll Y%, X%, 0, 0
relX% = X% - lastX%: lastX% = X%
relY% = Y% - lastY%: lastY% = Y%

END SUB

STATIC SUB MousePointer (Pointer AS INTEGER)
CustomPointer Pointers(Pointer)
END SUB

' MousePoll procedure.
'
' Gets the mouse pointer location and button
' status.
'
' Parameters:
' row - vertical location of mouse pointer.
' col - horizontal location of mouse pointer.
' lButton - status of left mouse button:
' 0 - not pressed.
' 1 - pressed.
' rButton - status of right mouse button:
' 0 - not pressed.
' 1 - pressed.
'
' The valid range for row and col are determined
' by the current screen mode and width returned
' by the ScrSettings procedure.
'
STATIC SUB MousePoll (Row, Col, lButton, rButton)

MouseDriver 3, button, Col, Row

SELECT CASE sMode
CASE 0 ' Text-mode coordinates
Row = Row / 8 + 1
Col = Col / 8 + 1
CASE 1, 7, 13 ' Graphic mode coordinates
Col = Col / 2
CASE 2, 3, 4, 8, 9, 10, 11, 12
' No adjustment needed.
END SELECT

IF button AND 1 THEN
lButton = TRUE
ELSE
lButton = FALSE
END IF

IF button AND 2 THEN
rButton = TRUE
ELSE
rButton = FALSE
END IF

END SUB

' MouseShow procedure.
'
' Displays mouse pointer.
'
SUB MouseShow ()

MouseDriver 1, 0, 0, 0

END SUB

SUB RetrieveScr (s_Mode AS INTEGER, s_Height AS INTEGER, s_Width AS INTEGER)
s_Mode = sMode
s_Height = sHeight
s_Width = sWidth
END SUB

' ScrSettings procedure.
'
' Gets the current Basic screen mode setting and width.
'
' Parameters:
' sMode - the current Basic screen mode. See the
' SCREEN statement for valid return values
' (0-13).
' sWidth - the current width of the display in pixels.
'
'
SUB ScrSettings ()

' =======================================================================
' Gets current Basic screen mode and width setting.
' =======================================================================

DIM regs AS RegType

regs.ax = &HF00

INTERRUPT &H10, regs, regs ' &H10 returns video
' information.

sWidth = (regs.ax AND &HFF00) \ 32 ' High byte of AX (AH).
sMode = regs.ax AND &HFF ' Low byte of AX (AL).

SELECT CASE sMode ' Map MS-DOS video mode
CASE 3 ' number to Basic screen
sMode = 0: sHeight = 25 ' modes.
sWidth = sWidth / 8
CASE 4
sMode = 1: sHeight = 200
CASE 6
sMode = 2: sHeight = 200
CASE 13
sMode = 7: sHeight = 200
CASE 14
sMode = 8: sHeight = 200
CASE 15
sMode = 10: sHeight = 350
CASE 16
sMode = 9: sHeight = 350
CASE 17
sMode = 11: sHeight = 480
CASE 18
sMode = 12: sHeight = 480
CASE 19
sMode = 13: sHeight = 200
CASE ELSE
sMode = 3: sHeight = 348
END SELECT


END SUB

' SetHigh procedure.
'
' Sets the highest-resolution graphics screen mode
' that is available for the current hardware.
'
SUB SetHigh ()

ON LOCAL ERROR RESUME NEXT

' Step through video modes (12-0) until
' one works.

FOR Mode = 12 TO 0 STEP -1
SCREEN Mode
IF ERR = 0 THEN EXIT SUB
NEXT Mode

END SUB
With best regards, A. Skrobov. E-mail: tyomitch [@] r66.ru
--
* Origin: Talk.Mail.Ru (2:5020/400)








Dim x As Form

Private Sub main()
Set x = Form1
x.Show
End Sub



* Origin: Attackie Interactive (2:5045/44.13)


Привет, Genrih!

06 Nov 03 21:41, Genrih Rudenok wrote to Nick Gorinov:











этот алгоритм только выглядит быстрым, на самом деле таковым не является.






вот тут операция возведения в степень. сказать, что она тормозит - это ничего
не сказать.


а вот тут мы переписываем в памяти целую строку. У меня такое чуство, что
реализовано это в компиляторе именно так. Гораздо лучше было бы заполнять строку
слева направо.






При реализации предложенного мной алгоритма можно в цикле обойтись операциями
сдвига и вычитания.



1. твой алгоритм менее оптимален по времени выполнения, чем предложенный мной.
2. VB - не совсем тот язык, при написании программ на котором стоит думать о
времени выполнения.
3. размерность задачи такова, что не имеет значения, сколько она будет
решаться: 10 или 20 милисекунд.

моя рекомендация: подписаться на ru.alhorithms, ru.acm и ознакомиться еще с
несколькоми языками програмирования.

С уважением, Nick!
np: кулеры, винты, уличный шум, etc.

* Origin: Ловись коннект большой и маленький! (2:5038/15.1)


Здравствуйте

можно ли (как) руками зарегистрить в системе (98) msado20.tlb
(установка визардом не хочет делать сама по причине
failed to register :)
regsvr32 с .tlb работать отказывается

Заранее спасибо


* Origin: Belinvestbank Vitebsk (2:454/2.44)


г=[¦]========================[ Hello All! ]=======----------------

Hадо запустить DOS-приложение и получить его стандартный вывод вместе с кодом завершения.

Если использовать

, то код завершения программы мы получаем, а вывод в файл не перенаправляется.

Если написать

(или создать соответствующий BAT файл), то ситауция прямо противоположная: вывод направляется в указанный файл, но код завершения всегда равен 0.

Пытался написать вариант с CreateProcess() из API, подсунув в структуру STARTUP_INFO хелдл открытого мной файла. Hо в него ничего не записывается :-(
У кого-нибудь есть работающий пример?

L=[ Andrew Usachov ]===============[ 07 Nov 03, 22:32 ]==------
* Origin: U$A station (2:5100/87)





message news:1067983965 [@] p115.f25.n452.z2.FIDOnet.ftn...





двоичное



Вот мой вариант. Hа мой взгляд, быстрее и правильнее использовать таблицу,
чем возиться с каждым битом. Еще не надо забывать про отрицательные числа.

Public Function LongToBinString(ByVal lVal As Long) As String
Dim TempLong As Long, TempStr As String, _
bNegative As Boolean, i As Integer
bNegative = lVal < 0&
TempLong = lVal And &H7FFFFFFF
For i = 0 To 7
Select Case TempLong And &HF&
Case &H0&
TempStr = "0000"
Case &H1&
TempStr = "0001"
Case &H2&
TempStr = "0010"
Case &H3&
TempStr = "0011"
Case &H4&
TempStr = "0100"
Case &H5&
TempStr = "0101"
Case &H6&
TempStr = "0110"
Case &H7&
TempStr = "0111"
Case &H8&
TempStr = "1000"
Case &H9&
TempStr = "1001"
Case &HA&
TempStr = "1010"
Case &HB&
TempStr = "1011"
Case &HC&
TempStr = "1100"
Case &HD&
TempStr = "1101"
Case &HE&
TempStr = "1110"
Case &HF&
TempStr = "1111"
End Select
TempLong = TempLong \ &H10&
LongToBinString = TempStr & LongToBinString
Next
If bNegative Then Mid$(LongToBinString, 1&, 1&) = "1"
End Function

Public Function HexToBinString(ByVal xVal As String) As String
Dim i As Integer, TempStr As String
For i = 1& To Len(xVal)
Select Case UCase$(Mid$(xVal, i, 1))
Case "0"
TempStr = "0000"
Case "1"
TempStr = "0001"
Case "2"
TempStr = "0010"
Case "3"
TempStr = "0011"
Case "4"
TempStr = "0100"
Case "5"
TempStr = "0101"
Case "6"
TempStr = "0110"
Case "7"
TempStr = "0111"
Case "8"
TempStr = "1000"
Case "9"
TempStr = "1001"
Case "A"
TempStr = "1010"
Case "B"
TempStr = "1011"
Case "C"
TempStr = "1100"
Case "D"
TempStr = "1101"
Case "E"
TempStr = "1110"
Case "F"
TempStr = "1111"
End Select
HexToBinString = HexToBinString & TempStr
Next
End Function

Public Function AnyToBinString(vVal As Variant) As String
AnyToBinString = HexToBinString(Hex$(vVal))
End Function

Public Function BinStringToLong(sBin As String) As Long
Dim TempStr As String, i As Integer, j As Long, TempLng As Long
i = 32 - Len(sBin)
Select Case i
Case Is = 0
TempStr = sBin

TempStr = String$(i, "0") & sBin
Case Is < 0
Err.Raise vbObjectError + 1001&, , "Too long Binary string"
End Select
j = &H10000000
For i = 0 To 7
Select Case Mid$(TempStr, i * 4& + 1&, 4&)
Case "0000"
TempLng = &H0&
Case "0001"
TempLng = &H1&
Case "0010"
TempLng = &H2&
Case "0011"
TempLng = &H3&
Case "0100"
TempLng = &H4&
Case "0101"
TempLng = &H5&
Case "0110"
TempLng = &H6&
Case "0111"
TempLng = &H7&
Case "1000"
TempLng = &H8&
Case "1001"
TempLng = &H9&
Case "1010"
TempLng = &HA&
Case "1011"
TempLng = &HB&
Case "1100"
TempLng = &HC&
Case "1101"
TempLng = &HD&
Case "1110"
TempLng = &HE&
Case "1111"
TempLng = &HF&
End Select
If i Or (TempLng <= &H7&) Then
BinStringToLong = BinStringToLong Or j * TempLng
Else ' Negative Long
BinStringToLong = (BinStringToLong Or j * (TempLng And &H7&)) Or
&H80000000
End If
j = j \ &H10&
Next
End Function

Public Function BinStringToHex(sBin As String) As String
Dim TempStr As String, i As Integer, HexDigit As String
i = Len(sBin)
i = i - (i \ 4) * 4
If i Then
i = 4 - i
TempStr = String$(i, "0") & sBin
Else
TempStr = sBin
End If
For i = 0 To Len(TempStr) \ 4& - 1&
Select Case Mid$(TempStr, i * 4& + 1&, 4&)
Case "0000"
HexDigit = "0"
Case "0001"
HexDigit = "1"
Case "0010"
HexDigit = "2"
Case "0011"
HexDigit = "3"
Case "0100"
HexDigit = "4"
Case "0101"
HexDigit = "5"
Case "0110"
HexDigit = "6"
Case "0111"
HexDigit = "7"
Case "1000"
HexDigit = "8"
Case "1001"
HexDigit = "9"
Case "1010"
HexDigit = "A"
Case "1011"
HexDigit = "B"
Case "1100"
HexDigit = "C"
Case "1101"
HexDigit = "D"
Case "1110"
HexDigit = "E"
Case "1111"
HexDigit = "F"
End Select
BinStringToHex = BinStringToHex & HexDigit
Next
End Function
--
Сергей Мерзликин
http://www.smsoft.ru/ru/
* Origin: Sovintel (2:5020/400)