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

modCRC.bas

$
0
0
This is my code for CRC calculating. It calculates CRC32 using the standard polynomial 0x04C11DB7, and also 2 different 16bit CRCs (one uses the standard CRC16 polynomial 0x8005, and the other uses the CCITT polynomial 0x1021). Both the CRC32 and CRC16 functions allow the following parameters to be configured that affect the calculation of the CRC:
InvertInitCRC (if true, the initial CRC value has all 1 bits, otherwise it is has all 0 bits)
MirrorInputBits (if true, the bit order in each byte of input data is reversed before being used to calculate the CRC)
MirrorOutputBits (if true, the order of the bits in the output CRC is reversed, which is a 32bit reversal for CRC32 and a 16bit reversal for CRC16)
InvertFinalCRC (if true, the output bits of the CRC are all inverted, where 1 becomes 0, and 0 becomes 1)

These above parameters are all required parameters in both functions. That is, they must be explicitly set to true or false.

Also, both CRC functions have an optional parameter called SwapOutputBytes. This simply affects the "endianness" of the output CRC (the order in which the CRC's bytes are stored in memory or in a file).

The CRC16 function, has an extra required parameter called UsePolyCCITT. If true, it uses the CCITT polynomial (often used in various communications protocols), which is 0x1021. If false, it uses the standard CRC16 polynomial, which is 0x8005.

Note that for the CRC32 function to perform the standard CRC32 calculation, the 4 required parameters must be set as shown here:
InvertInitCRC = True
MirrorInputBits = True
MirrorInputBits = True
InvertFinalCRC = True

Note that for the CRC16 function to perform the standard CRC16 calculation, the 5 required parameters must be set as shown here:
UsePolyCCITT = False
InvertInitCRC = False
MirrorInputBits = True
MirrorInputBits = True
InvertFinalCRC = False




Here's the complete code for this module. Just copy and paste it into a module in VB6, and then you will be able to use the CRC32 and CRC16 functions from anywhere else in your code.

Code:

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)



Public Function CRC32(ByRef Data() As Byte, _
                      ByVal InvertInitCRC As Boolean, _
                      ByVal MirrorInputBits As Boolean, _
                      ByVal MirrorOutputBits As Boolean, _
                      ByVal InvertFinalCRC As Boolean, _
                      Optional ByVal SwapOutputBytes As Boolean) As Long
                       
Dim ByteNumber As Long
Dim BitNumber As Long
Dim CurrentByte As Long
Dim CRC As Long
Const Poly As Long = &H4C11DB7

If InvertInitCRC Then CRC = &HFFFFFFFF Else CRC = 0

For ByteNumber = 0 To UBound(Data)
    CurrentByte = Data(ByteNumber)
    If MirrorInputBits Then CurrentByte = ReverseBits8(CurrentByte)
    CurrentByte = SwapBytes4(CurrentByte)
    CRC = CRC Xor CurrentByte
    For BitNumber = 0 To 7
        If CRC And &H80000000 Then
            CRC = ShiftLeft32(CRC) Xor Poly
        Else
            CRC = ShiftLeft32(CRC)
        End If
    Next BitNumber
Next ByteNumber
If MirrorOutputBits Then CRC = ReverseBits32(CRC)
If InvertFinalCRC Then CRC = CRC Xor &HFFFFFFFF
If SwapOutputBytes Then CRC = SwapBytes4(CRC)
CRC32 = CRC
End Function



Public Function CRC16(ByRef Data() As Byte, _
                      ByVal UsePolyCCITT As Boolean, _
                      ByVal InvertInitCRC As Boolean, _
                      ByVal MirrorInputBits As Boolean, _
                      ByVal MirrorOutputBits As Boolean, _
                      ByVal InvertFinalCRC As Boolean, _
                      Optional ByVal SwapOutputBytes As Boolean) As Integer
                     
Dim ByteNumber As Long
Dim BitNumber As Long
Dim CurrentByte As Long
Dim CRC As Integer
Dim Poly As Integer
Const PolyStandard As Integer = &H8005
Const PolyCCITT As Integer = &H1021

If UsePolyCCITT Then Poly = PolyCCITT Else Poly = PolyStandard
If InvertInitCRC Then CRC = &HFFFF Else CRC = 0

For ByteNumber = 0 To UBound(Data)
    CurrentByte = Data(ByteNumber)
    If MirrorInputBits Then CurrentByte = ReverseBits8(CurrentByte)
    CurrentByte = SwapBytes2(CurrentByte)
    CRC = CRC Xor CurrentByte
    For BitNumber = 0 To 7
        If CRC And &H8000 Then
            CRC = ShiftLeft16(CRC) Xor Poly
        Else
            CRC = ShiftLeft16(CRC)
        End If
    Next BitNumber
Next ByteNumber
If MirrorOutputBits Then CRC = ReverseBits16(CRC)
If InvertFinalCRC Then CRC = CRC Xor &HFFFF
If SwapOutputBytes Then CRC = SwapBytes2(CRC)
CRC16 = CRC
End Function



Private Function ReverseBits8(ByVal Value As Byte) As Byte
Dim Value2 As Byte
Dim n As Long

Value2 = (Value And 1) * &H80
For n = 1 To 7
    Value2 = Value2 + ShiftLeft32(ShiftRight32(Value, n) And 1, 7 - n)
Next n
ReverseBits8 = Value2
End Function



Private Function ShiftLeft32(ByVal Value As Long, Optional ByVal BitCount As Long = 1) As Long
Dim temp As Currency
Dim temp2 As Long

CopyMemory temp, Value, 4
temp = temp * (2 ^ BitCount)
CopyMemory temp2, temp, 4
ShiftLeft32 = temp2
End Function



Private Function ShiftRight32(ByVal Value As Long, Optional ByVal BitCount As Long = 1) As Long
Dim temp As Currency
Dim temp2 As Long

CopyMemory temp, Value, 4
temp = Int((temp * 10000) / (2 ^ BitCount)) / 10000
CopyMemory temp2, temp, 4
ShiftRight32 = temp2
End Function



Private Function ReverseBits32(ByVal Value As Long) As Long
Dim Value2 As Long
Dim n As Long

Value2 = (Value And 1) * &H80000000
For n = 1 To 31
    Value2 = Value2 + ShiftLeft32(ShiftRight32(Value, n) And 1, 31 - n)
Next n
ReverseBits32 = Value2
End Function



Private Function SwapBytes4(ByVal Value As Long) As Long
Dim Value2 As Long

CopyMemory ByVal VarPtr(Value2) + 0, ByVal VarPtr(Value) + 3, 1
CopyMemory ByVal VarPtr(Value2) + 1, ByVal VarPtr(Value) + 2, 1
CopyMemory ByVal VarPtr(Value2) + 2, ByVal VarPtr(Value) + 1, 1
CopyMemory ByVal VarPtr(Value2) + 3, ByVal VarPtr(Value) + 0, 1
SwapBytes4 = Value2
End Function



Private Function ShiftRight16(ByVal Value As Integer, Optional ByVal BitCount As Long = 1) As Integer
Dim temp As Long
Dim temp2 As Integer

CopyMemory temp, Value, 2
temp = temp \ (2 ^ BitCount)
CopyMemory temp2, temp, 2
ShiftRight16 = temp2
End Function



Private Function ShiftLeft16(ByVal Value As Integer, Optional ByVal BitCount As Long = 1) As Integer
Dim temp As Long
Dim temp2 As Integer

CopyMemory temp, Value, 2
temp = temp * (2 ^ BitCount)
CopyMemory temp2, temp, 2
ShiftLeft16 = temp2
End Function



Private Function ReverseBits16(ByVal Value As Integer) As Integer
Dim Value2 As Integer
Dim n As Long

Value2 = (Value And 1) * &H8000
For n = 1 To 15
    Value2 = Value2 + ShiftLeft32(ShiftRight32(Value, n) And 1, 15 - n)
Next n
ReverseBits16 = Value2
End Function



Private Function SwapBytes2(ByVal Value As Integer) As Integer
Dim Value2 As Integer

CopyMemory ByVal VarPtr(Value2) + 0, ByVal VarPtr(Value) + 1, 1
CopyMemory ByVal VarPtr(Value2) + 1, ByVal VarPtr(Value) + 0, 1
SwapBytes2 = Value2
End Function


[VB6, Vista+] Undocumented ListView feature: Footer items

$
0
0
Ran across this nifty thing on codeproject, and successfully got it working in VB.

Tested and working with 5.0 ListView and API ListView, have not tried with 6.0 ListView and presumably it wouldn't work (Windows Common Controls 5.0 is actually the more modern control due to linkage with the real comctl32.dll, and required for a lot of modern features like this and group view). The items are present and displayed the same way in all views, including tile and group view modes.

This one is a little complicated to set up, but straightforward to use. First, it requires a type library with the undocumented interfaces IListViewFooter and IListViewFooterCallback, then the latter has to be implemented by a class module. From there, more undocumented goodness: LVM_SETIMAGELIST with a wParam of 4 will set the icons used in the footer, and LVM_QUERYINTERFACE retrieves an instance of IListViewFooter.
For the purposes of this code, I'll assume you have a ListView set up already. I use the system imagelist, but you can assign any imagelist (well, api imagelist):

Code:

Public Const IID_IListViewFooter = "{F0034DA8-8A22-4151-8F16-2EBA76565BCC}"
Public Const LVM_QUERYINTERFACE = (LVM_FIRST + 189)
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpszGuid As Long, pGuid As Any) As Long
Public Type GUIDA
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type
Public m_himlSysSmall As Long
Public Function GetFileTypeIconIndex(ext As String) As Long
  Dim sfi As SHFILEINFO
  Dim pidl As Long
If SHGetFileInfo(ext, FILE_ATTRIBUTE_NORMAL, sfi, Len(sfi), SHGFI_SYSICONINDEX Or SHGFI_SMALLICON Or SHGFI_USEFILEATTRIBUTES) Then
    GetFileTypeIconIndex = sfi.iIcon
  End If
End Function

The code to insert items can be placed wherever, but it won't show until there's items in the ListView.
Code:

  m_himlSysSmall = GetSystemImagelist(SHGFI_SMALLICON)
    Call SendMessage(ListView1.hWnd, LVM_SETIMAGELIST, 4, ByVal m_himlSysSmall)

Dim pLVF As IListViewFooter
Dim pFtrCB As cLVFooterCallback
Set pFtrCB = New cLVFooterCallback
Dim iidLVF As GUIDA
Call CLSIDFromString(StrPtr(IID_IListViewFooter), iidLVF)

Call SendMessage(hLVS, LVM_QUERYINTERFACE, VarPtr(iidLVF), pLVF)
If (pLVF Is Nothing) Then
    Debug.Print "Failed to get LV Footer interface"
    Exit Sub
End If
Dim lFtrIco As Long
lFtrIco = GetFileTypeIconIndex(".jpg") 'just an example, it's a standard index for the assigned image list.
With pLVF
    .SetIntroText "Intro text - hello!"
    .InsertButton 0, "Test Item 1", "where does this go", lFtrIco, 2000
    .Show pFtrCB
End With

'2000' - the lParam - has no special meaning, you can store whatever Long you want there.

The attached ZIP contains the typelib, the typelib source code, a batch file to compile it from a standard VS6 install, and the class module implementing the callback. I didn't bother will a full fledged example because presumably anyone interested in this would be adding it onto an already well set-up ListView, but if really needed let me know.

Coming up next in the world of undocumented ListView: subsetted groups (link for "Display all x items"), subitem label editing, and if I'm particularly ambitious.. apparently you can use groups in full virtual mode.
Attached Files

[VB6, Vista+] Undocumented ListView feature: Subsetted Groups (simple, no TLB)

$
0
0

Compatibility: Like other modern features, this should work with API-created ListView's including krools, as well as the 5.0 Common Controls ListView in an IDE and/or compiled EXE manifested for the latest comctl32.dll version; and will almost certainly not work with the VB "Common Controls 6.0" ocx. Works with Windows Vista and higher.

Subsetted groups allow you to show only a limited number of rows, and have a link at the bottom to show the hidden items. Works in any view where group view is supported (e.g. large icon and details, not list, etc). Not only is all the info needed to do it undocumented, but MSDN provides some of the constants then explicitly says it can't be done. Not sure what their deal is... I mean yeah there's some issues (see warning) but no reason they couldn't have fixed it between Vista and 10).
So I had been converting this project to VB, and after I had already implemented the full IListView class, I went back and decided to try LVM_SETGROUPSUBSETCOUNT anyway, having originally thought the project author had tried that first since it was mentioned where he got the idea from. Lo and behold, it worked. So now you can subsetted groups with just a couple lines, and no TLB, no subclassing, nothing.


Code:

Public Const LVM_FIRST = &H1000
Public Const LVM_SETGROUPSUBSETCOUNT = (LVM_FIRST + 190)
Public Const LVM_GETGROUPSUBSETCOUNT = (LVM_FIRST + 191)

 'is included in standard group def despite MSDN saying not supported:
    LVGF_SUBSET = &H8000
    LVGS_SUBSETED = &H40
    LVGS_SUBSETLINKFOCUSED = &H80

Now that you have your constants, when you're adding a group you want to be subsetted, add LVGF_SUBSET to .mask, and LVGS_SUBSETED to .State and .StateMask.
Next add the subset link text,
.pszSubsetTitle = StrPtr(sSubSetText)
.cchSubsetTitle = Len(sSubSetText) + 1 'MSDN says this needs its own flag, but this combo of flags and properties works for both me and the codeproject sample

Then, after the group has been added, to set the number of rows simply use:
Call SendMessage(hLVS, LVM_SETGROUPSUBSETCOUNT, 0, ByVal 2&)
where 2 can be anything, it's the number of rows you want.

And that's all it takes!

WARNING:
Note that this is an undocumented message, and as such has SERIOUS issues: MSDN explicitly says subset text cannot be set. They lied, but changing the variable holding it after running your program without restarting the IDE can cause damage your project, leading to crashes and having to re-enter control settings. If Group View is not enabled, or no groups are added, or no groups are marked as subsetted, the ListView window will lock up and nothing can be drawn to that area of the screen until the program is ended.

[VB6, XP+] Code snippet: Show combined file properties window- SHMultiFileProperties

$
0
0
It's easy to show the file property window for a single file with ShellExecuteEx, but what if you wanted to also show a property window for multiple files in multiple paths as you can do in Explorer? The ShellExecuteEx method provides no option to pass an array of files. So you have to turn to SHMultiFileProperties. The reason this has never been done in VB before (at least as far as I could find with Google), is that it requires an IDataObject to describe the files, and that's traditionally been a tough thing to do. But thanks to some shell32 API's, it's not as bad as you'd think.

There's two APIs we can use to get the needed IDataObject, SHCreateDataObject and SHCreateFileDataObject. The former is only available on Vista and higher, and the latter is undocumented and exported by ordinal only. However, it's been at the same ordinal from XP through 8.1 (haven't checked 10), so I'll use that in the sample code. If you don't need to support XP, switch it out- they're extremely similar.

Requirements
Windows XP or higher
For the IDE only, a type library containing the definition for IDataObject. Some versions of OLEGuids might work, but I recommend using my Modern Interfaces Type Library, although just the original version of olelib would be sufficient. Simply download and add a reference to olelib.tlb to your project.

Code
Code:

Public Declare Function SHCreateFileDataObject Lib "shell32" Alias "#740" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pDataInner As Any, ppDataObj As olelib.IDataObject) As Long
'For Vista+ if you wanted:
'Public Declare Function SHCreateDataObject Lib "shell32" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pdtInner As Any, riid As UUID, ppv As Any) As Long
Public Declare Function SHMultiFileProperties Lib "shell32" (ByVal pdtobj As Long, ByVal dwFlags As Long) As Long
Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Declare Sub ILFree Lib "shell32" (ByVal pidl As Long)

Public Sub ShowMultiFileProperties(sFiles() As String)
'Displays merged file properties window
'Will also display normal property window if a single file is passed
'Unicode is supported

Dim pData As olelib.IDataObject 'always explicitly type this with the parent
Dim apidl() As Long
Dim cpidl As Long
Dim i As Long
ReDim apidl(UBound(sFiles))

If (UBound(sFiles) = 0) And (sFiles(0) = "") Then Exit Sub

For i = 0 To UBound(sFiles)
    apidl(i) = ILCreateFromPathW(StrPtr(sFiles(i))) 'create a fully qualified pidl for each file
Next i
cpidl = UBound(apidl) + 1
Call SHCreateFileDataObject(VarPtr(0), cpidl, VarPtr(apidl(0)), ByVal 0&, pData) 'VarPtr(0) is always equal to the desktop's pidl
If (pData Is Nothing) Then
    Debug.Print "ShowMultiFileProperties: Could not create data object"
    Exit Sub
End If

Call SHMultiFileProperties(ObjPtr(pData), 0) 'passing IDataObject ByRef like you'd think from MSDN results in a crash, so the declare is changed to Long and we send the object pointer

Set pData = Nothing
For i = 0 To UBound(apidl)
    ILFree apidl(i) 'never forget to set your pidls free
Next i
End Sub

Duktape JS engine for vb6

$
0
0
Hi guys, thought i would share a project I have been working on.

I wanted to find a newer javascript engine that I could use with vb6. All in all the MS script control is very capable and easy to use, but it has some nuances that makes it not work with some javascript and does not support all newer constructs. Also there is no built in debugging support unless you try to host the IActiveScript interfaces yourself. (i never could get the debug interfaces working with vb6 either)

I started looking around and found the duktape javascript engine and got it working with vb6. I also devised a way to give the scripts access to COM objects.

An example use could be as simple as:
Code:

  Dim duk As New CDukTape
  msgbox duk.Eval("1+2")

Below are my current supported test cases:

Code:

'    js = "1+2"
'    js = "alert(1+2)"
'    js = "while(1){;}"                'timeout test
'    js = "prompt('text')"
'    js = "a='testing';alert(a[0]);"

'------------- vbdevkit tests ---------------------
'    js = "fso2.ReadFile('c:\\lastGraph.txt')"
'    js = "alert(dlg.OpenDialog(4))"
'    js = "pth = dlg.OpenDialog(4,'title','c:\\',0); fso2.ReadFile(pth)"
'--------------------------------------------------

'    js = "form.Text1.Text = 'test'"
'    js = "form.Text1.Text + ' read back in from javascript!'"
'    js = "form.caption = 'test!';alert(form.caption)"
'    js = "for(i=0;i<10;i++)form.List2.AddItem('item:'+i);alert('clearing!');form.List2.Clear()"
'    js = "var ts = fso.OpenTextFile('c:\\lastGraph.txt',1,true,0);v = ts.ReadAll(); v"        'value of v is returned from eval..
'    js = "var ts = fso.OpenTextFile('c:\\lastGraph.txt',1); v = ts.ReadAll();alert(v)"        '(default args test)

Its not as automatic as the MS script control, you do have to generate JS class wrappers for the COM object you want to use, but there is also a generator for it. In the future this stage could be automated but not yet.

This project is at a good point right now and generally usable so thought I would share at this point.

https://github.com/dzzie/duk4vb

The duktape engine also supports a debugger protocol, which is going to be my next step.

[VB6, Vista+] Host Windows Explorer on your form: navigation tree and/or folder

$
0
0
IExplorerBrowser

IExplorerBrowser is an easy to use, more complete version of IShellView (in fact, it has an IShellView at its core that you can access) that lets you have a complete Explorer frame on your form, with very little code. You can either have just a plain file view, or with a navigation tree and toolbar. It uses all the same settings and does all the same things as Explorer, and your program can interact with those actions to do things like browse for files, or be the basis of a namespace extension.
The only complication is that there's no event notifying of an individual file selection within the view, and getting a list of selected files is fairly complex- however there is a function to do it in the demo project.
Here's how it looks if you're just using folder view without the frames:


INamespaceTreeControl

If all you want is the navigation tree, you have the INamespaceTreeControl. It's got a decent amount of options for however you want to display things, including checkboxes. There is a wide range of events that you're notified of via the event sink, and most of these use IShellItem- the demo project does show to to convert that into a path, but it's a very useful interface to learn if you're going to be doing shell programming. The selection is reported through IShellItemArray, which is slightly easier than IDataObject.
It's got one little quirk though... you have the option to set the folder icons yourself, but if you don't want to do that and just use the default icon that you see in Explorer, you have to return -1, which requires a v-table swap. The demo project shows how to go both ways, no thanks to MSDN and their complete lack of documentation of this.
But this is by far the easiest to create way of having a full-featured Explorer-like navigation- I've made a regular TreeView into this, and it took hundreds of lines and heavy subclassing. This is a simple object. (Note that it does support some advanced features through related interfaces, like custom draw, drop handling, and accessibility... these interfaces are included in oleexp, but have not been brought to the sample project here, perhaps in the future I'll do a more in-depth one if there's any interest)

Requirements
Windows Vista or higher required as these interfaces did not exist in earlier OS versions
oleexp.tlb: Modern Interfaces Type Library v2.0 or higher (17 Jun 2015) - Only required in the IDE. Add/fix in demo references to olelib.tlb and oleexp.tlb.

These 'controls' create themselves- all you need is a blank form, and here's the creation code for a basic idea of how these things work (code to initialize some variables omitted):
Code:

Set pNST = New NamespaceTreeControl
pNST.Initialize Me.hWnd, prc, lFlag
Set pAdv = New cNSTEvents
Set pUnkAdv = pAdv
pNST.TreeAdvise pUnkAdv, lpck
pNST.InsertRoot 0, isiDesk, SHCONTF_FOLDERS, NSTCRS_EXPANDED Or NSTCRS_VISIBLE, pif

Attached Files

Register/Unregister both DLLs and OCXs with RightClick

$
0
0
I used a vbscript provided by Olaf to register vbRichClient5, changed it a bit, and added 4 entries to registry.
Now I'm able to register/unregister both DLLs and OCXs with a simple RightMouse click over the file.

This probably worth less than nothing, but it works for me, and might be useful for somebody else.
Just copy Register.vbs to C:\Windows and execute the file Register.reg

Register.zip
Attached Files

Vb6 - cng test

$
0
0
Attached is a test program for various CNG (Cryptography Next Generation) functions.
1. Create Key Pair
2. Sign Data
3. Verify Signature
4. Test Hashes (AES-GMAC not functional yet)
5. Generate Random
6. Enumerate Algorithms
7. Test Encryption
8. Test Forward Secret (Eliptical DH keys not functional yet)
9. Create TLS 1.0 Master Keys

Tested on Windows Vista and Windows 8.1.

J.A. Coutts
Attached Images
 
Attached Files

Hook system wide with DLL in C++

$
0
0
Hello,

Even we are in 2015 and vb6 is old, it’s still great. As I had been in difficult to find a simple and efficient method to do hooking system wide, so I share my source code, here in zip attachment.

This project allow you to do global hook, system wide in Windows. The principle is to put the hook with a DLL, then get the message by subclassing our program. This hook system wide work only with 32 bits applications.

The DLL in attachment was compiled in C++. Which allow you to put hook system wide in Windows, then send to our program, with SendMessage, the message WM_USER and the hook code (nCode). With subclassing of our program, we can get the hook code by subtract WM_USER.

The hook provided from the DLL is not specific to our program but global in all Windows (system wide).

The DLL support these hooks types :
' WH_CALLWNDPROC = CallWndProc;
' WH_CALLWNDPROCRET = CallWndRetProc;
' WH_CBT = CBTProc;
' WH_DEBUG = DebugProc;
' WH_FOREGROUNDIDLE = ForegroundIdleProc;
' WH_GETMESSAGE = GetMsgProc;
' WH_JOURNALPLAYBACK = JournalPlaybackProc;
' WH_JOURNALRECORD = JournalRecordProc;
' WH_KEYBOARD = KeyboardProc;
' WH_KEYBOARD_LL = LowLevelKeyboardProc;
' WH_MSGFILTER = MessageProc;
' WH_MOUSE = MouseProc;
' WH_MOUSE_LL = LowLevelMouseProc;
' WH_SHELL = ShellProc;
' WH_SYSMSGFILTER = SysMsgProc;

This project provide a demo of these hooks system wide :
CBT / CreateWnd : get the name of the handle parent of the window to be created.
Keyboard = get the code of the keystroke.
Mouse = get the name of the handle pointed by the left click.

I’m not the author of the DLL, neither hooking and subclassing methods.
I took these three elements and make a simple project.
The DLL was coded in C++ by Renfield – 2007
Source code of subclassing by Renfield – 2010
Hooking routines by vbAccelerator – 2003

Have fun ;-)

-ZIP Removed By Moderator-

[VB6] Color Management - Different Approach

$
0
0
Note: uploaded the wrong file dialog class with this project. Will correct that & update the zip later tonite. In the meantime, you can grab the open file dialog from this link (also on this site). The open file dialog is not needed for the class, but is used for the sample project.

The class included in the attached zip file is intended for those that want to add some color management to their VB projects with minimal effort. The color management class (cICMLite) uses GDI higher level color management built-in functions and returns the image as a stdPicture object suitable to assigning to picture box, image control, etc, or selecting the picture handle into a DC for BitBlt and other rendering functions.

Pros:
1. Easy to use. Call the cICMLite.LoadPIctureICM function to return the image as a stdPicture
2. Unicode supported. Can optionally use the class as a unicode-friendly version of VB's LoadPicture
3. Can load PNG and TIFF files that GDI+ can read/process
4. CMYK jpgs handled without any additional requirements when run on Win7 or better
5. Can load alpha bitmaps, both premultiplied and not
6. Can load bitmaps using versions 4 & 5 of the BitmapInfoHeader format

Cons:
1. CMYK jpgs are supported on XP and above. However, on Vista GDI+ v1.1 manifest needed to use any embedded profiles. Embedded profiles ignored on XP but fully supported on Win7+ with/without GDI+ v1.1 manifests.
2. Transparency in PNG, TIFF, & bitmap images is filled with a backcolor your provide to cICMLite. This is because VB stdPictures do not support transparency except for icons & gifs.
3. Minor limitation. Cannot use the class for soft proofing printer ICM profiles.
4. Since icons don't support ICM, they are not specifically handled and passed to VB's LoadPicture. We all know that VB is quite limited with support for modern icons. However, you do not have to use the class to load any image files. You could also add your own custom handling routine to the class to handle modern icons.
5. When running on Vista or XP, GDI+ versions have some bugs that can prevent color managment profiles from being read

Some notes
1. In the class, you may find the pvValidateAlphaChannel logic useful for other graphic routines
2. GIFs, containing ICM profiles, are processed based on theory. I have not found any in the wild. The logic is unique
3. BMPs, containing ICM profiles, are processed based on theory. I've found only one in the wild & it was a test image
Since GDI+ does not honor alpha channels in bitmaps, and VB cannot load versions 4/5 of the BitmapInfoHeader, all bitmaps are processed manually. When possible, passed off to VB. The logic in the handling routines perform minimal sanity checks. Feel free to beef it up if desired.
4. GDI+ is used to extract ICM profiles from JPG, PNG, TIFF. Not guaranteed to find these if they exist in meta data tags vs. known ICM tags.

Since forum rules limit amount of stuff we attach, I'll include a link to my hotmail's one-drive where you can download additional images to play with. Googling for ICM Profiles can also yield more images to play with.
Attached Files

[VB6, Vista+] Code snippet: KnownFolders made easy with IKnownFolderManager

$
0
0
Using the KnownFolderManager Object

oleexp 2.0 includes the IKnownFolderManager and IKnownFolder interfaces.

If plan on doing any work with the Known Folders that replaced CSIDL Special Locations and you're working exclusively with Vista and higher, there's now the IKnownFolderManager interface, for which Windows provides a default instance of, which makes your job much easier.

Code:

Dim pKFM as KnownFolderManager
Set pKFM = New KnownFolderManager

Now you have a ready-to-use manager that gives you the following:

.FindFolderFromPath /IDList - Have the path of a special folder and want to get its IKnownFolder interface to find out information about it? You can specify a full or partial path. If you work with PIDLs, e.g. the result from a folder browser that you could use here directly without converting back and forth to a string path, there's a function to get a known folder directly from that as well.


.FolderIdFromCsidl - Still working with CSIDLs? This will ease the transition into support Known Folders.

.GetFolder / .GetFolderByName - You can use either the GUID or canonical name to return a Known Folder object.

Code:

Dim pikf As IKnownFolder
pKFM.FindFolderFromPath "C:\Users\Jon\Downloads", FFFP_EXACTMATCH, pikf

Once you have a Known Folder, in the form of a IKnownFolder object, you can get tons of information about it:

From the main IKnownFolder object, you can get all its file system information, like its PROPERTYKEY, path, pidl, or even an IShellItem interface for it (you can also change the path with SetPath), then there's a significant subset of information in the description:
Code:

pikf.GetFolderDefinition desc
pikf.GetId pid
PrintGUID pid
Debug.Print "Icon=" & BStrFromLPWStr(desc.pszIcon, False)
Debug.Print "Name=" & BStrFromLPWStr(desc.pszName, False)
Debug.Print "Description=" & BStrFromLPWStr(desc.pszDescription, False)
Debug.Print "LocalizedName=" & BStrFromLPWStr(desc.pszLocalizedName, False)
Debug.Print "ToolTip=" & BStrFromLPWStr(desc.pszToolTip, False)
Debug.Print "Category=" & desc.category 'peruser, common, etc
Debug.Print "Attributes=" & desc.dwAttributes

This is by far the easiest way to work with these special folders on newer versions of Windows.

Most of the oleexp projects use this, but again:
Code:

Public Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) ' Frees memory allocated by the shell

Public Function BStrFromLPWStr(lpWStr As Long, Optional ByVal CleanupLPWStr As Boolean = True) As String
SysReAllocString VarPtr(BStrFromLPWStr), lpWStr
If CleanupLPWStr Then CoTaskMemFree lpWStr
End Function

'also handy,
Public Declare Function StringFromGUID2 Lib "ole32.dll" (ByRef rguid As Any, ByVal lpsz As String, ByVal cchMax As Long) As Long

Public Sub PrintGUID(TempGUID As UUID)
Dim GuidStr As String
Dim lLen As Long

GuidStr = Space(80)
lLen = StringFromGUID2(TempGUID, GuidStr, 80)

If (lLen) Then
    GuidStr = StrConv(Left$(GuidStr, (lLen - 1) * 2), vbFromUnicode)
    Debug.Print GuidStr
End If
End Sub

[VB6] Color Management and VB6 How-Tos

$
0
0
The intent of this thread is to explain how color management can be used in VB6. There may be code samples included in some posts and/or links where code samples can be found. This thread will be updated as needed. Per the posting rules of the codebank, 'tutorial' like threads are ok here.

Some definitions/terms used throughout

Color Management: The primary goal is to obtain a good match across color devices; for example, the colors of one frame of a video should appear the same on a computer LCD monitor, on a plasma TV screen, and as a printed poster. Color management helps to achieve the same appearance on all of these devices. For Microsoft's definition, description & justification, see this link. Another reference can be found here that attempts to explain color management in layman terms but also goes indepth

Color transformation: The transformation of the representation of a color from one color space to another.

Color Profile: A file that contains matrices and/or look up tables that are used for color transformations.

Color Gamut: A subset of all possible colors relative to a specific color space. Basically a range of colors supported by a color space

Device-Dependent: Expresses colors relative to some other reference space, a subset of colors which can be displayed using a particular monitor or printer, or can be captured using a particular digital camera or scanner.

Device-Independent: Expresses colors in absolute terms. sRGB (standard RGB) is such a color space.

Why do I want to support color management and how much effort is needed? "Why" is simple enough. If you are displaying graphics that should always be seen by the user/customer as perfect as possible, then you should support color management. How much of a headache is this? Can be a lot initially. At a minimum, these issues need to be resolved:

- Whatever monitor your application runs on should be calibrated. For the average user, this is not trivial.
- Whatever monitor your application runs on should also have installed device-specific profiles to ensure best color matching
- You need to be able to extract/apply embedded color profiles/data from any image you display, if those profiles exist
- In VB, you need to activate color management for your applications. This is NOT done by default. Two API calls turns it on.

Even if calibration is not performed nor a manufacturer-supplied color profile is being used, supporting color management for images can produce more accurate colors relative to the source image than would otherwise be displayed on the screen without it. Extraction of color profiles is made easier with the use of GDI+. But earlier versions have bugs that can prevent some data extraction and all versions of GDI+ do not support extraction of all image formats that support color profile embedding.

Activating color management within VB is the easiest thing you can do, but does very little without the ability of applying embedded image color profiles. Generally speaking, if no profile has been assigned to the monitor, then Windows assumes sRGB color space is in use. And if color profiles are not applied to images, then rendering done by Windows assumes it is between sRGB source and sRGB destination. Bottom line is that color management is prevented. If there is a color profile assigned to the monitor, then activating color management in VB for your display contexts (DCs, hDC properties) may improve color display a bit. Most monitor color profiles are not equivalent to sRGB, so color transformations are likely to occur.

In the next sections, I'll discuss how you can extract color profiles from images and various ways to apply those profiles to the images for a more accurate display. Also, VB6 users may or may not use GDI+ for the lion's share of rendering images, so I'll also try to show how these profiles can be used with both GDI and GDI+. But for simplicity sake, let's just say that enabling color management for embedded profiles will require the use of both GDI and GDI+. GDI used to perform color transformation & GDI+ used to extract profile data.

Some examples on this site:
Color Management with GDI+
Color Management - Different Approach
Color Management (ICC Profile) support in VB6: guide and sample project

Algorithm - Detect Alpha Usage and Type From Pixel Data

$
0
0
For those of us that use GDI+, we know that it has a major issue loading bitmaps that contain alpha data. Maybe not a major concern, because GDI basically ignores the alpha channel in most every function in its arsenal. But unfortunately, the GdipGetImageFlags function may not be useful in all cases. What if you render to a DIB and supply a pixel color to be made transparent? Maybe that color exists, maybe not; therefore, maybe transparency exists in the DIB, maybe it doesn't. This routine is not restricted for GDI+ users only. GDI users may find it useful as well.

So, let's say we have access to 32bpp pixel data and want to know if it contains transparency and if so, how is that transparency interpreted. The function below can be of big help. Read the comments I've sprinkled about the function and you should have no issues.

There are very specific, rare cases, when the logic used can fail. Those are addressed in the function's comments. This is a function I plan on using in new projects moving forward. Here are some scenarios that can be avoided. Offer an option to ignore the alpha channel in these cases:
- Steganography: If known to exist & alpha channel used for data only, image will be displayed correctly, but hidden data is lost
- All black image: Image displayed correctly
- VB picture object. Unless known it contains a valid alpha channel, ignore it. VB picture objects can produce dirty alpha channels. VB has no direct support of alpha channels. And unless a valid channel was purposely added to the picture object, it is otherwise invalid.

Simple Transparency as used here. Alpha values are either 0 or 255. Those that are 0 have RGB values also zero. Can also be considered premultiplied RGB compnents against the alpha channel
Complex Transparency as used here. Mix of alpha values that range from 0 to 255. Alpha values of zero can have non-zero RGB values. RGB components may or may not be premultiplied against the alpha channel.

The function is provided below
Code:

Public Function ValidateAlphaChannelEx( _
        ByVal PixelPointer As Long, _
        ByVal PixelCount As Long, _
        Optional ByVal MaskPointer As Long, _
        Optional ByVal MaskCount As Long) As AlphaChannelUsage
       
    ' Method determines if the alhpa channel is used and how it is used
    ' Only supports 32 bpp pixel data. Passing any other format will result in a crash
    ' Assumption is that you will only call this routine to test 32 bpp data
    ' Notes:
    '  1. If function returns values less than 2 (acuOpaque). The result should be handled manually:
    '      - acError indicates bad mask information passed
    '      - acuAllBlack indicates all color values are exactly zero. 100% transparent or 100% black?
    '      - acuOpaqueAssumed indicates all alpha values are zero, but all RGB values are not zero
    '  2. If dirty alpha values are passed, the return value may not be valid. Dirty alpha
    '      values can occur when images are drawn on a 32bpp surface and the alpha bytes are
    '      ignored. Can also occur if steganography is used in the image and the alpha byte
    '      is used for that purpose.
    '  3. It is possible that acuPremultipliedRGB can be wrong in a specific scenario: every RGB
    '      component is less than it's alpha value on purpose but the image's RGB components
    '      were NOT premultiplied against the alpha values. This specific case should be very
    '      rare and the routine assumes premultiplication, as no way of knowing thru code
   
    ' Parameters...
    ' PixelPointer :: i.e., VarPtr(pixelArray(0)), pointer returned from GdipBitmapLockBits, CreateDIBSection
    '  Note: The pixel data pointed to by PixelPointer must be 32 bit per pixel format
    '      and the pixel data must be contiguous from PixelPointer to PixelPointer+PixelCount-1
    '      the stride must be positive not negative. If negative, ensure pointer adjusted for a
    '        positive stride. Function does not care if pixel data is right-side up or not
    ' PixelCount :: amount of pixel data to process, i.e., Width * Height
    ' MaskPointer :: optional and if not provided, bytes are assumed to be in DIB format
    '  Note: BitmapInfoHeader & its later versions allow masks to be included
    '  If provided, a minimum of 3 masks (R,G,B) expected and maximum of 4 masks (Alpha)
    '  Expect the pointer to the masks to be consecutive 4 byte values: R,G,B,Alpha
    ' MaskCount :: must be one of these values: 0, 3, 4
   
    ' Mask information is generally valid only if the image has not yet been loaded into a GDI
    '  bitmap/DIB or a GDI+ image object, i.e., you are manually parsing a bitmap file.
    '  If it has already been loaded correctly, then the format of the PixelPointer you passed
    '  will already be in what this routine considers default:
    '  Defaults: Red=&HFF0000, Green=&HFF00, Blue=&HFF, Alpha=&HFF000000
    ' Unless masks use less than 8 bits each, the only important mask is the Alpha mask, the
    '  routine below does not care if pixel format is RGB,BGR,GBR,GRB,etc
   
    ValidateAlphaChannelEx = acuError                      ' default return value
    If PixelPointer = 0& Or PixelCount < 1& Then Exit Function

    Dim lMasks(0 To 3) As Long, lShifts(0 To 3) As Long      ' BGRA masks
    Dim lPtr As Long, bAlpha As Long, lFormat As Long
    Dim lColor As Long, lPrevColor As Long
    Dim bData() As Long, tSA As SafeArray
    Const ZEROES As Long = 256&
   
    ' ///// Step 1: validate passed masks are valid and/or apply default masks
    If MaskPointer Then
        If (MaskCount = 3& Or MaskCount = 4&) Then
            CopyMemory lMasks(0), ByVal MaskPointer, MaskCount * 4& ' get RGB masks
            lColor = (lMasks(0) Or lMasks(1) Or lMasks(2))          ' see if any are actually set
            If lColor Then
                If lMasks(3) = 0& Then                      ' apply default alpha if needed
                    lMasks(3) = lColor Xor -1&
                ElseIf (lMasks(3) And lColor) Then          ' see if alpha overlaps RGB mask
                    Exit Function
                End If
            End If
        End If
    End If
    ' if no mask information provided, default values will be used
    If lColor = 0& Then
        lMasks(0) = &HFF0000: lMasks(1) = &HFF00&: lMasks(2) = &HFF: lMasks(3) = &HFF000000
    End If
    For lPtr = 0& To 3&                                    ' validate masks within 8 bit boundary
        lShifts(lPtr) = lMasks(lPtr) And -lMasks(lPtr)
        If ((lMasks(lPtr) \ lShifts(lPtr)) And &HFF) > 255 Then Exit Function ' invalid mask
    Next
   
    ' ///// Step 2: setup an overlay onto the passed pixel pointer
    With tSA
        .cbElements = 4&
        .cDims = 1
        .pvData = PixelPointer
        .pvBounds.cElements = PixelCount
    End With
    CopyMemory ByVal VarPtrArray(bData), VarPtr(tSA), 4&
    On Error GoTo ExitRoutine
   
    ' ///// Step 3: test the alpha channel
    lPrevColor = bData(0) Xor 1&            ' force a no-match at start of loop
    For lPtr = 0& To PixelCount - 1&
        lColor = bData(lPtr)                ' get 32bit color
        If Not lColor = lPrevColor Then    ' and extact the alpha byte
            If lColor = 0& Then
                lFormat = lFormat Or ZEROES ' entire value is zero
                ' all zeroes indicates 100% transparent or 100% black image
                ' mix of zero & non-zero alpha values indicates transparency
            Else
                bAlpha = (lColor And lMasks(3)) \ lShifts(3) And &HFF
                If bAlpha = 0& Then
                    If (lColor And Not lMasks(3)) Then  ' RGB value is non-zero
                        If (lFormat And Not ZEROES) > acuOpaque Then
                            ' at least one other alpha value was > 0 and < 255
                            ' since this alpha is zero & RGB non-zero. Done:
                            lFormat = acuComplexTransparency: Exit For
                        End If
                        lFormat = lFormat Or acuOpaqueAssumed ' keep going, maybe all alphas are zero
                    End If
                ElseIf bAlpha = 255& Then
                    If (lFormat And acuOpaqueAssumed) Then
                        ' already seen alpha zero & non-zero RGB. Here we have 255 alpha. Done:
                        lFormat = acuComplexTransparency: Exit For
                    End If
                    lFormat = lFormat Or acuOpaque
                   
                ' else if any RGB values > alpha then not-premultiplied
                ElseIf bAlpha < (lColor And lMasks(0)) \ lShifts(0) And &HFF Then
                    lFormat = acuComplexTransparency: Exit For ' definitly ARGB
                ElseIf bAlpha < (lColor And lMasks(2)) \ lShifts(2) And &HFF Then
                    lFormat = acuComplexTransparency: Exit For ' definitly ARGB
                ElseIf bAlpha < (lColor And lMasks(1)) \ lShifts(1) And &HFF Then
                    lFormat = acuComplexTransparency: Exit For ' definitly ARGB
                Else
                    lFormat = lFormat Or acuPremultipliedRGB ' likely pARGB, but not sure yet
                End If
            End If
            lPrevColor = lColor
        End If
    Next
   
    ' ///// Step 4: Analyze result
    If (lFormat And acuPremultipliedRGB) Then
        ValidateAlphaChannelEx = acuPremultipliedRGB
    ElseIf lFormat = ZEROES Then
        ValidateAlphaChannelEx = acuAllBlack
    ElseIf lFormat = (ZEROES Or acuOpaque) Then
        ValidateAlphaChannelEx = acuSimpleTransparency
    Else
        ValidateAlphaChannelEx = (lFormat And Not ZEROES)
    End If
   
ExitRoutine:
    ' ///// Step 5: Clean up
    CopyMemory ByVal VarPtrArray(bData), 0&, 4&
   
End Function

The declarations are here
Code:

Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
Private Type SafeArrayBound          ' OLE structure
    cElements As Long
    lLbound As Long
End Type
Private Type SafeArray
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    pvBounds As SafeArrayBound  ' single dimension usage
End Type

Public Enum AlphaChannelUsage
    acuError = &H80000000      ' invalid Mask information passed to ValidateAlphaChannelEx
    acuAllBlack = 0            ' image can be interpreted as 100% black or 100% transparent
    acuOpaqueAssumed = 1        ' all alpha values are zero, assuming image is not meant to be 100% transparent
    acuOpaque = 2              ' alpha channel is used, but all alpha values are 255
    acuSimpleTransparency = 4  ' alpha channel is used and contains simple transparency only
    acuComplexTransparency = 8  ' alpha channel is used and contains complex transparency
    acuPremultipliedRGB = 16    ' R,G,B components are multiplied against the alpha channel
    acuMask_HasTransparency = acuSimpleTransparency Or acuComplexTransparency Or acuPremultipliedRGB
    acuMask_AlphaBlendFriendly = acuOpaque Or acuSimpleTransparency Or acuPremultipliedRGB
    acuMask_Opaque = acuOpaque Or acuOpaqueAssumed
End Enum

Edited: Different interpretations you may want to consider.

1. Let's say you passed mask bits to the function and the function returns acuError. That indicates the mask was interpreted as invalid. This can happen for 3 primary reasons: a) it is invalid, any of the masks use more than 8 bits, b) the R,G,B masks combined use less than 24 bits & no alpha mask provided, leaving the routine to assume the alpha mask uses 9+ bits, or c) the alpha mask spans over one of the other masks. In a really malformatted file, I guess it would be possible to supply a mask for just one component and none for the others. In any of these cases, the likelihood that an alpha channel is used is slim to none. May want to interpret acuError in these cases as acuOpaque or acuOpaqueAssumed. That is my plan.

2. Though acuOpaqueAssumed is not included in the acuMask_AlphaBlendFriendly, this does not mean AlphaBlend cannot be used with the pixel data. acuOpaqueAssumed simply means that the pixel data has all zero alpha values along with non-zero RGB values. Alphablend can be used as long as the blend function of that API doesn't include the alpha channel (AC_SRC_ALPHA)

3. Interpreting acuAllBlack depends on whether it is expected or not. Is it possible to create a 100% transparent image? Sure. Can an all black 32bpp image exist? Sure. Are either any use? Highly doubtful. But maybe your app wants an invisible image to be applied to some control? Maybe acuAllBlack can indicate a empty DIB (no image data)? If acuAllBlack is unexpected, really a simple decision: is it better to display an invisible image or a black image or report it as 'invalid'? Your choice

Just FYI: If you don't care how the alpha channel is used, only that it is used, then you can create your own function that would be extremely fast. And it is easy to do. Simply look at the alpha channel only and it should be in use if one of these conditions apply. Once known, abort your loop.
a. Any alpha value is in the range: 1-254 inclusively
b. Any mix of 0 & 255 alpha values. Assumption: All zero alpha values <> 100% transparent image
Pseudo-code follows. Same gotchas apply as above, i.e., steganography, dirty alpha channel, etc.
Code:

Dim bSimple As Byte, p As Long
For p = 0 To [nrPixels] - 1
... extract AlphaValue with appropriate mask (if applicable)
    Select Case [AlphaValue]
        Case 0: If (bSimple And 2) Then Exit For
                bSimple = bSimple Or 1
        Case 255: If (bSimple And 1) Then Exit For
                bSimple = bSimple Or 2
        Case Else: Exit For
    End Select
Next p
If p = [nrPixels] Then ' no alpha else alpha is used

M2000 now can handle Word

$
0
0
After two days I found a way to call methods with named arguments. The problem was in typelib "IDispatch Interface - Eduardo Morcillo"
So I use the ole/com object user to extract the idl file.

Code:

        long _stdcall GetIDsOfNames(
                        [in] IID* riid,
                        [in] LPSTR* rgszNames,
                        [in] long cNames,
                        [in] long lcid,
                        [in, out] long* rgDispId);

I do a big search to find a way to pass a sting array for rgszNames, because from second element we have the named arguments. So after searching all possible variations (like safe arrays), I found the most easy solution.
Code:

        long _stdcall GetIDsOfNames(
                        [in] IID* riid,
                        [in] long* rgszNames,
                        [in] long cNames,
                        [in] long lcid,
                        [in, out] long* rgDispId);

I use mktyplib Idispatch.IDL to make the tlb

So how I can pass a string array? I think that the array is a simple long array with pointers to actual bstr (that use an array string). So i do a copy of StrPtr(stringvar or string_element_of_array) to a long type array and I pass that array. No need to convert to unicode, is ready in unicode. Secondly the array is read only for the GetIDsOfNames and i count that the job happen too fast, for vb to rearrange bstr (but maybe this is a fault). I do the same for rgDispId but here only we pass the first item.
This is a line from mdlIDispatch module in M2000 ver 8 rev 11, where fixnamearg is the number of named arguments. We just pass the first element of each array. and the others are valid from 3rd parameter, the number of elements.
lngRet = IDsp.GetIDsOfNames(rIid, myptr(0), fixnamearg + 1, cLid, varDISPID(0))

This is an example in M2000 using named arguments in Method command. Because SET is used for other purpose, I use Declare to set new objects. We can set objects as result from Method. We see that in Add method in Documents object of Word.Application.
I do some test with no named arguments, with mix and with one or two named arguments...and work fine.
Declare statement used for libraries also.
Here is the unfinished language definition
Here is the code - there is also a signed executable. Only the executable M2000.exe and the help2000.mdb needed to run the program.

Code:

declare global alfa "Word.Application"
declare global doc  use alfa, "Documents"
global wdDoNotSaveChanges=0
Global WdNewBlankDocument = 0 \\Blank document
Global WdNewEmailMessage = 2 \\E-mail message
Global WdNewFrameset = 3 \\Frameset
Global WdNewWebPage = 1 \\Web page
Global WdNewXMLDocument = 4 \\XML document
test
module kappa {
      With alfa, "visible" as anyname
      try ok {
            anyname=true
      }
      a$=key$
            try {
            with alfa, "top",100,"left",0
           
            try ok_doc { method doc, "add", "", DocumentType:=WdNewWebPage as doc1 }
            if not ok_doc then print "no doc" : exit
            method doc1, "activate"
            declare global selection  use alfa, "selection"  \\ now we can make a selection
            method selection, "TypeText","This is my text in Word Document using M2000"
            a$=key$
            try saved { method doc1,"close" }
         
            if not saved then {
            print "document not saved, press any key"
              refresh
              a$=key$
              method doc1,"close", SaveChanges:=wdDoNotSaveChanges  \\closed without saving
              }
            flush error
      }
      a$=key$
      \\ now we hide word
      if ok then {try { anyname=false }}
      try { declare doc1 nothing }     
      try { declare selection nothing }     
}
kappa
wait 10
try {method alfa, "quit"
declare doc nothing
declare alfa nothing }

dm Simple VM

$
0
0
hi, This is my little Toy VM I try to made tonight it a little basic at the moment since it my first real try at something like this. I try and add more stuff as I go along anyway hope you like the first version.

Comments are welcome.

vb Code:
  1. 'DM++ Virutal Machine Alpha 1
  2. Option Explicit
  3.  
  4. 'Registers
  5. Private Registers(8) As Integer
  6.  
  7. 'vm stuff
  8. Private Enum EOpCodes
  9.     RET = 0
  10.     PUSH
  11.     POP
  12.     IADD
  13.     ISUB
  14.     IMUL
  15.     IDIV
  16.     ISTORE
  17.     ILOAD
  18.     IPRINT
  19. End Enum
  20.  
  21. Private Const MAX_CODE = 100
  22. Private progcode(MAX_CODE) As Integer
  23. Private pCodeCnt As Integer
  24. Private PC As Integer
  25. Private Opcode As EOpCodes
  26.  
  27. 'Stack start code
  28. Private a_stack(100) As Integer
  29. Private StkPc As Integer
  30.  
  31. Private Function StackTop() As Integer
  32.     If (StkPc < 0) Then StkPc = 0
  33.     StackTop = a_stack(StkPc)
  34. End Function
  35.  
  36. Private Sub sPop()
  37.     StkPc = (StkPc - 1)
  38. End Sub
  39.  
  40. Private Sub sPush(item As Integer)
  41.     If (StkPc < 0) Then StkPc = 0
  42.     a_stack(StkPc) = item
  43.     StkPc = (StkPc + 1)
  44. End Sub
  45.  
  46. 'End of stack code
  47.  
  48. 'Start of vm
  49. Private Sub ResetVM()
  50.     PC = 0
  51.     StkPc = 0
  52.     Erase a_stack
  53.     Erase progcode
  54. End Sub
  55.  
  56. Private Sub VM()
  57. Dim value1 As Integer
  58. Dim value2 As Integer
  59. Dim RegAddr As Integer
  60.  
  61.     While (PC < pCodeCnt)
  62.         'Get byte.
  63.         Opcode = progcode(PC)
  64.        
  65.         Select Case Opcode
  66.             Case EOpCodes.PUSH
  67.                 PC = (PC + 1)
  68.                 Call sPush(progcode(PC))
  69.             Case EOpCodes.IADD
  70.                 Call sPop
  71.                 value1 = StackTop()
  72.                 Call sPop
  73.                 value2 = StackTop()
  74.                 'Push back the answer
  75.                 Call sPush(value1 + value2)
  76.             Case EOpCodes.ISUB
  77.                 Call sPop
  78.                 value1 = StackTop()
  79.                 Call sPop
  80.                 value2 = StackTop()
  81.                 'Push back the answer
  82.                 Call sPush(value2 - value1)
  83.             Case EOpCodes.IMUL
  84.                 Call sPop
  85.                 value1 = StackTop()
  86.                 Call sPop
  87.                 value2 = StackTop()
  88.                 'Push back the answer
  89.                 Call sPush(value1 * value2)
  90.             Case EOpCodes.ISTORE
  91.                 PC = (PC + 1)
  92.                 'Store in regsiter get addr
  93.                 RegAddr = progcode(PC)
  94.                 'Store value into register.
  95.                 Call sPop
  96.                 Registers(RegAddr) = StackTop
  97.             Case EOpCodes.ILOAD
  98.                 PC = (PC + 1)
  99.                 'Get register address.
  100.                 RegAddr = progcode(PC)
  101.                 'Get value
  102.                 'Push onto the stack.
  103.                 Call sPush(Registers(RegAddr))
  104.             Case EOpCodes.IPRINT
  105.                 'Get top of stack
  106.                 Call sPop
  107.                 Call MsgBox("Stack Top = " & CInt(StackTop()))
  108.             Case EOpCodes.RET
  109.                 'Close
  110.                 Call Unload(frmmain)
  111.         End Select
  112.        
  113.         'INC Program Counter
  114.         PC = (PC + 1)
  115.     Wend
  116.    
  117. End Sub
  118. 'End of vm
  119.  
  120. Private Sub EmitCode(code As Integer)
  121.     progcode(pCodeCnt) = code
  122.     pCodeCnt = (pCodeCnt + 1)
  123. End Sub
  124.  
  125. Private Sub cmdExit_Click()
  126.     Call Unload(Me)
  127. End Sub
  128.  
  129. Private Sub cmdRun_Click()
  130.     'Simple PUSH,ADD Print example
  131.     'PUSH 10
  132.     'PUSH 10
  133.     'IADD
  134.     'IPRINT
  135.     'RET
  136.    
  137.     Call EmitCode(PUSH)
  138.     Call EmitCode(10)
  139.     Call EmitCode(PUSH)
  140.     Call EmitCode(16)
  141.     Call EmitCode(IADD)
  142.     Call EmitCode(IPRINT)
  143.     Call EmitCode(RET)
  144.     'Run VM
  145.     Call VM
  146.    
  147.     'Example register demo Push,Store,Load
  148.     'PUSH 16
  149.     'ISTORE 1
  150.     'ILOAD 1
  151.     'PUSH 2
  152.     'IADD
  153.     'PRINTI
  154.    
  155.     'Emit test program registers
  156.     Call EmitCode(PUSH)
  157.     Call EmitCode(16)
  158.     Call EmitCode(ISTORE)
  159.     Call EmitCode(1)        'Set Regsiter 1 stack top value
  160.     Call EmitCode(ILOAD)    'Get register 1
  161.     Call EmitCode(1)
  162.     Call EmitCode(PUSH)
  163.     Call EmitCode(2)
  164.     'Add 2 to the value on the stack
  165.     Call EmitCode(IADD)
  166.     Call EmitCode(IPRINT)
  167.     Call EmitCode(RET)
  168.     'Run VM
  169.     Call VM
  170. End Sub

[VB6] IPreviewHandler: Show non-image file previews from any reg'd preview handler

$
0
0
IPreviewHandler Example

Many file types have registered preview handlers, not just images. Typically documents, videos, fonts, music, even registry files, all have a preview handler that you can put on your application with little effort.

Compatibility
The current sample project won't run on XP, but if you replace the IFileDialog file selection dialog and possibly a few other things, the core IPreviewHandler interface was available in XP.

Requirements
Requires a reference to oleexp3.tlb or higher.

-------------------------------

The registry holds registered preview handlers in the HKEY_CLASSES_ROOT\filetype\ShellEx\{8895b1c6-b41f-4c1c-a562-0d564250836f} key, but as a shortcut you can also use the AssocQueryString API with ASSOCSTR_SHELLEXTENSION as the sample project shows.

Here's the basic code to show a preview:
Code:

Private Sub ShowPreviewForFile(isi As IShellItem, hWnd As Long, rc As RECT)
'isi - an IShellItem representing the file (in example loaded from IFileDialog)
'hWnd - hWnd to show the preview on, typically a form, frame, or picturebox
'rc - A rectangle representing the area within the window to show the preview;
'      client-based so starts at 0
Dim iif As IInitializeWithFile
Dim iis As IInitializeWithStream
Dim iisi As IInitializeWithItem
Dim pUnk As oleexp3.IUnknown
Dim hr As Long
Dim sFile As String, sExt As String
Dim lp As Long
Dim tHandler As UUID
On Error GoTo e0

    isi.GetDisplayName SIGDN_FILESYSPATH, lp
    sFile = BStrFromLPWStr(lp)
    Debug.Print "sFile=" & sFile
    sExt = Right$(sFile, (Len(sFile) - InStrRev(sFile, ".")) + 1)
    Debug.Print "sExt=" & sExt

If sExt = "" Then Exit Sub

If (ipv Is Nothing) = False Then
    ipv.Unload
    Set ipv = Nothing
End If
If hGlobal Then GlobalFree hGlobal

hr = GetHandlerCLSID(sExt, tHandler)
If hr = 1 Then
    Debug.Print "Got handler CLSID; attempting to create IPreviewHandler"
    hr = CoCreateInstance(tHandler, 0, CLSCTX_INPROC_SERVER Or CLSCTX_LOCAL_SERVER, IID_IPreviewHandler, ipv)
    If (ipv Is Nothing) Then
        Debug.Print "Failed to create IPreviewHandler interface, hr=" & hr
        Exit Sub
    End If
    'Set iisi = ipv 'this normally can be used in place of Set pUnk / .QueryInterface, but we need the HRESULT
    Set pUnk = ipv
    If pUnk.QueryInterface(IID_IInitializeWithItem, iisi) = S_OK Then
        hr = iisi.Initialize(isi, STGM_READ)
        Debug.Print "iisi.init hr=" & hr
        GoTo gpvh
    Else
        Debug.Print "IInitializeWithItem not supported."
    End If
'    Set iif = ipv
    Set pUnk = ipv
    If pUnk.QueryInterface(IID_IInitializeWithFile, iif) = S_OK Then
        hr = iif.Initialize(sFile, STGM_READ)
        GoTo gpvh
    Else
        Debug.Print "IInitializeWithFile not supported."
    End If

        'use IStream
        Dim hFile As Long
        Dim pstrm As IStream
        Dim lpGlobal As Long
        Dim dwSize As Long
        Debug.Print "Attempting to use IStream"
        hFile = CreateFile(sFile, FILE_READ_DATA, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
        If hFile Then
            dwSize = GetFileSize(hFile, ByVal 0&)
            Debug.Print "Got file size=" & dwSize
            If dwSize = 0 Then Exit Sub
            hGlobal = GlobalAlloc(GPTR, dwSize)
            lpGlobal = GlobalLock(hGlobal)
            If lpGlobal Then
                Call ReadFile(hFile, ByVal lpGlobal, dwSize, dwSize, ByVal 0&)
                Call GlobalUnlock(hGlobal)
                Call CreateStreamOnHGlobal(hGlobal, 1, pstrm)
'                Set iis = ipv
                Set pUnk = ipv
                hr = pUnk.QueryInterface(IID_IInitializeWithStream, iis)
                Debug.Print "QI.hr=" & hr
                If (iis Is Nothing) Then
                    Debug.Print "IInitializeWithStream not supported."
                    Call CloseHandle(hFile)
                    GoTo out
                Else
                    hr = iis.Initialize(pstrm, STGM_READ)
                End If
            End If
           
            Call CloseHandle(hFile)

    End If
gpvh:
    hr = ipv.SetWindow(hWnd, rc)
    Debug.Print "SetWindow hr=" & hr
    hr = ipv.DoPreview()
    Debug.Print "DoPreview hr=" & hr
    isi.GetDisplayName SIGDN_NORMALDISPLAY, lp
    sFile = BStrFromLPWStr(lp)
    Label1.Caption = "DoPreview called for " & sFile
Else
    Label1.Caption = "Could not find registered preview handler for file type."
End If
out:

Set iisi = Nothing
Set iif = Nothing
Set iis = Nothing

On Error GoTo 0
Exit Sub

e0:
Debug.Print "ShowPreviewForFile.Error->" & Err.Description & " (" & Err.Number & ")"
End Sub

It's really simpler than it looks; the hard part it the initialization, a preview handler typically only supports 1 out of the 3 IInitialize__ interfaces, so we have to go through all of them, and IStream ones are too common to omit, and that's the only complex part.

It may vary from system to system, but plain images generally aren't supported with this method, but there's a large variety of ways to preview them.

----------------
Project based on Using Preview Handlers in Windows Vista
Attached Files

VB6 - TLSCrypto Using CNG

$
0
0
The attached programs are the culmination of my efforts to update my cryptography Class to use Cryptography Next Generation (CNG) from Microsoft. It is by no means the final version, as it simply upgraded SSLClient/SSLServer to TLSClient/TLSServer. As such it uses TLS1.0 and the Cipher Suite 05 (TLS_RSA_WITH_RC4_128_SHA), and both TLS1.0 and RC4 are not universally supported by all servers these days. The next step in the evolution of these programs will be to expand them to support more secure ciphers and TLS1.2.

There are substantial differences between the earlier CRYPTO API and CNG, and upgrading was necessary because Windows 8.1 no longer supports all the Schannel calls in CAPI. Having said that, CNG is far more flexible in the ciphers that it supports, but it is also more difficult to utilize, and I ran into many difficulties that were not covered in the available literature (which is very limited). The major differences are:
1. CAPI uses "Little Endian" format for Certificate and Key data, but CNG uses "Big Endian" format. "Big Endian" format is how the RFC's require this data to be transmitted, so reversing the data becomes unnecessary with CNG.
2. CNG uses Objects extensively, and quite often they are not used directly in CNG calls. Because Visual Basic cleans up after itself, care must be taken to retain these objects if they are to be used again.

I had intended to use the CAPI Server program (SSLServer) to test the CNG Client program (TLSClient), but I ran into difficulty with the TLSEncrypt routine that I could not resolve. It would properly encrypt and transmit the first encrypted record (ClientFinished), but the server program (SSLServer) would report an HMAC error on the second encrypted record (App Data). To facilitate further debugging, I upgraded the server program as well (TLSServer). Strangely enough, the same Client program (TLSClient) that was giving me all the trouble worked just fine with with the upgraded TLSServer program.

You may wonder why I used CAPI to recover the Certificate Data, instead of CNG. The main thrust of my cryptography work is on the Client side of the ledger, and server Apps really need multi-threading to support blocking socket calls. Visual Basic doesn't handle multi-threading very well, and I did not want to spend a lot of time on the server code. It was simpler for me to use the existing Certificate code and transfer the Private Key to CNG.

To run these 2 programs, open 2 separate instances of the IDE and load TLSClient in one and TLSServer in the other. Start both of them, bring both windows to the foreground, and separate them as much as possible. Click the down arrow on the dropdown box in the Client program and click on "LocalHost". As long as "LocalHost" is defined in your "Hosts" file, it should connect with the Server program, negotiate a TLS session, and get a short message from the server. The server program will automatically create both the Container and the RSA Key Pair if they don't already exist, but in order to use TLSServer, you will have to create Certificates and add them to the Certificate Store. The "Readme.txt" file contains instructions on how to do that.

Both programs have been tested on Windows Vista and Windows 8.1.

J.A. Coutts
Attached Images
 
Attached Files

VB6 - ResDecomp Class Decompiles RES Files

$
0
0
ResDecomp

This class reads a .RES (Resource) file as created by Visual Basic 6.0 or resource compilers such as RC.EXE and extracts resources.

This version decompiles RT_STRING resource StringTable data to UTF-16LE strings and ID values but does not attempt detailed decompilation of other types of resources.

While primarily addressing RT_STRING resources, the header fields and raw data payload of each resource are made available to the client program. In many cases this is enough, as can be seen in the demo program ResStrings when it fetches and decodes the custom resource type "UTF8TEXT" and reports it.

There isn't a huge ton of code involved. Most of the bulk of the attachment comes from sample data, icons, etc.


Samples

Two applications using the class are included:

ResStrings

Decompiles an included SAMPLE.res, reporting the results to a RichTextBox. Simple printing is implemented.

DecompStrings

Drag and drop a .RES file onto DecompString's Explorer icon or run DecompString from a command prompt passing the .RES file name as parameters. Decompiles the .RES file and exports Strings as a UTF-8 XML document, named the same as the input file but with an .XML extension.


Requirements

VB6 SP6 to compile.

DecompStrings: MSXML 3.0.

ResStrings: Richtx32.ocx (and RichEdit 2.0 at the system level, certainly Win2K SP3 and later, many Win9x systems).


Using ResDecomp.cls

Add the Class to your Project.

Create a WithEvents instance of the Class.

Call the .Extract() method passing the .RES file name.

The Started event is raised first, relaying the file name.

Then the Resource event is raised multiple times, passing a ResourceIndex value numbering the resources from 0 which may or may not be useful to you. Within this event's handler you can access the current resource's header field values, the raw header and data bytes, and arrays containing the string and string ID values if the resource is type RT_STRING as properties of your ResDecomp instance.

Finally the Finished event is raised at the end of the .RES file.

The advantage of this is that you can easily apply any filtering and formatting of resources as they are parsed out of the .RES file. The downside is that you must host instances of this Class in object modules (i.e. not static .BAS modules). But most programs where this Class would be useful can deal with that, or you could always rework things by moving the loop out from Extract() and into your client code.
Attached Files

Unicode Full Controls (UFC)

Advance Scrolliodo with Jpg encoder class

$
0
0
I found a very nice encoder class for jpeg saving.

ScrollioDo was first a nice simple scroller but without a DIB under, so this one has a DIB and only the Viewport extracted each time we scroll.
In this post I add the jpg encoder class by John Korejwa (from www.planetsourcecode.com).

Here j is a new cJpeg class
Code:

j.Quality = 75
j.Comment = "Scrollio Example"
j.SetSamplingFrequencies 1, 1, 1, 1, 1, 1  ' the best (by default is 2,2,1,1,1,1)
Scrollio.DiB.needHDC    \\ Scrollio never hold a Hdc...always make a new to export.
j.SampleHDC Scrollio.DiB.HDC1, Scrollio.DiB.width, Scrollio.DiB.height
Scrollio.DiB.FreeHDC
j.SaveFile b$

This program is free to make it anything, including to improve.
What we can do with that program:
We can scroll with a zoom of X20 a 20 megapixel picture very fast (and from IDE). We can make a list of pictures from a folder including sub folders and we can scroll and zoom in exactly the same position for every picture (if all has the same size and orientation).
Jpg files are opened and rotate internal based on exif data.
We can paint with a green and a white pen defining size and transparency. We can rotate in any angle (using a mask and a merge function).

Program has some controls (all internal, no dll or ocx needed) for scroll bar, scrollio control. Showing a method that one scrollio controll share same DIB with other. Showing how we can place a "Denoise soft filter". Also scrollio handle Wmf and Emf with a slider for quality control. We can place a wmf inside scrollio control and save this in the form.

There are some nice effect with cursor move. We can move cursor and move anywhere in a 20Mpixel photo without using scrollbars. A >5k width times 20 is a 100k width, but largebar can work nice..
ScrollioJPGr.zip
Attached Files
Viewing all 1480 articles
Browse latest View live


<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>