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

VB6 LightWeight COM and vbFriendly-BaseInterfaces

$
0
0
Some stuff for the advanced VB-users among the community (or the curious) ...

I was recently working on some things in this area (preparations for the
C-Emitter of a new VB6-compiler, with regards to "C-style defined Classes") -
and this Tutorial is more or less a "by-product".

I've just brought parts of it into shape, since I think this stuff can be
useful for the community even whilst working with the old compiler.

To gain more IDE-safety (and keep some noise out of the Tutorial-Folders),
I've decided to implement the Base-stuff in its own little Dll-Project:
vbInterfaces.dll

The sources for this Helper-Dll are contained in an appropriate Folder
(vbFriendlyInterfaces\vbInterfaces-Dll\...) in this Tutorial-Zip here:
vbFriendlyInterfaces.zip

The Dll-Project currently contains vbFriendly (Callback-) Interfaces for:
- IUnknown
- IDispatch
- IEnumVariant
- IPicture

Feel free to contribute stuff you think would be useful to include in the
Dll-Project itself - although what it currently contains with regards to
IUnknown and IDispatch, allows to develop your own vtMyInterface-stuff
already "separately" (in a normal VB-StdExe-project for example).

Before entering the Tutorial-Folder and start running the Examples, please make
sure, that you compile the vbInterfaces.dll first from the above mentioned Folder.

The above Zip contains currently a set of 10 Tutorial-Apps, all in their own Folders
(numbered from 0 to 9, from "easy to more advanced") - and here is the
Tutorial-FolderList:
.. 0 - LightWeight COM without any Helpers
.. 1 - LightWeight LateBound-Objects
.. 2 - LightWeight EarlyBound-Objects
.. 3 - LightWeight Object-Lists
.. 4 - Enumerables per vbIEnumVariant
.. 5 - MultiEnumerations per vbIEnumerable
.. 6 - Performance of vbIDispatch
.. 7 - Dynamic usage of vbIDispatch
.. 8 - Simple SOAPDemo with vbIDispatch
.. 9 - usage of vbIPictureDisp

For the last two Tutorial-Demos above I will post separate CodeBank articles,
since they are larger ones - and deserve a few Extra-comments.

Maybe some explanations for NewComers to the topic, who want to learn what
the terms "LightWeight COM", or "C-style Class-implementation" mean:

First, there's a clear separation to be made between "a Class" and "an Object",
since these terms mean two different things really, which we need to look at separately.

- "a Class" is the "BluePrint", which lives in the static Memory of our running Apps or Dlls
- "an Object" (aka "an Instance of a Class") lives as a dynamic Memory-allocation (which refers back to the "BluePrint").

And VB-Objects (the ones we create as Instances from a VB-ClassModules "BluePrint" per New) are quite "large animals" -
since they will take up roughly 116 Bytes per instance-allocation, even when they don't contain any Private Variable Definitions.

A Lightweight COM-Object can be written in VB6 (later taking up only as few as 8Bytes per Instance),
when we resort to *.bas-Modules (similar to the code-modules one would write in plain C).

Here's some Code, how one would implement that (basically the same, as contained in Tutorial-Folder #0):

Let's say we want to implement a lightweight COM-Class (MyClass), which has only a single
Method (AddTwoLongs) in its Public Interface (IMyClass).

We start with the "BluePrint", and the VB-Module which implements that "C-style" would contain only:
Code:

Private Type tMyCOMcompatibleVTable
  'Space for the 3 Function-Pointers of the IUnknown-Interface
  QueryInterface As Long
  AddRef        As Long
  Release        As Long
  'followed by Space for the single Function-Pointer of our concrete Method
  AddTwoLongs    As Long
End Type

Private mVTable As tMyCOMcompatibleVTable 'preallocated (static, non-Heap) Space for the VTable

Public Function VTablePtr() As Long 'the only Public Function here (later called from modMyClassFactory)
  If mVTable.QueryInterface = 0 Then InitVTable 'initializes only, when not already done
  VTablePtr = VarPtr(mVTable) 'just hand out the Pointer to the statically defined mVTable-Variable
End Function

Private Sub InitVTable() 'this method will be called only once (and is thus not "performance-critical")
  mVTable.QueryInterface = FuncPtr(AddressOf modMyClassFactory.QueryInterface)
  mVTable.AddRef = FuncPtr(AddressOf modMyClassFactory.AddRef)
  mVTable.Release = FuncPtr(AddressOf modMyClassFactory.Release)
 
  mVTable.AddTwoLongs = FuncPtr(AddressOf modMyClassFactory.AddTwoLongs)
End Sub

I assume, the above is not that difficult to understand (most "static things" are easy this way) -
what it ensures is, that it "gathers things in one static place" - in this case:
"Function-Pointers in a certain Order" - this "List of Function-Pointers" remains (in its defined order)
behind the static UDT-variable mVTable - and that was it already...

What remains (perhaps a bit more difficult to understand to "make the leap") is,
how the above code-definition will interact, when we now come to the "dynamic part"
(the Objects and their instantiations from a BluePrint).

To have the dynamic part more separated, let's use an additional module (modMyClassFactory):

And as the choosen name (modMyClassFactory) suggests, this is the part which finally hands out
the new Instances (similar to one of the 4 exported Functions, which any ActiveX-Dll needs to support,
which is named 'DllGetClassFactory' for a reason).

So let's show the ObjectCreation-Function in that *.bas Module first:
Note, that UDT struct-definitions are only there for the compiler to "have info about needed space" -
(I've marked these Length-Info parts in light orange below - and the dynamic allocation part in magenta)...
Code:

Private Type tMyObject 'the Object-Instances will occupy only 8Bytes (that's half the size of a Variant-Type)
  pVTable As Long
  RefCount As Long
End Type
 
'Factory Helper-Function to create a new Class-Instance (a new Object) of type IMyClass
Public Function CreateInstance() As IMyClass '<- this Type is defined in a little TypeLib, contained in TutorialFolder #0
Dim MyObj As tMyObject 'we use our UDT-based Object-Type in a Stack-Variable for more convenience
    MyObj.pVTable = modMyClassDef.VTablePtr 'whilst filling its members (as e.g. pVTable here)
    MyObj.RefCount = 1 '<- the obvious value, since we are about to create a "fresh instance"

Dim pMem As Long
    pMem = CoTaskMemAlloc(LenB(MyObj)) 'allocate space for our little 8Byte large Object
    Assign ByVal pMem, MyObj, LenB(MyObj) 'copy-over the Data from our local MyObj-UDT-Variable
    Assign CreateInstance, pMem 'assign the new initialized Object-Reference to the Function-Result
End Function

What remains now, is to provide the Implementation-code for the 4 VTable-methods (which is contained in that same Module)
Code:

'IUnknown-Implementation
Public Function QueryInterface(This As tMyObject, ByVal pReqIID As Long, ppObj As stdole.IUnknown) As Long '<- HResult
  QueryInterface = &H80004002 'E_NOINTERFACE, just for safety reasons ... but there will be no casts in our little Demo
End Function

Public Function AddRef(This As tMyObject) As Long
  This.RefCount = This.RefCount + 1
  AddRef = This.RefCount
End Function

Public Function Release(This As tMyObject) As Long
  This.RefCount = This.RefCount - 1
  Release = This.RefCount
  If This.RefCount = 0 Then CoTaskMemFree VarPtr(This) '<- here's the dynamic part again, when a Class-instance dies
End Function

'IMyClass-implementation (IMyClass only contains this single method)
Public Function AddTwoLongs(This As tMyObject, ByVal L1 As Long, ByVal L2 As Long, Result As Long) As Long '<- HResult
  Result = L1 + L2 'note, that we set the Result ByRef-Parameter - not the Function-Result (which would be used for Error-Transport)
End Function

Finally (to have it complete) a Helper-Function and a few APIs, which are contained in another small *.bas Module
Code:

Declare Function CoTaskMemAlloc& Lib "ole32" (ByVal sz&)
Declare Sub CoTaskMemFree Lib "ole32" (ByVal pMem&)
Declare Sub Assign Lib "kernel32" Alias "RtlMoveMemory" (Dst As Any, Src As Any, Optional ByVal CB& = 4)
 
Function FuncPtr(ByVal Addr As Long) As Long 'just a small Helper for the AddressOf KeyWord
  FuncPtr = Addr
End Function

So, what was (codewise) posted above, is complete - and how a bare-minimum-implementation
for a lightweight "8-Byte large COM-object" could look like in VB6 (and not much different in C) -
no need to copy it over into your own Modules because as said, this is all part of the first little
Demo (in Tutorial-Folder #0, which also includes the needed TypeLib to run the thing).

Happy studying and experimenting... ;)

Olaf
Attached Files

[VB6, Vista+] A compact function to retrieve any property by name, locally formatted

$
0
0
This is related to the greatly expanded property system available in Vista+, and is closely related to the more complete tour of the system in my other projects.

While this method is inefficient and shouldn't be used for large numbers of properties or large numbers of files*, if you just need a few specific properties from a single file this method is a quick way to get them. The results appear as they do in Explorer's Details view; according to your locale, with units, etc. The key shortcut here is the SHGetPropertyStoreFromParsingName function and other PS_ APIs, which let us skip over all the IShellItem interface work.

Requirements
-Windows Vista or higher
-oleexp 2.0 or higher (no new release related to this code)

Usage
After putting the below code in a module, just call the GetPropertyDisplayString(file, property) function, it will return a string with the property as it appears in Explorer. For example, System.Dimensions on a JPG file might return "640 x 480", or System.Width as "100 pixels"; or an AVI's System.Length as "01:30:20". It's more than just raw numbers (although those can be retrieved too; see the larger project).
sResult = GetPropertyDisplayString("C:\myfile.jpg", "System.Width")

Code
Code:

Public Declare Function PSGetPropertyKeyFromName Lib "propsys.dll" (ByVal pszName As Long, ppropkey As PROPERTYKEY) As Long
Public Declare Function PSFormatPropertyValue Lib "propsys.dll" (ByVal pps As Long, ByVal ppd As Long, ByVal pdff As PROPDESC_FORMAT_FLAGS, ppszDisplay As Long) As Long
Public Declare Function SHGetPropertyStoreFromParsingName Lib "shell32" (ByVal pszPath As Long, pbc As Any, ByVal Flags As GETPROPERTYSTOREFLAGS, riid As UUID, ppv As Any) As Long
Public Declare Function PSGetPropertyDescription Lib "propsys.dll" (PropKey As PROPERTYKEY, riid As UUID, ppv As Any) As Long
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 GetPropertyDisplayString(szFile As String, szProp As String) As String
'Gets the string value of the given canonical property; e.g. System.Company, System.Rating, etc
'This would be the value displayed in Explorer if you added the column in details view
Dim pkProp As PROPERTYKEY
Dim pps As IPropertyStore
Dim lpsz As Long
Dim ppd As IPropertyDescription

PSGetPropertyKeyFromName StrPtr(szProp), pkProp
SHGetPropertyStoreFromParsingName StrPtr(szFile), ByVal 0&, GPS_DEFAULT, IID_IPropertyStore, pps
PSGetPropertyDescription pkProp, IID_IPropertyDescription, ppd
PSFormatPropertyValue ObjPtr(pps), ObjPtr(ppd), PDFF_DEFAULT, lpsz
SysReAllocString VarPtr(GetPropertyDisplayString), lpsz
CoTaskMemFree lpsz


End Function

Include the following in your module only if you're not using the mIID.bas module from the oleexp thread:
Code:

Public Sub DEFINE_UUID(Name As UUID, L As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
  With Name
    .Data1 = L
    .Data2 = w1
    .Data3 = w2
    .Data4(0) = B0
    .Data4(1) = b1
    .Data4(2) = b2
    .Data4(3) = B3
    .Data4(4) = b4
    .Data4(5) = b5
    .Data4(6) = b6
    .Data4(7) = b7
  End With
End Sub
Public Function IID_IPropertyStore() As UUID
'DEFINE_GUID(IID_IPropertyStore,0x886d8eeb, 0x8cf2, 0x4446, 0x8d,0x02,0xcd,0xba,0x1d,0xbd,0xcf,0x99);
Static IID As UUID
 If (IID.Data1 = 0) Then Call DEFINE_UUID(IID, &H886D8EEB, CInt(&H8CF2), CInt(&H4446), &H8D, &H2, &HCD, &HBA, &H1D, &HBD, &HCF, &H99)
  IID_IPropertyStore = IID
 
End Function
Public Function IID_IPropertyDescription() As UUID
'(IID_IPropertyDescription, 0x6f79d558, 0x3e96, 0x4549, 0xa1,0xd1, 0x7d,0x75,0xd2,0x28,0x88,0x14
Static IID As UUID
 If (IID.Data1 = 0) Then Call DEFINE_UUID(IID, &H6F79D558, CInt(&H3E96), CInt(&H4549), &HA1, &HD1, &H7D, &H75, &HD2, &H28, &H88, &H14)
  IID_IPropertyDescription = IID
 
End Function

ALTERNATIVE: Get directly by PROPERTYKEY
Now that I've published a complete list of PROPERTYKEY's from propkey.h, if you include the mPKEY.bas module from the oleexp project, you can use those directly like this:
Code:

Public Function GetPropertyKeyDisplayString(szFile As String, pkProp As PROPERTYKEY) As String
Dim pps As IPropertyStore
Dim lpsz As Long
Dim ppd As IPropertyDescription

SHGetPropertyStoreFromParsingName StrPtr(szFile), ByVal 0&, GPS_DEFAULT, IID_IPropertyStore, pps
PSGetPropertyDescription pkProp, IID_IPropertyDescription, ppd
PSFormatPropertyValue ObjPtr(pps), ObjPtr(ppd), PDFF_DEFAULT, lpsz
SysReAllocString VarPtr(GetPropertyKeyDisplayString), lpsz
CoTaskMemFree lpsz
End Function

Common Properties
For a full list of system properties, see propkey.h in the SDK (or unofficial copies online); or the larger projects I have that will enumerate them all.

Otherwise, see the MSDN post Metadata Properties for Media Files for the popular ones.

-------------------------------
* - When working with large numbers of files, or user-selectable properties, it's best to implement IShellItem and IPropertySystem based solutions from the ground up.

[vb6] SavePictureEx (Unicode compatible and a bit more)

$
0
0
Not anywhere close to deep-thought-provoking code nor is it any breakthrough. I thought I'd share a workaround I've been using for awhile.

VB's SavePicture uses existing APIs that have the ability to be unicode compatible. If we bypass VB and use those APIs instead, problem solved.

In addition, depending on how the picture was created and assigned in VB, the original data is cached and that data can be saved. For example, if you load a JPG during design-view into a VB picture property, the actual JPG data is preserved, but if you try to call VB's SavePicture, it is saved as a bitmap and not a JPG. We can save the the image as a JPG copy. This does not mean VB or the APIs can convert the image to JPG, it simply means that if the original image format is maintained, it can be saved. This also applies to GIFs and icons that contain multiple sub-icons. Anyone can take the routine provided below and super-size it to allow optional parameters that would be used to identify requests for image conversion to other formats. I'll leave that to you.

Rule of thumb is that VB will cache original data when pictures are loaded during design-time, not runtime.

In the code below, notice the blue-highlighted text? If the blue text were removed, then if the passed tgtPicture parameter contained the original image data for GIF/JPG, then the original image data would be saved.
Code:

' APIs used
Private Declare Function SHCreateStreamOnFileEx Lib "shlwapi.dll" (ByVal pszFile As Long, ByVal grfMode As Long, ByVal dwAttributes As Long, ByVal fCreate As Long, ByVal reserved As Long, ByRef ppstm As IUnknown) As Long
Private Declare Function GetFileAttributesW Lib "kernel32.dll" (ByVal lpFileName As Long) As Long

Code:

Public Sub SavePictureEx(tgtPicture As IPictureDisp, ByVal FileName As String)

    Dim oStream As IUnknown, oPicture As IPicture
    Dim lRtn As Long, bFlagCreate As Long
    Const INVALID_FILE_ATTRIBUTES As Long = -1&
    Const STGM_CREATE As Long = &H1000&
    Const STGM_WRITE As Long = &H1&
    Const FILE_ATTRIBUTE_NORMAL = &H80&
   
    If tgtPicture Is Nothing Then Exit Sub
    If tgtPicture.Handle = 0& Then Exit Sub
   
    If GetFileAttributesW(StrPtr(FileName)) = INVALID_FILE_ATTRIBUTES Then bFlagCreate = 1&
    lRtn = SHCreateStreamOnFileEx(StrPtr(FileName), STGM_WRITE Or (STGM_CREATE * bFlagCreate), _
                            FILE_ATTRIBUTE_NORMAL, bFlagCreate, 0&, oStream)
    If lRtn = 0& Then
        Set oPicture = tgtPicture
        If tgtPicture.Type = vbPicTypeBitmap Then
            oPicture.SaveAsFile ByVal ObjPtr(oStream), 1&, lRtn ' always save as bitmap
        Else
If oPicture.KeepOriginalFormat Then
            oPicture.SaveAsFile ByVal ObjPtr(oStream), 0&, lRtn ' save original data if it exists
        Else
            oPicture.SaveAsFile ByVal ObjPtr(oStream), 1&, lRtn ' save using VB's default SavePicture logic
        End If
        Set oStream = Nothing ' closes the file
    Else
        Err.Raise lRtn, "SavePictureEx"
    End If

End Sub

The above code is compatible with XP and above. The API SHCreateStreamOnFileEx doesn't exist on lower operating systems. If required, that API can be replaced with a custom function that:
- creates a compatible stream object (CreateStreamOnHGlobal API)
- saves the data to that stream (oPicture.SaveAsFile)
- creates a file (CreateFile API)
- reads the data from the stream pointer to the file (ReadFile API)
- close the file and unlock/release the stream

FYI: IUnknown and IPicture are valid objects in VB, they are just hidden by default from intellisense

[VB6] Register any control as a drop target that shows the Explorer drag image

$
0
0

Dragging from Explorer

Dragging from Firefox

So as we all know, the drag cursor for a VB drop target is a hideous relic of the Windows 3.1 days. No more! Ever since XP, there has been an interface called IDropTargetHelper that automatically shows the proper drag image. And not just for Explorer file drops; the drag image you see in any modern program will now also appear on your VB6 drop target. And more good news, it's only a tiny bit more complicated than using the normal OLEDragDrop features (this method completely replaces the native OLE DnD stuff and controls should be 'None' for OLEDropMode- the IDropTarget class has DragEnter, DragOver, DragLeave, and Drop events if you need them).

Requirements
-Windows XP or higher
-oleexp.tlb (any version; no new release is associated with this project and the interfaces used date back to the 1.x versions)

How It Works

-First, a class module that implements IDropTarget and contains an instance of IDropTargetHelper needs to be created
-The only tricky thing is getting the file list from the IDataObject; but the sample class handles this and just passes a file list back.
-Then, any control can call the RegisterDragDrop API to become a target supporting the new images!

Note that while the example just accepts file drops with the standard CF_HDROP format, you have the full data object passed from the source of the drag, and could retrieve any format it contains (there's tons of clipboard formats; text, html, images, etc).

Note on Unicode support: All the code is designed to support Unicode, but the file names in the sample project are displayed in a regular VB textbox which cannot show extended characters-- but the file names returned are in Unicode and if displayed in a Unicode-enabled control will be rendered correctly.

Code
cDropTarget
Code:

Option Explicit
Private Declare Function DragQueryFileW Lib "shell32.dll" (ByVal hDrop As Long, ByVal iFile As Long, Optional ByVal lpszFile As Long, Optional ByVal cch As Long) As Long
Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long
Private Declare Function CoCreateInstance Lib "ole32" (rclsid As Any, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, riid As Any, pvarResult As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszGuid As Long, pGuid As Any) As Long

'IDropTargetHelper is what lets us show the drag image
Private pDTH As IDropTargetHelper

Private Const CLSID_DragDropHelper = "{4657278A-411B-11D2-839A-00C04FD918D0}"
Private Const IID_IDropTarget = "{4657278B-411B-11D2-839A-00C04FD918D0}"

Implements IDropTarget

Private Sub Class_Initialize()
Dim dhiid As UUID
Dim dthiid As UUID

Call CLSIDFromString(StrPtr(CLSID_DragDropHelper), dhiid)
Call CLSIDFromString(StrPtr(IID_IDropTarget), dthiid)
Call CoCreateInstance(dhiid, 0&, CLSCTX_INPROC_SERVER, dthiid, pDTH)
End Sub

Private Sub IDropTarget_DragEnter(ByVal pDataObj As oleexp3.IDataObject, ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As oleexp3.DROPEFFECTS)
  Debug.Print "DragEnter"
 
  Dim pt As oleexp3.POINT
  pt.x = ptX
  pt.y = ptY
 
  pDTH.DragEnter Form1.Picture1.hWnd, pDataObj, pt, pdwEffect

End Sub

Private Sub IDropTarget_DragLeave()
Debug.Print "DragLeave"

pDTH.DragLeave
 
End Sub

Private Sub IDropTarget_DragOver(ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As oleexp3.DROPEFFECTS)
    Debug.Print "DragOver"

  Dim pt As oleexp3.POINT
  pt.x = ptX
  pt.y = ptY

    pDTH.DragOver pt, pdwEffect
   
    'Notice that the text shows 'Move' in the caption; you can change pdwEffect to something else
    'pdwEffect = DROPEFFECT_COPY
    'pdwEffect = DROPEFFECT_NONE 'this shows that a drop is not allowed, and the drop event won't fire
End Sub

Private Sub IDropTarget_Drop(ByVal pDataObj As oleexp3.IDataObject, ByVal grfKeyState As Long, ByVal ptX As Long, ByVal ptY As Long, pdwEffect As oleexp3.DROPEFFECTS)
Debug.Print "Drop"
Dim idx As Long
  Dim pt As oleexp3.POINT
  pt.x = ptX
  pt.y = ptY
 
 pDTH.Drop pDataObj, pt, pdwEffect
 
 'For this project, we're just going to accept the files and pass back what
 'operation we did with them. But to add more functionality, you can look
 'at grfKeyState; that will tell you if ctrl is being held so you can move,
 'or if the right mouse button is down and you should show a menu of options
 Dim fmt As FORMATETC
 fmt.cfFormat = CF_HDROP
 fmt.TYMED = TYMED_HGLOBAL
 fmt.dwAspect = DVASPECT_CONTENT
 fmt.lindex = -1
 
 Dim stg As STGMEDIUM
 
 If pDataObj.QueryGetData(fmt) = S_OK Then
    pDataObj.GetData fmt, stg
    Dim nFiles As Long, sFiles() As String
    Dim i As Long
    Dim sBuffer As String
    nFiles = DragQueryFileW(stg.Data, &HFFFFFFFF, 0, 0)
    ReDim sFiles(nFiles - 1)
    For i = 0 To nFiles - 1
        SysReAllocStringLen VarPtr(sBuffer), , DragQueryFileW(stg.Data, i)
        DragQueryFileW stg.Data, i, StrPtr(sBuffer), Len(sBuffer) + 1&
        sFiles(i) = sBuffer
    Next
Else
    Debug.Print "failed querygetdata"
End If
   

  pdwEffect = Form1.DropFiles(sFiles, grfKeyState)
End Sub

Sample Form
Code:

Option Explicit
Private Declare Function RegisterDragDrop Lib "ole32" _
        (ByVal hWnd As Long, ByVal DropTarget As IDropTarget) As Long
Private Declare Function RevokeDragDrop Lib "ole32" (ByVal hWnd As Long) As Long

Private cIDT As cDropTarget

Public Function DropFiles(sFiles() As String, KeyState As Long) As DROPEFFECTS
'Do whatever with the files
Text1.Text = ""
Text1.Text = Join(sFiles, vbCrLf)
DropFiles = DROPEFFECT_NONE 'We didn't do anything with the dropped files here,
                            'but if you do move/copy/link them, report that back
End Function

Private Sub Form_Load()
Set cIDT = New cDropTarget
Call RegisterDragDrop(Picture1.hWnd, cIDT)

End Sub

Private Sub Form_Unload(Cancel As Integer)
Call RevokeDragDrop(Picture1.hWnd)
End Sub

Dragging FROM controls
Note that if you combine this method with a control that's a drag source for files using my SHCreateDataObject/SHDoDragDrop method, you will now see the Explorer icon right on the control you're dragging from, and the filetype icon will now show up. No additional coding required. At some point in the future I'll release a sample combining them, but in the mean time they are completely compatible if someone else wants to. (I have tested and confirmed this, it's just ripping out the file listview that has dozens of other features and thousands of lines of code associated with it-- testing is easier on a fully complete file view-- isn't practical)

------------------------------------------
Project updated: Forgot DragDropHelper coclass can't be used on XP; updated to use it by CLSID with CoCreateInstance. Code for Class_Initialize updated in sample project and above in this post.
Attached Files

[VB6] PicSave - Simple SavePicture as GIF, PNG, JPEG

$
0
0
Sometimes you need a better SavePicture() function. Not a lot better, just one that can save in some compressed format instead of just BMP format. Like JPEG usually, or PNG. Well this one does that, and throws in GIF as well though as usual (being based on GDI+) those tend to come out dithered and sort of crap in general.

What we have here is a simple preclared-instance Class with one method: SavePicture().

You give it a StdPiture, a file name (yes, it can save using Unicode paths), which format you want, and for JPEG you can add a "quality" in percent. It saves to disk, not to Byte arrays.

Nothing here people haven't seen before. This is just a "stripped to essentials" rendition of the well worn theme.


It only requires a version of Windows with IE 5 or later. It uses GDI+ but most systems with IE 5 or later cover that as well. In any case it should work on nearly anything you run anymore.

There are no 3rd party DLLs required, and not even any typelibs. Just add PicSave.cls to your Projects.


The attachment contains a simple demo. Its bulk is all source image data.


The StdPicture you pass to it must have a bitmap handle. In practical terms this means you may have to pass it the persistant-image property (.Image) if you have drawn your picture onto a Form, PictureBox, etc. and there is no provision for dealing with metafile vector images.


Notes:

New attachment incorporating feedback from discussion below to address issues encountered when GDI v. 1.1 is in play, running on 64-bit Windows, etc.

Also note that this makes no effort to handle transparency or alpha-channel translucency for GIF or PNG output. It saves simple "whole bitmap" images. If you load a picture with transparency into a StdPicture and save it back using this class the transparency is lost.
Attached Files

[VB6] Creation of GIF-animation with the transparent background.

$
0
0
Hi everyone!
This project allows to create an GIF animations with the transparent background. As far as i know the GDI+ doesn't allow to set the property of "Disposal Method" in the "Graphic Control Extension" block, therefore each next frame is overlayed to the previous frame. For the opaque frames it's doesn't matter. In order to solve this issue i decide to change the needed bytes manually in the raw GIF file.
It allows to prevent the restrictions of the transparent frames. Also this example contains the oct-tree class, which calculates the optimal palette for the each frame. There are the ability of the additional settings: threshold of the transparency, duration, and number of the loops for entire animation. For the disabling of the transparency enough set the threshold to zero. The greater the value of the threshold field the greater semitransparent pixels become transparent completely.

Name:  Безымянный.png
Views: 58
Size:  105.4 KB
Regards,
Кривоус Анатолий.
Attached Images
 
Attached Files

[VB6] - Library info.

$
0
0
Hi everyone.
This is quite simple project, which allows to view some information about libraries and PE-files:
  • Export;
  • Import;
  • Delay import;
  • For type libraries and PE which contains the type libraries:
    1. Interfaces;
    2. CoClasses;
    3. Types;
    4. Enumerations;
    5. Aliases.

It requires Edanmo's OLE interfaces & functions (olelib.tlb) for the work.

Regards,
Кривоус Анатолий.
Attached Files

[vb6] Class to Support PNG, TIF and GIF Animation

$
0
0
We all know VB is old and doesn't support many of the common image formats, specifically: TIF, PNG and alpha-blended icons. The attached class enables VB to support those formats and a bit more. There is no usercontrol involved. Just a bit of subclassing (IDE safe) to enable the images to be rendered with APIs that do support the alpha channel: AlphaBlend and DrawIconEx. The class methods/properties can be categorized as follows:

I. VB Replacement Methods
- LoadPicture: Unicode supported. Has options to keep original image format when loading. This enables you to navigate animated GIF frames and multipage TIFs. It also allows you to save that original data to file. Method accepts byte arrays also.
- SavePicture: Unicode supported. Has options to always save to bitmap or save original format if it exists
- PictureType: Returns the original image format, i.e., GIF, PNG, TIF, etc, if that format exists

II. Management Methods
- IsManaged: Return whether the class is rendering the image or VB is
- UnManage: Simply unsubclasses a managed image

III. Navigation Methods
- SubImageCount: Returns the number of frames/pages contained within the managed image
- SubImageIndex: Returns the current frame/page displayed by the managed image
- SubImage: Returns a stdPicture object of the requested frame/page
- GetGIFAnimationInfo: Returns an array containing loop count and each frame's display interval for animated GIFs

Quickly. How does this class do it?

1. It creates thunks to subclass the VB picture objects. The source code of the thunks are provided in the package. These thunks draw the image using the APIs AlphaBlend or DrawIconEx. For you ASM gurus out there: I'm a noob with ASM. I'm sure others can rewrite that ASM code to be more efficient.

2. To support AlphaBlend API, images may be converted to a 32bit bitmap having the pixel data premultiplied against the alpha channel. These bitmaps will never display correctly outside of the class. Therefore the class' SavePicture function allows you to create a copy of the bitmap that can be displayed outside of the class. This copy can be passed to the clipboard and/or drag/drop methods of your project.

3. GDI+ is relied upon to parse/load TIF and PNG. It is also used to support JPG in CMYK format and multi-frame GIF rendering. GDI+ is a requirement for the class. If it fails to load or thunks fail to be created, the class will silently fall back to standard VB methods and VB restrictions.

The transparency displayed by the image control is not faked. It is true transparency and the attached test project should easily prove that. For those of you that follow my projects, you are aware of another similar solution I posted last month. This is far better, far safer (crash-wise) and in many ways, far easier to use. Just drop the class in your project & go.

Important to understand. TIF and PNG support is not available at design-time. This is because the class code isn't activated until run-time. Some motivated individuals out there could easily create a windowless usercontrol that hosts an image control that could support all formats at design-time. Just a thought and subtle prod.

The class can be expanded by those willing to put in the effort. Ideas would be to incorporate GDI+ high quality scaling, conversion from one image format to another, image effects like rotation, blur, and more. Other image formats can easily be supported from outside the class. If you can parse/render that new format to a 32bpp bitmap, then you can use the class' LoadPicture to display that image. Have fun.

We all know VB when compiled can behave differently vs when uncompiled. Some differences are subtle, others are not. Here's one that is key for animating GIFs. In the test project posted below, the animation works because VB caches the GIF format for the GIF that was loaded into Image1 during design-time. During run-time that info is still cached by VB so the class can extract the entire GIF. But when you compile the project, the GIF no longer animates. Why? Well, when compiled, the GIF information is lost. VB no longer caches it. This can be proven in a simple test project. Add a image control and button. Add a GIF or JPG to that image control. Add the following code behind the button. Click the button when project is running compiled and uncompiled. Different results. The workaround is simply to save GIFs you want to animate in a resource file and load the GIF from that.
Code:

Dim IPic As IPicture
Set IPic = Image1.Picture
MsgBox CStr(IPic.KeepOriginalFormat)

Name:  Untitled.jpg
Views: 61
Size:  40.7 KB
Attached Images
 
Attached Files

[vb6] Class to make Image Controls Support PNG, TIF, GIF Animation

$
0
0
We all know VB is old and doesn't support many of the common image formats, specifically: TIF, PNG and alpha-blended icons. The attached class enables VB to support those formats and a bit more. There is no usercontrol involved. Just a bit of subclassing (IDE safe) to enable the images to be rendered with APIs that do support the alpha channel: AlphaBlend and DrawIconEx. The class is not limited to just Image controls, can be applied to most (if not all) of VB's picture, icon, and other image properties.

Image formats supported. The 'includes' below are in addition to what VB supports:
:: BMP. Includes 32bpp alpha and/or premultiplied. Includes those stored with v4 & v5 of the bitmap info header
:: GIF. Includes methods to navigate frames
:: JPG. Includes CMYK color space
:: ICO,CUR. Includes 32bpp alpha and/or PNG-encoded Vista-type icons
:: WMF. Includes non-placeable (next update)
:: EMF
:: PNG
:: TIF. Both single page & multi-page. Supported compression schemes depend on version of GDI+ installed

The class methods/properties can be categorized as follows:

I. VB Replacement Methods
- LoadPicture: Unicode supported. Has options to keep original image format when loading. This enables you to navigate animated GIF frames and multipage TIFs. Cached data allows you to save that original data to file
- SavePicture: Unicode supported. Has options to always save to bitmap or save original format if it exists
- PictureType: Returns the original image format, i.e., GIF, PNG, TIF, etc, if that format exists
note: LoadPicture & SavePicture both accept byte array as source/destination medium

II. Management Methods
- IsManaged: Return whether the class is rendering the image or VB is
- UnManage: Simply unsubclasses a managed image
- HasOriginalFormat: Return whether or not any Picture is caching original image format data

III. Navigation Methods
- SubImageCount: Returns the number of frames/pages contained within the managed image
- SubImageIndex: Returns the current frame/page displayed by the managed image
- SubImage: Returns a stdPicture object of the requested frame/page
- GetGIFAnimationInfo: Returns an array containing loop count and each frame's display interval for animated GIFs

Quickly. How does this class do it?

1. It creates thunks to subclass the VB picture objects. The source code of the thunks are provided in the package. These thunks draw the image using the APIs AlphaBlend or DrawIconEx. For you ASM gurus out there: I'm a noob with ASM. I'm sure others can rewrite that ASM code to be more efficient.

2. To support AlphaBlend API, images may be converted to a 32bit bitmap having the pixel data premultiplied against the alpha channel. These bitmaps will never display correctly outside of the class. Therefore the class' SavePicture function allows you to create a copy of the bitmap that can be displayed outside of the class. This copy can be passed to the clipboard and/or drag/drop methods of your project.

3. GDI+ is relied upon to parse/load TIF and PNG. It is also used to support JPG in CMYK format and multi-frame GIF rendering. GDI+ is a requirement for the class. If it fails to load or thunks fail to be created, the class will silently fall back to standard VB methods and VB restrictions.

The transparency displayed by the image control is not faked. It is true transparency and the attached test project should easily prove that. Important to understand. TIF and PNG support is not available at design-time. This is because the class code isn't activated until run-time. Some motivated individuals out there could easily create a windowless usercontrol that hosts an image control (and this class) that could support all formats at design-time. Just a thought and subtle prod.

The class can be expanded by those willing to put in the effort. Ideas would be to incorporate GDI+ high quality scaling, conversion from one image format to another, image effects like rotation, blur, and more. Other image formats can easily be supported from outside the class. If you can parse/render that new format to a 32bpp bitmap, then you can use the class' LoadPicture to display that image. Have fun.

When compiled, VB can behave differently vs when uncompiled. Some differences are subtle, others are not. Here's one that is key for animating GIFs. In the test project posted below, the animation works because VB caches the GIF format for the GIF that was loaded into Image1 during design-time. During run-time that info is still cached by VB so the class can extract the entire GIF. But when you compile the project, the GIF no longer animates. Why? Well, when compiled, the GIF information is lost. VB no longer caches it. This can be proven in a simple test project. Add a image control and button. Add a GIF or JPG to that image control. Add the following code behind the button. Click the button when project is running compiled and uncompiled. Different results. The workaround is simply to save GIFs you want to animate in a resource file and load the GIF from that.
Code:

Dim IPic As IPicture
Set IPic = Image1.Picture
MsgBox CStr(IPic.KeepOriginalFormat)

Design-time vs. Run-time screenshot
Name:  Untitled.jpg
Views: 20
Size:  33.2 KB
Attached Images
 
Attached Files

[VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget

$
0
0
About
This project is a followup to [VB6] Basic unzip without 3rd party DLL or shell32- IStorage-based, to create a zip using the same method. At the time, I didn't know if it was possible, and later I thought you'd have to implement a custom IDataObject, so I hadn't thought it worth the effort. But I revisited this topic after a question, and found that with a couple workarounds for some weird errors, it's entirely possible to not only do it, but to do it without a custom IDataObject.

Requirements
-oleexp3.tlb 3.0 or higher.
-Windows XP or higher (the core ZipFiles() sub should work on XP, HOWEVER.. for simplicity the demo project uses Vista+ dialogs to choose files; you'll need a new way of selecting files for XP)

The Challenges
(background info, these are solved issues, not needed to use the code)
There were three very strange issues I had to work around. First, a reference needed to be created to the zip file being created. This reference was found by using the immediate parent folder and the relative pointer to that file... think of it as using "C:\folder" and "file.zip". That is used to get the drop target for the file (this method uses the drag-drop interface in code). folder is asked for the drop target for file.zip-- this fails. BUT.. if we combine them, and ask the desktop for the drop target for "C:\folder\file.zip", it succeeds. This makes very little sense to me.

The second issue was the error that had other people created their own IDataObject implementation. When you try to drop multiple files on an empty zip, you get an error saying that it can't add files to a new zip file because the new zip file is empty. Of course it's empty. A more detailed and app-crashing error says the IDataObject is invalid. Fortunately, by luck my initial test only tried to add one file. And this worked without producing the error. And if that wasn't bizarre enough, once that first file is added you can then add multiple files-- and not even one at a time, it will now accept the same type of multi-file IDataObject it errored on before.

Lastly, if 9 or more files were being added, Windows would display a compressed folders error (not an error in VB/the program) saying it couldn't find/read the first file. The first file would then not appear in the zip, but the rest would. But only on the first time files from that folder were added to a zip. But if that's the case, why wouldn't trying to add the other 8 files trigger the can't-add-multi-to-empty error?? Since it was an external error, I added a Sleep/DoEvents/Sleep routine to try to figure out where precisely the error was happening; but then since adding it I have not been able to reproduce the bug (it comes back without sleep). So please let me know if this one rears its head again... I think the solution at that point would to only add in blocks of 8.

The Code
Here's the core routine and its supporting APIs and functions:
Code:

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long) ' Frees memory allocated by the shell
Public Declare Function ILCombine Lib "shell32" (ByVal pidl1 As Long, ByVal pidl2 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 Declare Function SHCreateFileDataObject Lib "shell32" Alias "#740" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pDataInner As Any, ppDataObj As oleexp3.IDataObject) As Long
Public Declare Function SHGetDesktopFolder Lib "shell32" (ppshf As IShellFolder) As Long ' Retrieves the IShellFolder interface for the desktop folder.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long

Public Const MK_LBUTTON = 1

Public Sub ZipFiles(sZipPath As String, pszToZip() As String)
Dim pZipStg As oleexp3.IStorage
Dim pZipStrm As oleexp3.IStream
Dim psfZipFolder As IShellFolder
Dim pidlZipFolder As Long
Dim pDT As IDropTarget

Dim pidlToZip() As Long
Dim idoToZip As oleexp3.IDataObject

'So weird bug... if you try to drop multiple files onto the newly created
'empty zip file, you get an error saying it can't create it because it's
'empty. stupid to begin with, of course it's empty to begin with. but even
'stupider, if you only drop 1 file, it works. so we have to only drop one
'file at first, then we can drop the rest
Dim pidlToZip2() As Long
Dim idoToZip2 As oleexp3.IDataObject

Dim pszZipFile As String 'name of zip file only, e.g. blah.zip
Dim pszZipFolder As String 'full path to folder that will contain .zip
Dim pidlZipFile As Long

Dim pchEaten As Long
Dim q As Long
Dim bMulti As Boolean

ReDim pidlZip(0)
ReDim pidlToZip(0)
pszZipFolder = Left$(sZipPath, InStrRev(sZipPath, "\") - 1)
pszZipFile = Right$(sZipPath, Len(sZipPath) - InStrRev(sZipPath, "\"))
Debug.Print "zipfolder=" & pszZipFolder
Debug.Print "zipfile=" & pszZipFile

pidlToZip(0) = ILCreateFromPathW(StrPtr(pszToZip(0)))
If UBound(pszToZip) > 0 Then
    ReDim pidlToZip2(UBound(pszToZip) - 1)
    For q = 1 To UBound(pszToZip)
        pidlToZip2(q - 1) = ILCreateFromPathW(StrPtr(pszToZip(q)))
    Next
    bMulti = True
End If
pidlZipFolder = ILCreateFromPathW(StrPtr(pszZipFolder))

Set psfZipFolder = GetIShellFolder(isfDesktop, pidlZipFolder)
Set pZipStg = psfZipFolder 'this calls QueryInterface internally
If (pZipStg Is Nothing) Then
    Debug.Print "Failed to create IStorage"
    GoTo clnup
End If

Set pZipStrm = pZipStg.CreateStream(pszZipFile, STGM_CREATE, 0, 0)
If (pZipStrm Is Nothing) Then
    Debug.Print "Failed to create IStream"
    GoTo clnup
End If

psfZipFolder.ParseDisplayName 0&, 0&, StrPtr(pszZipFile), pchEaten, pidlZipFile, 0&
If pidlZipFile = 0 Then
    Debug.Print "Failed to get pidl for zip file"
    GoTo clnup
End If

Call SHCreateFileDataObject(VarPtr(0&), UBound(pidlToZip) + 1, VarPtr(pidlToZip(0)), ByVal 0&, idoToZip)
If (idoToZip Is Nothing) Then
    Debug.Print "Failed to get IDataObject for ToZip"
    GoTo clnup
End If

Dim pidlFQZF As Long
pidlFQZF = ILCombine(pidlZipFolder, pidlZipFile)
'This is very weird. Both psfZipFolder and pidlZipFile(0) are valid, but if we request the IDropTarget using those,
'pDT fails to be generated. But when the zip file's relative pidl is combined with the pidl for its folder, and
'passed to isfDesktop as a fully qualified pidl, it works
'psfZipFolder.GetUIObjectOf 0&, 1, pidlZipFile(0), IID_IDropTarget, 0&, pDT
isfDesktop.GetUIObjectOf 0&, 1, pidlFQZF, IID_IDropTarget, 0&, pDT

If (pDT Is Nothing) Then
    Debug.Print "Failed to get drop target"
    GoTo clnup
End If


pDT.DragEnter idoToZip, MK_LBUTTON, 0&, 0&, DROPEFFECT_COPY
pDT.Drop idoToZip, MK_LBUTTON, 0&, 0&, DROPEFFECT_COPY

If bMulti Then
    Sleep 1500
    DoEvents
    Sleep 1500
    Debug.Print "adding rest of files..."
    Call SHCreateFileDataObject(VarPtr(0&), UBound(pidlToZip2) + 1, VarPtr(pidlToZip2(0)), ByVal 0&, idoToZip2)
    If (idoToZip2 Is Nothing) Then
        Debug.Print "Failed to get IDataObject for ToZip2"
        GoTo clnup
    End If
   
    pDT.DragEnter idoToZip2, MK_LBUTTON, 0, 0, DROPEFFECT_COPY
    pDT.Drop idoToZip2, MK_LBUTTON, 0, 0, DROPEFFECT_COPY
End If
'cleanup
clnup:
ILFree pidlToZip(0)
If bMulti Then
    For q = 0 To UBound(pidlToZip2)
        Call ILFree(pidlToZip2(q))
    Next
End If
Call ILFree(pidlZipFile)
Call ILFree(pidlZipFolder)
Call ILFree(pidlFQZF)
End Sub

'-----------------------------
'Supporting functions
Public Function GetIShellFolder(isfParent As IShellFolder, pidlRel As Long) As IShellFolder
  Dim isf As IShellFolder
  On Error GoTo out

  Call isfParent.BindToObject(pidlRel, 0, IID_IShellFolder, isf)

out:
  If Err Or (isf Is Nothing) Then
    Set GetIShellFolder = isfDesktop
  Else
    Set GetIShellFolder = isf
  End If

End Function
Public Function isfDesktop() As IShellFolder
  Static isf As IShellFolder
  If (isf Is Nothing) Then Call SHGetDesktopFolder(isf)
  Set isfDesktop = isf
End Function
Public Function LPWSTRtoStr(lPtr As Long, Optional ByVal fFree As Boolean = True) As String
SysReAllocString VarPtr(LPWSTRtoStr), lPtr
If fFree Then
    Call CoTaskMemFree(lPtr)
End If
End Function

'----------------------------------------------
'Below not needed in a project with mIID.bas
'----------------------------------------------

Private Function IID_IDropTarget() As UUID
'{00000122-0000-0000-C000-000000000046}
Static iid As UUID
 If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &H122, CInt(&H0), CInt(&H0), &HC0, &H0, &H0, &H0, &H0, &H0, &H0, &H46)
 IID_IDropTarget = iid
End Function
Private Function IID_IShellFolder() As UUID
  Static iid As UUID
  If (iid.Data1 = 0) Then Call DEFINE_OLEGUID(iid, &H214E6, 0, 0)
  IID_IShellFolder = iid
End Function
Private Sub DEFINE_OLEGUID(Name As UUID, L As Long, w1 As Integer, w2 As Integer)
  DEFINE_UUID Name, L, w1, w2, &HC0, 0, 0, 0, 0, 0, 0, &H46
End Sub
Private Sub DEFINE_UUID(Name As UUID, L As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
  With Name
    .Data1 = L
    .Data2 = w1
    .Data3 = w2
    .Data4(0) = B0
    .Data4(1) = b1
    .Data4(2) = b2
    .Data4(3) = B3
    .Data4(4) = b4
    .Data4(5) = b5
    .Data4(6) = b6
    .Data4(7) = b7
  End With
End Sub

Existing Archives
If you wanted to add to existing archive, it's just a few adjustments. All you'd have to do is skip over the parts that generate a new zip file, and go directly to getting an IDropTarget for it and dropping the file IDataObject. If there's enough interest I may add some sample code for this in the future.
Attached Files

VB6 Virtual unicode-aware ListControl (grouping TreeList-Demo)

$
0
0
A Virtual-ListControl is sufficient for almost any purpose,
since anything it will render will be triggered from the outside,
in appropriate OwnerDraw-Events - which will then visualize
Data which is hosted outside of the Control as well.

This allows for quite some flexibility, even when one tries
to implement a TreeList-scenario on just such a simple "VList".

The VList-Control which comes with this Demo is (codewise) quite
small (about 350 lines of code) - and based on a normal ListBox-
WindowClass (and not a ListView).

Nevertheless, it:
- is Unicode-aware
- has no dependencies to other COM-libs
- supports OwnerDrawn-Headers
- supports multiple Columns (including HScrolling if needed)
- supports Sorting (including SortMarker-Rendering on the Col-Headers)
- encapsulates already the Basic-GDI-routines (no GDI-Declares needed at the outside)
- when used in conjunction with cGDIPlusCache can render Icons and Png-Content in each Cell

So, all in all a good wireframe to start developing your own (relative lightweight)
GridControl around it.

Here's a ScreenShot, what the Demo will produce "TreeList-wise":



In the above Picture, "Group 2" is in collapsed state - and please note
the formatted and right-aligned output in the last Column, which is
currently in "Sorted-Ascending"-state (ensured by a HeaderClick).

This sorting is ensured over the outside DataContainer (a normal ADO-Recordset),
and works (due to the Data-arrangement within that Recordset) "below the Group-Level"
(inside the Group-Nodes).

Here's the Demo-Zip: VList_GroupDemo_Classic.zip
(please use the VB-ProjectGroup-File: "_TestGroup.vbg" -
as long as you don't want to compile the VList.ocx into a binary first).

Have fun!

Olaf
Attached Files

one selecting answer

$
0
0
i need a one selecting answer program written by vb6, becouse i have a project in how to build an e_exam

[VB6, Vista+] Undocumented ListView feature: Groups in Virtual Mode

$
0
0

Well, this project has been a long time coming. Just when I thought I had it, a mysterious and difficult-to-trace crash reared its head. But that last issue has finally been resolved.

According to Microsoft, Group Mode can't be used when the ListView is in Virtual Mode-- when LVS_OWNERDATA is set. But they have confused 'can't be done' with 'undocumented and unsupported'. Through the use of undocumented interfaces, IListView and IOwnerDataCallback, I have brought grouping while in virtual mode to VB6 as a port of some excellent work by Timo Kunze. You can also thank LucasMKG here since if he hadn't kept on me to work on this and finally got me looking at OnCacheHint, this project might never have been completed.

How It Works

-A class module must implement the IOwnerDataCallback interface
-Then, the reference is set like this:
Set cLVODC = New cLVOwnerDataCB
Dim pILV As IListView
Call SendMessage(hLVVG, LVM_QUERYINTERFACE, VarPtr(IID_IListView), pILV)
pILV.SetOwnerDataCallback cLVODC

-After that, it's just a matter of creating the ListView.

Project Notes
-This project fully supports Unicode by responding to WM_NOTIFYFORMAT with NFR_UNICODE and responding to LVN_GETDISPINFOW. Currently I'm experiencing a problem with StrPtr that corrupts subitem text; I haven't had this problem before (as in, it was fine the other day with this same unchanged code) and it shouldn't effect anyone else, but if for some reason it does let me know; but when compiled the problem goes away.
-This project is mainly a proof of concept; information about the groups is hard-coded. In a real project you'll need to be careful to keep item numbers and information updated, including the .cItems LVGROUP member (which isn't read-only, it must be set), and to return the correct group information in cLVOwnerDataCB--- see below.
-You could probably apply this method to a Comctllib (5) ListView, but this project makes its own with CreateWindowEx.

Requirements
-Windows 7 or higher (for Vista, the typelib needs to be recompiled with a different IID for IListView; if anyone wants this let me know)
-lvundoc.tlb - Must be added as a reference. If you have a previous version, make sure to replace it with the one in this download.
-Common Controls 6.0 Manifest - Your project (and the IDE if you want to see groups) needs a manifest specifying 6.0 controls; see here. The demo project has a manifest built in.

Setting Group Callback Information
The demo project has these hardcoded for 99 items in 3 groups. You'll need to change that for real-world projects. Refer to the following information from Timo's project:
Quote:

/// \brief <em>Will be called to retrieve an item's zero-based control-wide index</em>
///
/// This method is called by the listview control to retrieve an item's zero-based control-wide index.
/// The item is identified by a zero-based group index, which identifies the listview group in which
/// the item is displayed, and a zero-based group-wide item index, which identifies the item within its
/// group.
///
/// \param[in] groupIndex The zero-based index of the listview group containing the item.
/// \param[in] groupWideItemIndex The item's zero-based group-wide index within the listview group
/// specified by \c groupIndex.
/// \param[out] pTotalItemIndex Receives the item's zero-based control-wide index.
///
/// \return An \c HRESULT error code.
virtual HRESULT STDMETHODCALLTYPE GetItemInGroup(int groupIndex, int groupWideItemIndex, PINT pTotalItemIndex) = 0;
/// \brief <em>Will be called to retrieve the group containing a specific occurrence of an item</em>
///
/// This method is called by the listview control to retrieve the listview group in which the specified
/// occurrence of the specified item is displayed.
///
/// \param[in] itemIndex The item's zero-based (control-wide) index.
/// \param[in] occurrenceIndex The zero-based index of the item's copy for which the group membership is
/// retrieved.
/// \param[out] pGroupIndex Receives the zero-based index of the listview group that shall contain the
/// specified copy of the specified item.
///
/// \return An \c HRESULT error code.
virtual HRESULT STDMETHODCALLTYPE GetItemGroup(int itemIndex, int occurenceIndex, PINT pGroupIndex) = 0;
/// \brief <em>Will be called to determine how often an item occurs in the listview control</em>
///
/// This method is called by the listview control to determine how often the specified item occurs in the
/// listview control.
///
/// \param[in] itemIndex The item's zero-based (control-wide) index.
/// \param[out] pOccurrencesCount Receives the number of occurrences of the item in the listview control.
///
/// \return An \c HRESULT error code.
virtual HRESULT STDMETHODCALLTYPE GetItemGroupCount(int itemIndex, PINT pOccurenceCount) = 0;
Attached Files

Rotation and scale in one routine (also for 32bit bitmaps)

$
0
0
This is an example on another example. I get the Tanner_H's code from there Color Management (ICC Profile) support in VB6: guide and sample project and I put a textbox where we can write the angle (0 is North) in degrees (I have specify 1.4 and 1.6 zoom factors). As we see the rotation is perfect for transparent png.
Also I made two options, one for 1:1 render and the other as fit to picturebox.
Pictureboxes are in non AutoRedraw mode, and that is for the ICC profile (for specific HDC). This was there as I found it in the code from Tanner_H.
The rotation and scale use single floating computation on a 2X2 pixels. Also canvas get bigger to hold any rotation.


NewOne.zip

George
Attached Files

VB6 - TLSSend Using CNG

$
0
0
Attached is a program called TLSSend. This Version uses MS CNG (Cryptography Next Generation), and sends email messages to:
1. Your ISP
2. Gmail
3. MS Live
using ports 25, 1025, 465, or 587. Port 25 is the standard SMTP port, port 1025 is the Plain Authentication port offered by some services, port 465 is for the standard "Secure" connection, and port 587 is for the "Secure" connection using STARTTLS. Port 465 negotiates a secure connection directly after the TCP connection is established, whereas port 587 starts the connection in text mode, but negotiates the secure connection before the transmission of the authentication information.

When first run, TLSSend automatically activates the Setup form. There you will find the requirements for your ISP, Gmail, and MS Live(Outlook/Hotmail) accounts. Each one requires the name of the Outbound Server, the account name, the Password, and the ports utilized. Both Gmail and Live do not support non-secure connections, and MS Live does not support port 465. My own ISP accepts connections on all four ports, but unfortunately doesn't support TLS 1.2 on the secure connections. Strange part is that it requires SHA256 for the Hash algorithm when there are about 40% of servers that still use SHA1.

There is currently a problem with Gmail that does not stop it from working. A secure server will forward a Certificate chain that includes the RSA Key used and a Signature. The signature attached to the last Certificate is normally a Hash of the Server (first) Certificate encrypted with the RSA Private key from the last Certificate (Certificate Authority). For reasons unknown, Google uses a Certificate issued by Equifax that contains a 2048 bit/256 byte RSA Public Key, but the attached Signature is 1024 bit/128 byte. A 128 byte Signature cannot be created using a 256 byte Key, and 128 byte Keys have not been in use since the end of 2013. Since TLSSend does not support 128 Byte keys/signatures, it cannot verify the Server Certificate from Google.

J.A. Coutts
Attached Images
 
Attached Files

Directory Tree - Generates a list of subdirectories.

$
0
0
Directory Tree demonstrates how to list all subdirectories under a directory. Simply specify the "root" directory and output file.

This can be useful, for example, when writing a program that searches for files.
Attached Files

Here's how to make VB6 execute a program and then wait for it to close.

$
0
0
It's a VB6 sub called RunAndWait.
Code:

Private Const SYNCHRONIZE As Long = &H100000

Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long


Public Sub RunAndWait(ByVal FileName As String, Optional ByVal Args As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus)
Dim ProcID As Long
Dim hProc As Long
ProcID = Shell("""" & FileName & """ " & Args, WindowStyle)
hProc = OpenProcess(SYNCHRONIZE, 0, ProcID)
WaitForSingleObject hProc, -1
CloseHandle hProc
End Sub

Just paste this code into a module and you will be able to call it from anywhere in your program.

Framework for making plugins

$
0
0
You know how a lot of software these days use plugins, whether it's a graphics program, or a web browser, that allows additional functionality that was not present in the base program? Well I figured out how to do this in VB6.

Here's 2 templates, one for a plugin host, and one for a plugin. These are commented enough that you will be able to see how to use them. They are intended to be placed in modules (BAS files).

First template is modPluginHost, and should be used when compiling your main program's EXE file.
Code:

Private Const SYNCHRONIZE As Long = &H100000

Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32.dll" () As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Public Type InitStructType
    StructSize As Long
    'Define the structure's elements here.
End Type
Public InitStruct As InitStructType
' This plugin initialization structure will contain
' all data that must be passed from the host to the
' plugin. For example, in an image processing
' plugin, this would contain image dimensions and a
' pointer to pixel data.



Public Function CallPlugin(ByVal PluginFileName As String) As Boolean
' PluginFileName is the EXE file of the plugin.
' It can be a relative or absolute path.

Dim ProcID As Long
Dim hProc As Long

On Error Resume Next
ProcID = Shell("""" & PluginFileName & """ " & CStr(GetCurrentProcessId) & " " & CStr(VarPtr(InitStruct)), vbNormalFocus)
If Err.Number Then Err.Clear
If ProcID = 0 Then Exit Function
hProc = OpenProcess(SYNCHRONIZE, 0, ProcID)
WaitForSingleObject hProc, -1
If hProc = 0 Then Exit Function
CloseHandle hProc
CallPlugin = True
End Function

Second template is modPlugin, and should be used when compiling your plugin's EXE file.
Code:

Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000

Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32.dll" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32.dll" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long

Public Type InitStructType
    StructSize As Long
    'Define the structure's elements here.
End Type
Public InitStruct As InitStructType
' This plugin initialization structure will contain
' all data that must be passed from the host to the
' plugin. For example, in an image processing
' plugin, this would contain image dimensions and a
' pointer to pixel data.

Dim HostProcID As Long



Public Sub InitPlugin()
'This should be the very first thing called in your plugin.
'Preferably, call this in the Form_Load event of your plugin's main form.

Dim CmdLineArgs() As String
Dim HostInitStructAddr As Long
Dim hProc As Long

CmdLineArgs() = Split(Command, " ")
HostProcID = CmdLineArgs(0)
HostInitStructAddr = CmdLineArgs(1)

hProc = OpenProcess(GENERIC_READ, 0, HostProcID)
If hProc = 0 Then End
If ReadProcessMemory(hProc, HostInitStructAddr, InitStruct, 4) <> 0 Then
    CloseHandle hProc
    End
End If
If ReadProcessMemory(hProc, HostInitStructAddr, InitStruct, InitStruct.StructSize) <> 0 Then
    CloseHandle hProc
    End
End If
CloseHandle hProc
End Sub



Public Function ReadDataFromHost(ByVal LocalDataAddr As Long, ByVal HostDataAddr As Long, ByVal DataSize As Long) As Boolean
Dim hProc As Long

hProc = OpenProcess(GENERIC_READ, 0, HostProcID)
If hProc = 0 Then Exit Function
If ReadProcessMemory(hProc, HostDataAddr, ByVal LocalDataAddr, DataSize) <> 0 Then
    CloseHandle hProc
    Exit Function
End If
CloseHandle hProc
ReadDataFromHost = True
End Function



Public Function WriteDataToHost(ByVal LocalDataAddr As Long, ByVal HostDataAddr As Long, ByVal DataSize As Long) As Boolean
Dim hProc As Long

hProc = OpenProcess(GENERIC_WRITE, 0, HostProcID)
If hProc = 0 Then Exit Function
If WriteProcessMemory(hProc, HostDataAddr, ByVal LocalDataAddr, DataSize) <> 0 Then
    CloseHandle hProc
    Exit Function
End If
CloseHandle hProc
WriteDataToHost = True
End Function

Other than defining the elements of the InitStructType user defined type (which should match exactly between the host and the plugin), there's really nothing that needs to be edited in these templates.

VB6 - Grammatical Evolution

$
0
0
This is a small project inspired by Grammatical Evolution.

It's a Genetic Algorithm that evolves a Program-Code.
(in fact i'd prefer to call it Code-Evolution, since it involves even ROM and uses RAM, and since Grammatical Evolution is something more sophisticated)

The GA individuals-Structure is this:

-Inputs
-Outpus
-RAM
-ROM (Constants)
-Code

The Parts that evolve are ROM and CODE.

Public Sub INIT(PopulationSize As Long, Inputs As Long, Outputs As Long, Rams As Long, Roms As Long, NCodeLines As Long, _
EVOSonsPerc As Double, EVOChildMutationProb As Double, EVOMutationRate As Double)



At the Moment the CODE have this set of instructions:

R = A + B
R = A - B
R = A * B
R = A / B
R = A ^ B
R = IIf(A > B, A, B) Greater
R = IIf(A < B, A, B) Smaller
R = A

JUMP to line Code
Jump if A>B to line Code
Jump if A<B to line Code

Where A,B can be: Input,RAM,ROM
and R can be RAM,Output


One single line of code occupy 7 Values defined so:
1 - Main instruction
2 - Type of A
3 - Address of A (depending on its type)
4 - Type of B
5 - Address of B (depending on its type)
6 - Type of R
7 - Address of R (depending on its type)

(If 1 operand or jump,some of these are not used)



Launch the program and watch moving object learn to stay on "Green Circle"
In Test01 a set of Object move according to their Codes.
They have 2 imputs:
Difference of Angle to GreenCircle
Distance to GreenCircle
2 output:
Speed
Turn Angle



It has been written quickly and still a lot to improve.


By the way, I'd like to share this on Github or GitLab... cause I'd like to have contributors and new test tasks-designer.
I tried both, but both gives me error when I download the code and try to open it with VB6. Can someone tell me why?


If you have improvements or test-tasks designed.. Share!
Attached Files

Figures - experimenting with polygons

$
0
0
Figures is an experiment in generating and animating simple polygons. Instead of using horizontal and vertical coordinates for each element, the program uses the distances (radii?) as measured from the polygon's center. Because these distances are evenly distributed over a full circle, there's no need to define an angle. To, for example, define the following figures just specify:

3 equal "distances" for a triangle, 4 for a square, and 8 for an octagon.

Variable distances inside one polygon (think stars/sprockets) are allowed. There's also a rudimentary function which allows you to append one polygon to another polygon.

"Figures" is an old project which I decided to clean and upload here. It is, however, slow, has some stability issues, and, the terminology used in the code could use cleaning.
Attached Files
Viewing all 1508 articles
Browse latest View live


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