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

VB6 - Netgear Telnet

January 11, 2015, 11:11 pm
$
0
0
I upgraded my Internet connection and discovered that my old Netgear router just didn't have the capacity to keep up with it. I kept that old one around because I had several, and I really appreciated the command mode via Telnet. After some research, I purchased a new Netgear router (WNDR3400). When I checked for open ports, I discovered that port 23 was active on the LAN interface, but when I connected with Telnet, I got nothing. With a little more research, I found that Netgear allows you to enable the Telnet interface by sending it a special packet via a small program called "TelnetEnable.exe". The description given is that it takes the MAC address of the LAN Interface and combines it with the UserID and Password. It then does an MD5 Hash on it along with some byte swapping, and encrypts it all using Blowfish and the key "AMBIT_TELNET_ENABLE+".

I was tempted to try and duplicate the encryption, but Blowfish isn't supported by Microsoft and it is quite an old standard. As well, Telnet is not enabled by default on all modern Microsoft Operating Systems. So I created a small program to duplicate the Telnet Interface called TelNetgear. The TelnetEnable program requires the MAC address of the LAN interface, so the program automatically sends an ARP request to the configured IP address to determine the MAC address residing at that address. This is only good for IPv4, as ARP is not used in IPv6. Instead of a broadcast IP address, IPv6 uses a multicast MAC address (33:33:00:01:00:02).

When TelNetgear attempts to connect with the router, it first uses ShellExecute to call the "TelnetEnable" program. If successful, it will then connect with port 23. The router should respond with the "#" prompt as illustrated below. This Netgear router uses Unix type commands, and is very powerful for it's compact size. You can enter those commands in the lower Textbox, or you can use the commands listed in the yellow Listbox. Those commands are loaded from a text file called "Commands.txt", which can be edited with any standard Text Editor. I have included only a few of the many commands available. My knowledge of the Unix commands is quite limited. The "help" command lists a few, and the "busybox" command lists a few more. But there are more than that (eg. RouterInfo), and viewers are free to offer suggestions.

Some routers require UserID/Password after enabling Telnet, so that logic will have to be added if required. My particular router does not, and that means there is no restriction to access on the local network. If there is any doubt about the security of your local network (for example WiFi access on the same subnet), you should reboot the router after accessing, as this reverts the Telnet interface back to the default condition.

J.A. Coutts
Attached Images
 
Attached Files
↧
Search

[VB6] Common Dialog Replacement - IFileDialog Vista+

January 14, 2015, 7:13 pm
$
0
0
Attached is a working example of using the IFileDialog interface introduced in Vista. It is the replacement for the common dialog used for opening/saving files and browsing for folders. This code is not compatible with XP and lower. You should ensure your project has needed logic to verify system is Vista or better. This version does not currently support enhancements provided by Win7 and above. I do plan on adding them in the near future.

The classes are plug & play. No TLB references are required. The main class is the FileDialog class and can be used-as is. The optional IFileDialogEvents class is provided so that you can receive callbacks while the FileDialog is displayed. Before Vista, this would have required subclassing the dialog, but Vista provided a way to do this through simple callback events. This optional events class is not required to display the dialog. But that class is required if you want callbacks, wish to filter what is displayed in the dialog, or want to add your own controls to the dialog. That class must be implemented if used. This means adding a line of code in your declarations section: Implements IFileDialogEvents. Lets talk about the three types of events. You can opt to have any of them or none of them.

Each event sent from the class includes a reference to the Dialog, a user-defined key for the instance of the Dialog, and appropriate event-driven parameters. Some events expect an answer back from you. Though all events will be added when you Implement the class, you only have to code for the ones you asked for & want to respond to.

1. Standard Callback Events. The FileDialog can forward events to whatever is displaying the dialog. The most common events are: DialogOnInit, OnFolderChanging, OnSelectionChange, OnFieOk. The OnFileOk event occurs just before the user is about to close the dialog and offers you a chance to prevent closing the dialog and/or cache any custom control properties set by the user while the dialog was displayed. The OnFolderChanging event offers you a way to prevent the user from navigating to what they clicked on. There are a few other events that are forwarded and can be reviewed on MSDN. Note: DialogOnInit is a custom event the class sends. It is intended for you to finalize any custom controls you may have added, i.e., setting an option button, selecting a combobox item, etc, before the dialog is displayed. Any actions you take will not be forwarded back through events until DialogOnInit returns. Should you need to actually subclass the dialog, you can do it at this time since the hWnd of the dialog is known.

2. Filter Events. We all know we can assign filters to a file dialog like *.exe, *.txt, *.dll, etc. The dialog offers a more advanced filter where you can individually choose whether what is returned during navigation is actually displayed. When the filter is active, Windows sends you, one by one, every item that would be displayed. You can opt to say yes or no. Note: This was removed in Win7 & may not be added back.

3. Custom Control Events. You have the option to add controls to the dialog. These include combo/check/text boxes, option/command buttons, labels, & menu-like controls. There is little point in adding controls if you have no way of knowing if the user is clicking on them. So the dialog can send you some events. However, these events are lacking in my opinion. They do offer basic stuff, like something was clicked, something was selected, but little else. Any added textbox controls, for example, have no events passed. There are no got/lost focus events for the controls. Locating these controls for manual subclassing will be a challenge.

Here's the gotcha. As mentioned, this is not compatible with anything lower than Vista. But you also must get outside of your comfort zone a bit too. Where the older common dialog returned file & folder names, this new version returns objects as IShellItems and IShellItemArrays (when multi-selecting items). That's really not a bad thing. Not only can you have these items give you the file/folder name and 'display' name, you can ask it to give you that name as plain text or as a URL or a few other formats. You can have it give you attributes of the object. Since no TLBs are used, the FileDialog class has methods that will allow you to query the returned object for those things.

What I don't like about this new implementation of the dialog? The folder browsing is too limited in my opinion. The older version allowed several flags to restrict what was displayed. This new version has very little options for folders. Win7 added the ability to restrict browsing to the local domain, but other than that, not much. The lack of options from previous version lends to possibility of needing custom filters (#2 above). Additionally, the previous version allowed files to be displayed with folders when browsing for folders. The new version doesn't have that ability. Matter of learning to adjust I guess, but I feel code for the older version of folder browsing may still be worth keeping around.

There is no sample project included. I think that the FileDialog class is fairly straightforward to use and has lots of comments. A vast majority of the code is needed to simply to offer the wide range of options and provide methods to be called during events. The IFileDialogEvents class is to be implemented only, you will never create this class as a stand-alone object. I'm sure that there will be questions and we can address them here as needed.

These classes don't have all the dummy-proofing I tend to add in. It's a work-in-progress. But it is important you become familiar with it before attempting to use it for any serious projects. And come back occasionally to look for updates.

Edited:
Well that's embarrassing. Thought I'd get the Filter events without having to create FileDialogEvents. Wrong. Quick modification to include FileDialogEvents if either Filter or Control events are wanted.
Attached Files
↧
↧

[VB6] Creating/Using COM Interfaces without TLBs

January 15, 2015, 5:00 pm
$
0
0
This idea was something I just wondered if I could do. So, when I figured it out, wasn't too difficult to create a mostly generic template that could be used & re-used as needed. And that's what we have here.

With VB we may have to jump through hoops trying to declare and use a Windows COM interface that doesn't inherit from IDispatch. Typically, we would add a type library (TLB) to our project that contains the interfaces we plan on using. That works pretty well and is the preferred option.

With this code/idea, you can create these interfaces with pure VB code and without using any TLBs. If you're not the type that enjoys low-level coding, run away now, don't look back, just keep running ;)

This is pretty low-level stuff. The code creates a memory only VTable and thunks for the interface methods. But in order to do this, YOU have to research the interface. You need to know the IID (GUID) and the order of the methods in the interface (not the order posted on MSDN). Then you have to create each of the interface's methods as VB functions. Honestly, it's not that bad after you've done a few of them. I can generally whip up a working sample in about 5-10 minutes after I've found the IID and VTable order. MSDN is extremely useful in describing each method's parameters & return values.

FYI: IID is only needed should whatever you are passing this interface to asks it to identify itself. You want it to be able to say it is what it is pretending to be. In reality, and depending on what the interface is being used for, it's not often asked. But why risk it. The IID is the easiest thing to find. The VTable order is often more challenging.

Any how. As I said, low level. Because there are no TLBs to access these interfaces, we have to call them by their pointer and VTable function address offsets. Again, pretty easy really with the code provided and knowing the VTable order. But it does take some getting used to. For example, many times you may create or receive pointers to interfaces which you are required to add or remove a reference to. VB does this for us automatically. VB does not help here. You have to know when/if you must up the ref count or release the reference. Code is available to do that for you once you know those answers.

This is in no way an attempt to code without TLBs. However, it is kinda neat to know that you can create a class-only object that can be moved from project to project without requiring a TLB. I think that is about the only true advantage. The disadvantage, obviously, it's harder to do this manually.

That attached zip file has a sample project and the IFauxInterface template. That template has lots of comments, in fact, more comments than code. The sample project's IBindStatusCallback class was created from that template. The form in the project creates a pointer only interface and uses low-level access to manipulate it. Enjoy

Regarding the thunks. No malicious code in there. The thunks basically do this:
- store the stack
- set up the stack for the callback: add the class' object pointer and the parameters
- call the VB class private function
- restore/adjust/pop the stack as needed & set the VB function return address
48 bytes used per thunk, 4 bytes per VTable entry, 8 bytes per Interface pointer

Just another FYI. The VTable and thunk structure used can be visualized with this image. The entire structure is one block of contiguous memory.
Name: vtable.png Views: 6 Size: 17.9 KB

Edited: If you don't see the progress bar dialog before the download finishes. The download was too quick or used cached data. The progress dialog is created in the form. The IBindStatusCallback class is what pushes that progress bar to be updated from the events it sends. What is giving us those progress events is the URLmon.dll via the interface we created from the template.
Attached Images
 
Attached Files
↧

[VB6] Common Dialog Replacement - IFileDialog Vista+ (No TLBs)

January 14, 2015, 7:13 pm
$
0
0
Updated/Revamped a bit: 17 Jan 2015

Attached is a working example of using the IFileDialog interface introduced in Vista. It is the replacement for the common dialog used for opening/saving files and browsing for folders. This code is not compatible with XP and lower. You should ensure your project has needed logic to verify system is Vista or better. This version does not currently support enhancements provided by Win7 and above. I do plan on adding them in the near future. This class-only solution is based off of my project: Creating COM Interfaces without TLBs

The classes are plug & play. No TLB references are required. The main class is the IFileDialog class and can be used-as is. The optional IFileDialogEvents class is provided so that you can receive callbacks while the IFileDialog is displayed. Before Vista, this would have required subclassing the dialog, but Vista provided a way to do this through simple callback events. This optional events class is not required to display the dialog. But that class is required if you want callbacks, wish to filter what is displayed in the dialog, or want to add your own controls to the dialog. That class must be implemented if used. This means adding a line of code in your declarations section: Implements IFileDialogEvents. Lets talk about the three types of events. You can opt to have any of them or none of them.

Each event sent from the class includes a reference to the Dialog, a user-defined key for the instance of the Dialog, and appropriate event-driven parameters. Some events expect an answer back from you. Though all events will be added when you Implement the class, you only have to code for the ones you asked for & want to respond to.

1. Standard Callback Events. The IFileDialog can forward events to whatever is displaying the dialog. The most common events are: DialogOnInit, OnFolderChanging, OnSelectionChange, OnFieOk. The OnFileOk event occurs just before the user is about to close the dialog and offers you a chance to prevent closing the dialog and/or cache any custom control properties set by the user while the dialog was displayed. The OnFolderChanging event offers you a way to prevent the user from navigating to what they clicked on. There are a few other events that are forwarded and can be reviewed on MSDN. Note: DialogOnInit is a custom event the class sends. It is intended for you to finalize any custom controls you may have added, i.e., setting an option button, selecting a combobox item, etc, before the dialog is displayed. Any actions you take will not be forwarded back through events until DialogOnInit returns. Should you need to actually subclass the dialog, you can do it at this time since the hWnd of the dialog is known.

2. Filter Events. We all know we can assign filters to a file dialog like *.exe, *.txt, *.dll, etc. The dialog offers a more advanced filter where you can individually choose whether what is returned during navigation is actually displayed. When the filter is active, Windows sends you, one by one, every item that would be displayed. You can opt to say yes or no. Note: This was deprecated in Win7 & may not be added back.

3. Custom Control Events. You have the option to add controls to the dialog. These include combo/check/text boxes, option/command buttons, labels, & menu-like controls. There is little point in adding controls if you have no way of knowing if the user is clicking on them. So the dialog can send you some events. However, these events are lacking in my opinion. They do offer basic stuff, like something was clicked, something was selected, but little else. Any added textbox controls, for example, have no events passed. There are no got/lost focus events for the controls. Locating these controls for manual subclassing will be a challenge.

Here's the gotcha. As mentioned, this is not compatible with anything lower than Vista. But you also must get outside of your comfort zone a bit too. Where the older common dialog returned file & folder names, this new version returns objects as IShellItems and IShellItemArrays (when multi-selecting items). That's really not a bad thing. Not only can you have these items give you the file/folder name and 'display' name, you can ask it to give you that name as plain text or as a URL or a few other formats. You can have it give you file attributes of the object. Since no TLBs are used, the IFileDialog class has methods that will allow you to query the returned object for those things.

What I don't like about this new implementation of the dialog? The folder browsing is too limited in my opinion. The older version allowed several flags to restrict what was displayed. This new version has very little options for folders. Win7 added the ability to restrict browsing to the local domain, but other than that, not much. The lack of options from previous version lends to possibility of needing custom filters (#2 above). Additionally, the previous version allowed files to be displayed with folders when browsing for folders. The new version doesn't have that ability. Matter of learning to adjust I guess, but I feel code for the older version of folder browsing may still be worth keeping around.

These classes don't have all the dummy-proofing I tend to add in. It's a work-in-progress. But it is important you become familiar with it before attempting to use it for any serious projects. And come back occasionally to look for updates.

What advantage does this have over TLBs? Only one I can think of: can create a class that can be added to any project without needing to carry over TLBs into the target application.

The sample project does not touch all the properties the IFileDialog class offers. Explore a bit.
Attached Files
↧

[VB6] Using the new IFileDialog interface for customizable Open/Save (TLB, Vista+)

January 17, 2015, 2:12 am
$
0
0
LaVolpe put out an excellent class module that implements these interfaces, but I've been working on using them through a different approach for some time and wanted to post it as well since, while requiring a TLB, it offers advantages like having IShellItem as a declarable type used all over projects, interfaces, and APIs.

IFileDialog / IFileOpenDialog / IFileSaveDialog

IFileSaveDialog and IFileOpenDialog were introduced in Windows Vista to supersede the GetOpenFileName/GetSaveFileName API, and offer several advantages (although certainly some drawbacks). Windows provides a default implementation, so they're fairly easy to use in VB. Among the advantages is easy addition of custom controls, something that was not previously possible in VB (or at least so hard no one bothered).

The typelib:
This project uses oleexp.tlb, which is my own expansion of olelib.tlb. Originally I just had a modified olelib, but now for compatibility reasons I've split off my additions so that there's minimal changes to olelib to maximize compatibility. See the olechanges.txt file for details. This project MIGHT work with an unmodified olelib.tlb since it doesn't use any of the changed interfaces, but I strongly advise using my upgraded olelib, as the only code-breaking changes are turning a few subs into functions since the return value is important (and only on IShellFolder/2 and IEnumIDList).
Full source code for both the upgraded olelib.tlb and oleexp.tlb is included and can be compiled into a hash-identical copy with VS6.0's MKTYPLIB.
This project uses oleexp.tlb version 1.1, if you have an earlier version from my other projects please upgrade it (fully backwards compatible, no code changes to other projects will be needed).

IShellItem:
For modern Windows, IShellItem is becoming more and more important. This project will familiarize you with using this object. The typelib based approach to this offers the advantage of being able to use IShellItem and related types project-wide, and pass them around easily, both within the project and to APIs and interfaces that use them. The sample project has helper functions that show how to create and manipulate IShellItem and related functions.
--

The attached ZIP includes olelib and oleexp, as well as a sample project illustrating the use of the dialogs. There's examples for a very simple Open, a typical Open dialog, a simple Save dialog, a multi-file-open dialog, and a highly customized open dialog.

In Your Own Project
To use IFileDialog-based Open/Save, your project needs to add a reference to olelib and oleexp. cFileDialogEvents.cls is required only if you want to receive feedback while the dialog is open (including from added custom controls).

-----------------------------------
Here's how simple a basic Open File dialog is with this tlb:

Code:
Dim fodSimple As FileOpenDialog
Dim isiRes As IShellItem
Dim lPtr As Long

Set fodSimple = New FileOpenDialog

With fodSimple
    .SetTitle "Simple File Open"
    .Show Me.hWnd
   
    .GetResult isiRes
    isiRes.GetDisplayName SIGDN_FILESYSPATH, lPtr
    Text1.Text = BStrFromLPWStr(lPtr, True)
End With
Set isiRes = Nothing
Set fodSimple = Nothing
That's all it takes to get the very simplest Open File dialog going, and shows how the class is used.

Events
While previously subclassing was required to receive event notifications while the dialog was displayed, this is now accomplished simply by adding the optional cFileDialogEvents class and calling the .Advise method.
This same class also receives events from any custom controls added.

Customization
I thought that even with this approach, it was going to be hard. But the class is set up to make this a very easy process.
To add a simple label and a button,
Code:

Dim fdc As IFileDialogCustomize
Set fdc = pDlg 'pDlg is the FileOpenDialog object

pDlg.Advise cFDE, 0 'the events class

fdc.AddText 1000, "This is a test label."
fdc.AddPushButton 1001, "New Button"
With that, the events class will have its OnButtonClicked method called when its clicked.


Here's the full sample code that produces the dialog in the above screenshot:

Code:
On Error Resume Next 'A major error is thrown when the user cancels the dialog box
List1.Clear
Dim isiRes As IShellItem

Dim isiDef As IShellItem 'default folder
Dim FOLDERID_Pictures As UUID
Dim pidlDef As Long

Dim lPtr As Long
Dim lOptions As FILEOPENDIALOGOPTIONS

'Set up filter
Dim FileFilter() As COMDLG_FILTERSPEC
ReDim FileFilter(1)

FileFilter(0).pszName = "Image Files"
FileFilter(0).pszSpec = "*.jpg;*.gif;*.bmp"

FileFilter(1).pszName = "All Files"
FileFilter(1).pszSpec = "*.*"

'set up default folder: note that this only shows the very first time
'                      after that, the last directory is default
'                      automatically. override with SetFolder.
Call CLSIDFromString(StrPtr(fidPictures), FOLDERID_Pictures)
Call SHGetKnownFolderIDList(FOLDERID_Pictures, 0, 0, pidlDef)
If pidlDef Then
    Call SHCreateShellItem(0, 0, pidlDef, isiDef)
End If

Set fod = New FileOpenDialog
Set cEvents = New cFileDialogEvents

With fod
    .Advise cEvents, 0
    .SetTitle "Select Thine File Sir"
    .GetOptions lOptions
    lOptions = lOptions Or FOS_FILEMUSTEXIST Or FOS_FORCESHOWHIDDEN 'just an example of options... shows hidden files even if they're normally not shown
    .SetOptions lOptions
    .SetOkButtonLabel "Mine File"
    .SetFileNameLabel "Look! A custom file label!!!"
   
    If (isiDef Is Nothing) = False Then
        .SetFolder isiDef
    End If
    .SetFileTypes 2, VarPtr(FileFilter(0).pszName)
   
    'Now we'll begin adding custom controls
    'First, we set up the interface
    'The control IDs can be any number, and should
    'really be stored as consts
    Set fdc = fod
   
    fdc.AddText 1000, "This is a test label."
   
    fdc.AddPushButton 1001, "New Button"
    fdc.MakeProminent 1001 'Moves to by the open button; only checkboxes, buttons, combos, menus can be made prominent
   
    fdc.AddPushButton 1002, "Some Other Button"
   
    fdc.StartVisualGroup 2000, "VG-1"
    fdc.AddCheckButton 2001, "Checkers!", 1
    fdc.AddSeparator 2002
    'For menus, and radio buttons/combos, first you add the control, then add items with AddControlItem
    fdc.AddMenu 2010, "Checkers?"
    fdc.AddControlItem 2010, 3000, "Pretty good."
    fdc.AddControlItem 2010, 3001, "Pretty bad."
    fdc.AddControlItem 2010, 3002, "Neutral!"
    fdc.AddEditBox 2003, "Other."
    fdc.EndVisualGroup
   
    fdc.StartVisualGroup 4000, "Radio station?"
    fdc.AddRadioButtonList 4001
    fdc.AddControlItem 4001, 4010, "Radio Station Alpha"
    fdc.AddControlItem 4001, 4011, "Radio Station Beta"
    fdc.EndVisualGroup
   
    fdc.AddComboBox 5000
    fdc.AddControlItem 5000, 5010, "Combo Alpha"
    fdc.AddControlItem 5000, 5011, "Combo Beta"
    fdc.AddControlItem 5000, 5012, "Combo Gamma"
    fdc.SetSelectedControlItem 5000, 5011


    .Show Me.hWnd
   
    .GetResult isiRes
    isiRes.GetDisplayName SIGDN_FILESYSPATH, lPtr
    Text1.Text = BStrFromLPWStr(lPtr, True)
End With
   
If pidlDef Then Call CoTaskMemFree(pidlDef)
Set isiRes = Nothing
Set isiDef = Nothing
Set fod = Nothing
Attached Files
↧
↧

[VB6] Modern Shell Interface Type Library - oleexp.tlb

January 17, 2015, 8:58 pm
$
0
0
oleexp.tlb : Modern Shell Interfaces
Current Version: 1.3
Previously the latest version of this sub-project was just included in whatever code I released that depended on it, but now I'm going to make it stand as individual project.

So back in the day, E. Morcillo released the very comprehensive interface library olelib.tlb (Edanmo's OLE interfaces & functions). It contained a massive number of interfaces, enums, structs, etc. But after a point it was no longer updated and thus doesn't have any interfaces from Windows Vista or Windows 7. So I set out to bring these interfaces to VB, and quickly realized that so much would have to be duplicated and would then be conflicting, that the only sensible way to approach this would be to create an expansion library based on olelib.

I've kept it as a separate type library, oleexp.tlb, and made minimal changes to the original olelib.tlb to maximize compatibility, although some changes were needed that may require minor code changes (including oleexp as a reference, turning subs into functions). I'll elaborate on these more below.

New Interfaces
Interfaces added by oleexp (v1.3):
interface IEnumIDList;
interface IShellFolder;
interface IShellFolder2;
interface ITaskbarList3;
interface ITaskbarList4;
interface IShellItem;
interface IShellItem2;
interface IShellItemImageFactory;
interface IThumbnailProvider;
interface IEnumShellItems;
interface IShellItemArray;
interface IShellLibrary;
interface IObjectWithPropertyKey;
interface IPropertyChange;
interface IPropertyChangeArray;
interface IProgressDialog;
interface IOperationsProgressDialog;
interface IFileOperationProgressSink;
interface IFileOperation;
interface IContextMenu3;
interface IPropertyStore;
interface IObjectArray;*
interface IObjectCollection;*
interface IApplicationDestinations;*
interface ICustomDestinationsList;*
interface IModalWindow;
interface IFileDialogEvents;
interface IShellItemFilter;
interface IFileDialog;
interface IFileSaveDialog;
interface IFileOpenDialog;
interface IFileDialogCustomize;
interface IFileDialogControlEvents;
interface IFileDialog2;
interface IPropertyDescriptionList;

All related structures and enums are also included.

* - Under development; may not bee 100% error free

Sample Projects

[VB6] Use IFileOperation to replace SHFileOperation for modern Copy/Move box/prompts - Also shows usage of IShellItem; now updated to show the Advise method in action- using a class module to implement an interface to get feedback: Have the shell progress dialog (now more detailed) send the operation progress back to your application.

[VB6] Using the new IFileDialog interface for customizable Open/Save (TLB, Vista+) - Has the benefit of allowing easy access to events from the dialog, as well as making it very easy to add your own controls.

[VB6] Working with Libraries (Win7+) - Uses the IShellLibrary interface to get all folders in a library, add more, get the default save location, get the icon, and even create a new library. Also shows the use of IEnumShellItems and IShellItemArray.

...more to come soon!

Changes to olelib.tlb
(olelib v1.9)
-Had to eliminate coclass pointing to ITaskBarList to reassign it to the new ITaskbarList3/4 interfaces; since the CLSID can't be changed, even a new coclass name would result to limiting the new one to the functions of the first.

-IShellFolder, IShellFolder2, and IEnumIDList are not implemented correctly in olelib (some things should be functions instead of subs), so oleexp contains new definitions and they have been removed from olelib. They remain commented out in the source if for some reason you had code depending on the wrong definitions. Any projects using this would now have to include oleexp.

-Included shell32.dll declares and the IFolderFilter interface have been moved to oleexp.tlb. If you're using these in another project you must now include oleexp.tlb in them.

Included in the ZIP
-oleexp.tlb, v1.3
-olelib.tlb, v1.9
-olelib2.tlb and source - Nothing modified from original release; all original files
-Full source for both oleexp and the updated olelib, can be compiled to identical hashes with VS6 MKTYPLIB.
-The originals of source files modified in olelib
-mk.bat and mkex.bat - shortcuts to compile olelib.tlb and oleexp.tlb, respectively. May need to modify if VS6 MKTYPLIB is not in default directory on your system.

------------------------------
Any and all feedback is welcome. Many thanks to E. Morcillo for the olelib foundation, all the olelib source is all his code.
Attached Files
↧

[VB6] Win7 Taskbar Features with ITaskbarList3 (overlay, progress in taskbar, etc)

January 19, 2015, 5:19 am
$
0
0
ITaskbarList Demo

Windows 7 introduced the ITaskbarList3 and ITaskbarList4 interfaces that added a number of new features to the taskbar for your program. The most commonly seen is the ability to turn the taskbar into a progress bar, and there's also the ability to add an overlay icon, add buttons below the thumbnail, and change the area the thumbnail covers among others. Like many other shell interfaces, it's available to VB either through type libraries or by directly calling the vtable. I prefer the former approach since many times internal structures and interfaces have far wider uses, so they can be put in the TLB and be accessible everywhere, not just within a class.

This project uses oleexp.tlb, my Modern Shell Interfaces expansion of Edanmo's olelib.tlb. The latest version is included in the ZIP; once you've extracted everything, in the sample project, go to References and update the paths. If you already work with olelib, the included olelib.tlb is a higher version that should replace that one. There's a few minor changes, but nothing major- just a few things moved to oleexp and 3 interfaces had some of their subs turned into functions. See the oleexp thread in the link above for complete details. If you're already using oleexp.tlb, make sure you have at least the version included here (dated 1/18/15).


Using ITaskbarList

Usage is fairly simple; you generally want to use it as a module level variable in your main form;

Code:
Private iTBL As TaskbarList

'...then in form_load:

Set iTBL = New TaskbarList
From there you can begin calling its functions, most of which are very straightforward:
Code:
    iTBL.SetOverlayIcon Me.hWnd, hIcoOvr, "Overlay icon active."
    iTBL.SetProgressState Me.hWnd, TBPF_INDETERMINATE 'marquee
    iTBL.SetThumbnailTooltip Me.hWnd, Text1.Text
    iTBL.SetThumbnailClip Me.hWnd, [rect]
The only thing a little complicated is the buttons.

Code:
Dim pButtons() As THUMBBUTTON
ReDim pButtons(2) 'basic 3-button setup

arIcon(0) = ResIconToHICON("ICO_LEFT", 32, 32)
arIcon(1) = ResIconToHICON("ICO_UP", 32, 32)
arIcon(2) = ResIconToHICON("ICO_RIGHT", 32, 32)

Call SubClass(Me.hWnd, AddressOf F1WndProc)

With pButtons(0)
    .dwMask = THB_FLAGS Or THB_TOOLTIP Or THB_ICON
    .iid = 100
    .dwFlags = THBF_ENABLED
    Call Str2Inta("Stop", pInt)
    For i = 0 To 259
        .szTip(i) = pInt(i) 'this doesn't seem to be working... will address in a future release
    Next i
    .hIcon = arIcon(0)
End With

[fill in the other buttons]

iTBL.ThumbBarAddButtons Me.hWnd, 3, VarPtr(pButtons(0))

Icons
The TaskbarList interface deals with hIcons; in the sample project, they're stored in a resource file and loaded from there, but you could load them from anywhere with any method that will give you a valid hIcon.

Subclassing
The only thing that requires subclassing is receiving notification when a user clicks on a button below the thumbnail. If you're not going to be using that feature, then you won't need to subclass. The sample project does include a very simple subclassing module that receives the WM_COMMAND message that's sent when a button is clicked, and passes the ID of the button (the LoWord of the wParam) back to the main form.
Attached Files
↧

HSV and RGB conversion

January 19, 2015, 5:13 pm
$
0
0
Here's some code I wrote that you can place in a Module and use in any graphics program that needs to convert RGB to HSV or HSV to RGB.

Code:
Public Sub RGBtoHSV(ByVal R As Byte, ByVal G As Byte, ByVal B As Byte, _
                    ByRef H As Byte, ByRef S As Byte, ByRef V As Byte)
Dim MinVal As Byte
Dim MaxVal As Byte
Dim Chroma As Byte
Dim TempH As Single
If R > G Then MaxVal = R Else MaxVal = G
If B > MaxVal Then MaxVal = B
If R < G Then MinVal = R Else MinVal = G
If B < MinVal Then MinVal = B
Chroma = MaxVal - MinVal

V = MaxVal
If MaxVal = 0 Then S = 0 Else S = Chroma / MaxVal * 255

If Chroma = 0 Then
    H = 0
Else
    Select Case MaxVal
        Case R
            TempH = (1& * G - B) / Chroma
            If TempH < 0 Then TempH = TempH + 6
            H = TempH / 6 * 255
        Case G
            H = (((1& * B - R) / Chroma) + 2) / 6 * 255
        Case B
            H = (((1& * R - G) / Chroma) + 4) / 6 * 255
    End Select
End If
End Sub
                   


Public Sub HSVtoRGB(ByVal H As Byte, ByVal S As Byte, ByVal V As Byte, _
                    ByRef R As Byte, ByRef G As Byte, ByRef B As Byte)
Dim MinVal As Byte
Dim MaxVal As Byte
Dim Chroma As Byte
Dim TempH As Single

If V = 0 Then
    R = 0
    G = 0
    B = 0
Else
    If S = 0 Then
        R = V
        G = V
        B = V
    Else
        MaxVal = V
        Chroma = S / 255 * MaxVal
        MinVal = MaxVal - Chroma
        Select Case H
            Case Is >= 170
                TempH = (H - 170) / 43
                If TempH < 1 Then
                    B = MaxVal
                    R = MaxVal * TempH
                Else
                    R = MaxVal
                    B = MaxVal * (2 - TempH)
                End If
                G = 0
            Case Is >= 85
                TempH = (H - 85) / 43
                If TempH < 1 Then
                    G = MaxVal
                    B = MaxVal * TempH
                Else
                    B = MaxVal
                    G = MaxVal * (2 - TempH)
                End If
                R = 0
            Case Else
                TempH = H / 43
                If TempH < 1 Then
                    R = MaxVal
                    G = MaxVal * TempH
                Else
                    G = MaxVal
                    R = MaxVal * (2 - TempH)
                End If
                B = 0
        End Select
        R = R / MaxVal * (MaxVal - MinVal) + MinVal
        G = G / MaxVal * (MaxVal - MinVal) + MinVal
        B = B / MaxVal * (MaxVal - MinVal) + MinVal
    End If
End If
End Sub
↧
Search

VB6 QR-Encoding+Decoding and IME-Window-Positioning

January 23, 2015, 7:38 pm
$
0
0
This Demo depends on vbRichClient5 (version 5.0.21 and higher), as well as the latest vbWidgets.dll.
One can download both new packages from the Download-page at: http://vbrichclient.com/#/en/Downloads.htm
(vbWidgets.dll needs to be extracted from the GitHub-Download-Zip and placed beside vbRichClient5.dll,
there's small "RegisterInPlace-Scripts" for both Dll-Binaries now).

After both dependencies were installed, one can load the below Demo-Project into the VB-IDE:
QRandIMEDemo.zip

According to the Title of this Thread, we try to show the:

Free positioning of an IME-Window:
delegating its IME_Char-Messages into free choosable Widget-controls (the Demo does
that against cwTextBox-Widgets exclusively - but could accomplish that also against cwLabels
or cwImages.

Here is the interesting part (the IME-API-Declarations and Wrapper-Functions are left out),
which is contained in the new cIME-Class (available in the Code-Download from the vbWidgets-GitHub-Repo):

Code:
'RC5-SubClasser-Handler
Private Sub SC_WindowProc(Result As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long)
Const WM_IME_SETCONTEXT = 641, WM_IME_STARTCOMPOSITION = 269, WM_IME_CHAR = 646
On Error GoTo 1

  Select Case Msg
      Case WM_IME_SETCONTEXT
        SwitchOpenStatus wParam
       
      Case WM_IME_STARTCOMPOSITION
        HandleIMEPos
     
      Case WM_IME_CHAR
        Dim WFoc As cWidgetBase, KeyCode As Integer
        Set WFoc = FocusedWidget: KeyCode = CInt("&H" & Hex(wParam And &HFFFF&))
        If Not WFoc Is Nothing Then
          If WFoc.Key = tmrFoc.Tag Then RaiseEvent HandleIMEChar(WFoc, KeyCode, ChrW(KeyCode))
        End If
        Exit Sub 'handled ourselves - so we skip the default message-handler at the end of this function
  End Select
 
1: Result = SC.CallWindowProc(Msg, wParam, lParam)
End Sub
 
Private Sub tmrFoc_Timer()
  HandleIMEPos
End Sub

Private Function FocusedWidget() As cWidgetBase
  If Cairo.WidgetForms.Exists(hWnd) Then Set FocusedWidget = Cairo.WidgetForms(hWnd).WidgetRoot.ActiveWidget
End Function

Private Sub HandleIMEPos()
Dim WFoc As cWidgetBase, AllowIME As Boolean
On Error GoTo 1

  Set WFoc = FocusedWidget
  If WFoc Is Nothing Then
    tmrFoc.Tag = ""
  Else
    RaiseEvent HandleIMEPositioning(WFoc, AllowIME)
    If AllowIME Then tmrFoc.Tag = WFoc.Key
  End If
 
1: SwitchOpenStatus AllowIME
End Sub
As one can see, this Class is (currently) only raising two Events to the outside -
received by a hosting (RC5) cWidgetForm-Class.

The elsewhere mentioned problems with "forcibly ANSIed" IME-WChars do not happen in
this Demo, because of a "full queue of W-capable APIs" (including a W-capable MessageLoop,
which is available in the RC5 per Cairo.WidgetForms.EnterMessageLoop...

The Integration of an RC5-cWidgetForm into an existing VB6-Project is relative easy (no need
to rewrite everything you have) - this Demo shows how one can accomplish that, by showing
the RC5-Form modally - starting from a normal VB-Form-CommandButton:

Here's all the code in the normal VB6-Starter-Form, which accomplishes that:
Code:
Option Explicit

Private VBFormAlreadyUnloaded As Boolean

Private Sub cmdShowRC5IMEForm_Click()
  With New cfQRandIME ' instantiate the RC5-FormHosting-Class
 
    .Form.Show , Me 'this will create and show the RC5-Form with the VB-Form as the underlying Parent
   
    'now we enter the W-capable RC5-message-pump, which will loop "in  place" till the RC5-Form gets closed again
    Cairo.WidgetForms.EnterMessageLoop True, False
 
    'the RC5-Form was closed, so let's read-out the Public Vars of its hosting cf-Class
    If Not VBFormAlreadyUnloaded Then '<- ... read the comment in Form_Unload, on why we need to check this flag
      Set Picture1.Picture = .QR1.QRSrf.Picture
      Set Picture2.Picture = .QR2.QRSrf.Picture
    End If
  End With
End Sub

Private Sub Form_Unload(Cancel As Integer) 'this can happen whilst the RC5-ChildForm is showing, ...
  VBFormAlreadyUnloaded = True  'so we set a Flag, to not implicitely load this VB-ParentForm again, when filling the Result-PicBoxes
End Sub

Private Sub Form_Terminate() 'the usual RC5-cleanup call (when the last VB-Form was going out of scope)
  If Forms.Count = 0 Then New_c.CleanupRichClientDll
End Sub
The above Starter-Form (fMain.frm) will look this way


And pressing the CommandButton, it will produce the modal RC5-WidgetForm:


What one can see above is two (cwTextBox-based) Edit-Widgets - and the left one
is showing the free positioned IME-Window - the IME-Window (when visible), will
jump automatically, as soon as the user switches the Input-Focus to a different Widget.

To test this in a bit more extreme scenario even, I've made the two cwQRSimple-Widgets
(in the lower section of the Form) movable - and in case the IME-Window is shown
below one of them as in this ScreenShot:


... the IME-Window will follow the currently focused QR-Widget around, when it's dragged
with the Mouse...

Here's the complete code of the cfQRandIME.cls (which hosts the RC5-cWidgetForm-instance):
Code:
Option Explicit

Public WithEvents Form As cWidgetForm, WithEvents IME As cIME

Public QREnc As New cQREncode, QRDec As New cQRDecode 'the two (non-visible) QR-CodecClass-Vars
Public TB1 As cwTBoxWrap, TB2 As cwTBoxWrap 'the two TextBox-Wrapper-Classes
Public QR1 As cwQRSimple, QR2 As cwQRSimple 'the two QR-Widgets
 
Private Sub Class_Initialize()
  Set Form = Cairo.WidgetForms.Create(vbFixedDialog, "QR-Widgets and IME-Window-Positioning", , 800, 600)
      Form.IconImageKey = "QRico2"
      Form.WidgetRoot.ImageKey = "bgPatForm"
      Form.WidgetRoot.ImageKeyRenderBehaviour = ImgKeyRenderRepeat
     
  Set IME = New cIME 'create the vbWidgets.cIME-instance
      IME.BindToForm Form '...and bind our cWidgetForm-instance to it (IME will throw two Events at us then)
End Sub

Private Sub Form_Load() 'handle Widget-Creation and -Adding on this Form
  Form.Widgets.Add(New cwSeparatorLabel, "Sep1", 11, 8, Form.ScaleWidth - 22, 42).SetCaptionAndImageKey "EditBox-DemoArea", "Edit", &H11AA66
    Set TB1 = Form.Widgets.Add(New cwTBoxWrap, "TB1", 25, 60, 280, 38)
        TB1.TBox.CueBannerText = "Session-Login..."
        TB1.Widget.ImageKey = "session1"
    Set TB2 = Form.Widgets.Add(New cwTBoxWrap, "TB2", 325, 60, 280, 38)
        TB2.TBox.CueBannerText = "Place some Info here..."
        TB2.Widget.ImageKey = "info1"
     
  Form.Widgets.Add(New cwSeparatorLabel, "Sep2", 11, 155, Form.ScaleWidth - 22, 42).SetCaptionAndImageKey "QRCode-DemoArea", "Preview", &H1030EE
    Set QR1 = Form.Widgets.Add(New cwQRSimple, "QR1", 25, 240, 250, 220)
    Set QR2 = Form.Widgets.Add(New cwQRSimple, "QR2", 325, 280, 250, 220)
End Sub

Private Sub Form_BubblingEvent(Sender As Object, EventName As String, P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant, P5 As Variant, P6 As Variant, P7 As Variant)
  If EventName = "Change" And TypeOf Sender Is cwTextBox Then 'we handle the Change-Event of the QRWidget-Child-Textboxes here
    If Not (Sender Is QR1.TBox Or Sender Is QR2.TBox) Then Exit Sub
   
    'resolve to the (TextBox-Hosting) cwQRSimple-Widget in question
    Dim QR As cwQRSimple: Set QR = IIf(Sender Is QR1.TBox, QR1, QR2)
   
    'Encode the current Text of our QR-Widget - and place the returned Pixel-Surface in QR.QRSrf
    Set QR.QRSrf = QREnc.QREncode(New_c.Crypt.VBStringToUTF8(QR.Text))
 
    'to verify, we perform a true Decoding of the QR-Text from the Pixels of the just created QR-Widgets QR-Surface
    QRDec.DecodeFromSurface QR.QRSrf
    'and reflect this decoded Unicode-StringResult in the Caption of the QR-Widget (so, ideally QR.Caption should match QR.Text)
    If QRDec.QRDataLen(0) Then QR.Caption = New_c.Crypt.UTF8ToVBString(QRDec.QRData(0)) Else QR.Caption = ""
  End If
 
  'the QR-Widgets (cwQRSimple) are moveable - and in case they have an active IME-Window, we will move that too
  If EventName = "W_Moving" And TypeOf Sender Is cwQRSimple Then IME_HandleIMEPositioning Sender.TBox.Widget, True
End Sub

Private Sub IME_HandleIMEPositioning(FocusedWidget As cWidgetBase, AllowIME As Boolean)
  If TypeOf FocusedWidget.Object Is cwTextBox Then
    AllowIME = True '<- here we allow IME-Windows only for cwTextBox-Widgets (but we could also allow IME on other Widget-Types)
    IME.SetPosition FocusedWidget.AbsLeftPxl + 3, FocusedWidget.AbsTopPxl + FocusedWidget.ScaleHeightPxl + 4
  End If
End Sub

Private Sub IME_HandleIMEChar(FocusedWidget As cWidgetBase, ByVal IMEKeyCode As Integer, IMEWChar As String)
  FocusedWidget.KeyPress IMEKeyCode 'simply delegate the incoming IMEKeyCode into the Widget in question
  'the above is the more generic delegation-method into any Widget (which are all derived from cWidgetBase)
 
  '*alternatively* (for cwTextBoxes, which is the only Widget-Type we allow IME for in this Demo here)
  'we could also use:
'  Dim TB As cwTextBox
'  Set TB = FocusedWidget.Object
'      TB.SelText = IMEWChar
End Sub
Note the two blue marked EventHandlers at the bottom of the above code-section, which
make use of the two cIME-Events, which were mentioned at the top of this posting.


QR-Code Generation and Decoding:

The base QR-Encoding/Decoding-support is now included in vb_cairo_sqlite.dll (from two C-libs which are now statically contained).
And the vbWidgets.dll project contains the two Wrapper-Classes (cQREncode, cQRDecode) for these new exposed APIs.

cQREncode/cQRDecode is used in conjunction with thrown Change-Events of our cwQRSimple-Widgets
(which you saw in the ScreenShot above).

Here's the central Eventhandler which is contained in the RC5-WidgetForm-Hosting Class (cfQrandIME):
Code:
Private Sub Form_BubblingEvent(Sender As Object, EventName As String, P1, P2, P3, P4, P5, P6, P7)
  If EventName = "Change" And TypeOf Sender Is cwTextBox Then 'we handle the Change-Event of the QRWidget-Child-Textboxes here
    If Not (Sender Is QR1.TBox Or Sender Is QR2.TBox) Then Exit Sub
   
    'resolve to the (TextBox-Hosting) cwQRSimple-Widget in question
    Dim QR As cwQRSimple: Set QR = IIf(Sender Is QR1.TBox, QR1, QR2)
   
  'Encode the current Text of our QR-Widget - and place the returned Pixel-Surface in QR.QRSrf
    Set QR.QRSrf = QREnc.QREncode(New_c.Crypt.VBStringToUTF8(QR.Text))
 
    'to verify, we perform a true Decoding of the QR-Text from the Pixels of the just created QR-Widgets QR-Surface
    QRDec.DecodeFromSurface QR.QRSrf
    'and reflect this decoded Unicode-StringResult in the Caption of the QR-Widget (so, ideally QR.Caption should match QR.Text)
    If QRDec.QRDataLen(0) Then QR.Caption = New_c.Crypt.UTF8ToVBString(QRDec.QRData(0)) Else QR.Caption = ""
  End If
 
  'the QR-Widgets (cwQRSimple) are moveable - and in case they have an active IME-Window, we will move that too
  If EventName = "W_Moving" And TypeOf Sender Is cwQRSimple Then IME_HandleIMEPositioning Sender.TBox.Widget, True
End Sub
So that's quite simple as far as QR-codes are concerned (because of the Bubbling-Event-mechanism of the
RC5-WidgetEngine - but also due to the quite powerful Cairo-ImageSurface-Objects, which are used in the
cQREncode/Decode-classes to transport the encoded (or to be decoded) Pixel-Information.

From a cCairoSurface it is possible, to write to PNG-, or JPG-ByteArrays or -Files at any time,
so exporting of the QR-Code-Images is not covered by this Demo - but would require only
a line of Code or two, in concrete adaptions of the above example.

Have fun,

Olaf
Attached Files
↧
↧

WebBrowser GET method hook

January 27, 2015, 12:48 am
$
0
0
Hi, i'm trying to hook the all GET query method during the page loading. but what i know is that 'BeforeNavigate' method for the first url query. i mean as soon as i hit the specific url which is include couple of urls, frams and script pages. so, i want to modify that url at my own parameters. any ideas ? thanks in advance.

Cheers.
↧

[VB6] Virtual 5.0 ListView

January 27, 2015, 9:03 am
$
0
0
Here is another take on the classic vbVision Virtual ListView from 2001.

It has been substantially reworked to remove the IDE-testing dependency on the old Dbgwproc.dll that most people don't even have installed anymore. This rendition also enables item icons and indenting, minor enough features but easy enough to implement. You could expand this to add column header sort indicators or other features.

This is a UserControl wrapper for the 5.0 ListView that shipped with VB5 and VB6. Comments are left to help you try to modify it for the 6.0 ListView, but as written it works with the 5.0 ListView (COMCTL32.OCX). Since the 5.0 ListView can be upgraded to a Common Controls 6.0 ListView using a simple SxS manifest most people do not use the "Visual Basic 6" MSCOMCTL.OCX anymore anyway though.


Virtual ListView?

The idea here is that unlike in default mode where the ListView stores the item and subitem collections, a virtual ListView relies on your program to maintain the underlying datastore. This buys you a couple of things:

  • No data duplication. The ListView only needs copies of the elements currently being displayed. This can save on RAM, especially for large data sets.
  • Fast scrolling and paging. A virtual-mode ListView can be a performance screamer compared to conventional operation over huge data sets. Assuming of course that you can feed it data quickly!


Huge data sets are the main motivation.

Though it is a really poor design practice, some users will insist they need to be able to scroll over entire massive sets of data. What they want is a "giant" grid view of raw data. Since ListView controls work best in report view when in virtual mode, this is the most likely use case for them.

V50ListView is always in report view.


The Demo

The demo offered here goes beyond that of the 2001 original by showing use with an ADO Recordset returned from a Jet SQL query.

To demonstrate what can be done there are a few silly things shown in it. An item icon is used based on the data in each row, here a happy or sad face is displayed depending on whether a "sale" row was "returned" or not. Every 10th row is indented merely for demo purposes.

This demo project will construct a demo database to use with just one table of 100,000 rows. Because it attempts to make "real looking" data it grinds a bit and can take 30 to 45 seconds to do this step, but the database will be reused on subsequent runs. You can also interrupt database creation and just go on from the point of interruption using the rows written at that point.

You can change a constant at the top of Form1 to create a larger database (500,000 or 1,000,000 rows) but you'll have to wait a little longer.

Name: sshot1.png Views: 43 Size: 29.8 KB

Once the ListView is "populated" you can scroll it, use the End, Home, Page UP, Page Down, etc. and see how quickly it can move through the data.

I have also tried a modified version with two V50ListView controls on one form to make sure there are no subclassing collisions, and it seems to work fine:

Name: sshot2.png Views: 34 Size: 29.2 KB


Using V50ListView

In the attached archive the V50ListView folder contains the pieces necessary:

  • V50LVSubclasser.bas
  • V50ListView.ctl
  • V50ListView.ctx


Copy those 3 files to your own Project's folder to use them, then add the two modules. There is also a resources subfolder there that holds the V50ListView's ToolBoxBitmap image, but of course that's already embedded in the .ctx file so your new Project doesn't really need it.

In order to detect whether it is running at design-time early enough a small hack is also needed. You can put this into your Project's startup Form:

Code:
Private Sub Form_Initialize()
    V50LVSubclasser.UserMode = True
End Sub
Or if you have a startup Sub Main() you can set this global Boolean there instead.

The ItemDataRequest event and the Items property are key here. Setting Items to the number of rows to be displayed causes V50ListView to start raising the ItemDataRequest event to get data to display.

Hopefully the demo Form1 code is enough to help you see how the ItemDataRequest parameters are used to set text, small icons, and indents.

As it stands you also need to associate the ImageList at runtime if you use small icons. Normally you can do this via the design-time Properties window or the Property Pages of the ListView but I haven't implemented that yet. But most people won't be using many V50ListView controls and often won't need icons anyway. However you can just use something like:

Code:
Private Sub Form_Load()
    Set V50ListView1.SmallIcons = ImageList1
End Sub

Caveats

Any subclassing poses risks during IDE testing. If you wish you could revert to the Dbgwproc.dll technique to make breakpoints a little safer to use.

A good solution might be to move V50ListView into a separate ActiveX Control (OCX) Project and compile it. Then during testing of your main Project use the compiled OCX, and when creating a final production version remove the reference and add the two modules to compile it into the program.


Running the Demo

You might compile it first and run the EXE. This speeds database creation a little bit. ;)

Otherwise it runs fine in the IDE.
Attached Images
  
Attached Files
↧

[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>
↧

[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?
↧
Search

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 StrComp(Key, m_SubclassKeys(CStr(lID)), vbTextCompare) = 0 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()
    SubclassWindow 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
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.
  • Just bumped into SCGI as an alternative to FastCGI. Would it be better to use this protocol?
  • How should we handle the mixed "\" "/" use in CGI parameters like DOCUMENT_ROOT on Windows? For example: DOCUMENT_ROOT = C:\Users\Jason\Downloads\nginx-1.7.9/html. Should I just convert all forward slashes to back slashes?



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?



Pre-Requisites
You must have an Nginx web server instance running and configured for FastCGI on your computer. Nginx can be downloaded from here: http://nginx.org/en/download.html

You must have vbRichClient5 installed on your computer. vbRichClient5 can be downloaded from here: http://www.vbrichclient.com


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: 50 Size: 15.8 KB

The Current Browser Output Showing Unicode>UTF-8 output and the received CGI params:
Name: Response.jpg Views: 40 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
↧

[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 1512 articles
Browse latest View live
Search
<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>