Visual Basic 6.0 - HEX in VB

Привет, Roman.

Вы, было дело, писали 8 мая 2004 г., 7:06:
















Hу тогда вот тебе ишшо и мой вариант

============8<=================

Option Explicit

Enum OutTypes
tpDecimal = 1
tpHex
tpOctal
End Enum

Function AddAnyValue(Value1, Value2, Optional OutType As OutTypes = tpDecimal) As String
Select Case OutType
Case tpDecimal
AddAnyValue = CStr(Val(Value1) + Val(Value2))
Case tpHex
AddAnyValue = "&H" & Hex(Val(Value1) + Val(Value2))
Case tpOctal
AddAnyValue = "&O" & Oct(Val(Value1) + Val(Value2))
Case Else
Err.Raise 5, , "Invalid OutType value specified!" & vbCr & "Valid values are 0 to 2"
End Select
End Function

' Usage:

Private Sub Command1_Click()
Debug.Print AddAnyValue(123, &O456)
Debug.Print AddAnyValue("123", &O456, tpHex)
Debug.Print AddAnyValue(123, "&H456", tpOctal)
Debug.Print AddAnyValue("123", "&O456", 7)
End Sub




Value1 и Value2 'кушают' как числа, так и строковые выражения, которые
могут быть рассмотрены как числа.
--
С уважением, Alexander
2:42:53 PM
* Origin: Talk.Mail.Ru (2:5020/400)




VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmHTTP
BorderStyle = 3 'Fixed Dialog
Caption = "HTTP server"
ClientHeight = 30
ClientLeft = 45
ClientTop = 330
ClientWidth = 1365
Icon = "HTTP.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 30
ScaleWidth = 1365
StartUpPosition = 3 'Windows Default
Begin MSWinsockLib.Winsock HTTP
Left = 0
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
LocalPort = 80
End
Begin VB.Timer tmrRedirect
Enabled = 0 'False
Interval = 50
Left = 480
Top = 0
End
End
Attribute VB_Name = "frmHTTP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const wwwroot As String = "c:\wwwroot"

Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As Long
lpDesktop As Long
lpTitle As Long
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Byte
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As
Long
Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long,
phWritePipe As Long, lpPipeAttributes As SECURITY_ATTRIBUTES, ByVal nSize As
Long) As Long
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA"
(ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal
bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As
Long, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO,
lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function DuplicateHandle Lib "kernel32" (ByVal
hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal
hTargetProcessHandle As Long, lpTargetHandle As Long, ByVal dwDesiredAccess As
Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA"
(ByVal dwFlags As Long, ByVal lpSource As String, ByVal dwMessageId As Long,
ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long,
ByVal Arguments As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function PeekNamedPipe Lib "kernel32" (ByVal hNamedPipe As
Long, ByVal lpBuffer As String, ByVal nBufferSize As Long, lpBytesRead As
Long, lpTotalBytesAvail As Long, lpBytesLeftThisMessage As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal
lpBuffer As String, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As
Long, ByVal lpOverlapped As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As
Long, ByVal uExitCode As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal
lpBuffer As String, ByVal nNumberOfBytesToWrite As Long,
lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Const DUPLICATE_SAME_ACCESS As Long = 2&
Private Const ERROR_BROKEN_PIPE As Long = 109&
Private Const ERROR_NO_DATA As Long = 232&
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000&
Private Const STARTF_USESHOWWINDOW As Long = &H1
Private Const STARTF_USESTDHANDLES As Long = &H100&
Dim GottenData As String, Url As String, Method As String
Dim hShell As Long, hOutputRead As Long, hInputWrite As Long

Private Sub Form_Load()
HTTP.Listen
End Sub

Private Sub Form_Unload(Cancel As Integer)
Kill
End Sub

Private Sub HTTP_Close()
Kill
End Sub

Private Sub HTTP_ConnectionRequest(ByVal requestID As Long)
HTTP.Close
HTTP.Accept requestID
End Sub

Private Sub HTTP_DataArrival(ByVal bytesTotal As Long)
Dim Data As String

HTTP.GetData Data
GottenData = GottenData & Data
Analyze GottenData
End Sub

Private Sub Analyze(Data As String)
Dim Lines As Variant, Request As Variant, Pos As Long, i As Long, InParms As
Boolean
Data = Replace(Data, vbCr, vbNullString)
Lines = Split(Data, vbLf)
If UBound(Lines) = -1 Then Exit Sub
Request = Split(Lines(0))
If UBound(Request) = -1 Then Method = "INVALID" Else Method =
UCase(Request(0))
Select Case Method
Case "GET": Url = Unescape(CStr(Request(1))): If Right$(Url, 1) = "/" Then
Url = Url & "index.htm"
Pos = Len(Lines(0)) + 1
For i = 1 To UBound(Lines)
Pos = Pos + Len(Lines(i)) + 1
If Len(Lines(i)) = 0 Then
Data = Mid$(Data, Pos + 1)
HTTP.SendData "HTTP/1.1 200 OK" & vbCrLf & vbCrLf &
Content(wwwroot + Replace(Url, "/", "\")) & vbCrLf & vbCrLf
DoEvents
HTTP.Close: HTTP.Listen
Exit Sub
End If
Next
Case "POST": Url = Unescape(CStr(Request(1))): If Right$(Url, 1) = "/"
Then Url = Url & "index.htm"
Pos = Len(Lines(0)) + 1: InParms = False
For i = 1 To UBound(Lines)
Pos = Pos + Len(Lines(i)) + 1
If Len(Lines(i)) = 0 Then
If InParms Then
Exit For
Else
Request = vbNullString
InParms = True
End If
ElseIf InParms Then
Request = Request & Lines(i) & vbCrLf
End If
Next
If InParms Then
Data = Mid$(Data, Pos + 1)
HTTP.SendData "HTTP/1.1 200 OK" & vbCrLf & vbCrLf
Url = wwwroot + Replace(Url, "/", "\")
Start
Redirect Unescape(CStr(Request)) & chr$(26)
Exit Sub
End If
Case Else:
Pos = InStr(Data, vbLf)
If Pos = 0 Then Data = vbNullString Else Data = Mid$(Data, Pos + 1)

End Select
End Sub


Private Sub Start()
Dim hOutputReadTmp As Long, hOutputWrite As Long
Dim hInputWriteTmp As Long, hInputRead As Long
Dim hErrorWrite As Long
Dim sa As SECURITY_ATTRIBUTES
Dim pi As PROCESS_INFORMATION
Dim si As STARTUPINFO
With sa
.nLength = Len(sa)
.lpSecurityDescriptor = 0
.bInheritHandle = 1
End With

If CreatePipe(hOutputReadTmp, hOutputWrite, sa, 0) = 0 Then DisplayError
("CreatePipe")
' Necessary in case the child application closes one of its std output
handles.
If DuplicateHandle(GetCurrentProcess, hOutputWrite, GetCurrentProcess,
hErrorWrite, 0, 1, DUPLICATE_SAME_ACCESS) = 0 Then DisplayError
("DuplicateHandle")

If CreatePipe(hInputRead, hInputWriteTmp, sa, 0) = 0 Then DisplayError
("CreatePipe")

' Otherwise, the child inherits the handles and, as a result, non-closeable
handles are created.
If DuplicateHandle(GetCurrentProcess, hOutputReadTmp, GetCurrentProcess,
hOutputRead, 0, 0, DUPLICATE_SAME_ACCESS) = 0 Then DisplayError
("DupliateHandle")
If DuplicateHandle(GetCurrentProcess, hInputWriteTmp, GetCurrentProcess,
hInputWrite, 0, 0, DUPLICATE_SAME_ACCESS) = 0 Then DisplayError
("DupliateHandle")
If CloseHandle(hOutputReadTmp) = 0 Then DisplayError ("CloseHandle")
If CloseHandle(hInputWriteTmp) = 0 Then DisplayError ("CloseHandle")

With si
.cb = Len(si)
.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
.hStdOutput = hOutputWrite
.hStdInput = hInputRead
.hStdError = hErrorWrite
.wShowWindow = vbHide
End With
If CreateProcess(vbNullString, Url, 0, 0, 1, 0, 0, vbNullString, si, pi) =
0 Then DisplayError ("CreateProcess")
hShell = pi.hProcess
If CloseHandle(pi.hThread) = 0 Then DisplayError ("CloseHandle")

' You need to make sure that no handles to the write end of the output pipe
are maintained in this process
' or else the pipe will not close when the child process exits and the
ReadFile will hang.
If CloseHandle(hOutputWrite) = 0 Then DisplayError ("CloseHandle")
If CloseHandle(hInputRead) = 0 Then DisplayError ("CloseHandle")
If CloseHandle(hErrorWrite) = 0 Then DisplayError ("CloseHandle")

tmrRedirect.Enabled = True
End Sub

Private Sub Kill()
tmrRedirect.Enabled = False

If HTTP.State = sckConnected Then
HTTP.SendData vbCrLf & vbCrLf
DoEvents
End If
TerminateProcess hShell, 0
If CloseHandle(hShell) = 0 Then DisplayError ("CloseHandle")
If CloseHandle(hOutputRead) = 0 Then DisplayError ("CloseHandle")
If CloseHandle(hInputWrite) = 0 Then DisplayError ("CloseHandle")
End If
HTTP.Close
HTTP.Listen
End Sub

Private Sub Redirect(Data As String)
Dim nBytesWrote As Long
If WriteFile(hInputWrite, Data, Len(Data), nBytesWrote, 0) = 0 Then
If Err.LastDllError = ERROR_BROKEN_PIPE Then
' Child has closed
Kill
Else
DisplayError ("WriteFile")
End If
End If
End Sub

Private Sub tmrRedirect_Timer()
Dim lpBuffer As String
Dim nBytesRead As Long
If PeekNamedPipe(hOutputRead, vbNullString, 0, 0, nBytesRead, 0) = 0 Then
If Err.LastDllError = ERROR_BROKEN_PIPE Then
' Child has closed
Kill
Else
DisplayError ("PeekNamedPipe")
End If

lpBuffer = Space(nBytesRead)
If ReadFile(hOutputRead, lpBuffer, Len(lpBuffer), nBytesRead, 0) = 0
Then
DisplayError ("ReadFile")
Else

End If
End If
End Sub


Private Sub DisplayError(pszAPI As String)
Dim szPrintBuffer As String * 512
Call FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, Err.LastDllError, 0,
szPrintBuffer, Len(szPrintBuffer), 0)
MsgBox "Error in calling " & pszAPI & vbCrLf & "Code: " & Err.LastDllError
& vbCrLf & "Message: " & szPrintBuffer
End
End Sub

Private Function Content(Name As String) As String
Dim FileNum As Integer: FileNum = FreeFile
If Dir(Name) = "" Then GoTo Send404
Open Name For Binary As FileNum
Content = Input(LOF(FileNum), FileNum)
Close FileNum
Exit Function



End Function

Private Function Unescape(Data As String) As String
Dim chr As String, Result As String, code As Byte

chr = Left$(Data, 1): Data = Mid$(Data, 2)
If chr = "%" Then
chr = Left$(Data, 2): Data = Mid$(Data, 3)
code = Val("&H" & chr)

Result = Result & VBA.chr$(code)
Else
Result = Result & "%" & chr
End If
Else
Result = Result & chr
End If
Wend
Unescape = Result
End Function

пример обработчика POST:
int main()
{char c;while(!feof(stdin)){fread(&c,1,1,stdin);printf("%c",c);}return 0;}

* Origin: FidoNet Online - http://www.fido-online.com (2:5020/175.2)


Hi, All!

Hаpод, посоветуйте, что делать! Ситуация такая: Благодаpя такому вот скотству

Fast System Calls
One other performance improvement is in the area of system call
dispatching. Those familiar with the internals of Windows NT associate the
assembly language instruction "INT 0x2E" with system calls, since it's with
this instruction that Windows NT and Windows 2000 transition from user mode to
the kernel-mode system call interface where the native API is implemented. Many
Win32 APIs invoke system calls. Windows XP uses the _SYSENTER/SYSEXIT_ pair of
instructions to transition into and out of kernel-mode for system calls if it's
running on a Pentium II or higher. This instruction sequence requires fewer
clock cycles to execute, improving the speed of system calls.

пpогpамма, над котоpой мы тут коллективом pаботаем (я больше тестиногом занимаюсь, честно говоpя :-))) ) запускается только в pежиме совместимости с 2000 под ХР. Задача -- как сделать пpи инсталляции, чтобы исполнимый файл уже имел соответствующий паpаметp в своих свойствах? Возможно ли это вообще?

Best Regards, All!

//Vlad

P.S.: Кому интеpесно, пpогpамма -- pедактоp FIDO почты на эхотаге. Смотpеть здесь http://gfe.h10.ru/ Hо сpазу пpедупpеждаю, что пока идет беттатестинг! Потому сильно ногами не бейте. :-)))

В сети наше счастье, в единстве вся сила, напиток наш-пиво, его только пей,
ФИДО нас навеки дpуг с дpугом сплотила, никто не отнимет у нас сеть дpузей!

* Origin: Interactiv! (2:461/863)




Всем привет!

А вот пробовал ли кто управлять IRDA контроллером из VB6? Может, есть
ActiveX какие?

--
С наилучшими пожеланиями, Max Lesnik.
* Origin: Talk.Mail.Ru (2:5020/400)





Там все то же. Просто св-во располагается в другом объкте.


Кстати, а в случае DAO эта инфа второстепенна.

* Origin: WinPoint 95 (2:5030/1450.6)




Hi All,

Почему-то укрепилось поверье, что для того, чтобы работать с консолью из-под
VB, нужно много всякой возни с ReadConsole/WriteConsole и другими
разношёрстными API. Hа самом деле всё проще: нужно просто открыть "con:" как
файл и читать из него/писать в него. Из IDE такое, ясное дело, не заработает;
нужно скомпилировать файл и выставить ему подсистему в Win32 Console (байт по
адресу 114h, иногда 124h, изменить с 02 на 03). Получится полноценное
консольное приложение вовсе безо всякого API! Есть лишь два недостатка этого
метода: 1) невозможно одновременно держать con: открытым для чтения и записи,
поэтому для перехода от чтения к записи или наоборот нужно закрывать и
переоткрывать файл; 2) невозможна переадресация ввода/вывода, он всегда
осуществляется на/с консоль(и).

* Origin: FidoNet Online - http://www.fido-online.com (2:5020/175.2)















Ты мне предлагаешь соревнование? :)

* Origin: 1134 (2:5045/44.13)








debug.print tpDecimal & tpHex & tpOctal

123



Hю! ;)


* Origin: 1134 (2:5045/44.13)




Привет, Roman.

Вы, было дело, писали 9 мая 2004 г., 8:36:




Делать мне боле неча :-)

It's just an alternative!


--
С уважением, Alexander
4:18:38 PM
* Origin: Talk.Mail.Ru (2:5020/400)




Привет, Roman.

Вы, было дело, писали 9 мая 2004 г., 8:41:











Hе думаешь же ты, что это код из какого-нибудь серьезного проекта?
Писалось сходу, на коленке и предполагался сначала Choose(), потому и
приписал 1, а с Select Case, конечно, надо

"Valid values are 1 to 3"


Hевелика ошибка imho. Для того он и Enum, чтобы писать _правильные_
значения параметров. А вообще функция - полное дерьмо и вряд ли
кому-нибудь и когда-нибудь понадобиться. Так, для демонстрации
нескольких удобных вещей: Enum, Optional аргумент, использование
Variant для автоматического преобразования типов, Err.Raise.
Подозреваю, что для того, кто еще не знает как с Hex работать, это
тоже будет не лишним...


--
С уважением, Alexander
4:20:28 PM
* Origin: Talk.Mail.Ru (2:5020/400)