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

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

Using a variable to open a form

$
0
0
Hi,

Im looking to use the text from the variable to open a form

Does anyone know? Im stumped :(

If i havnt made myself clear please message me back.

Thanks in advance!



Private Sub lstPurchases_DblClick()

Dim Selection As String

Selection = lstPurchases

Frm"Text from Selection variable".show


End Sub

Reset array to 0-Zero - Fast way ?

$
0
0
hi, I have a question:

Supposing to have an array (of doubles), ARR, that contains N values.

To set all values of the array to Zero, is it faster to scan it and set each value
Code:

For i = 0 To N
    ARR(i) = 0
Next

or to use Redim
Code:

Redim ARR(N)
?

Edit: Ooops, sorry for posting this in CodeBank instead of Visual Basic 6 and Earlier

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

LynxGrid..Modifications

$
0
0
This is a 'rar' file...I just added a '.zip' extension.

The modified LynxGrid that I abandoned for vhGrid might be useful to someone.

Note: the coding is very ugly or basic.

LucasMKG
saying Hala to Jonney and fafalone...for now...:D
Attached Files

Is there any way to control with references on any devices without missing error

$
0
0
Hi guys, i'm back to help me to solve this small problem (if could)

my problem not in coding
the problem when i try to run my (*.exe) file on other device, there's error shows like (*.dll) not found...

So, Is there any way to put the references file in "project.exe" without need to put the references on the new devices at every time ?

and thanks...

EXtract Gray Level Coocurence Matrix (Haralick Texture)

$
0
0
Re-Implementation of Haralick Texture Wrotten in Visual Basic Classic

for general information, haralick texture is algorithm to extract textural feature of an image. your can read more about haralick texture in here

Actually this is re-implmentation some-part of my bachelor thesis.

I re-wrote the GLCM texture from java here :

http://rsb.info.nih.gov/ij/plugins/d...M_Texture.java

Glad help ! ^^

if there any correction, or revision please tell, or just come to my github :

https://github.com/noxymon/GLCMVB6
Attached Files

Vibian - The Mini VB6 Framework

$
0
0
Good day:

I found a library which can compete with .net framework. Its was Vibian a single DLL but rich in VB6 functions. Please help them to improve this code and library it has a big potential.

Here is the statement from the author according to PSC website:

It is a simple but powerful COM library for VB6 which emulates/bring some VB.NET functions but utilizing Windows API, built in VB6 functions, and WMI instead of CLR or using .NET Framework. And its also makes VB6 programming more covenient.

This library has the ability to access the following:
* Network
* Power Management
* File System
* Registry
* Operating System Operations
* Advanced Math functions and Math constants
* Cryptography
* Windows Firewall
* Windows Services
* XML Parser
* INI File Operation
* ZIP File Operation
* Additional VB6 functions

It also emulates the "My" Keyword on VB.NET.

Notice: I do not own the whole code. Some parts of the code are owned by the respective authors. Developers who want to Improve the code of this library are welcome. Just upload the improved source code on PSC and please avoid changing the function names or delete the existing functions, enums, sub/function arguments, and constants in order to maintain the standards and to prevent messing the developers. You are allow to add functions or arguments (avoid deleting or altering the existing argument order, append optional if making additional argument in an existing fuction) on this library.


Available classes on this library file:
* StdRegistry (Registry)
* OSinfo (OS info)
* StdProcessor (Processor)
* StdInfo (PC Info)
* DiskInfo (Disk Drive Info)
* SpecialDirectory (Windows Special Directories)
* Math2 (Additional Math function)
* StdFileSystem (File System)
* MathConstant (Additional Math constants)
* StdNetwork (Network)
* StdPowerSource (Power Source)
* StdSystemAction (Computer Action)
* StdSettings (Manage App Settings)
* StdTaskbar (Taskbar Info)
* StdServices (Windows Services)
* StdSoundVolume (Sound Volume)
* TextFile (Text File Access)
* VB6Extension (Additional VB6 functions)
* StdComputer (Computer class)
* My ("My" keyword)
* CpuUsageObject (CPU usage, Must be initialize when the app starts. Dont declare it inside the timer events)
* CDPlayerAdvanced (Advanced CD Player)
* CompactDiscPlayerBasic (Basic CD Player)
* StdEnigma (Enigma Ecryption)
* SoundRecorder (Record Sound)
* StdFirewall (Windows Firewall)
* StdBase64 (Base 64 Encoding/decoding)
* StdCryptography (Cryptograpghy class)
* StdMD5 (MD5)
* StdSHA (SHA)
* StdCRC32 (CRC32)
* StdHTTP (HTTP)
* StdFTP (FTP)
* StdSerial (Serial Comm)
* StdDrives (Disk Drives)
* StdTimer (Timer)
* StdDateTime (Addition Date and Time functions)
* StdIniFile (Ini file)
* XMLDocumentFile (XML Parser)
* StdMouse (Mouse)
* ZipObject (Zip Files)
* StdKeyboard (Keyboard)

[VB6] Check If a Window is on the Desktop

$
0
0
If you save your window position when your application exits, it's good to check to make sure that the monitor it was on is still there and is the same size it used to be when you start up. This code takes in an hWnd and returns true if the window is entirely inside the user's desktop area, allowing you to decide if you need to move the window or not.

This must be placed in a module to work.

Code:

Option Explicit

Private Type Rect
  Left    As Long
  Top    As Long
  Right  As Long
  Bottom  As Long
End Type

Private Declare Function EnumDisplayMonitors Lib "user32" (ByVal hDC As Long, ByVal lprcClip As Long, ByVal lpfnEnum As Long, dwData As Long) As Long
Private Declare Function CombineRgn Lib "gdi32.dll" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32.dll" (ByRef lpRect As Rect) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hWnd As Long, ByRef lpRect As Rect) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long

Private Const API_TRUE = 1
Private Const RGN_OR As Long = 2
Private Const RGN_DIFF As Long = 4
Private Const NULLREGION As Long = 1

Private Function MonitorEnumProc(ByVal lngMonitorHandle As Long, _
                                ByVal lngMonitorHDC As Long, _
                                ByRef typWorkingScreen As Rect, _
                                ByRef lngDesktopRegionHandle As Long) As Long
   
    Dim lngWorkingScreenRegion As Long
   
    ' Make the screen's rect into a region
    lngWorkingScreenRegion = CreateRectRgnIndirect(typWorkingScreen)
   
    ' Combine it with all the desktops so far.
    CombineRgn lngDesktopRegionHandle, lngWorkingScreenRegion, lngDesktopRegionHandle, RGN_OR
       
    ' Dispose of the screen's region
    DeleteObject lngWorkingScreenRegion
       
    ' Proceeed to the next screen
    MonitorEnumProc = API_TRUE

End Function

Public Function hWndIsInDesktopRegion(ByVal hWnd As Long) As Boolean
   
    Dim typRect As Rect
    Dim lngSrcRegionHandle As Long
    Dim lngDesktopRegionHandle As Long
   
    ' Create an empty region that will be used to combine the desktop regions into
    ' typRect is empty at init per VB convention
    lngDesktopRegionHandle = CreateRectRgnIndirect(typRect)
   
    ' Create a region that is the window we are interested in
    GetWindowRect hWnd, typRect
    lngSrcRegionHandle = CreateRectRgnIndirect(typRect)
       
    ' Enum the monitors to create the desktop region.
    Call EnumDisplayMonitors(0&, 0&, AddressOf MonitorEnumProc, lngDesktopRegionHandle)
   
    ' Test to see if our region is in the combined region
    If CombineRgn(lngDesktopRegionHandle, lngSrcRegionHandle, lngDesktopRegionHandle, RGN_DIFF) = NULLREGION Then
        hWndIsInDesktopRegion = True
    Else
        hWndIsInDesktopRegion = False
    End If
       
    ' Dispose of the local and desktop regions
    DeleteObject lngSrcRegionHandle
    DeleteObject lngDesktopRegionHandle
   
End Function

VB6 Simple View-SQL-Editor for JET-mdb's

$
0
0
Just a little Demo (80 lines of code) which could easily be enhanced (with a little love) -
to real "Tool-Status".

For example when a "full Access-Installation" is not given on some machine or something - or when
you're tired to switch between Access' "SQL-View" and "Table-View", just to see results of your View-Defs
(or simply want to prevent all this "auto-intelligence, with an abundance of parentheses", Access will
happily throw into your hand-edited View-SQL anytime it feels in the mood...). ;)

The demo reads the current Views (and Tables) from any given JET-mdb (the Zip contains a small "BookStore" like one)...
and then displays the current SQL of existing Views, as well as the results this View-SQL will produce (in a DataGrid).

Here's the Demo-Zip: ViewEditor.zip

And a ScreenShot:



Olaf
Attached Files

VB6 StarRating-Control (cairo-Rendering)

$
0
0
This is an implementation, based on Vector-Drawing (with the cairo-Wrapper-Classes from vbRichClient5).
No (PNG- or other) Images were used - just plain Drawing-Commands (to gain more flexibility with regards to
the Stars Shape - and to easier allow for different Base-Colors to fill the interior of the given Star-DrawingPath).

A normal VB6-UserControl is used as the Host for these Drawings - fully transparent and alpha-aware.

The Star-Rendering will be smooth and antialiased, even when the Controls are resized
(to behave properly in DPI-aware Apps).

The MinHeight of the Control is 16-, its MaxHeight 56-Pixels.

The ScreenShot below shows, how the rendering behaves with different Sizes (and Colors).

The Value of the Control can be set also per Mouse-Interaction (Drag- or Click) - and
will (in Drag-Mode) show a darker "Hover-Overlay" (so the older Value can be seen for comparison,
until the Mouse-Button is released).

Here's the Source-Zip: StarRating2.zip
(updated with a fix for: "Allow Zero-Detection whilst clicking outside the first Star")

New version - (containing the fix above, but also a new modRC5Regfree.bas, which when included
into a Project, will ensure regfree-loading of the RC5-Main-Classes automatically - when:
- your App will run from a compiled Executable ... and
- when a \Bin\-SubFolder exists below your App.Path, which contains copies of the 3 RC5 BaseDlls
Version 3: StarRating3.zip

And here a ScreenShot:



Olaf
Attached Files

[VB6] IcoWriter - Yet another "hIcon to array/file saver"

$
0
0
IcoWriter is a VB6 class that can be used to save hIcon handles into ICO format. it can provide them as a Byte array or write them to a disk file you provide a name for.

Details

Unlike some sample code IcoWriter will save multiple images of different dimensions and color depths as a single ICO.

It does not handle "Vista" icon images (256x256 PNG images) but it handles most square and rectangular images below 256 pixels in both dimensions. I don't recommend it for anything larger than 48x48 though. Color depths supported are 1-bpp, 4-bpp, 8-bpp, 24-bpp, and 32-bpp with alpha channel.

You might obtain hIcon handles in several different ways in a VB6 program. IcoWriter is offered here embedded in a demo application that uses several of these.

It is also possible to load other bitmap images formats and use them via an ImageList control. The demo does this with PNG source images, though as written that requires WIA 2.0. You could modify the demo code to use GDI+ directly too.

IcoWriter takes a stab (ok, multiple stabs) at handling color depth reduction to get somewhat better results than it might otherwise produce. However "garbage in, garbage out" and so this isn't perfect. Especially for creating 1-bpp images out of 24-bpp source images!

A proper color quantization algorithm might improve on IcoWriter's current results. But I'm no Graphics Guru so I'll live with what I have for now. ;)


Requirements

VB6 to run or compile the demo of course.

Windows XP or later to work with 32-bpp alpha channel ("XP") icon images.

WIA 2.0 (included with Vista and later, can be installed into Windows XP SP 1 or later). This is just for the demo, IcoWriter does not use WIA.


Testing the demo

If you have a PC meeting the requirements, everything should be there. Just unzip the attachment into a folder and open it in VB6 by "double clicking" on the .VBP file. Then you should be able to run it. Do people still have Explorer set to double-click mode... in 2015?

Check the created Saved folder for the results. These are best examined using IcoFX or another decent icon editor.

The attachment's size is largely made up of source images.
Attached Files

[VB6] Basic unzip without 3rd party DLL or shell32- IStorage-based

$
0
0
So the only other method I've really seen to extract zip archives without shell32 or a 3rd party DLL is a full implementation of the ZIP algorithm, and while this isn't exactly a lightweight method, it's not nearly as complex as that was with all its class modules. As I've mentioned a few times, I'm definitely not a fan of the shell32 object, and I came across an unzip method using things I do like: shell interfaces. Thanks to low-level Windows ZIP integration, it's possible to extract the contents of a simple ZIP archive (doesn't support password-protected zips for example) using IStorage, IStream, and some API.

Requirements
A type library with IStorage and IStream is required, and I strongly recommend using oleexp for future compability (get it here)- any version is fine, there's no new version like new examples usually need; and the sample project is written for that. However, if you change a couple 'oleexp3.x' declares, the original olelib is supported (for the sample project, you'll need a new way of selecting the zip file too since it's using FileOpenDialog).

This method is compatible with Windows XP and higher, but note the sample project for simplicity has a Vista+ FileOpen

Code
Below is a free-standing module you can use without anything else in the demo project (besides oleexp or olelib with changes):

Code:

Option Explicit

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 SHBindToParent Lib "shell32" (ByVal pidl As Long, riid As UUID, ppv As Any, pidlLast As Long) As Long
Public Declare Function SHCreateStreamOnFileEx Lib "shlwapi" (ByVal pszFile As Long, ByVal grfMode As STGM, ByVal dwAttributes As FILE_ATTRIBUTES, ByVal fCreate As Long, ByVal pstmTemplate As Long, ppstm As oleexp3.IStream) As Long
Public Declare Function PathFileExistsW Lib "shlwapi" (ByVal lpszPath As Long) As Long
Public Declare Function CreateDirectoryW Lib "kernel32" (ByVal lpPathName As Long, ByVal lpSecurityAttributes 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 Const NOERROR = 0&
Public Const FILE_ATTRIBUTE_NORMAL = &H80

Public Sub UnzipFile(sFile As String, Optional ByVal sTo As String = "")
'unzip without 3rd party dll
Dim psfParent As oleexp3.IShellFolder
Dim pidlFQ As Long
Dim pidlChild As Long
Dim pszDest As String

If sTo = "" Then
    'defaults to create a folder with the zip's name in the same folder as the zip
    pszDest = sFile
    pszDest = Left$(pszDest, Len(pszDest) - 4) 'remove .zip
Else
    pszDest = sTo
End If

'First, we need the parent pidl, child pidl, and IShellFolder
'These are all references to the file very common in shell programming
pidlFQ = ILCreateFromPathW(StrPtr(sFile))
Call SHBindToParent(pidlFQ, IID_IShellFolder, psfParent, pidlChild)
If (psfParent Is Nothing) Or (pidlChild = 0) Then
    Debug.Print "UnzipFile.Failed to bind to file"
    Exit Sub
End If

'Now that we have the IShellFolder, we want the IStorage object
'That is what we'll be able to extract from, thanks to the
'very low level system zip integration with zipfldr.dll
Dim pStg As oleexp3.IStorage
psfParent.BindToObject pidlChild, 0, IID_IStorage, pStg
If (pStg Is Nothing) Then
    Debug.Print "UnzipFile.Failed to bind to storage"
    Exit Sub
End If
Debug.Print "UnzipFile.extract to " & pszDest

StgExtract pStg, pszDest

Set pStg = Nothing
Set psfParent = Nothing
ILFree pidlFQ


End Sub
Private Sub StgExtract(pStg As oleexp3.IStorage, pszTargetDir As String, Optional fOverwrite As Long = 0)
'This function is recursively called to extract zipped files and folders

'First, create the target directory (even if you're extracting to an existing folder, it create subfolders from the zip)
If (PathFileExistsW(StrPtr(pszTargetDir)) = 0) Then
    Call CreateDirectoryW(StrPtr(pszTargetDir), ByVal 0&)
    If (PathFileExistsW(StrPtr(pszTargetDir)) = 0) Then
        Debug.Print "StgExtract.Failed to create directory " & pszTargetDir
        Exit Sub
    End If
End If

'The enumerator will loop through each storage object
'Here, that will be zipped files and folders
Dim pEnum As IEnumSTATSTG
Set pEnum = pStg.EnumElements(0, 0, 0)
If (pEnum Is Nothing) Then
    Debug.Print "StgExtract.pEnum==nothing"
    Exit Sub
End If

Dim celtFetched As Long
Dim stat As STATSTG
Dim pszPath As String

    Do While (pEnum.Next(1, stat, celtFetched) = NOERROR)
        pszPath = SysAllocString(stat.pwcsName) 'contains a file name
'        Debug.Print "pszPath on alloc=" & pszPath
        If (Len(pszPath) > 1) Then
            pszPath = AddBackslash(pszTargetDir) & pszPath 'combine that with the path (recursive, so can be zipped folder path)
'            Debug.Print "pszPath on combine=" & pszPath
            If stat.Type = STGTY_STORAGE Then 'subfolder
                Dim pStgSubfolder As oleexp3.IStorage
                Set pStgSubfolder = pStg.OpenStorage(SysAllocString(stat.pwcsName), 0, STGM_READ, 0, 0)
                If (pStgSubfolder Is Nothing) Then
                    Debug.Print "StgExtract.pstgsubfolder==nothing"
                    Exit Sub
                End If
                StgExtract pStgSubfolder, pszPath 'and if there's more subfolders, we'll go deeper
            ElseIf stat.Type = STGTY_STREAM Then 'file
                'the basic idea here is that we obtain an IStream representing the existing file,
                'and an IStream representing the new extracted file, and copy the contents into the new file
                Dim pStrm As oleexp3.IStream
                Set pStrm = pStg.OpenStream(SysAllocString(stat.pwcsName), 0, STGM_READ, 0)
                Dim pStrmFile As oleexp3.IStream
               
                'here we add an option to not overwrite existing files; but the default is to overwrite
                'set fOverwrite to anything non-zero and the file is skipped
                'If we are extracting it, we call an API to create a new file with an IStream to write to it
                If PathFileExistsW(StrPtr(pszPath)) Then
                    If fOverwrite Then
                        Call SHCreateStreamOnFileEx(StrPtr(pszPath), STGM_CREATE Or STGM_WRITE, FILE_ATTRIBUTE_NORMAL, 1, 0, pStrmFile)
                    End If
                Else
                    Call SHCreateStreamOnFileEx(StrPtr(pszPath), STGM_CREATE Or STGM_WRITE, FILE_ATTRIBUTE_NORMAL, 1, 0, pStrmFile)
                End If
                If (pStrmFile Is Nothing) = False Then
                    'Debug.Print "StgExtract.Got pstrmfile"
                    Dim cbSize As Currency 'the STATSTG cbSize is ULONGLONG (equiv. to Currency), so files >2GB should be fine
                    pStrm.CopyTo pStrmFile, stat.cbSize, 0, cbSize
                    Set pStrmFile = Nothing
                    'Debug.Print "StgExtract.bytes written=" & CStr(cbSize)
                Else
                    'either an error or skipped an existing file; either way we don't exit, we'll move on to the next
                    'Debug.Print "StgExtract.pstrmfile==nothing"
                End If
                Set pStrm = Nothing
            End If
        End If
        pszPath = ""
        Call CoTaskMemFree(stat.pwcsName) 'this memory needs to be freed, otherwise you'll leak memory
    Loop
   
    Set pEnum = Nothing
   

End Sub
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
Public Function AddBackslash(s As String) As String

  If Len(s) > 0 Then
      If Right$(s, 1) <> "\" Then
        AddBackslash = s & "\"
      Else
        AddBackslash = s
      End If
  Else
      AddBackslash = "\"
  End If

End Function

Public Function IID_IStorage() As UUID
'({0000000B-0000-0000-C000-000000000046})
Static iid As UUID
 If (iid.Data1 = 0) Then Call DEFINE_OLEGUID(iid, &HB, 0, 0)
 IID_IStorage = iid
End Function

'-----------------------------------------------------------
'Below this is not needed if you're using mIID.bas
'(check if the above IID_IStorage exists or not, because this was released before the update that included it)
'-----------------------------------------------------------
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 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
Public 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

If anyone knows how I could add password support or create a zip file, definitely post ideas in the comments as I'll be working on it.

Thanks
This code is based on code using this method in C by sapero, found here.

------------------
Note: The file I uploaded was named UnzipNew.zip, I have no idea why VBForums keeps renaming it to U.zip. Have tried removing and reattaching several times.
Attached Files
Viewing all 1480 articles
Browse latest View live


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