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

[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

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 some versions have bugs that can prevent some data extraction and GDI+ does not support extraction on 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+

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 }

Windows 7 compatibility mode

$
0
0
I notice that when I use in vb6 program (M2000.exe) combatibility mode (anyone, including Wimdows 7 in a Widnows 7 system) the speed droped. We need 3.5 more time to do the same loop.
I am thinking that the problem are only with forms used by vb6, but I can't proove that. To proove it I have to write code in another language, a form and a big loop inside (not in an event handle routine) and try to run in compatibility mode and without.
This code run in an old computer with Windows 7 Home Basic and Intel Pentium 4 3Ghz with 1 GByte ram.

Using no compatibility mode
Name:  normal.jpg
Views: 37
Size:  8.8 KB

Using Windows 7 compatibility mode;;;
Name:  compatibility.jpg
Views: 33
Size:  8.0 KB

This is the code (comparing the two For commands)
Name:  progr.jpg
Views: 32
Size:  18.1 KB
Attached Images
   

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

winsock Acknowledgment control needed

$
0
0
hello...

here is the problem with winsock.ocx:

Host A ---- GET message -----> Host B ------ GET Message ------> INTERNET

Host A <---- Response ----- Host B <------ Response ------ INTERNET


the problem is the deffrence between Download Speed And Upload Speed

Host B download with speed (100 KB) and Uploading To Host A with (50 KB) , and no controlling in traffic in winsock.ocx

i want to send Acknowledgment to INTERNET only if Host A Send me its Acknowledgment....

IE Object - Get webpages text

$
0
0
Hello
I have a question still new to vb i use a hidden web browser control on a form to get a webpages text is there a simpler way to do this in visual basic without having to create the control itself on the form like looping the text from a ie object somehow in a public function?

Thanks

Tempest Test for Windows

$
0
0
First a bit of background on the subject:
Tempest is the concept of being able to retrieve usable information about what data is being processed by a computer or other electronic device, entirely from the "electronic noise" that is given off by that device. These RF emissions usually cause trouble if they cause interference with radio receivers like an AM radio that you are trying to listen to. The FCC has standards for reducing this interference to an acceptable level, but even so, if you are TRYING to pick up this signal it is usually possible.

Under the right conditions, this interference isn't just unintelligible noise, but can actually convey data that is being processed by the computer at that time. This can cause a privacy risk if the data being processed that causes these RF emissions contains information is confidential. This could be the case if for example you are looking at a document on your PC that has confidential information, but your monitor's RF emissions allow the screen image to be received by an adversary with a radio receiver.

To demonstrate the ability of a monitor to transmit intelligible information, Erik Thiele created a program called "Tempest for Eliza" (which you can read about here http://www.erikyyy.de/tempest/ ) which transmits Beethoven's song Fur Elise. It depends on the ability of a CRT monitor to send one pixel at a time to the screen with an electron gun, so that the signal going to the electron gun gets radiated as RF. So to send a tone, the brightness of a pixel is based on both the frequency of the audible tone and the RF frequency that you want to have to tune your AM radio to to receive it.

Unfortunately, this program has several problems. One is that it requires being compiled (no binaries can be downloaded). Another is that it only runs on Linux. And lastly, it is based on a CRT monitor which sends one pixel at a time. The last of these is a problem because modern LCD monitors process data one line at a time. While vertically, each line of the display is set in sequence, within each line, all of the pixels are set simultaneously. There is no "pixel clock" in an LCD monitor, just a line clock and a data clock. The data clock runs very fast like a CPU processor (probably at 10s or 100s of megahertz at least) and handles the image data very fast for that particular line. Depending on the monitor's microcontroller clock speed (which can be pretty much anything, and not predictable like the pixel clock of a CRT monitor), you will have the carrierwave signal based on that clock speed. Depending on what that frequency is, you may need to tune around your radio to find it or one of its harmonics (sometimes these can be lower than the clock frequency in the form of a lower side band). There's not much than can be done about this, except tune your AM radio (preferably a shortwave receiver so you get more frequencies to search through) to the strongest signal for your particular LCD monitor. However, since you don't need to worry about the pixels horizontally, that means that every pixel on a given line can be lit up at maximum brightness, and I have found that this actually makes the signal stronger. You only need to worry about modulating the brightness vertically.

And here's the solution I've found:
Of course, there's a pretty simple solution to fixing these things at once. To fix the first 2 things, just write your own version of this software in a language you are familiar with and which is designed to compile for Windows (VB6 in this case). And the last thing is to make it so that every pixel is lit up on a given line, which naturally is easy to do when you are writing it yourself (you just write it to do that). So below, there are 2 links to my VB6 version of this guy's program, designed from the ground up to work with LCD monitors (sorry if you want to use it with a CRT monitor, it won't work, as I've made this based on the fact that nearly everyone uses LCD not CRT monitors nowadays). The first link fixes problem 2 and 3 (it is made for Windows, not Linux, and it is optimized for LCD screens, but still requires compiling). The second link fixes all 3 problems. It has the source code, just as with the first link, but it also has a compiled EXE file (in case you don't want to go through the hassle of compiling it yourself, or if you don't have a copy of VB6 yourself). If you are really paranoid about viruses and stuff, you can use the first link, but as it is not a virus (I have no desire to hack anybody's PC) I would highly recommend the second link, which has all the source code (just as with the first link) and also has the compiled EXE file.

The name of the program is "Tempest Test for Windows". With it, you can determine how much RF signal is coming from your monitor that actually conveys information about what's on your computer screen, with the idea that if you are running a business that has confidential info on your computer, and you find that you can hear the music from this program playing on a nearby radio, you should consider Faraday shielding your PC or the room that the PC is in. As with the original "Tempest for Eliza" (which was created by Erik Thiele), it plays Fur Elise. The notes data are in the "song.txt" file, which can be edited to make it play any musical piece that you want.

Source code only: http://www.mediafire.com/?8f21lgj8bw6ed63

Source code and EXE: http://www.mediafire.com/?1mlhl1ir8j7fm2n


Controls:
There's only one control, the Esc key. Press it to close the program before the song has finished playing. If the song is allowed to continue playing, the program will close when the song ends.

Format of the "song.txt" file:
It is case-insensitive. Each note is specified by note letter, a modifier symbol ("#" for sharp, or "b" for flat, and yes that is a lowercase "B", but uppercase works as well, as the program is completely case insensitive), and an octave number (from 0 to 8), in that order. In the case of it not being sharp or flat, you leave out the modifier. For example, D sharp in octave 4 is D#4 (or d#4), while B normal in octave 7 is B7 (or b7), and B flat in octave 2 is Bb2 (or bb2, or bB2, or BB2). Each note or special symbol is separated from each other by a space. There are 2 special symbols ("." and "-"). The "." represents no tone transmitted for the period of one half of a note. The dash represents holding the previous note for a period of one note. Any other text in a given entry, or a blank entry (such as formed by an extra space at the start or end of the text file, or by 2 consecutive spaces in the middle of the file) will trigger the error "Stop statement encountered". This is because I left a stop statement in it while debugging it, prior to compiling it. That stopped the code is designed to stop it so that you can check one of the variables that holds the string for that note or special symbol, to see why it didn't match what the program was expecting (so you could go search for the specific bad string in the song.txt file and correct it). It's not nearly as useful with the EXE file, as it alerts you to the fact that there is something wrong with the file, but you'll need to manually look through the text file to see what's wrong. But I left it in anyway so that you could see if there is in fact something wrong with the text file, should you decide to edit it and put in your own song.

[VB6] Direct3D9.

$
0
0
Hello everyone.
In the archive contains a type library "DirectX 9 for Visual Basic 6.0 type library by The trick" (dx9vb.tlb) contains a description of the following interfaces:
  • IDirect3D9;
  • IDirect3DDevice9;
  • IDirect3DSurface9;
  • IDirect3DResource9;
  • IDirect3DSwapChain9;
  • IDirect3DTexture9;
  • IDirect3DBaseTexture9;
  • IDirect3DVolumeTexture9;
  • IDirect3DVolume9;
  • IDirect3DCubeTexture9;
  • IDirect3DVertexBuffer9;
  • IDirect3DIndexBuffer9;
  • IDirect3DStateBlock9;
  • IDirect3DVertexDeclaration9;
  • IDirect3DVertexShader9;
  • IDirect3DPixelShader9;
  • IDirect3DQuery9.

Also in the library declared many types, constants and enumerations. The work of this library tested poorly, so something may not work. Also in the archive includes several modules written in VB6:
  • D3DX_COLOR.bas - for work with colors;
  • D3DX_MATRICES.bas - for work with matrices;
  • D3DX_QUATERNION.bas - for work with quaternions;
  • D3DX_VECTOR2.bas, D3DX_VECTOR3.bas, D3DX_VECTOR4.bas - for work with vectors;
  • D3DX_MISC.bas - other functions.

These modules include analogs of the respective functions D3DX. Also in the archive contains several test examples.


Download.

[VB6] DirectSound.

$
0
0
With Direct3D9 I did the type library and module support functions for DirectSound. The archive contains a type library dsvb.tlb and module DS_Functions.bas. In the future, I add a class module to support asynchronous notification until you can use clsTrickWait.cls. The module DS_Functions contains the following functions:
  • DSCreateSoundBufferFromFile - creates an object with interface IDirectSoundBuffer8 from a file. Supported only WAVE and MP3 files is. MP3 files can contain only the ID3v1 and ID3v2 tags, any other may not be recognized/will not work. Too long (by time) files are not supported. For streaming you need to write streaming decoding based on the function code DSCreateSoundBufferFromMemory;
  • DSCreateSoundBufferFromMemory - the same, but instead of the file is passed a pointer to the data file in memory and size.


Also in the archive contains an example of a player that implements some methods IDirectSoundBuffer8 interface (volume, pan, frequency, effects). TLB especially did not well tested, so something may not work. If something is not working please write here.

Download.

VB6 - 2D DCT & IDCT - Separable Discrete Cosine Transform (Any Size)

$
0
0
After may attempts I succeed on coding separable 2D DCT IDCT (II) of any size rectangular window.

Here is the Code:

Code:

Private Function alpha(value As Long) As Double
    If value = 0 Then
        alpha = 0.707106781186547  '1 / Sqr(2)
    Else
        alpha = 1
    End If
End Function

Public Function MyDCT(INP() As Double) As Double()
    Dim W      As Long
    Dim H      As Long
    Dim K()    As Double
    Dim aU    As Double
    Dim aV    As Double

    Dim invW  As Double
    Dim invH  As Double
    Dim DivisorW As Double
    Dim DivisorH As Double
    Dim Sum    As Double

    Dim U      As Long
    Dim v      As Long
    Dim X      As Long
    Dim Y      As Long

    Dim byX()  As Double
    Dim Matrix() As Double

    W = UBound(INP(), 1)
    H = UBound(INP(), 2)

    ReDim Matrix(W, H)

    invW = 1 / (2 * (W + 1))
    invH = 1 / (2 * (H + 1))

    DivisorW = 2 / (W + 1)
    DivisorH = 2 / (H + 1)

    'Do by X---------------------------------------------------------
    ReDim K(W, W)
    For U = 0 To W
        aU = alpha(U)
        For X = 0 To W
            K(X, U) = aU * Cos(((2 * X + 1) * U * PI) * invW)
        Next
    Next


    ReDim byX(W, H)
    For Y = 0 To H
        For X = 0 To W
            Sum = 0
            For U = 0 To W
                Sum = Sum + INP(U, Y) * K(U, X)
            Next
            byX(X, Y) = Sum * DivisorW
        Next
        DoEvents
    Next
    '-------------------------------------------------------------------


    'Do by y
    ReDim K(H, H)
    For v = 0 To H
        aV = alpha(v)
        For Y = 0 To H
            K(Y, v) = aV * Cos(((2 * Y + 1) * v * PI) * invH)
        Next
    Next

    For X = 0 To W
        For Y = 0 To H
            Sum = 0
            For v = 0 To H
                Sum = Sum + byX(X, v) * K(v, Y)
            Next
            Matrix(X, Y) = Sum * DivisorH
        Next
        DoEvents
    Next

    MyDCT = Matrix

End Function

Public Function MyIDCT(INP() As Double) As Double()
    Dim W      As Long
    Dim H      As Long
    Dim K()    As Double
    Dim aU    As Double
    Dim aV    As Double

    Dim invW  As Double
    Dim invH  As Double
    Dim DivisorW As Double
    Dim DivisorH As Double
    Dim Sum    As Double

    Dim U      As Long
    Dim v      As Long
    Dim X      As Long
    Dim Y      As Long

    Dim byX()  As Double
    Dim Inverse() As Double

    W = UBound(INP(), 1)
    H = UBound(INP(), 2)

    ReDim Inverse(W, H)

    invW = 1 / (2 * (W + 1))
    invH = 1 / (2 * (H + 1))

    DivisorW = 2 / (W + 1)
    DivisorH = 2 / (H + 1)

    ReDim K(W, W)
    For U = 0 To W

        For X = 0 To W
            aU = alpha(X)
            K(X, U) = aU * Cos(((2 * U + 1) * X * PI) * invW)
        Next
    Next


    ReDim byX(W, H)
    For Y = 0 To H
        For X = 0 To W
            Sum = 0
            For U = 0 To W
                Sum = Sum + INP(U, Y) * K(U, X)
            Next
            byX(X, Y) = Sum    '* DivisorW
        Next
        DoEvents
    Next
    '-------------------------------------------------------------------


    'Do by y
    ReDim K(H, H)
    For v = 0 To H

        For Y = 0 To H
            aV = alpha(Y)
            K(Y, v) = aV * Cos(((2 * v + 1) * Y * PI) * invH)
        Next
    Next

    For X = 0 To W
        For Y = 0 To H
            Sum = 0
            For v = 0 To H
                Sum = Sum + byX(X, v) * K(v, Y)
            Next
            Inverse(X, Y) = Sum    '* DivisorH
        Next
        DoEvents
    Next

    MyIDCT = Inverse

End Function

Simple 3-Way Splitter

$
0
0
This is a very simple 3-way splitter project. It uses the Form instead of Pictureboxes as the splitter bars.

Any thoughts about improving it are welcomed
Attached Files

Custom GDI+ PNG Writer v2.0

$
0
0
Completely revamped, comments below reflect the new version. Backup your previous version if you still want it.

If you use GDI+ to write PNGs, one of the shortcomings is that many chunks/properties/tags are not written even if they exist in the PNG before saving it. Another issue many have is that GDI+ automatically adds a gAMA chunk whether you want it or not, whether you feel it is the correct value or not.

This class is meant as a stop-gap for adding chunks and removing chunks after the image is saved by GDI+ but before it is written to disk or to a byte array. I have added lots of comments throughout the class

Caveats:

1. The class does not provide compression for chunks that can include compressed data. Those chunks are IDAT (pixel data), iCCP (ICM profile), zTxt (compressed text only), iTXt (UTF8 text where compression is optional).

2. All but a few standard PNG chunks are now coded as separate functions, which makes it easier for those not totally familiar with the PNG layout to add chunks during PNG creation. There is also a generic function for adding any chunk one would want. The chunks not directly coded for are:

IDAT: pixel data. GDI+ creates these
sBIT: significant bits and pertains specifically to how the pixel data is interpreted
bKGD: suggested background color for rendering transparency on. This is specific to the bit depth of the written image
hIST: palette histogram, again specific to the written pixel data
tRNS: color to be transparent within the image. This is specific to the bit depth of the written image
sPLT: suggested palette. This is specific to the bit depth of the written image
pHYs: typically used to describe non-square pixel dimensions

The class is a text file uploaded here. Simply rename it as .cls once downloaded. Here's a really short example of usage...

- Assumption is GDI+ is loaded and running before you call any class methods.
Code:

Private Sub Command1_Click()
    Dim hImage As Long, c As IPngWriter
    GdipLoadImageFromFile StrPtr("C:\Test Images\LaVolpe.png"), hImage
    If hImage Then
        Set c = New IPngWriter

        ' example of adding a tEXt chunk
        c.AddChunk_tEXt keySoftware, "Custom PNGWriter Class", BeforeIEND
       
        ' example of removing the gAMA, cHRM & sRGB chunks
        c.WritePngToFile hImage, "D:\Users\LaVolpe\Desktop\Test.PNG", CHUNK_gAMA, CHUNK_sRGB, CHUNK_cHRM

        Set c = Nothing
        GdipDisposeImage hImage
    Else
        MsgBox "Failed to load that image"
    End If
End Sub

Should you want a short routine to review the chunks that exist in any valid PNG file, you can use the following.
Code:

Private Sub pvReadPngChunks(FileName As String)

    Dim fnr As Integer, lName As Long, lSize As Long
    Dim sName As String * 4&
    Dim lPtr As Long, lMax As Long
    Dim lPrevName As Long, bFailed As Boolean
   
    On Error Resume Next
    fnr = FreeFile()
    Open FileName For Binary Access Read As #fnr
    If Err Then
        MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
        Exit Sub
    End If
    On Error GoTo 0
    lMax = LOF(fnr)
   
    If lMax < 46& Then
        bFailed = True: GoTo ExitRoutine
    Else
        Get #fnr, 1, lName
        If lName <> 1196314761 Then bFailed = True: GoTo ExitRoutine
        Get #fnr, , lName
        If lName <> 169478669 Then bFailed = True: GoTo ExitRoutine
        Debug.Print "Processing "; FileName;
        lPtr = 9
        Do Until lPtr + 8& > lMax
            Get #fnr, lPtr, lSize: lSize = pvReverseLong(lSize)
            Get #fnr, , lName
            Mid$(sName, 4, 1) = Chr$(((lName And &HFF000000) \ &H1000000) And &HFF)
            Mid$(sName, 3, 1) = Chr$((lName And &HFF0000) \ &H10000)
            Mid$(sName, 2, 1) = Chr$((lName And &HFF00&) \ &H100)
            Mid$(sName, 1, 1) = Chr$(lName And &HFF)
            If lName = lPrevName Then
                Debug.Print ","; sName; "("; CStr(lSize); ")";
            Else
                lPrevName = lName
                Debug.Print vbCrLf; sName; "("; CStr(lSize); ")";
            End If
            lPtr = lPtr + 12& + lSize
        Loop
    End If
    Debug.Print vbCrLf; "Done..."
   
ExitRoutine:
    Close #fnr
    If bFailed Then MsgBox "Failed to process that file. Sure it was a PNG?", vbQuestion + vbOKOnly
End Sub

Private Function pvReverseLong(ByVal inLong As Long) As Long

    ' fast function to reverse a long value from big endian to little endian
    ' PNG files contain reversed longs, as do ID3 v3,4 tags
    pvReverseLong = _
      (((inLong And &HFF000000) \ &H1000000) And &HFF&) Or _
      ((inLong And &HFF0000) \ &H100&) Or _
      ((inLong And &HFF00&) * &H100&) Or _
      ((inLong And &H7F&) * &H1000000)
    If (inLong And &H80&) Then pvReverseLong = pvReverseLong Or &H80000000
End Function

And a short example using the above code follows. Note. For simplicity, I used VB's File I/O functions in above code. You may want to use APIs for unicode support
Code:

    Call pvReadPngChunks("C:\Test Images\LaVolpe.PNG")
Edited: Link to PNG format specifications

New version uploaded
Attached Files

[Vista+] Code Snippet: Get and set the Rating (stars) of a file

$
0
0
In Explorer, things like Pictures and some other types have a 'Rating' property category that shows a 0-5 star rating. You can get and set this rating programmatically, and this also provides a basis for getting and setting other properties. Requires oleexp, v2.0 or higher.

Code:

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 SHCreateItemFromIDList Lib "shell32" (ByVal pidl As Long, riid As UUID, ppv As Any) As Long

Public Function GetFileRating(sFile As String) As Long
'Returns the star rating of a file in number of stars
Dim pidl As Long
Dim isi As IShellItem2
Dim lp As Long
Dim pkRating As PROPERTYKEY '{64440492-4C8B-11D1-8B70-080036B11A03}, 9

DEFINE_PROPERTYKEY pkRating, &H64440492, CInt(&H4C8B), CInt(&H11D1), &H8B, &H70, &H8, &H0, &H36, &HB1, &H1A, &H3, 9

'first, get the shell item representing the file
pidl = ILCreateFromPathW(StrPtr(sFile))
Call SHCreateItemFromIDList(pidl, IID_IShellItem2, isi)

isi.GetUInt32 pkRating, lp 'it's a VT_UI4; 4-byte unsigned integer, which VB's Long can fill in for since a rating can't exceed 99 and be valid

Select Case lp
    Case 1 To 12 'sys default when you assign values in Explorer=1
        lp = 1
    Case 13 To 37 'default=25
        lp = 2
    Case 38 To 62 'default=50
        lp = 3
    Case 63 To 87 'default=75
        lp = 4
    Case 88 To 99 'default=99
        lp = 5
    Case Else
        lp = 0
End Select
GetFileRating = lp
Set isi = Nothing
Call ILFree(pidl) 'always release the memory used by pidls

End Function

Public Function SetFileRating(sFile As String, lNumberOfStars As Long) As Long
'Sets the star rating of a file. Should return 0 if things go ok.
Dim vvar As Variant
Dim lRating As Long
Dim isi As IShellItem2
Dim pidlFile As Long
Dim pps As IPropertyStore
Dim hr As Long
Dim pkRating As PROPERTYKEY '{64440492-4C8B-11D1-8B70-080036B11A03}, 9

DEFINE_PROPERTYKEY pkRating, &H64440492, CInt(&H4C8B), CInt(&H11D1), &H8B, &H70, &H8, &H0, &H36, &HB1, &H1A, &H3, 9

'The rating could technically be anything from 0 to 99; here I use the values that would be used if you set the rating in Explorer
Select Case lNumberOfStars
    Case 1: lRating = 1
    Case 2: lRating = 25
    Case 3: lRating = 50
    Case 4: lRating = 75
    Case 5: lRating = 99
    Case Else: lRating = 0
End Select
vvar = CVar(lRating) 'the property system will expect a PROPVARIANT, but in this case (not all cases), VariantToPropVariant isn't needed, we'll pass vvar directly

'We need the Property Store for the file, which we can get from its IShellItem
pidlFile = ILCreateFromPathW(StrPtr(sFile))
Call SHCreateItemFromIDList(pidlFile, IID_IShellItem2, isi)
   
isi.GetPropertyStore GPS_READWRITE, IID_IPropertyStore, pps 'we need write access- GPS_DEFAULT will not work
 
hr = pps.SetValue(pkRating, vvar) 'returns S_OK if successful
   
If hr = 0 Then
    hr = pps.Commit 'save the changes; returns S_OK if successful
End If

Set pps = Nothing
Set isi = Nothing
Call ILFree(pidlFile) 'always set your pidl free!

SetFileRating = hr
End Function

Public Sub DEFINE_PROPERTYKEY(Name As PROPERTYKEY, 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, pid As Long)
  With Name.fmtid
    .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
  Name.pid = pid
End Sub

If you're not using the mIID.bas from the oleexp thread, also include this:
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_IShellItem2() As UUID
'7e9fb0d3-919f-4307-ab2e-9b1860310c93
Static iid As UUID
If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &H7E9FB0D3, CInt(&H919F), CInt(&H4307), &HAB, &H2E, &H9B, &H18, &H60, &H31, &HC, &H93)
IID_IShellItem2 = iid
End Function
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

If you want to display these values in ListView of files, here's a good place to start.
Viewing all 1324 articles
Browse latest View live




Latest Images