Техническая поддержка :

Современные решения

для защиты Windows программ

и восстановления исходного кода

Обсуждение программирования на Visual Basic в конференции ru.visual.basic


RVB.FAQ

RY*>> ps. Сорри за оффтопик. Это мое последнее сообщение по этой теме.
RY*>> Просто соскучился. :))
AS> Соскучился? Звони на русское радио(с)
Сейчас читаю архивы эх. Пользуясь случаем, хочу публично извиниться перед тобой за свое неподобающее поведение в этой эхе в феврале 2002 года.


* Origin: 1134 (2:5045/44.13)


RichEdit с подсветкой синтаксиса

From: "Andrew Shelkovenko"

Hello, All!

Пример RichEdit-а с подсветкой синтаксиса.
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
spiff.tripnet.se/~iczelion/tut35.html


With best regards, Andrew Shelkovenko.
- RQ Search and Replace
- Rapid-Q documentation
Project


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


Re: HEX in VB

From: Alexander Asyabrik

Привет, Roman.

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


RY> function AddHexValue(hex1 as string, hex2 as string) as string
RY> if left$(hex1,2)<>"&H" then hex1 = "&H" + hex1
RY> if left$(hex1,1)<>"&" then hex1 = "&" + hex1
RY> if left$(hex2,2)<>"&H" then hex2 = "&H" + hex2
RY> if left$(hex2,1)<>"&" then hex2 = "&" + hex2
RY> dim h1 as long, h2 as long, hv as long
RY> h1 = clng(h1)
RY> h2 = clng(h2)
RY> hv = h1 + h2
RY> addhexvalue = hex$(h2)
RY> end sub

RY> Вот тебе и функция. ;)

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


===============>8================

Value1 и Value2 'кушают' как числа, так и строковые выражения, которые
могут быть рассмотрены как числа.



--
С уважением, Alexander
2:42:53 PM



* Origin: Talk.Mail.Ru (2:5020/400)


Кому тут был нужен простой HTTP-сервер, с обработкой GET и POST?

From: "A. Skrobov"

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
If HTTP.State <> sckConnected Then Exit Sub
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)
If Len(Data) > 0 Then Analyze Data
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 hShell <> 0 Then
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
ElseIf nBytesRead > 0 Then
lpBuffer = Space(nBytesRead)
If ReadFile(hOutputRead, lpBuffer, Len(lpBuffer), nBytesRead, 0) = 0
Then
DisplayError ("ReadFile")
Else
If nBytesRead > 0 Then HTTP.SendData Left(lpBuffer, nBytesRead)
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
Send404: Content = "404 - Not</font><br> <font color=#B00000>Found

The document you requested wasn't found at the
server

"
End Function

Private Function Unescape(Data As String) As String
Dim chr As String, Result As String, code As Byte
While Len(Data) > 0
chr = Left$(Data, 1): Data = Mid$(Data, 2)
If chr = "%" Then
chr = Left$(Data, 2): Data = Mid$(Data, 3)
code = Val("&H" & chr)
If code > 31 Then
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 (2:5020/175.2)


Re: Работа функций Win32Api под XP

From: Mike

Alexander Asyabrik wrote:
> VK> "Alexander Asyabrik" сообщил/сообщила в новостях
> VK> следующее: news:5219520062.20040421163544 [@] xxxx.xxxx.xxx...
> Поубывау бы!!! Убери немедленно эти цитаты, от спама житья же просто нет!
> PS Еще раз прошу - не цитируй большое мое е-мыло!

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

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

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


Re: HEX in VB

Пpиснилось мне как-то 08 мая 04, что Alexander Trishin пpиходил к Albert
Einstein, и говоpил ему о Re: HEX in VB
AT> Уж даже не знаю как еще подсказать. Может стаpшие товаpищи помогут :)
Да не, спасибо, все уже понял. Благодаpю.

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


Re: Работа функций Win32Api под XP

From: Alexander Asyabrik

Привет, Mike.

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


>> PS Еще раз прошу - не цитируй большое мое е-мыло!

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

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

И, кроме того, какое все это имеет отношение к теме?



--
С уважением, Alexander
10:46:24 PM



* Origin: Talk.Mail.Ru (2:5020/400)


Кому тут был нужен простой HTTP-сервер, с обработкой GET и POST?

Hello A..

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

AS> Select Case Method
AS> Case "GET": Url = Unescape(CStr(Request(1))): If Right$(Url, 1) =
AS> "/"
AS> Then Url = Url & "index.htm"
AS> Pos = Len(Lines(0)) + 1
AS> For i = 1 To UBound(Lines)
AS> Pos = Pos + Len(Lines(i)) + 1
AS> If Len(Lines(i)) = 0 Then
AS> Data = Mid$(Data, Pos + 1)
AS> HTTP.SendData "HTTP/1.1 200 OK" & vbCrLf & vbCrLf &
AS> Content(wwwroot + Replace(Url, "/", "\")) & vbCrLf & vbCrLf
AS> DoEvents
AS> HTTP.Close: HTTP.Listen
AS> Exit Sub
AS> End If
AS> Next

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

Anton

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


Кому тут был нужен простой HTTP-сервер, с обработкой GET и POST?

From: "A. Skrobov"

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

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

* Origin: FidoNet Online (2:5020/175.2)


HEX in VB

RY> AA>> Enum OutTypes
RY> AA>> tpDecimal = 1
RY> AA>> tpHex
RY> AA>> tpOctal
RY> AA>> End Enum
RY> AA>> Err.Raise 5, , "Invalid OutType value specified!" &
RY> AA>> vbCr & "Valid values are 0 to 2"
RY>> Hю! ;)
AA> Hе думаешь же ты, что это код из какого-нибудь серьезного
AA> проекта? Писалось сходу, на коленке и предполагался сначала Choose(),
AA> потому и приписал 1, а с Select Case, конечно, надо
AA> "Valid values are 1 to 3"
Да я знаю, просто моя внимательность на этот раз была выше твоей. ;)


* Origin: 1134 (2:5045/44.13)



Назад Содержание Вперед




Главная     Программы     Статьи     Разное     Форум     Контакты