Quantcast
Channel: VBForums - CodeBank - Visual Basic 6 and earlier
Viewing all 1536 articles
Browse latest View live
↧

[VB6] FYI: a better `Property Timer As Single`

January 29, 2015, 10:24 am
$
0
0
`Timer` global property comes handy for measuring elapsed time or for logging time-stamps. It basically returns number of seconds since midnight with 2 digits precision.

Usually to measure elapsed timer in seconds one can do something like this:
Code:
dblTimer = Timer
...
' Code here
...
Debug.Print Timer - dblTimer
Unfortunately this suffers from `Timer`'s midnight rollover and is not milliseconds precise.

Here is a naive fix for the rollover and a complete fix for the precision too:
Code:
Option Explicit

Private Declare Function GetSystemTimeAsFileTime Lib "kernel32.dll" (lpSystemTimeAsFileTime As Currency) As Long

Private Sub Form_Load()
    Debug.Print Timer, NaiveDateTimer, DateTimer
End Sub

Public Property Get NaiveDateTimer() As Double
    NaiveDateTimer = CLng(Date) * 86400# + CDbl(CStr(Timer))
End Property

Public Property Get DateTimer() As Double
    Dim cDateTime      As Currency
   
    Call GetSystemTimeAsFileTime(cDateTime)
    DateTimer = CDbl(cDateTime - 9435304800000@) / 1000#
End Property
The naive version just multiplies `Date` with number of seconds in a day and adds `Timer` which equals to number of seconds elapsed since `CDate(0)` = #1899-12-30#

The completely fixed `DateTimer` return value has the same semantics but is precise to 5 digits after the floating point i.e. 1/100 of a millisecond precise. Of course it all depends on OS and hardware support but the API call is easy and convenient -- the "hacked" parameter type is the trick here.

Here is how we log current date/time with milliseconds precision in our error reporting code:
Code:
    Debug.Print Format$(Now, "yyyy.mm.dd hh:mm:ss") & Right$(Format$(DateTimer, "0.000"), 4)

    > 2015.01.29 20:17:20.771
Enjoy!

cheers,
</wqw>
↧
Search

[VB6] High Quality Multimodal Printing

January 31, 2015, 11:20 am
$
0
0
This is a refinement of a .BAS module I answered a question thread with.

Basically the module has some helper functions for printing. These let you print in a non-WYSIWYG manner in a sort of "desktop publishing" layout approach and get decent quality results compared to crude approaches like printing VB Forms. It isn't really a "reporting" technique, though since everything it can print could be taken from databases or files you could use it for some simple kinds of reporting that create more of a "document" than lines of report text.

At this point you can print a number of things with it, each item laid out on a sort of "box" within a page. These things now include:

  • Text (String) data.
  • Images.
  • RichTextBox contents.
  • MSHFlexGrid contents (within limits, if you have too many rows this doesn't work, if it is too wide it doesn't work well).
  • MSChart contents (within limits, you may need to fiddle with more properties for fancy charts).


To get a better idea of what this does you almost have to run the demos. They are easier to test if you have some sort of virtual printer device(s), such as a PDF printer or Microsoft's XPS Document Writer or Office Document Image Writer or something.

They all use the same Form2, which is a simple "printer picker" dialog box.

Demo1 does a little of everything to print a single page. It is more complex than the others, so I recommend you begin by looking at Demo2, the simplest. If you run Demo1 in the IDE you may get a "collating sequence" exception. This is a Jet Text IISAM incompatibility within the VB6 IDE. Just run it a second time. Compiled programs won't have this issue. But Demo1 is a good one to go ahead and print to a physical color printer. The print quality isn't too bad.

Demo2 prints from a RichTextBox loaded with a sample document. All it adds is pagination and page numbering.

Demo3 does the same thing for another sample document. What it adds beyond Demo2 is two-column printing.

Printing an MSChart causes it to "blink out" quite visibly for a bit, and I have no fix yet. However this is probably a small penalty to get better chart printing.


Only tested on Windows Vista and Windows 7.

The attachment has all 3 demo projects and some sample data (which makes it as big as it is).
Attached Files
↧
↧

Simple Delay Sub

February 4, 2015, 3:17 pm
$
0
0
Below is some code that enables you to delay execution for a specified number of milliseconds. It uses DoEvents and Sleep to minimize the CPU load when waiting for the specified time.

This runs in VB5/VB6 and all versions of VBA including 64-bit as found in 64-bit Office 2010 and later. It uses one API call and makes use of a compilation constant "VBA7" to determine if it is being compiled in VBA 64-bit.

Code:
#If VBA7 Then
Public Declare PtrSafe Function timeGetTime Lib "Winmm.dll" () As Long
'Retrieves the number of milliseconds that have elapsed since the system was started, up to 49.7 days
' A bit more accurate than GetTickCount
'http://msdn.microsoft.com/en-us/library/windows/desktop/dd757629%28v=vs.85%29.aspx

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' http://msdn.microsoft.com/en-us/library/ms686298(VS.85).aspx

#Else
Public Declare Function timeGetTime Lib "Winmm.dll" () As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If


Public Sub Delay(ByVal DelayMS As Long)
' Delays execution for the specified # of milliseconds.
Dim EndDelay As Long, i As Long, Current As Long
Current = timeGetTime
EndDelay = DelayMS + Current
Do
  Select Case EndDelay - Current ' set how long we put the PC to sleep depends on how long is left
      Case Is < 20:  i = 1 ' sleep in 1 millisecond intervals
      Case Is < 100: i = 10
      Case Is > 110: i = 100
      End Select
  DoEvents
  Call Sleep(i) ' uses less CPU cycles than repeatedly calling SwitchToThread
  Current = timeGetTime
  Loop Until Current > EndDelay
End Sub
↧

MsgBox replacement with Optional Timeout

February 4, 2015, 3:46 pm
$
0
0
The code below is a replacement for MsgBox that is Unicode, runs on VB5/VB6 and all versions of VBA including 64-bit as in 64-bit Office 2010 and later. It uses an undocumented function for an optional timeout period that has been around since XP (theoretically it could go away but unlikely since it is still in as of 8.1). Since the main function uses "Wide" (Unicode) characters, I call the function MsgBoxW instead of VB's MsgBox.

The code checks the OS version and if it is earlier than XP it uses the standard MessageBox call (the same one VB/VBA MsgBox uses) instead of the undocumented call with timeout. the timeout period is optional and is entered in milliseconds (1000ms = 1sec). If you specify 0 for the timeout period then the message box remains onscreen until the user deals with it with the keyboard or mouse.

If a timeout period is specified and the timeout period is reached, the function returns with a value of vbTimedOut, defined as 32000 (I didn't pick this, the Windows designers did...).

I also threw in some other simple things. I used conditional compilation to set a constant at compile time for the number of bits of the program (not the OS). This variable is called NumBits and will be either 32 or 64.

When the MsgBoxW function is called, it will check to see if the Windows version has been determined via the Init sub and if not it will call Init. In that routine, the OS major version and minor versions are combined into the public variable OSVersion. To keep the code simple we use MajorVersion x 100 plus the MinorVersion. For example, Windows XP has a MajorVersion of 5 and a MinorVersion of 01 so OSVersion will be 501.

The OS Build number is saved into the public variable OSBuild.

the operating system bits (32 or 64) are found by examining the environment variable string "ProgramFiles(x86)". Windows does not have this environment variable in the 32-bit versions, only the 64-bit versions so we test for the length of the return variable.

Note that the Windows API functions want a handle passed to them so we have to figure out at compile time whether we are in 32 or 64-bit VB/VBA and set the size of the window handle accordingly. That's why you will see two function headers for MsgBoxW. Actually only one is used as determined by whether the compiler finds the conditional compilation constant VBA7 which only is found in Office 2010 and later VBA and if so, the code specifies the variable type of the window handle "hwnd" as a LongPtr. Office is smart enough to figure out internally whether the code is 32 or 64-bit and make the window handle 32 or 64 bit.

Likewise we have to have two sets of API declarations at the top of the code module, one for "traditional" 32-bit code including VB5 and 6 and one for the new Office VBA variables where we have to use LongPtr instead of Long where appropriate.

Also, in order to make the API calls Unicode instead of ANSI, we don't pass the MsgBox text or caption strings to the API calls as String but rather as pointers like StrPtr(theString) so VB won't do its conversion from native Unicode to ANSI. We als make the API calls that need these pointers use passed variables as ByVal instead of ByRef to get the pointer passed instead of an address to a pointer.

Code:
Private Type OSVERSIONINFO
' used by API call GetVersionExW
 dwOSVersionInfoSize As Long
 dwMajorVersion As Long
 dwMinorVersion As Long
 dwBuildNumber As Long
 dwPlatformId As Long
 szCSDVersion(1 To 256) As Byte
End Type
 
#If VBA7 Then
Private Declare PtrSafe Function GetVersionExW Lib "kernel32" (lpOSVersinoInfo As OSVERSIONINFO) As Long
' http://msdn.microsoft.com/en-us/library/ms724451%28VS.85%29.aspx

Private Declare PtrSafe Function MessageBoxW Lib "user32.dll" ( _
  ByVal hwnd As LongPtr, _
  ByVal PromptPtr As LongPtr, _
  ByVal TitlePtr As LongPtr, _
  ByVal UType As VbMsgBoxStyle) _
      As VbMsgBoxResult
' http://msdn.microsoft.com/en-us/library/ms645505(VS.85).aspx

Private Declare PtrSafe Function MessageBoxTimeoutW Lib "user32.dll" ( _
      ByVal WindowHandle As LongPtr, _
      ByVal PromptPtr As LongPtr, _
      ByVal TitlePtr As LongPtr, _
      ByVal UType As VbMsgBoxStyle, _
      ByVal Language As Integer, _
      ByVal Miliseconds As Long _
      ) As VbMsgBoxResult
' http://msdn.microsoft.com/en-us/library/windows/desktop/ms645507(v=vs.85).aspx (XP+, undocumented)

#Else
' for Office before 2010 and also VB6
Private Declare Function GetVersionExW Lib "kernel32" (lpOSVersinoInfo As OSVERSIONINFO) As Long
Private Declare Function MessageBoxW Lib "user32.dll" (ByVal hwnd As Long, ByVal PromptPtr As Long, _
  ByVal TitlePtr As Long, ByVal UType As VbMsgBoxStyle) As VbMsgBoxResult
Private Declare Function MessageBoxTimeoutW Lib "user32.dll" (ByVal HandlePtr As Long, _
  ByVal PromptPtr As Long, ByVal TitlePtr As Long, ByVal UType As VbMsgBoxStyle, _
  ByVal Language As Integer, ByVal Miliseconds As Long) As VbMsgBoxResult
#End If

Public Const vbTimedOut As Long = 32000 ' return if MsgBoxW times out


Public OSVersion As Long
Public OSBuild As Long
Public OSBits As Long

' NumBits will be 32 if the VB/VBA system running this code is 32-bit. VB6 is always 32-bit
'  and all versions of MS Office up until Office 2010 are 32-bit. Office 2010+ can be installed
'  as either 32 or 64-bit
#If Win64 Then
Public Const NumBits As Byte = 64
#Else
Public Const NumBits As Byte = 32
#End If



Sub Init()

' Sets the operating system major version * 100 plus the Minor version in a long
' Ex- Windows Xp has major version = 5 and the minor version equal to 01 so the return is 501
Dim version_info As OSVERSIONINFO
OSBuild = 0
version_info.dwOSVersionInfoSize = LenB(version_info)  '276
If GetVersionExW(version_info) = 0 Then
  OSVersion = -1 ' error of some sort. Shouldn't happen.
Else
  OSVersion = (version_info.dwMajorVersion * 100) + version_info.dwMinorVersion
  If version_info.dwPlatformId = 0 Then
      OSVersion = 301 ' Win 3.1
  Else
      OSBuild = version_info.dwBuildNumber
      End If
  End If

' Sets OSBits=64 if running on a 64-bit OS, 32 if on a 32-bit OS. NOTE- This is not the
'  # bits of the program executing the program. 32-bit  OFFice or VBA6 would return
'  OSBits = 64 if the code is running on a machine that has is running 64-bit Windows.
If Len(Environ$("PROGRAMFILES(X86)")) > 0 Then OSBits = 64 Else OSBits = 32 ' can't be 16

End Sub


#If VBA7 Then
Public Function MsgBoxW( _
 Optional Prompt As String = "", _
 Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
 Optional Title As String = "", _
 Optional ByVal TimeOutMSec As Long = 0, _
 Optional flags As Long = 0, _
 Optional ByVal hwnd As LongPtr = 0) As VbMsgBoxResult
#Else
Public Function MsgBoxW( _
 Optional Prompt As String = "", _
 Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
 Optional Title As String = "", _
 Optional ByVal TimeOutMSec As Long = 0, _
 Optional flags As Long = 0, _
 Optional ByVal hwnd As Long = 0) As VbMsgBoxResult
#End If
' A UniCode replacement for MsgBox with optional Timeout
' Returns are the same as for VB/VBA's MsgBox call except
'  If there is an error (unlikely) the error code is returned as a negative value
'  If you specify a timeout number of milliseconds and the time elapses without
'  the user clicking a button or pressing Enter, the return is "vbTimedOut" (numeric value = 32000)
' Inuts are the same as for the VB/VBA version except for the added in;ut variable
'  TimeOutMSec which defaults to 0 (infinite time) but specifies a time that if the
'  message box is displayed for that long it will automatically close and return "vbTimedOut"
' NOTE- The time out feature was added in Windows XP so it is ignored if you run this
'  code on Windows 2000 or earlier.
' NOTE- The time out feature uses an undocumented feature of Windows and is not guaranteed
'  to be in future versions of Windows although it has been in all since XP.

If OSVersion < 600 Then ' WindowsVersion less then Vista
  Init
  If OSVersion < 600 Then ' earlier than Vista
      If (Buttons And 15) = vbAbortRetryIgnore Then Buttons = (Buttons And 2147483632) Or 6 ' (7FFFFFFF xor 15) or 6
      End If
  End If
If (OSVersion >= 501) And (TimeOutMSec > 0) Then ' XP and later only
  MsgBoxW = MessageBoxTimeoutW(hwnd, StrPtr(Prompt), StrPtr(Title), Buttons Or flags, 0, TimeOutMSec)
Else ' earlier than XP does not have timeout capability for MessageBox
  MsgBoxW = MessageBoxW(hwnd, StrPtr(Prompt), StrPtr(Title), Buttons Or flags)
  End If
If MsgBoxW = 0 Then MsgBoxW = Err.LastDllError ' this should never happen
End Function
Comments?
↧

VB6 - Converting Unicode strings to Byte Array

February 8, 2015, 10:13 am
$
0
0
Visual Basic stores all strings as double wide characters (16 bits). This is no big deal if you are using standard ASCII characters (7 bits), as the first 9 bits are always zero. But when you need to use ANSI characters (8 bit), the Unicode conversion that VB does in the background creates a problem. For example, the string (shown as Hex):
31 81 32 82 33 83 34 84 35 85 36 86 37 87
gets stored in memory as:
31 00 81 00 32 00 1A 20 33 00 92 01 34 00 1E 20
35 00 26 20 36 00 20 20 37 00 21 20
The character &H82 gets changed to &H20 &H1A, as well as several others. To convert one of these strings to a byte array, I have been using the following code:
Code:
Public Function StrToByte(strInput As String) As Byte()
    Dim lPntr As Long
    Dim bTmp() As Byte
    Dim bArray() As Byte
    If Len(strInput) = 0 Then Exit Function
    ReDim bTmp(LenB(strInput) - 1) 'Memory length
    ReDim bArray(Len(strInput) - 1) 'String length
    CopyMemory bTmp(0), ByVal StrPtr(strInput), LenB(strInput)
    'Examine every second byte
    For lPntr = 0 To UBound(bArray)
        If bTmp(lPntr * 2 + 1) > 0 Then
            bArray(lPntr) = Asc(Mid$(strInput, lPntr + 1, 1))
        Else
            bArray(lPntr) = bTmp(lPntr * 2)
        End If
    Next lPntr
    StrToByte = bArray
End Function
And to convert it back to a string, I have been using:
Code:
Public Function ByteToStr(bArray() As Byte) As String
    Dim lPntr As Long
    Dim bTmp() As Byte
    ReDim bTmp(UBound(bArray) * 2 + 1)
    For lPntr = 0 To UBound(bArray)
        bTmp(lPntr * 2) = bArray(lPntr)
    Next lPntr
    Let ByteToStr = bTmp
End Function
Looping through the first routine 10,000 times took an average of 71.7 ms with a spread of 16 ms. Looking for a more efficient way to do these conversions, I investigated the "RtlUnicodeStringToAnsiString" function in "ntdll.dll".
Code:
Option Explicit

Private Declare Function UnicodeToAnsi Lib "ntdll.dll" Alias "RtlUnicodeStringToAnsiString" (ByRef DestinationString As ANSI_STRING, ByVal SourceString As Long, Optional ByVal AllocateDestinationString As Byte) As Long
Private Declare Function AnsiToUnicode Lib "ntdll.dll" Alias "RtlAnsiStringToUnicodeString" (ByVal DestinationString As Long, ByRef SourceString As ANSI_STRING, Optional ByVal AllocateDestinationString As Byte) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Type UNICODE_STRING
    Len As Integer
    MaxLen As Integer
    Buffer As String
End Type

Private Type ANSI_STRING
    Len As Integer
    MaxLen As Integer
    Buffer As Long
End Type

Private Function UniToAnsi(sUnicode As String) As Byte()
    Dim UniString As UNICODE_STRING
    Dim AnsiString As ANSI_STRING
    Dim Buffer() As Byte
    If Len(sUnicode) = 0 Then Exit Function
    UniString.Buffer = sUnicode
    UniString.Len = LenB(UniString.Buffer)
    UniString.maxLen = UniString.Len + 2
    AnsiString.Len = Len(UniString.Buffer)
    AnsiString.maxLen = AnsiString.Len + 1
    ReDim Buffer(AnsiString.Len) As Byte
    AnsiString.Buffer = VarPtr(Buffer(0))
    If UnicodeToAnsi(AnsiString, VarPtr(UniString)) = 0 Then
        UniToAnsi = Buffer
        ReDim Preserve UniToAnsi(UBound(Buffer) - 1)
        sUnicode = ByteToStr(UniToAnsi)
    End If
End Function
Looping through this routine 10,000 times took an average of 37.4 ms with a spread 16 ms. The advantage of this routine is that it not only returns the byte array, but also the corrected string. But there is a down side. If you pass an already corrected string through this routine again, it changes the corrected characters to &H3F ("?"). For example the corrected string:
31 81 32 82 33 83 34 84 35 85 36 86 37 87
gets converted to:
31 81 32 3F 33 3F 34 3F 35 3F 36 3F 37 3F

Even though the UniToAnsi routine is almost twice as efficient as the StrToByte routine, for me it was not worth the risk of doing a double conversion.

J.A. Coutts
↧
↧

[VB6] Subclassing With Common Controls Library

February 8, 2015, 11:50 am
$
0
0
Subclassing... An advanced topic that has become much easier over the years. About the only thing that can be considered advanced nowadays is the added research subclassing requires to properly handle messages and retrieving structures and data related to some pointer the subclass procedures receives.

What is posted here is simply a working, drop-in, collection of code that can be added to any project. Subclassed messages can be received in a form, class, usercontrol or property page. The code provided is specifically designed for the subclassing functions provided by the common controls library (comctl32.dll). It does not require manifesting or adding the Windows Common Control ocx to your project. The provided code is targeted for projects, not stand-alone classes, therefore, requires the bas module and separate implementation class below.

Content of modSubclasser follows
Code:
'----- modSubclasser ---------------------------------------------------------------------
' This module can be added to any project. Its declarations are all private and should
'  not cause any conflicts with any existing code already in your project.
' To use this module to subclass windows, very little overhead is needed:
'  1) Add this module to your project
'  2) Add the ISubclassEvent class to your project
'  3) In whatever code page (form/class/usercontrol/propertypage) that you want to
'      receive subclassed messages, add this in the declarations section of the code page:
'      Implements ISubclassEvent
'  4) As needed, call the SubclassWindow() method in this module
'  5) When subclassing no longer needed, call the UnsubclassWindow() method
'-----------------------------------------------------------------------------------------

Option Explicit

' comctl32 versions less than v5.8 have these APIs, but they are exported via Ordinal
Private Declare Function SetWindowSubclassOrdinal Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Private Declare Function DefSubclassProcOrdinal Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function RemoveWindowSubclassOrdinal Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
' comctl32 versions 5.8+ exported the APIs by name
Private Declare Function DefSubclassProc Lib "comctl32.dll" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32.dll" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long

Private Declare Function IsWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hWnd As Long, ByRef lpdwProcessId As Long) As Long
Private Declare Function DefWindowProcA Lib "user32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DefWindowProcW Lib "user32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function IsWindowUnicode Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetProcAddressOrdinal Lib "kernel32.dll" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcName As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
Private Const WM_DESTROY As Long = &H2

Private m_SubclassKeys As Collection
Private m_UseOrdinalAliasing As Boolean

Public Function SubclassWindow(ByVal hWnd As Long, Receiver As ISubclassEvent, Optional ByVal Key As String) As Boolean
    ' can subclass multiple windows simultaneously
    ' see ISubclassEvent comments for helpful tips regarding the Receiver's event
   
    ' hWnd: The window handle & must be in the same process
    ' Receiver: The form/class/usercontrol/propertypage that Implements ISubclassEvent
    '  and wants to receive messages for the hWnd. Receiver MUST NOT be destroyed before
    '  all subclassing it is recieving are first released. If unsure, you should call
    '  the following in its Terminate or Unload event: UnsubclassWindow -1&, Me
    ' Key: unique key used to identify this specific instance of subclassing
    '  Key is passed to each subclass event and can be used to filter subclassed
    '  messages. Keys are unique per Receiver
    ' Recommend always assigning a key if subclassing multiple windows.
   
    ' Function fails in any of these cases:
    '  hWnd is not valid or is not in the same process as project
    '  Receiver is Nothing
    '  Key is duplicated
    '  Trying to subclass the same window twice with the same Receiver
   
    If Receiver Is Nothing Or hWnd = 0& Then Exit Function
    Dim lValue As Long
   
    Key = Right$("0000" & Hex(ObjPtr(Receiver)), 8) & Right$("0000" & Hex(hWnd), 8) & Key
    If m_SubclassKeys Is Nothing Then
        lValue = LoadLibrary("comctl32.dll")
        If lValue = 0& Then Exit Function      ' comctl32.dll doesn't exist
        m_UseOrdinalAliasing = False
        If GetProcAddress(lValue, "SetWindowSubclass") = 0& Then
            If GetProcAddressOrdinal(lValue, 410&) = 0& Then
                FreeLibrary lValue              ' comctl32.dll is very old
                Exit Function
            End If
            m_UseOrdinalAliasing = True
        End If
        FreeLibrary lValue
        Set m_SubclassKeys = New Collection
    Else
        On Error Resume Next
        lValue = Len(m_SubclassKeys(CStr(ObjPtr(Receiver) Xor hWnd)))
        If Err Then
            Err.Clear
        Else
            Exit Function                      ' duplicate key
        End If
        On Error GoTo 0
    End If
    If IsWindow(hWnd) = 0 Then Exit Function    ' not a valid window
    If Not GetWindowThreadProcessId(hWnd, lValue) = App.ThreadID Then Exit Function
   
    lValue = ObjPtr(Receiver) Xor hWnd
    m_SubclassKeys.Add Key, CStr(lValue)
    If m_UseOrdinalAliasing Then
        SetWindowSubclassOrdinal hWnd, AddressOf pvWndProc, lValue, ObjPtr(Receiver)
    Else
        SetWindowSubclass hWnd, AddressOf pvWndProc, lValue, ObjPtr(Receiver)
    End If
    SubclassWindow = True
   
End Function

Public Function UnsubclassWindow(ByVal hWnd As Long, Receiver As ISubclassEvent, Optional ByVal Key As String) As Boolean

    ' should be called when the subclassing is no longer needed
    ' this will be called automatically if the subclassed window is about to be destroyed
    ' To remove all subclassing for the Reciever, pass hWnd as -1&

    ' Function fails in these cases
    '  hWnd was not subclassed or is invalid
    '  Receiver did not subclass the hWnd
    '  Key is invalid

    Dim lID As Long, lRcvr As Long
    If Receiver Is Nothing Or hWnd = 0& Then Exit Function
   
    lRcvr = ObjPtr(Receiver)
    If hWnd = -1& Then
        For lID = m_SubclassKeys.Count To 1& Step -1&
            If CLng("&H" & Left$(m_SubclassKeys(lID), 8)) = lRcvr Then
                hWnd = CLng("&H" & Mid$(m_SubclassKeys(lID), 9, 8))
                Call UnsubclassWindow(hWnd, Receiver, Mid$(m_SubclassKeys(lID), 17))
            End If
        Next
        UnsubclassWindow = True
        Exit Function
    End If
   
    On Error Resume Next
    lID = lRcvr Xor hWnd
    Key = Right$("0000" & Hex(lRcvr), 8) & Right$("0000" & Hex(hWnd), 8) & Key
    If Key = m_SubclassKeys(CStr(lID)) Then
        If Err Then
            Err.Clear
            Exit Function
        End If
        If m_UseOrdinalAliasing Then
            lID = RemoveWindowSubclassOrdinal(hWnd, AddressOf pvWndProc, lID)
        Else
            lID = RemoveWindowSubclass(hWnd, AddressOf pvWndProc, lID)
        End If
        If lID Then
            UnsubclassWindow = True
            m_SubclassKeys.Remove CStr(lRcvr Xor hWnd)
            If m_SubclassKeys.Count = 0& Then Set m_SubclassKeys = Nothing
        End If
    End If
End Function

Private Function pvWndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, _
                            ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
   
    Dim lAction As enumSubclassActions, bRtn As Boolean, sKey As String
    Dim IReceiver As ISubclassEvent, tObj As Object
   
    sKey = Mid$(m_SubclassKeys(CStr(uIdSubclass)), 17)
    RtlMoveMemory tObj, dwRefData, 4&
    Set IReceiver = tObj
    RtlMoveMemory tObj, 0&, 4&
   
    pvWndProc = IReceiver.ProcessMessage(sKey, hWnd, uMsg, wParam, lParam, lAction, bRtn, 0&)
    If uMsg = WM_DESTROY Then
        lAction = scevForwardMessage
        bRtn = False
        UnsubclassWindow hWnd, IReceiver, sKey
    End If
   
    If lAction = scevDoNotForwardEvent Then
        Exit Function
    ElseIf lAction = scevForwardMessage Then
        If m_UseOrdinalAliasing Then
            pvWndProc = DefSubclassProcOrdinal(hWnd, uMsg, wParam, lParam)
        Else
            pvWndProc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
        End If
    ElseIf IsWindowUnicode(hWnd) Then
        pvWndProc = DefWindowProcW(hWnd, uMsg, wParam, lParam)
    Else
        pvWndProc = DefWindowProcA(hWnd, uMsg, wParam, lParam)
    End If
   
    If bRtn Then Call IReceiver.ProcessMessage(sKey, hWnd, uMsg, wParam, lParam, scevDoNotForwardEvent, True, (pvWndProc))
   
End Function
Content of ISubclassEvent follows
Code:
'----- ISubclassEvent ---------------------------------------------------------------------
'  Ensure this class is named ISubclassEvent
'-----------------------------------------------------------------------------------------

Option Explicit

Public Enum enumSubclassActions
    scevForwardMessage = 0    ' continue the message down the subclassing chain
    scevSendToOriginalProc = 1 ' skip the chain & send message directly to original window procedure
    scevDoNotForwardEvent = -1 ' do not forward this message any further down the chain
End Enum

Public Function ProcessMessage(ByVal Key As String, ByVal hWnd As Long, ByVal Message As Long, _
                ByRef wParam As Long, ByRef lParam As Long, ByRef Action As enumSubclassActions, _
                ByRef WantReturnMsg As Boolean, ByVal ReturnValue As Long) As Long

' Key. The Key provided during the SubclassWindow() call
' hWnd. The subclassed window's handle
' Message. The message to process
' wParam & lParam. Message-specific values
' Action. Action to be taken after you process this message
' WantReturnMsg. Set to True if want to monitor the result after message completely processed
' ReturnValue. The final result of the message and passed only when WantReturnMsg = True

' Notes
'  WantReturnMsg. This parameter serves two purposes:
'  1) Indication whether this message is received BEFORE other subclassers have received
'      it or AFTER the last subclasser has processed the message.
'      If parameter = False, this is a BEFORE event
'      If parameter = True, this is an AFTER event
'  2) Allows you to request an AFTER event. Set parameter to True during the BEFORE event.
'  Parameter is ignored if Action is set to scevDoNotForwardEvent in the BEFORE event.
'  When WantReturnMsg is set to True, after the subclassing chain processes the
'      message, you will get a second event. The WantReturnMsg  parameter will be True
'      and the ReturnValue parameter will contain the final result. This is the AFTER event.

'  wParam & lParam can be changed by you. Any changes are forwarded down the chain as necessary

'  Key parameter, if set, is very useful if subclassing multiple windows at the same time.
'  All subclassed messages for the same object implementing this class receives all messages
'  for each subclassed window thru this same event. To make it simpler to determine which
'  hWnd relates to what type of window, the Key can be used.

'  The return value of this function is only used if Action is set to scevDoNotForwardEvent
End Function
A simple sample. Have form subclass one of its textboxes
Code:
Option Explicit
Implements ISubclassEvent

Private Sub cmdSubclass_Click()
    SuclassWindow Text1.hWnd, Me, "txt1"
End Sub
Private Sub cmdUnSubclass_Click()
    UnsubclassWindow Text1.hwnd, Me, "txt1"
End Sub
Private Function ISubclassEvent_ProcessMessage(ByVal Key As String, ByVal hWnd As Long, _
                    ByVal Message As Long, wParam As Long, lParam As Long, _
                    Action As enumSubclassActions, WantReturnMsg As Boolean, _
                    ByVal ReturnValue As Long) As Long

    Select Case Message
        ...
    End Select
End Function
Side note. I have created several versions of IDE-safe subclassing routines over the years and all but two were based off of Paul Caton's ideas/code that used assembly thunks as a go-between. So I do have lots of experience with subclassing. The functions provided in comctl32.dll are theoretically IDE-safe. I personally find that the IDE is more responsive with the thunk version vs. these comctl32 functions. No code is truly IDE-safe if it is poorly written. As always, save often when debugging while subclassing. These comctl32 functions do make setting up subclassing a breeze.

Edited: Changed keying to allow unsubclassing all windows by a specific Receiver, at once. Useful should you want to terminate subclassed hWnds in one call vs. one at a time. Other minor tweaks were also made. FYI: Keys are in this format: [8 chars][8 chars][key] where 1st 8 chars is Hex value of Receiver, 2nd 8 chars is Hex value of subclassed hWnd & the [key] is the user-provided key, if any. This Key structure allows unsubclassing all windows with only knowing the Receiver and/or unsubclassing a hWnd without knowing the Receiver(s) that subclassed it.

If needed, you can add this to the module to retrieve the Key you assigned to a specific instance of subclassing:
Code:
Public Function GetSubclassKey(ByVal hWnd As Long, Receiver As ISubclassEvent) As String
    On Error Resume Next
    GetSubclassKey = Mid$(m_SubclassKeys(CStr(ObjPtr(Receiver) Xor hWnd)), 17)
    If Err Then Err.Clear
End Function
↧

[Experimental] VB6 FastCGI Server

February 9, 2015, 2:23 pm
$
0
0
I was daydreaming about developing a web interface for my VB6 program, and I thought I'd play around with the Nginx web server since it is dead easy to deploy (no installer required), and LGPL. Nginx uses the FastCGI protocol, but I couldn't get it to work with any builds of the libfcgi.dll that I could find.

So I decided (perhaps madly) to try to implement my own FastCGI server in VB6.

This is an experimental FastCGI server written in VB6, and it also uses Olaf Schmidt's vbRichClient5 library. I know I'll be asked why I'm adding the extra dependency, and it's because I enjoy working with it, and I already use it in the rest of my app (so no extra overhead for me there). I also plan to take advantage of it's threading features for this server in a future release if I can get it working successfully. If you don't like it should be painless to ignore this project, or modify it to use MS Collection, Timer, and Winsock objects/controls if you want to adapt it.

NOW, when I say experimental, I mean it! Things are likely to change significantly over the life of this project in this thread, and there are undoubtedly major bugs and gaps in the current implementation. The goal is to eventually have a production ready FCGI server to work with the Nginx web server, but there's no timeframe nor guarantee as to when/if this might happen.

What is FastCGI?
From Wikipedia:

"FastCGI is a binary protocol for interfacing interactive programs with a web server. FastCGI is a variation on the earlier Common Gateway Interface (CGI); FastCGI's main aim is to reduce the overhead associated with interfacing the web server and CGI programs, allowing a server to handle more web page requests at once." More: http://en.wikipedia.org/wiki/FastCGI

FastCGI Website: http://www.fastcgi.com

Useful Resources
vbRichClient Site: You will need to download and register vbRichClient5.dll on your development machine to use this project. http://www.vbrichclient.com

FastCGI Spec: http://www.fastcgi.com/devkit/doc/fcgi-spec.html

CoastRD FastCGI Site: http://www.coastrd.com/fastcgi and interesting whitepaper: http://www.coastrd.com/fcgi-white-paper

Nginx Site: http://nginx.org/



The following list of Gaps in Understanding and Known Issues will be updated as I go.

Questions/Gaps in Understanding
  • The FastCGI protocol mentions that the web server can send SIGTERM to the FCGI server to ask it to close cleanly. Not sure how/if this is done in the Windows Nginx implementation since it handles it's FCGI communications over a TCP pipe and I've never received any message that I can identify as being related to SIGTERM.


Known Issues
  • Not responding to all FCGI Roles
  • Not processing all FCGI record types
  • FIXED IN 0.0.2 RELEASE Occasionally getting a "The connection was reset" error. Ngnix reports error: #5512: *263 upstream sent invalid FastCGI record type: 2 while reading upstream?


Latest Source Code FastCGI Server.zip

Version 0.0.1
  • So far we can process BEGIN, PARAMS, and STDIN requests from the web server, and respond with a basic web page listing all the received CGI parameters.
  • We can also handle Unicode transfer to the serve rin UTF-8 encoding.


Version 0.0.2
  • Fixed bad value for FCGI_END_REQUEST constant (should have been 3, was 2)


Screenshots
The main form Eventually the project will be UI-less, but this just makes it easier to close between test builds:
Name: FCGIServer.png Views: 16 Size: 15.8 KB

The Current Browser Output Showing Unicode>UTF-8 output and the received CGI params:
Name: Response.jpg Views: 12 Size: 43.0 KB


Over and Out - For Now!
I'm always interested in comments, criticisms, etc... so if this project interests you in any way, please climb aboard!
Attached Images
  
Attached Files
↧

[VB6] - 3D Fir-tree.

February 10, 2015, 9:20 am
↧
Search

[VB6] - Translation of the string to a number and vice versa.

February 10, 2015, 11:26 am
$
0
0
VB6 functions for translation and verification of numbers to strings (and back) is very uncomfortable in terms of the fact that there is a lot to write, and they have their "eat." We can write the numbers in the hexadecimal system or brackets in exponential notation, etc. On the one hand it is good, but on the other can be a challenge. I wrote two functions that convert decimal integers of unlimited dimension from one representation to another. Can be useful for example to display the (Setup) LARGE_INTEGER or any other large (very large scale) numbers.
Code:
Option Explicit
 
Private Declare Function GetMem2 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
 
Private Sub Form_Load()
    Dim Value() As Byte, Res As String
 
    StrToUI "1234567891011121314151617181920", Value
   
    Res = UIToStr(Value)
   
End Sub
' Перевод беззнакового целого числа из байтового представления в строку
Private Function UIToStr(bValue() As Byte) As String
    Dim i As Long, f As Boolean, loc() As Byte
    loc = bValue
    Do
        i = Div10UI(loc)
        UIToStr = CStr(i) & UIToStr
        f = False
        For i = UBound(loc) To 0 Step -1
            If loc(i) Then f = True: Exit For
        Next
    Loop While f
End Function
' Перевод беззнакового целого числа из строкового представления в массив байт
Private Sub StrToUI(sValue As String, Out() As Byte)
    Dim i As Long, lpStr As Long, v As Integer, b(0) As Byte
    ReDim Out(0)
    If Len(sValue) Then
        lpStr = StrPtr(sValue)
        For i = 0 To Len(sValue) - 1
            GetMem2 ByVal lpStr, v
            v = v - &H30
            If v < 0 Or v > 9 Then Err.Raise 13: Exit Sub
            b(0) = v
            If i Then Mul10UI Out
            AddUI Out, b()
            lpStr = lpStr + 2
        Next
    Else: Err.Raise 5
    End If
End Sub
Private Sub AddUI(Op1() As Byte, Op2() As Byte)
    Dim i As Long, p As Long, o As Long, q As Long
    If UBound(Op1) < UBound(Op2) Then ReDim Preserve Op1(UBound(Op2))
    Do
        If i <= UBound(Op2) Then o = Op2(i) Else o = 0
        q = CLng(Op1(i)) + o + p
        p = (q And &H100&) \ &H100
        Op1(i) = q And &HFF
        i = i + 1
    Loop While CBool(o Or p) And i <= UBound(Op1)
    If p Then ReDim Preserve Op1(i): Op1(i) = p
End Sub
Private Function Div10UI(Value() As Byte) As Long
    Dim i1 As Long, i2 As Long, acc() As Byte, loc() As Byte, q As Long, p As Long
    For i1 = 0 To (UBound(Value) + 1) * 8
        Div10UI = (Div10UI * 2) Or p
        If Div10UI < 10 Then p = 0 Else p = 1: Div10UI = Div10UI - 10
        For i2 = 0 To UBound(Value)
            q = (CLng(Value(i2)) * 2) Or p
            p = (q And &H100) \ &H100
            Value(i2) = q And &HFF&
        Next
    Next
End Function
Private Sub Mul10UI(Value() As Byte)
    Dim i As Long, p As Long, q As Long
    For i = 0 To UBound(Value)
        q = (CLng(Value(i)) * 4 + Value(i)) * 2 + p
        p = (q And &HFF00&) \ &H100
        Value(i) = q And &HFF
    Next
    If p Then ReDim Preserve Value(i): Value(i) = p
End Sub
↧
↧

[VB6] - "Lens" on VB6

February 10, 2015, 11:31 am
$
0
0
With this software, you can view a certain part of the screen increases, the increase can change the wheel, exit - ESC.
Module:
Code:
Option Explicit
 
' Модуль modMain.bas
' © Кривоус Анатолий Анатольевич (The trick), 2014
' Реализация "линзы"
' Увеличить - колесико вверх, уменьшить - вниз
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End Type
Private Type WINDOWPOS
    hwnd As Long
    hWndInsertAfter As Long
    x As Long
    y As Long
    cx As Long
    cy As Long
    flags As Long
End Type
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function InvertRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function ScrollDC Lib "user32" (ByVal hdc As Long, ByVal dx As Long, ByVal dy As Long, lprcScroll As Any, lprcClip As Any, ByVal hrgnUpdate As Long, lprcUpdate As Any) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function SetDCPenColor Lib "gdi32" (ByVal hdc As Long, ByVal colorref As Long) As Long
 
Private Const DC_PEN = 19
Private Const RDW_INVALIDATE = &H1
Private Const RDW_UPDATENOW = &H100
Private Const WM_WINDOWPOSCHANGING = &H46
Private Const HWND_TOPMOST = -1
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
 
Private Const GWL_WNDPROC = &HFFFFFFFC
Private Const WM_PAINT = &HF
Private Const WM_MOUSEWHEEL = &H20A&
 
Private Const HTCAPTION = 2
Private Const WM_NCHITTEST = &H84
 
Dim lpPrevWndProc As Long
Dim bBmp As Long
Dim oBmp As Long
Dim tDc As Long
Dim oPos As WINDOWPOS
Dim w As Long, h As Long, bi As BITMAPINFO, pix() As Long, out() As Long, Strength As Single
 
Public Sub Hook()
    Dim hRgn As Long
    Strength = 0.2
    w = frmTest.ScaleWidth: h = frmTest.ScaleHeight
    bi.bmiHeader.biSize = Len(bi.bmiHeader)
    bi.bmiHeader.biBitCount = 32
    bi.bmiHeader.biPlanes = 1
    bi.bmiHeader.biWidth = w
    bi.bmiHeader.biHeight = h
    ReDim pix(w * h - 1)
    ReDim out(UBound(pix))
    tDc = CreateCompatibleDC(frmTest.hdc)
    bBmp = CreateCompatibleBitmap(frmTest.hdc, w, h)
    oBmp = SelectObject(tDc, bBmp)
    Prepare frmTest.Left / Screen.TwipsPerPixelX, frmTest.Top / Screen.TwipsPerPixelY
    hRgn = CreateEllipticRgn(0, 0, w, h)
    SetWindowRgn frmTest.hwnd, hRgn, False
    SetWindowPos frmTest.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
    lpPrevWndProc = SetWindowLong(frmTest.hwnd, GWL_WNDPROC, AddressOf WndProc)
End Sub
Public Sub UnHook()
    SetWindowLong frmTest.hwnd, GWL_WNDPROC, lpPrevWndProc
    SelectObject tDc, oBmp
    DeleteDC tDc
    DeleteObject bBmp
End Sub
Private Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    'Debug.Print Msg
    Select Case Msg
    Case WM_WINDOWPOSCHANGING
        Dim wp As WINDOWPOS
        CopyMemory wp, ByVal lParam, Len(wp)
        WndProc = OnPosChanging(hwnd, wp)
    Case WM_NCHITTEST
        WndProc = HTCAPTION
    Case WM_PAINT
        WndProc = OnPaint(hwnd)
    Case WM_MOUSEWHEEL
        WndProc = OnWheel(hwnd, (wParam \ &H10000))
    Case Else
        WndProc = CallWindowProc(lpPrevWndProc, hwnd, Msg, wParam, lParam)
    End Select
End Function
Private Function OnWheel(ByVal hwnd As Long, ByVal Value As Integer) As Long
    Value = Value \ 120
    Strength = Strength + Value / 30
    If Strength > 1 Then Strength = 1 Else If Strength < 0 Then Strength = 0
    MakeLens
    RedrawWindow hwnd, ByVal 0, 0, RDW_INVALIDATE
End Function
Private Function OnPosChanging(ByVal hwnd As Long, Pos As WINDOWPOS) As Long
    Dim dx As Long, dy As Long
   
    If Pos.flags And SWP_NOMOVE Then Exit Function
   
    dx = Pos.x - oPos.x
    dy = Pos.y - oPos.y
   
    Prepare dx, dy
    RedrawWindow hwnd, ByVal 0, 0, RDW_INVALIDATE Or RDW_UPDATENOW
   
    oPos = Pos
End Function
Private Function OnPaint(ByVal hwnd As Long) As Long
    Dim ps As PAINTSTRUCT, opn As Long
    BeginPaint hwnd, ps
    SetDIBitsToDevice ps.hdc, 0, 0, w, h, 0, 0, 0, h, out(0), bi, 0
    opn = SelectObject(ps.hdc, GetStockObject(DC_PEN))
    SetDCPenColor ps.hdc, &HE0E0E0
    Ellipse ps.hdc, 1, 1, w - 2, h - 2
    SelectObject ps.hdc, opn
    EndPaint hwnd, ps
End Function
Private Sub MakeLens()
    Dim x As Long, y As Long
    Dim cx As Single, cy As Single
    Dim nx As Long, ny As Long
    Dim r As Single
    Dim pt As Long
   
    SelectObject tDc, oBmp
    GetDIBits tDc, bBmp, 0, h, pix(0), bi, 0
    SelectObject tDc, bBmp
   
    For y = 0 To h - 1: For x = 0 To w - 1
        cx = x / w - 0.5: cy = y / h - 0.5
        r = Sqr(cx * cx + cy * cy)
        nx = (cx + 0.5 + Strength * cx * ((r - 1) / 0.5)) * (w - 1)
        ny = (cy + 0.5 + Strength * cy * ((r - 1) / 0.5)) * (h - 1)
        out(pt) = pix(ny * w + nx)
        pt = pt + 1
    Next: Next
 
End Sub
Private Sub Prepare(ByVal dx As Long, ByVal dy As Long)
    Dim dDC As Long, x As Long, y As Long
    dDC = GetDC(0)
   
    ScrollDC tDc, -dx, -dy, ByVal 0, ByVal 0, ByVal 0, ByVal 0
    Select Case dx
    Case Is > 0
        x = oPos.x + w: y = oPos.y + dy
        BitBlt tDc, w - dx, 0, dx, h, dDC, x, y, vbSrcCopy
    Case Is < 0
        x = oPos.x + dx: y = oPos.y + dy
        BitBlt tDc, 0, 0, -dx, h, dDC, x, y, vbSrcCopy
    End Select
    Select Case dy
    Case Is > 0
        x = oPos.x + dx: y = oPos.y + h
        BitBlt tDc, 0, h - dy, w, dy, dDC, x, y, vbSrcCopy
    Case Is < 0
        x = oPos.x + dx: y = oPos.y + dy
        BitBlt tDc, 0, 0, w, -dy, dDC, x, y, vbSrcCopy
    End Select
    ReleaseDC 0, dDC
    MakeLens
End Sub
Form:
Code:
Option Explicit
 
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyEscape Then Unload Me
End Sub
Private Sub Form_Load()
    Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
    Hook
End Sub
Private Sub Form_Unload(Cancel As Integer)
    UnHook
End Sub


Lens.zip
Attached Files
↧

[VB6] - 4d hypercube (tesseract)

February 10, 2015, 11:39 am
$
0
0
I have always aroused the interest of four-dimensional figures, and generally multi-dimensional space. I decided to write a small program where you can twist the four in four-dimensional hypercube in six planes. In principle, many of these programs, but I decided to write it on your favorite VB6, moreover, with a little refinement can be done, and other shapes. The cube has six faces of the squares. Because drawing lines is quite possible to draw faces 4, and similarly hypercube, you can draw only 4-cube, rather than all eight, the rest will consist of adjacent faces of these figures.* For clarity, on the tops of the hypercube I made a circle, color and size which corresponds to the coordinate T (smaller and darker - more along the axis T).

Code:
Option Explicit
 
' Гиперкуб (тессеракт), просмотр проекции 4-хмерного гиперкуба на 2-х мерное пространство экрана.
' Автор: Кривоус Анатолий Анатольевич (The trick) 2013
' Возможность вращения по 6-ти осям (в 6-ти плоскостях), 3-х обычных трехмерных и 3-комбинированных (XT,YT,ZT) (T-ось четвертого измерения)
' Регулировка дистанции по оси Z (по оси T фиксированно 2), угла обзора для 3D
' Гиперкуб имеет размеры (0.5,0.5,0.5,0.5), центр в точке (0,0,0,2)
' Для проекции 4D->3D, имеется возможность переключать тип проекции с параллельной в перспективную
' Темные и малые вершины, находяться "глубже" по оси T, чем светлые
' Кнопками Z-зануляется скорость вращения по оси, кнопкам R сбрасывается поворот на 0 грудусов.
 
Private Type Vector4D          ' Четырехмерный вектор
    X As Single
    Y As Single
    Z As Single
    t As Single
    w As Single
End Type
Private Type Quad
    P(3) As Vector4D            ' Квадрат
End Type
Private Type Cube
    P(3) As Quad                ' Куб
End Type
 
Private Const PI2 = 6.28318530717959                                                                          ' 2 * PI
 
Dim XY As Single, ZX As Single, ZY As Single, _
    ZT As Single, XT As Single, YT As Single                                                                  ' Углы поворота
Dim Tesseract(3) As Cube                                                                                      ' 4 куба граней тессеракта
 
Private Function Vec4(ByVal X As Single, ByVal Y As Single, ByVal Z As Single, ByVal t As Single) As Vector4D ' Создание вектора
    Vec4.X = X: Vec4.Y = Y: Vec4.Z = Z: Vec4.t = t: Vec4.w = 1
End Function
Private Function Vec4Add(Vec1 As Vector4D, Vec2 As Vector4D) As Vector4D                                      ' Сложение векторов
    With Vec4Add
    .X = Vec1.X + Vec2.X: .Y = Vec1.Y + Vec2.Y: .Z = Vec1.Z + Vec2.Z: .t = Vec1.t + Vec2.t: .w = 1
    End With
End Function
Private Function Vec4Sub(Vec1 As Vector4D, Vec2 As Vector4D) As Vector4D                                      ' Разность векторов
    With Vec4Sub
    .X = Vec1.X - Vec2.X: .Y = Vec1.Y - Vec2.Y: .Z = Vec1.Z - Vec2.Z: .t = Vec1.t - Vec2.t: .w = 1
    End With
End Function
Private Sub Translation4D(ByVal X As Single, ByVal Y As Single, ByVal Z As Single, ByVal t As Single, Out() As Single) ' Перенос
    Identity4d Out(): Out(4, 0) = X: Out(4, 1) = Y: Out(4, 2) = Z: Out(4, 3) = t
End Sub
Private Sub Rotation4DXY(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости XY
    Dim C As Single, S As Single
    C = Cos(Angle): S = Sin(Angle): Identity4d Out()
    Out(0, 0) = C: Out(1, 0) = S: Out(0, 1) = -S: Out(1, 1) = C
End Sub
Private Sub Rotation4DZY(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости ZY
    Dim C As Single, S As Single
    C = Cos(Angle): S = Sin(Angle): Identity4d Out()
    Out(1, 1) = C: Out(2, 1) = S: Out(1, 2) = -S: Out(2, 2) = C
End Sub
Private Sub Rotation4DZX(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости ZX
    Dim C As Single, S As Single
    C = Cos(Angle): S = Sin(Angle): Identity4d Out()
    Out(0, 0) = C: Out(0, 2) = S: Out(2, 0) = -S: Out(2, 2) = C
End Sub
Private Sub Rotation4DXT(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости XT
    Dim C As Single, S As Single
    C = Cos(Angle): S = Sin(Angle): Identity4d Out()
    Out(0, 0) = C: Out(0, 3) = S: Out(3, 0) = -S: Out(3, 3) = C
End Sub
Private Sub Rotation4DYT(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости YT
    Dim C As Single, S As Single
    C = Cos(Angle): S = Sin(Angle): Identity4d Out()
    Out(1, 1) = C: Out(3, 1) = -S: Out(1, 3) = S: Out(3, 3) = C
End Sub
Private Sub Rotation4DZT(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости ZT
    Dim C As Single, S As Single
    C = Cos(Angle): S = Sin(Angle): Identity4d Out()
    Out(2, 2) = C: Out(3, 2) = -S: Out(3, 3) = S: Out(3, 3) = C
End Sub
Private Sub Projection(FOV As Single, w As Single, h As Single, F As Single, N As Single, Out() As Single) ' Матрица проекции
    Dim h_ As Single, w_ As Single, a_ As Single, b_ As Single
    ReDim Out(4, 4)
    h_ = 1 / Tan(FOV / 2): w_ = h_ / (w / h)
    a_ = F / (F - N)
    b_ = -N * F / (F - N)
    Out(0, 0) = h_: Out(1, 1) = w_: Out(2, 2) = a_: Out(2, 3) = b_: Out(3, 2) = 1
End Sub
Private Sub Identity4d(Out() As Single)                        ' Единичная матрица 5х5
    Dim i As Long
    ReDim Out(4, 4): For i = 0 To 4: Out(i, i) = 1: Next
End Sub
Private Sub MultiplyTransform(Out() As Single, Op1() As Single, Op2() As Single) ' Умножение 2-х матриц
    Dim Tmp() As Single, i As Long, j As Long, k As Long
    If UBound(Op1, 1) <> UBound(Op2, 2) Then Exit Sub          ' Умножение может быть только если число столбцов первого
    ReDim Tmp(UBound(Op2, 1), UBound(Op1, 2))                  ' равно числу строк второго
    For j = 0 To UBound(Op1, 2): For i = 0 To UBound(Op2, 1)
        For k = 0 To UBound(Op1, 1)
            Tmp(i, j) = Tmp(i, j) + Op1(k, j) * Op2(i, k)
        Next
    Next: Next
    Out = Tmp
End Sub
Private Function TransformVec4D(V As Vector4D, Transform() As Single) As Vector4D  ' Трансформация вектора
    With TransformVec4D
        .X = V.X * Transform(0, 0) + V.Y * Transform(1, 0) + V.Z * Transform(2, 0) + V.t * Transform(3, 0) + V.w * Transform(4, 0)
        .Y = V.X * Transform(0, 1) + V.Y * Transform(1, 1) + V.Z * Transform(2, 1) + V.t * Transform(3, 1) + V.w * Transform(4, 1)
        .Z = V.X * Transform(0, 2) + V.Y * Transform(1, 2) + V.Z * Transform(2, 2) + V.t * Transform(3, 2) + V.w * Transform(4, 2)
        .t = V.X * Transform(0, 3) + V.Y * Transform(1, 3) + V.Z * Transform(2, 3) + V.t * Transform(3, 3) + V.w * Transform(4, 3)
        .w = V.X * Transform(0, 4) + V.Y * Transform(1, 4) + V.Z * Transform(2, 4) + V.t * Transform(3, 4) + V.w * Transform(4, 4)
    End With
End Function
' Создание куба по 3-м граням верняя левая в глубину точка Pos, Dir - направления от этой точки
Private Function CreateCube(Pos As Vector4D, Dir1 As Vector4D, Dir2 As Vector4D, Dir3 As Vector4D) As Cube
    With CreateCube
    .P(0) = CreateQuad(Pos, Vec4Add(Pos, Dir1), Vec4Add(Pos, Dir2))
    .P(1) = CreateQuad(.P(0).P(1), Vec4Add(.P(0).P(1), Dir3), .P(0).P(2))
    .P(2) = CreateQuad(.P(1).P(1), Vec4Sub(.P(1).P(1), Dir1), .P(1).P(2))
    .P(3) = CreateQuad(.P(2).P(1), Pos, Vec4Add(.P(2).P(1), Dir2))
    End With
End Function
' Создание квадрата по трем точкам
Private Function CreateQuad(Pos1 As Vector4D, Pos2 As Vector4D, Pos3 As Vector4D) As Quad
    CreateQuad.P(0) = Pos1
    CreateQuad.P(1) = Pos2
    CreateQuad.P(3) = Pos3
    CreateQuad.P(2) = Vec4(Pos2.X + Pos3.X - Pos1.X, Pos2.Y + Pos3.Y - Pos1.Y, _
                          Pos2.Z + Pos3.Z - Pos1.Z, Pos2.t + Pos3.t - Pos1.t)
End Function
Private Sub cmdReset_Click(Index As Integer)    ' Сброс трансформаций
    Select Case Index
    Case 0: XY = 0
    Case 1: ZX = 0
    Case 2: ZY = 0
    Case 3: ZT = 0
    Case 4: XT = 0
    Case 5: YT = 0
    End Select
End Sub
Private Sub cmdResetAll_Click()                ' Сброс всех трансформаций
    XY = 0: ZX = 0: ZY = 0: ZT = 0: XT = 0: YT = 0
End Sub
Private Sub cmdZero_Click(Index As Integer)    ' Обнулить скорость
    sldRotateSpd(Index).Value = 0
End Sub
Private Sub Form_Load()
' Создаем тессеракт
    Tesseract(0) = CreateCube(Vec4(-0.5, 0.5, 0.5, -0.5), Vec4(1, 0, 0, 0), Vec4(0, 0, -1, 0), Vec4(0, -1, 0, 0))
    Tesseract(1) = CreateCube(Vec4(-0.5, 0.5, 0.5, 0.5), Vec4(1, 0, 0, 0), Vec4(0, 0, -1, 0), Vec4(0, -1, 0, 0))
    Tesseract(2) = CreateCube(Vec4(-0.5, 0.5, 0.5, -0.5), Vec4(1, 0, 0, 0), Vec4(0, 0, -1, 0), Vec4(0, 0, 0, 1))
    Tesseract(3) = CreateCube(Vec4(-0.5, -0.5, 0.5, 0.5), Vec4(1, 0, 0, 0), Vec4(0, 0, -1, 0), Vec4(0, 0, 0, -1))
End Sub
Private Sub sldRotateSpd_Scroll(Index As Integer) ' Регулятор скорости
    sldRotateSpd(Index).ToolTipText = sldRotateSpd(Index).Value
End Sub
Private Sub tmrRefresh_Timer()
    Dim Wrld() As Single, Tmp() As Single      ' Матрицы преобразований
    Dim C As Long, Q As Long, V As Long        ' Кубы, квадраты, векторы
    Dim Out4D As Vector4D                      ' Результирующий вектор
    Dim X As Single, Y As Single, _
        Sx As Single, Sy As Single, t As Single
 
    XY = XY + sldRotateSpd(0).Value / 1000      ' Прибавляем приращение к каждому углу
    ZX = ZX + sldRotateSpd(1).Value / 1000      ' ///
    ZY = ZY + sldRotateSpd(2).Value / 1000      ' ///
    ZT = ZT + sldRotateSpd(3).Value / 1000      ' ///
    XT = XT + sldRotateSpd(4).Value / 1000      ' ///
    YT = YT + sldRotateSpd(5).Value / 1000      ' ///
   
    Translation4D 0, 0, sldDist.Value / 100, 2, Wrld()  ' Сдвигаем от камеры на величину Distance
    Rotation4DXY XY, Tmp()                      ' Вычисляем матрицу поворота
    MultiplyTransform Wrld, Wrld, Tmp          ' Комбинируем трансформации
    Rotation4DZX ZX, Tmp()
    MultiplyTransform Wrld, Wrld, Tmp
    Rotation4DZY ZY, Tmp()
    MultiplyTransform Wrld, Wrld, Tmp
    Rotation4DZT ZT, Tmp()
    MultiplyTransform Wrld, Wrld, Tmp
    Rotation4DXT XT, Tmp()
    MultiplyTransform Wrld, Wrld, Tmp
    Rotation4DYT YT, Tmp()
    MultiplyTransform Wrld, Wrld, Tmp
   
    If Abs(XY) > PI2 Then XY = XY - Sgn(XY) * PI2  ' Ограничиваем промежутком 0..2Pi
    If Abs(ZX) > PI2 Then ZX = ZX - Sgn(ZX) * PI2
    If Abs(ZY) > PI2 Then ZY = ZY - Sgn(ZY) * PI2
    If Abs(ZT) > PI2 Then ZT = ZT - Sgn(ZT) * PI2
    If Abs(XT) > PI2 Then XT = XT - Sgn(XT) * PI2
    If Abs(YT) > PI2 Then YT = YT - Sgn(YT) * PI2
   
    Projection sldFOV.Value / 100, 1, 1, 0.1, 3.5, Tmp() ' Вычисляем матрицу проекции 3D -> 2D
   
    picDisp.Cls
   
    For C = 0 To UBound(Tesseract): For Q = 0 To 3: For V = 0 To 3  ' Проход по всем вершинам
        Out4D = TransformVec4D(Tesseract(C).P(Q).P(V), Wrld())      ' Трансформируем в мировые координаты
        t = Out4D.t                                                ' Для цвета сохраняем
        If optProjection(0).Value Then                              ' Перспективная проекция 4D -> 3D
            Out4D = Vec4(Out4D.X / (Out4D.t * 15), Out4D.Y / (Out4D.t * 15), Out4D.Z, 1)
        Else                                                        ' Параллельная проекция 4D -> 3D
            Out4D = Vec4(Out4D.X / 37.5, Out4D.Y / 37.5, Out4D.Z, 1)
        End If
        Out4D = TransformVec4D(Out4D, Tmp())                        ' Проецируем на плоскость
        If Out4D.Z > 0 And Out4D.Z < 1 Then                        ' Если глубина в пределах 0.1-3.5 то отрисовываем
            X = picDisp.ScaleWidth * (1 + Out4D.X / Out4D.t) / 2    ' Перевод в координаты PictureBox'а
            Y = picDisp.ScaleHeight * (1 - Out4D.Y / Out4D.t) / 2
            If V Then                                              ' Если не первая точка квадрата то рисуем линиию и круг
                picDisp.Line -(X, Y)
                picDisp.FillColor = RGB(64 + (3 - t) * 192, 0, 0)  ' Цвет в зависимости от глубины по координате T
                picDisp.Circle (X, Y), (4 - t) * 3
            Else                                                    ' Иначе переносим текущие координаты, для начала отрисовки
                picDisp.CurrentX = X: Sx = X
                picDisp.CurrentY = Y: Sy = Y
            End If
        End If
        Next
        picDisp.Line -(Sx, Sy)                                      ' Замыкаем квадрат
    Next: Next
   
    lblInfo.Caption = "XY: " & Format$(XY / PI2 * 360, "##0.0°") & vbNewLine & _
                    "ZX: " & Format$(ZX / PI2 * 360, "##0.0°") & vbNewLine & _
                    "ZY: " & Format$(ZY / PI2 * 360, "##0.0°") & vbNewLine & _
                    "ZT: " & Format$(ZT / PI2 * 360, "##0.0°") & vbNewLine & _
                    "XT: " & Format$(XT / PI2 * 360, "##0.0°") & vbNewLine & _
                    "YT: " & Format$(YT / PI2 * 360, "##0.0°")
End Sub


Tesseract.zip
Attached Files
↧

[VB6] - Saving pictures to a byte array in the format jpeg, without using file.

February 10, 2015, 11:45 am
$
0
0
This is useful for example to transmit or packaging. It is also possible to make conservation and other similar formats and also the opening of the bitmap memory.
Code:
Option Explicit
 
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
    GUID As GUID
    NumberOfValues As Long
    type As Long
    value As Long
End Type
Private Type EncoderParameters
    Count As Long
    Parameter As EncoderParameter
End Type
 
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
 
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function GetHGlobalFromStream Lib "ole32" (ByVal ppstm As Long, hGlobal As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
Private Declare Function GdipSaveImageToStream Lib "gdiplus" (ByVal image As Long, ByVal Stream As IUnknown, clsidEncoder As Any, encoderParams As Any) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
 
Private Const JpgCLSID As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"        ' Строковое представление CLSID jpeg энкодера
Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"  ' Строковое представление GUID качества сохранения
Private Const EncoderParameterValueTypeLong As Long = 4                            ' Тип значений для энкодера 32 битный без знака
 
Private Sub Form_Load()
    Dim dDc As Long                                        ' Контекст устройства рабочего стола
    Dim dhWnd As Long                                      ' Хендл окна рабочего стола
    Dim tBmp As Long                                        ' Bitmap, в который копируем данные
    Dim IStream As IUnknown                                ' Объект потока
    Dim hMem As Long                                        ' Хендл объекта памяти
    Dim lSize As Long                                      ' Размер памяти, предоставляемый объектом памяти
    Dim lPt As Long                                        ' Адрес памяти
    Dim Dat() As Byte                                      ' Данные рисунка, после кодирования (фактически бинарный JPG)
    Dim fNum As Integer                                    ' Файловый номер
    Dim tDc As Long                                        ' Временный контекст устройства
    Dim oBmp As Long                                        ' Старая картинка, выбраная во временный контекст
       
    dhWnd = GetDesktopWindow()                              ' Получаем хендл окна рабочего стола
    dDc = GetDC(dhWnd)                                      ' Получаем контекст устройства рабочего стола
    tDc = CreateCompatibleDC(dDc)                          ' Создаем совместимый с ним контекст
    tBmp = CreateCompatibleBitmap(dDc, Screen.Width / _
          Screen.TwipsPerPixelX, Screen.Height / _
          Screen.TwipsPerPixelY)                          ' Создаем картинку по размеру экрана
    oBmp = SelectObject(tDc, tBmp)                          ' Выбираем картинку во временный контекст
    BitBlt tDc, 0, 0, Screen.Width / _
          Screen.TwipsPerPixelX, Screen.Height / _
          Screen.TwipsPerPixelY, dDc, 0, 0, vbSrcCopy      ' Отрисовываем все с рабочего стола во временную картинку
    SelectObject tDc, oBmp                                  ' Очистка ресурсов ...
    DeleteDC tDc
    ReleaseDC dhWnd, dDc
   
    If CreateStreamOnHGlobal(0&, 1&, IStream) Then _
          MsgBox "Ошибка создание потока": _
          DeleteObject (tBmp): Exit Sub                    ' Создаем объект потока
    If Not SaveJPG(tBmp, IStream) Then _
          MsgBox "Ошибка сохранение файла в поток": _
          DeleteObject (tBmp): Exit Sub                    ' Сохраняем картинку
   
    DeleteObject tBmp                                      ' Очистка ресурсов
   
    If GetHGlobalFromStream(ObjPtr(IStream), hMem) Then _
          MsgBox "Ошибка получения хендла памяти": _
          Exit Sub                                        ' Получаем хендл объекта памяти потока
    lSize = GlobalSize(hMem)                                ' Получаем размер объекта памяти
    If lSize Then                                          ' Если размер действительный...
        lPt = GlobalLock(hMem)                              ' Блокируем и получаем указатель на него
        ReDim Dat(0 To lSize - 1)                          ' Выделяем буфер, куда сохраняться данные
        CopyMemory Dat(0), ByVal lPt, lSize                ' Копируем данные из объекта памяти потока в буфер
        GlobalUnlock hMem                                  ' Разблокируем объект памяти
    End If
   
    ' Для проверки, сохраним данные в файл
    fNum = FreeFile
    Open "D:\Temp.jpg" For Binary As fNum
    Put fNum, , Dat
    Close fNum
   
End Sub
' Процедура сохранения картинки в jpeg формате в поток
Private Function SaveJPG(hBitmap As Long, Stream As IUnknown, Optional Quality As Byte = 50) As Boolean
    Dim SI As GdiplusStartupInput                          ' Для инициализации GDI+
    Dim token As Long                                      ' Маркер GDI +
    Dim lBmp As Long                                        ' Картинка GDI+
    Dim JpgEnc As GUID                                      ' CLSID jpeg энкодера
    Dim Res As Long                                        ' Результат операции сохранения в поток
    Dim Par As EncoderParameters                            ' Параметры jpeg энкодера
   
    SI.GdiplusVersion = 1                                  ' Параметры запуска
    If GdiplusStartup(token, SI) Then Exit Function        ' Запускаем GDI+
    If GdipCreateBitmapFromHBITMAP(hBitmap, 0, lBmp) Then _
            GdiplusShutdown (token): Exit Function          ' Создаем GDI+ картинку из хендла картинки GDI
    CLSIDFromString StrPtr(JpgCLSID), JpgEnc                ' Получаем структуру CLSID для jpeg энкодера
    ' Задаем количество параметров для энкодера
    Par.Count = 1                                          ' Количество - 1 (качество картинки)
    Par.Parameter.NumberOfValues = 1                        ' Количество значений в параметре 1
    Par.Parameter.type = EncoderParameterValueTypeLong      ' Значение параметра 32 битное без знака
    Par.Parameter.value = VarPtr(CLng(Quality))            ' Указатель на значение качества сохранения
    CLSIDFromString StrPtr("EncoderQuality"), _
            Par.Parameter.GUID                              ' Получаем GUID качества сохранения
    Res = GdipSaveImageToStream(lBmp, Stream, JpgEnc, Par)  ' Сохраняем в поток
    GdipDisposeImage lBmp                                  ' Очистка ресурсов ...
    GdiplusShutdown token                                  ' Выключаем GDI+
    If Res Then Exit Function                              ' Если неудачно сохранили, то выходим
    SaveJPG = True                                          ' Успешное выполнение
End Function
↧

[VB6] - Vocoder.

February 10, 2015, 12:35 pm
$
0
0


Hello everyone. Creating music, I've seen a lot of different virtual instruments and effects. One of the most interesting effects is the vocoder, which allows you to modulate his voice and make it look like a voice like a robot or something like that. Vocoder was originally used to compress the voice data, and then it began to be used in the music industry. Because I had free time, I decided to write something like this for the sake of the experiment and describe in detail the stages of development on VB6.

Link (on Russian).
↧
↧

[VB6] - Kernel-mode driver.

February 10, 2015, 12:38 pm
$
0
0
Hello everyone. There was a time, and decided to write something unusual on VB6, namely to try to write a driver. I must say before that I never wrote a driver and have no programming experience in kernel mode. The driver, according to my idea, will have to read the memory is not available in user mode, namely in the range 0x80000000 - 0xffffffff (in default mode, without IMAGE_FILE_LARGE_ADDRESS_AWARE).

Link (on Russian).

↧

[VB6] - Circular spectrum visualizer.

February 10, 2015, 12:44 pm
$
0
0
Representing the source code and compiled program graphical visualizer audio spectrum. The sound is analyzed through a standard recording device Windows, ie You can select the microphone and view range with it, or you can select stereo mixer and view the range of reproduced sound. In this visualizer is possible to adjust the number of displayed octaves, adjustable transparency background amplification. You can also download a palette of external PNG file format 32ARGB, damping effects "blur" and "burning". This view allows the visualizer spectrum in two modes as arcs (rings) and form sectors. In the first form of the radial coordinate is responsible for the frequency octave, corner - between octaves. Harmonics are separated from each other by an octave, are on the same line, color - intensity. In the second mode, the radial coordinate - the volume, color - frequency, angular coordinate - frequency (period - 1 octave). This idea was suggested to me Vladislav Petrovky (aka Hacker), only his idea a little differently had displayed spectrum as a curve, I have done in the form of sectors.

Link (on Russian).

↧
Search

[VB6] - Class for subclassing windows and classes.

February 10, 2015, 1:09 pm
$
0
0
Developed a class with which you can work with subclassing. The class has an event WndProc, which is caused when receiving the message window. You can also put on a class subclassing windows. There are methods to pause subclassing and its removal, as well as information on subclassing. Work very convenient, because stop button can stop the project without any consequences. Run better through Start with full compile, because This will prevent crashes, a failed compilation. I imagine even brought a separate button next to the regular compilation and use it.
A little bit about working with the class. To install subclassing the window method is called Hook, with a handle of the window. If the method returns True, then subclassing installed. Event processing WndProc, you can change the behavior of the window. In argument Ret can transfer the return value if you want to call the procedure by default, then you need to pass in the argument DefCall - True.* To install windows subclassing a group (class), you need to call a method HookClass, passing a handle window whose class you need to intercept. On success, the method returns True. Subclassing will operate from next window created in this class, ie, on the parameter passed subclassing will not work. Also by default, this type of subclassing suspended. I did it because of the fact that if you do not process messages create windows properly, then the project will not start with error Out of memory.* To remove the need to call a method of subclassing Unhook, Returns True on success.

Link (on Russian).

↧

[VB6] - FM synthesizer (Trick FM)

February 10, 2015, 1:24 pm
$
0
0
Once upon a time he studied sound synthesis, in particular FM (frequency modulation) method. Was written test program synthesizer. Today I tweaked it a little bit, did GUI, etc.
Features:
  • 6 oscillators;
  • 6 waveforms ;
  • ADSR envelope for each oscillator;
  • Modulation matrix 6x6 + 6 for audio output;
  • Gate into 16 parts with adjustable stiffness.

In general, full-FM synthesizer.
Keys:
Z-C5
S-C#5
X-D5
D-D#5
C-E5
V-F etc.
Q-C6
I-C7
To work need a library dx8vb.dll

Link (on Russian).

↧
↧

[VB6] - Multithreading is an example of a fractal Julia.

February 10, 2015, 1:31 pm
$
0
0
I really like fractals and fractal sets. Wrote several test programs, where you can generate and change the settings for different fractals. In this example, you can generate the Julia set and change all the parameters of generation (including load a palette of images). To avoid a program hangs, I generation and rendering stuck in another thread. Example does not work IDE, operates in a compiled form.

Link (on Russian).

↧

[VB6] - Custom rendering window (non-client) and TaskBar indication.

February 10, 2015, 1:42 pm
$
0
0
In Windows 7, there was a remarkable thing - indication of progress on the taskbar button. To use this feature on VB6 (and any other language) you need to create an object TaskBarList, get ITaskBarList3 interface and use its methods and SetProgressState, SetProgressValue.* In my unit, I added the ability to set the state of the progress bar on the taskbar, and duplicated this indicator on the form itself + added ability to use animated icons in the form header (also supported by the usual icons). From this example, you can learn how to draw the non-client area of the window, make buttons that light up when you hover. The example uses double buffering, so everything works smoothly and without flicker. This module can be attached to any project with any forms.

Link (on Russian).

↧

[VB6] - Kernel mode driver.

February 11, 2015, 4:28 am
$
0
0

Hello everyone (sorry my English). There was a time, and decided to write something unusual on VB6, namely to try to write a driver. I must say before that I never wrote a driver and have no programming experience in kernel mode. The driver, according to my idea, will have to read the memory is not available in user mode, namely in the range 0x80000000 - 0xffffffff (in default mode, without IMAGE_FILE_LARGE_ADDRESS_AWARE). Immediately give the driver source code which is obtained:
Code:
' modTrickMemReader.bas  - модуль драйвера
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Option Explicit
 
Public Enum NT_STATUS
    STATUS_SUCCESS = 0
    STATUS_INVALID_PARAMETER = &HC000000D
End Enum
 
Public Type UNICODE_STRING
    Length              As Integer
    MaximumLength      As Integer
    lpBuffer            As Long
End Type
 
Public Type LIST_ENTRY
    Flink              As Long
    Blink              As Long
End Type
 
Public Type KDEVICE_QUEUE
    Type                As Integer
    Size                As Integer
    DeviceListHead      As LIST_ENTRY
    Lock                As Long
    Busy                As Long
End Type
 
Public Type KDPC
    Type                As Byte
    Importance          As Byte
    Number              As Integer
    DpcListEntry        As LIST_ENTRY
    DeferredRoutine    As Long
    DeferredContext    As Long
    SystemArgument1    As Long
    SystemArgument2    As Long
    DpcData            As Long
End Type
 
Public Type DISPATCHER_HEADER
    Lock                As Long
    SignalState        As Long
    WaitListHead        As LIST_ENTRY
End Type
 
Public Type KEVENT
    Header              As DISPATCHER_HEADER
End Type
 
Public Type IO_STATUS_BLOCK
    StatusPointer      As Long
    Information        As Long
End Type
 
Public Type Tail
    DriverContext(3)    As Long
    Thread              As Long
    AuxiliaryBuffer    As Long
    ListEntry          As LIST_ENTRY
    lpCurStackLocation  As Long
    OriginalFileObject  As Long
End Type
 
Public Type IRP
    Type                As Integer
    Size                As Integer
    MdlAddress          As Long
    Flags              As Long
    AssociatedIrp      As Long
    ThreadListEntry    As LIST_ENTRY
    IoStatus            As IO_STATUS_BLOCK
    RequestorMode      As Byte
    PendingReturned    As Byte
    StackCount          As Byte
    CurrentLocation    As Byte
    Cancel              As Byte
    CancelIrql          As Byte
    ApcEnvironment      As Byte
    AllocationFlags    As Byte
    UserIosb            As Long
    UserEvent          As Long
    Overlay            As Currency
    CancelRoutine      As Long
    UserBuffer          As Long
    Tail                As Tail
End Type
 
Public Type DEVICEIOCTL
    OutputBufferLength  As Long
    InputBufferLength  As Long
    IoControlCode      As Long
    Type3InputBuffer    As Long
End Type
 
Public Type IO_STACK_LOCATION
    MajorFunction      As Byte
    MinorFunction      As Byte
    Flags              As Byte
    Control            As Byte
    ' Поле DeviceIoControl из объединения
    DeviceIoControl    As DEVICEIOCTL
    pDeviceObject      As Long
    pFileObject        As Long
    pCompletionRoutine  As Long
    pContext            As Long
End Type
 
Public Type DRIVER_OBJECT
    Type                As Integer
    Size                As Integer
    pDeviceObject      As Long
    Flags              As Long
    DriverStart        As Long
    DriverSize          As Long
    DriverSection      As Long
    DriverExtension    As Long
    DriverName          As UNICODE_STRING
    HardwareDatabase    As Long
    FastIoDispatch      As Long
    DriverInit          As Long
    DriverStartIo      As Long
    DriverUnload        As Long
    MajorFunction(27)  As Long
End Type
 
Public Type DEVICE_OBJECT
    Type                As Integer
    Size                As Integer
    ReferenceCount      As Long
    DriverObject        As Long
    NextDevice          As Long
    AttachedDevice      As Long
    CurrentIrp          As Long
    Timer              As Long
    Flags              As Long
    Characteristics    As Long
    Vpb                As Long
    DeviceExtension    As Long
    DeviceType          As Long
    StackSize          As Byte
    Queue(39)          As Byte
    AlignRequirement    As Long
    DeviceQueue        As KDEVICE_QUEUE
    Dpc                As KDPC
    ActiveThreadCount  As Long
    SecurityDescriptor  As Long
    DeviceLock          As KEVENT
    SectorSize          As Integer
    Spare1              As Integer
    DeviceObjExtension  As Long
    Reserved            As Long
End Type
Private Type BinaryString
    D(255)              As Integer
End Type
 
Public Const FILE_DEVICE_UNKNOWN    As Long = &H22
Public Const IO_NO_INCREMENT        As Long = &H0
Public Const IRP_MJ_CREATE          As Long = &H0
Public Const IRP_MJ_CLOSE          As Long = &H2
Public Const IRP_MJ_DEVICE_CONTROL  As Long = &HE
Public Const FILE_DEVICE_MEMREADER  As Long = &H8000&
Public Const IOCTL_READ_MEMORY      As Long = &H80002000
 
Public DeviceName      As UNICODE_STRING  ' Строка с именем устройства
Public DeviceLink      As UNICODE_STRING  ' Строка с именем ссылки
Public Device          As DEVICE_OBJECT    ' Объект устройства
 
Dim strName As BinaryString    ' Строка с именем устройства
Dim strLink As BinaryString    ' Строка с именем ссылки
 
Public Sub Main()
End Sub
 
' // Если ошибка - False
Public Function NT_SUCCESS(ByVal Status As NT_STATUS) As Boolean
    NT_SUCCESS = Status >= STATUS_SUCCESS
End Function
 
' // Получить указатель на стек пакета
Public Function IoGetCurrentIrpStackLocation(pIrp As IRP) As Long
    IoGetCurrentIrpStackLocation = pIrp.Tail.lpCurStackLocation
End Function
 
' // Точка входа в драйвер
Public Function DriverEntry(DriverObject As DRIVER_OBJECT, RegistryPath As UNICODE_STRING) As NT_STATUS
    Dim Status As NT_STATUS
    ' Инициализация имен
    Status = Init()
    ' Здесь не обязательна проверка, но я поставил, т.к. возможно усовершенствование функции Init
    If Not NT_SUCCESS(Status) Then
        DriverEntry = Status
        Exit Function
    End If
    ' Создаем устройство
    Status = IoCreateDevice(DriverObject, 0, DeviceName, FILE_DEVICE_MEMREADER, 0, False, Device)
    ' Проверяем создалось ли устройство
    If Not NT_SUCCESS(Status) Then
        DriverEntry = Status
        Exit Function
    End If
    ' Создаем связь для доступа по имени из пользовательского режима
    Status = IoCreateSymbolicLink(DeviceLink, DeviceName)
    ' Проверяем корректность
    If Not NT_SUCCESS(Status) Then
        ' При неудаче удаляем устройство
        IoDeleteDevice Device
        DriverEntry = Status
        Exit Function
    End If
    ' Определяем функции
    DriverObject.DriverUnload = GetAddr(AddressOf DriverUnload) ' Выгрузка драйвера
    DriverObject.MajorFunction(IRP_MJ_CREATE) = GetAddr(AddressOf DriverCreateClose)    ' При вызове CreateFile
    DriverObject.MajorFunction(IRP_MJ_CLOSE) = GetAddr(AddressOf DriverCreateClose)    ' При вызове CloseHandle
    DriverObject.MajorFunction(IRP_MJ_DEVICE_CONTROL) = GetAddr(AddressOf DriverDeviceControl)  ' При вызове DeviceIoControl
    ' Успех
    DriverEntry = STATUS_SUCCESS
   
End Function
 
' // Процедура выгрузки драйвера
Public Sub DriverUnload(DriverObject As DRIVER_OBJECT)
    ' Удаляем связь
    IoDeleteSymbolicLink DeviceLink
    ' Удаляем устройство
    IoDeleteDevice ByVal DriverObject.pDeviceObject
End Sub
 
' // Функция вызывается при открытии/закрытии драйвера
Public Function DriverCreateClose(DeviceObject As DEVICE_OBJECT, pIrp As IRP) As NT_STATUS
    pIrp.IoStatus.Information = 0
    pIrp.IoStatus.StatusPointer = STATUS_SUCCESS
    ' Возвращаем IRP пакет менеджеру ввода/вывода
    IoCompleteRequest pIrp, IO_NO_INCREMENT
    ' Успех
    DriverCreateClose = STATUS_SUCCESS
End Function
 
' // Функция обработки IOCTL запросов
Public Function DriverDeviceControl(DeviceObject As DEVICE_OBJECT, pIrp As IRP) As NT_STATUS
    Dim lpStack As Long
    Dim ioStack As IO_STACK_LOCATION
    ' Получаем указатель на стек пакета
    lpStack = IoGetCurrentIrpStackLocation(pIrp)
    ' Проверяем указатель на валидность
    If lpStack Then
        ' Копируем в локальную переменную
        memcpy ioStack, ByVal lpStack, Len(ioStack)
        ' Проверяем IOCTL и объединение AssociatedIrp в котором содержится SystemBuffer
        ' В SystemBuffer содержится буфер, переданный нами в DeviceIoControl
        If ioStack.DeviceIoControl.IoControlCode = IOCTL_READ_MEMORY And _
            pIrp.AssociatedIrp <> 0 Then
           
            Dim lpPointer  As Long
            Dim DataSize    As Long
            ' Копируем параметы из SystemBuffer
            memcpy lpPointer, ByVal pIrp.AssociatedIrp, 4
            memcpy DataSize, ByVal pIrp.AssociatedIrp + 4, 4
            ' Проверяем размер буфера
            If DataSize <= ioStack.DeviceIoControl.OutputBufferLength Then
                ' Проверяем количество страниц, которые мы можем прочитать
                Dim lpStart As Long
                Dim pgCount As Long
                Dim pgSize  As Long
                Dim pgOfst  As Long
                ' Определяем адрес начала страницы
                lpStart = lpPointer And &HFFFFF000
                ' Определяем смещение от начала страницы
                pgOfst = lpPointer And &HFFF&
                ' Проход по станицам и проверка на PageFault
                Do While MmIsAddressValid(ByVal lpStart) And (pgSize - pgOfst < DataSize)
                    lpStart = lpStart + &H1000
                    pgCount = pgCount + 1
                    pgSize = pgSize + &H1000
                Loop
                ' Если хоть одна страница доступна
                If pgCount Then
                    ' Получаем реальный размер в байтах
                    pgSize = pgCount * &H1000 - pgOfst
                    ' Корректируем резмер
                    If DataSize > pgSize Then DataSize = pgSize
                    ' Возвращаем реальный размер прочитанных данных
                    pIrp.IoStatus.Information = DataSize
                    ' Успех
                    pIrp.IoStatus.StatusPointer = STATUS_SUCCESS
                    ' Копируем данные в SystemBuffer
                    memcpy ByVal pIrp.AssociatedIrp, ByVal lpPointer, DataSize
                    ' Возвращаем IRP пакет менеджеру ввода/вывода
                    IoCompleteRequest pIrp, IO_NO_INCREMENT
                    ' Упех
                    DriverDeviceControl = STATUS_SUCCESS
                    ' Выход
                    Exit Function
   
                End If
               
            End If
   
        End If
       
    End If
    ' Возвращаем реальный размер прочитанных данных
    pIrp.IoStatus.Information = 0
    ' Ошибка DeviceIoControl
    pIrp.IoStatus.StatusPointer = STATUS_INVALID_PARAMETER
    ' Возвращаем IRP пакет менеджеру ввода/вывода
    IoCompleteRequest pIrp, IO_NO_INCREMENT
    ' Ошибка
    DriverDeviceControl = STATUS_INVALID_PARAMETER
   
End Function
 
' // Функция инициализации
Private Function Init() As NT_STATUS
    ' Инициализируем имя устройства
    '\Device\TrickMemReader
    strName.D(0) = &H5C:    strName.D(1) = &H44:    strName.D(2) = &H65:    strName.D(3) = &H76:    strName.D(4) = &H69:
    strName.D(5) = &H63:    strName.D(6) = &H65:    strName.D(7) = &H5C:    strName.D(8) = &H54:    strName.D(9) = &H72:
    strName.D(10) = &H69:  strName.D(11) = &H63:  strName.D(12) = &H6B:  strName.D(13) = &H4D:  strName.D(14) = &H65:
    strName.D(15) = &H6D:  strName.D(16) = &H52:  strName.D(17) = &H65:  strName.D(18) = &H61:  strName.D(19) = &H64:
    strName.D(20) = &H65:  strName.D(21) = &H72:
    ' Создаем UNICODE_STRING
    RtlInitUnicodeString DeviceName, strName
    ' Инициализация ссылки на имя устройства из user-mode
    '\DosDevices\TrickMemReader
    strLink.D(0) = &H5C:    strLink.D(1) = &H44:    strLink.D(2) = &H6F:    strLink.D(3) = &H73:    strLink.D(4) = &H44:
    strLink.D(5) = &H65:    strLink.D(6) = &H76:    strLink.D(7) = &H69:    strLink.D(8) = &H63:    strLink.D(9) = &H65:
    strLink.D(10) = &H73:  strLink.D(11) = &H5C:  strLink.D(12) = &H54:  strLink.D(13) = &H72:  strLink.D(14) = &H69:
    strLink.D(15) = &H63:  strLink.D(16) = &H6B:  strLink.D(17) = &H4D:  strLink.D(18) = &H65:  strLink.D(19) = &H6D:
    strLink.D(20) = &H52:  strLink.D(21) = &H65:  strLink.D(22) = &H61:  strLink.D(23) = &H64:  strLink.D(24) = &H65:
    strLink.D(25) = &H72:
    ' Создаем UNICODE_STRING
    RtlInitUnicodeString DeviceLink, strLink
'
End Function
 
Private Function GetAddr(ByVal Value As Long) As Long
    GetAddr = Value
End Function
So, the driver must have an entry point DriverEntry, which causes the controller I/O driver is loaded. In the parameters of a pointer to an object-driver and a pointer to a string containing the name of the registry key corresponding to the loadable driver. In the Init procedure, we create two lines, one with the name of the device, the other with reference to the device name. Because we can not use the runtime kernel mode, it is necessary to create a string in the form of a static array, wrapped in a user-defined type, thereby VB6 allocates memory for the array on the stack. If you use a string that will inevitably be caused by one of the functions for runtime and copy assignment line, and we can not allow that. Then we can call IoCreateDevice, which creates a device object. Device object is the recipient of I/O requests and to him we will access when calling CreateFile function from user mode. The first parameter is a pointer to an object-driver; the second parameter is 0, then since we do not have the structure of the expansion device, and we do not need to allocate memory; the third parameter we pass the name of the device, it is we need to implement access to the device; fourth parameter passed to the device type (see below). in the fifth, we pass 0 as we have "non-standard device"; in the sixth pass False, because We do not need single-user mode; the last parameter - the output. As the name of the device we have to use a string like \Device\DeviceName (where DeviceName - TrickMemReader), is the name we need to ensure that we can create a link to it, which in turn need to access the device from user mode.
↧
Viewing all 1536 articles
Browse latest View live
Search
<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>