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

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

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

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

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


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)


Свойства

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еть здесь gfe.h10.ru/ Hо сpазу пpедупpеждаю, что пока идет беттатестинг! Потому сильно ногами не бейте. :-)))

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

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


IRDA - VB6

From: "Max Lesnik"

Всем привет!

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

--
С наилучшими пожеланиями, Max Lesnik.



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


Re[2]: Пароль на БД

>>> DAO, ADO, RDO? В смысле интересует больше строка в программе, где нужно
S>> указать Пароль в ADO указывается в ConnectionString,
AP> Как ADO указать я нашел, теперь интересует DAO.
Там все то же. Просто св-во располагается в другом объкте.
S>> но ты бы лучше сказал, какая база?
AP> MS Access
Кстати, а в случае DAO эта инфа второстепенна.

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


Более простой способ создания консольных приложений

From: "A. Skrobov"

Hi All,

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

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


HEX in VB

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>> Вот тебе и функция. ;)
AA> Hу тогда вот тебе ишшо и мой вариант
Ты мне предлагаешь соревнование? :)

* Origin: 1134 (2:5045/44.13)


HEX in VB

AA> Enum OutTypes
AA> tpDecimal = 1
AA> tpHex
AA> tpOctal
AA> End Enum

debug.print tpDecimal & tpHex & tpOctal

123

AA> Err.Raise 5, , "Invalid OutType value specified!" & vbCr &
AA> "Valid values are 0 to 2"
Hю! ;)


* Origin: 1134 (2:5045/44.13)


Re: HEX in VB

From: Alexander Asyabrik

Привет, Roman.

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


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

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

It's just an alternative!


--
С уважением, Alexander
4:18:38 PM



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


Re: HEX in VB

From: Alexander Asyabrik

Привет, Roman.

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

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!" & vbCr &
RY> AA> "Valid values are 0 to 2"
RY> Hю! ;)

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)



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




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