Visual Basic 6.0 - RVB.FAQ

Сейчас читаю архивы эх. Пользуясь случаем, хочу публично извиниться перед тобой за свое неподобающее поведение в этой эхе в феврале 2002 года.


* Origin: 1134 (2:5045/44.13)




Hello, All!

Пример RichEdit-а с подсветкой синтаксиса.
http://groups.yahoo.com/group/Rapid-Q/files/HLEditor.zip
Только для примера.
1. Hе быстро, но уже терпимо.
2. Парсер не вполне корректный.
3. Привязка цветов к ключевым словам не доделана.

Hаписан на Rapid-Q BASIC (очень близко к VB).

parser based on RQB2HTML - Rapid-Q BASIC source code to HTML converter by
William Yu.
Syntax hilight based on example from Iczelion's Win32 Assembly Tutorial part
35
http://spiff.tripnet.se/~iczelion/tut35.html


With best regards, Andrew Shelkovenko.


Project


* Origin: Demos online service (2:5020/400)




Привет, 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)




Alexander Asyabrik wrote:





Это глупо. Спам-роботы в первую очередь сканируют поле From.

--
Best regards
(M)ike
При ответе на e-mail убрать из адреса NOS

* Origin: Best antimagic/antiUFO cure: http://skeptik.net (2:5020/400)


Пpиснилось мне как-то 08 мая 04, что Alexander Trishin пpиходил к Albert
Einstein, и говоpил ему о Re: HEX in VB

Да не, спасибо, все уже понял. Благодаpю.

С наилучшими пожеланиями,
Einstein (aka Victor V.)
(mailto: enstainATyandexDOTru, URL: www.enstain.da.ru)
Winamp не вещает :(
* Origin: Imagination is more important than knoweledge! (2:4624/8.204)




Привет, Mike.

Вы, было дело, писали 10 мая 2004 г., 19:21:






Если у тебя хватило ума написать mikeNOS [@] skeptik.net вместо
mike [@] skeptik.net это еще не основание называть кого-либо глупцом,
особенно если почтовый сервер его провайдера не позволяет написать
лабуду в это поле.

И, кроме того, какое все это имеет отношение к теме?
--
С уважением, Alexander
10:46:24 PM
* Origin: Talk.Mail.Ru (2:5020/400)


Hello A..

08 May 04 19:30, you wrote to all:


















Я может навскидку чего-то не понял, но как мне кажется ты увлекся внешней
стороной дела, забыв собственно о протоколе HTTP. это я к тому, что выдавать
всегда безусловно "200 OK" неверно. 404 - это не только густой мех, тьфу, то
есть html-текст, но и полезное сало.... но может я чего и не понял.
а цель такого проекта? да еще на виндах, где есть очень даже приличный IIS?

Anton

* Origin: -== Sibkot Mail Station ==- (2:5000/130.84)




Tue May 11 2004 09:56, Anton Lobastoff wrote to A. Skrobov:








Либо ты не прочитал сабж, либо не относишься к нему. Кому-то был нужен именно
такой сервер, где главное - не "кошерность", а компактность.
И там, кстати, поддержка GET вообще была вторична.
Я уж не говорю, что это слегка подкрученный Telnet-сервер, а вовсе не
изначально разрабатываемый как HTTP. И уж совсем не утверждаю, что кто-то им
будет пользоваться "профессионально", размещая под ним настоящие сайты.

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














Да я знаю, просто моя внимательность на этот раз была выше твоей. ;)


* Origin: 1134 (2:5045/44.13)