Обсуждение программирования на 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 = " 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)

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