VB6 - ImageListPicker Control

January 5, 2013, 10:32 am

≫ Next: [VB6] DownloadURL2File Function (Unicode-aware) + IsInternetConnected Function

≪ Previous: [VB6] Uncompressed AVI Writer

$

0

0

This is a simple GUI UserControl for "picking" from a list of pictures.

Your program loads some pictures into it, then the user can scroll the visible list horizontally and click on one to select it.


METHODS

Add - Add a StdPicture to the list.

Delete X - Delete picture X from the list. X from 1 to n.

ClearAll - Clears the list.


PROPERTIES

ListItems(X) - Retrieves item X as a StdPicture object.

ListIndex - Currently selected item, 0 = none selected.

ThumbNailHeight, ThumbnailWidth - Visible size in pixels for the scrolling thumbnails.

ThumbnailsMargin - Space between each thumbnail in pixels. Must be 3 or greater to allow room for the selection rectangle.


EVENTS

Click - Fired when user clicks on a thumbnail image.


No special requirements or dependencies. Uses intrinsic VB6 controls and image operations. Just add the .CTL and .CTX files to your Project folder then add the control using Project|Add|File...

Source provided in the attachment as part of a demo project, along with some sample pictures (which is why the attachment is so large).

You could enhance it to add "tag" values, "file names" and so on. It would be easy enough to create a "vertical" version of this control too.

Attached Images

 

Attached Files

• ImageListPicker.zip‎ (60.9 KB)

---

[VB6] DownloadURL2File Function (Unicode-aware) + IsInternetConnected Function

January 17, 2013, 2:26 pm

≫ Next: JACZip Archiver

≪ Previous: VB6 - ImageListPicker Control

$

0

0

Code:

---


Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreateFileW Lib "kernel32.dll" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, Optional ByVal dwFlagsAndAttributes As Long, Optional ByVal hTemplateFile As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInternet As Long) As Long
Private Declare Function InternetOpenW Lib "wininet.dll" (ByVal lpszAgent As Long, ByVal dwAccessType As Long, ByVal lpszProxyName As Long, ByVal lpszProxyBypass As Long, ByVal dwFlags As Long) As Long
Private Declare Function InternetOpenUrlW Lib "wininet.dll" (ByVal hInternet As Long, ByVal lpszUrl As Long, ByVal lpszHeaders As Long, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal dwNumberOfBytesToRead As Long, ByRef lpdwNumberOfBytesRead As Long) As Long
Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long
Private Declare Function WriteFile Lib "kernel32.dll" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToWrite As Long, Optional ByRef lpNumberOfBytesWritten As Long, Optional ByVal lpOverlapped As Long) As Long

'Downloads the file specified by the sURL argument to the local file pointed
'by the sFileName parameter. The optional Chunk parameter determines the number
'of bytes to be downloaded at a time. Bigger chunks download faster while smaller
'ones enables the GUI to be more responsive. Returns the total number of bytes
'successfully written to disk. Maximum download size of 2047.99 MB only.

Public Function DownloadURL2File(ByRef sURL As String, ByRef sFileName As String, Optional ByVal Chunk As Long = 1024&) As Long
    Const INTERNET_OPEN_TYPE_DIRECT = 1&, INTERNET_FLAG_DONT_CACHE = &H4000000, INTERNET_FLAG_RELOAD = &H80000000
    Const GENERIC_WRITE = &H40000000, FILE_SHARE_NONE = 0&, CREATE_ALWAYS = 2&
    Const INVALID_HANDLE_VALUE = -1&, ERROR_INSUFFICIENT_BUFFER = &H7A&
    Dim hInternet As Long, hURL As Long, hFile As Long, nBytesRead As Long, nBytesWritten As Long
    Dim bSuccess As Boolean, sBuffer_Ptr As Long, sBuffer_Size As Long, sBuffer As String

    If LenB(sURL) = 0& Or LenB(sFileName) = 0& Or Chunk < 2& Then Exit Function

    hInternet = InternetOpenW(StrPtr(App.Title), INTERNET_OPEN_TYPE_DIRECT, 0&, 0&, 0&)
    If hInternet Then
        hURL = InternetOpenUrlW(hInternet, StrPtr(sURL), 0&, 0&, INTERNET_FLAG_DONT_CACHE Or INTERNET_FLAG_RELOAD, 0&)
        If hURL Then
            hFile = CreateFileW(StrPtr(sFileName), GENERIC_WRITE, FILE_SHARE_NONE, 0&, CREATE_ALWAYS) 'Overwrite existing
            If hFile <> INVALID_HANDLE_VALUE Then
                Do: SysReAllocStringLen VarPtr(sBuffer), , (sBuffer_Size + Chunk) * 0.5!
                    sBuffer_Size = LenB(sBuffer):  sBuffer_Ptr = StrPtr(sBuffer)
                    Do While InternetReadFile(hURL, sBuffer_Ptr, sBuffer_Size, nBytesRead)
                        If nBytesRead Then
                            bSuccess = (WriteFile(hFile, sBuffer_Ptr, nBytesRead, nBytesWritten) <> 0&) _
                                        And (nBytesWritten = nBytesRead): Debug.Assert bSuccess
                            DoEvents
                            If bSuccess Then DownloadURL2File = DownloadURL2File + nBytesWritten
                        Else
                            Exit Do
                        End If
                    Loop
                Loop While Err.LastDllError = ERROR_INSUFFICIENT_BUFFER
                hFile = CloseHandle(hFile):                              Debug.Assert hFile
            End If
            hURL = InternetCloseHandle(hURL):                            Debug.Assert hURL
        End If
        hInternet = InternetCloseHandle(hInternet):                      Debug.Assert hInternet
    End If
End Function


---

Code:

---


Private Declare Function InternetCheckConnectionW Lib "wininet.dll" (Optional ByVal lpszUrl As Long, Optional ByVal dwFlags As Long, Optional ByVal dwReserved As Long) As Long

'Allows an application to check if a connection to the Internet can be established.
Public Function IsInternetConnected(Optional ByRef sURL As String = "http://www.google.com/") As Boolean
    Const FLAG_ICC_FORCE_CONNECTION = &H1&

    IsInternetConnected = InternetCheckConnectionW(StrPtr(sURL), FLAG_ICC_FORCE_CONNECTION)
End Function


---

JACZip Archiver

January 19, 2013, 2:40 pm

≫ Next: DataGrid Multiple Row Selection

≪ Previous: [VB6] DownloadURL2File Function (Unicode-aware) + IsInternetConnected Function

$

0

0

JACZip is a straight forward ZIP Archive/Unarchive program using the
built in facilities within Windows. The Microsoft implementation of
the ZIP function into the Windows Explorer is to say the least
cumbersome, and with WinZip you never really know what it has done.
If the old Command Line PKZIP supported long file names, I would
probably still be using it.

The program has been tested on Vista and Win7. XP SP2 also supports
zipped files, but JACZip has not been tested on that platform. It
requires "Microsoft Shell Controls And Automation", "Microsoft
Scripting Runtime", as well as the "Microsoft Common Dialog Control",
and the "Microsoft Flexgrid Control".

A more detailed explanation is contained in the readme file.

J.A. Coutts

Attached Files

• JACZipD.zip‎ (16.0 KB)

DataGrid Multiple Row Selection

January 27, 2013, 10:53 am

≫ Next: [VB6] Dereferencing Pointers sans CopyMemory

≪ Previous: JACZip Archiver

$

0

0

The Data Bound DataGrid Control provides the ability to select
multiple rows using the CTRL key and mouse, but it lacks the
ability to use the SHIFT key in conjunction with the mouse.
The routines below add that ability by utilizing the MouseUp event.

Code:

---

Option Explicit

Dim PrevBmk          As Long
Dim CurrentBmk      As Long

Private Sub DataGrid1_Click()
        If DataGrid1.SelBookmarks.Count > 0 Then
                'If there is a bookmark present, make it the previous bookmark
                CurrentBmk = DataGrid1.SelBookmarks(DataGrid1.SelBookmarks.Count - 1)
        End If
End Sub

Private Sub DataGrid1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
        Dim M%, N%
        If Shift > 0 And DataGrid1.SelBookmarks.Count = 0 Then
                'Prompt user to utilize row selection column
                MsgBox "You must use the far left column to select multiple records!"
        ElseIf Shift = vbShiftMask Then
                PrevBmk = CurrentBmk 'Save previous bookmark
                CurrentBmk = DataGrid1.SelBookmarks(DataGrid1.SelBookmarks.Count - 1)
                Debug.Print PrevBmk, CurrentBmk
                If PrevBmk = 0 Then Exit Sub 'no previous bookmark
                N% = CurrentBmk - PrevBmk 'Number of bookmarks to be made (+/-)
                Select Case N% 'Set step direction for/next routine
                        Case Is < 0
                                M% = 1 'Step forward
                        Case Is = 0
                                Exit Sub 'Only 1 selected
                        Case Is > 0
                                M% = -1 'Step reverse
                End Select
                For N% = N% To -M% Step M%
                        DataGrid1.SelBookmarks.Add DataGrid1.GetBookmark(-N%)
                        Debug.Print DataGrid1.SelBookmarks(DataGrid1.SelBookmarks.Count - 1)
                Next N%
        End If
End Sub

---

[VB6] Dereferencing Pointers sans CopyMemory

January 28, 2013, 11:14 am

≫ Next: VB6 - DirectShow WebCam Minimal Code

≪ Previous: DataGrid Multiple Row Selection

$

0

0

Here are several functions which retrieves the value or data located at the memory address specified by the given pointer. These functions perform the inverse operation of VarPtr, StrPtr and ObjPtr. Rather than using the ubiquitous CopyMemory, alternative APIs are presented instead.

The API declarations:

Code:

---


Private Declare Function ObjSetAddRef Lib "msvbvm60.dll" Alias "__vbaObjSetAddref" (ByRef ObjDest As Object, ByVal Ptr2Obj As Long) As Long
Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Private Declare Sub CopyBytes Lib "msvbvm60.dll" Alias "__vbaCopyBytes" (ByVal ByteLen As Long, ByVal Destination As Long, ByVal Source As Long)
Private Declare Sub GetMem1 Lib "msvbvm60.dll" (ByVal Ptr As Long, ByRef RetVal As Byte)
Private Declare Sub GetMem2 Lib "msvbvm60.dll" (ByVal Ptr As Long, ByRef RetVal As Integer)
Private Declare Sub GetMem4 Lib "msvbvm60.dll" (ByVal Ptr As Long, ByRef RetVal As Long)
Private Declare Sub GetMem8 Lib "msvbvm60.dll" (ByVal Ptr As Long, ByRef RetVal As Currency)


---

The pointer dereferencing functions:

Code:

---


'Retrieves the Byte value from the specified memory address
Public Function GetBytFromPtr(ByVal Ptr As Long) As Byte
    GetMem1 Ptr, GetBytFromPtr
End Function

'Retrieves the Integer value from the specified memory address
Public Function GetIntFromPtr(ByVal Ptr As Long) As Integer
    GetMem2 Ptr, GetIntFromPtr
End Function

'Retrieves the Long value from the specified memory address
Public Function GetLngFromPtr(ByVal Ptr As Long) As Long
    GetMem4 Ptr, GetLngFromPtr
End Function

'Retrieves the Currency value from the specified memory address
Public Function GetCurFromPtr(ByVal Ptr As Long) As Currency
    GetMem8 Ptr, GetCurFromPtr
End Function

'Returns a copy of a null-terminated Unicode string (LPWSTR/LPCWSTR)
Public Function GetStrFromPtr(ByVal Ptr As Long) As String
    SysReAllocString VarPtr(GetStrFromPtr), Ptr
End Function

'Returns an object from the given pointer
Public Function GetObjFromPtr(ByVal Ptr As Long) As Object
    ObjSetAddRef GetObjFromPtr, Ptr
End Function

'Returns a copy of a UDT given a pointer (replace As UDT with any desired Type)
Public Function GetUDTFromPtr(ByVal Ptr As Long) As UDT
    CopyBytes LenB(GetUDTFromPtr), VarPtr(GetUDTFromPtr), Ptr
End Function



---

Sample usage:

Code:

---


Private Type UDT        'Len  LenB
                        '---------
    Byt As Byte        '  1    4  <-- padded to fill 32 bits
    Bln As Boolean      '  2    2
    Int As Integer      '  2    2
    Lng As Long        '  4    4
    Obj As Object      '  4    4
    Sng As Single      '  4    4
    Str As String      '  4    4
    Cur As Currency    '  8    8
    Dtm As Date        '  8    8
    Dbl As Double      '  8    8
    Vnt As Variant      ' 16    16
    FLS As String * 40  ' 40    80  <-- Unicode in memory; ANSI when written to disk
                        '---------
End Type                '101  144


---

Code:

---


Public Sub DerefPtrs()    'Call from Debug window
    Dim U As UDT

    Debug.Print
    Debug.Print "GetBytFromPtr = " & GetBytFromPtr(VarPtr(CByte(&HAD)))
    Debug.Print "GetIntFromPtr = " & GetIntFromPtr(VarPtr(&HEAD))
    Debug.Print "GetLngFromPtr = " & GetLngFromPtr(VarPtr(&HADC0FFEE))
    Debug.Print "GetCurFromPtr = " & GetCurFromPtr(VarPtr(1234567890.1234@))
    Debug.Print "GetStrFromPtr = """ & GetStrFromPtr(StrPtr(App.Title)) & """"
    Debug.Print "GetObjFromPtr = """ & GetObjFromPtr(ObjPtr(App)).Path & """"
    Debug.Print

    With U
        .Byt = &HFF
        .Bln = True
        .Int = &H7FFF
        .Lng = &H7FFFFFFF
        Set .Obj = Forms
        .Sng = 3.402823E+38!
        .Str = "The Quick Brown Fox Jumps Over The Lazy Dog"
        .Cur = 922337203685477.5807@
        .Dtm = Now
        .Dbl = 4.94065645841247E-324
        .Vnt = CDec(7.92281625142643E+27)
        .FLS = "Jackdaws Love My Big Sphinx Of Quartz..."
    End With

    With GetUDTFromPtr(VarPtr(U))
        Debug.Print "Byt = " & .Byt
        Debug.Print "Bln = " & .Bln
        Debug.Print "Int = " & .Int
        Debug.Print "Lng = " & .Lng
        Debug.Print "Obj = """ & TypeName(.Obj) & """"
        Debug.Print "Sng = " & .Sng
        Debug.Print "Str = """ & .Str & """"
        Debug.Print "Cur = " & .Cur
        Debug.Print "Dtm = " & .Dtm
        Debug.Print "Dbl = " & .Dbl
        Debug.Print "Vnt = " & .Vnt
        Debug.Print "FLS = """ & .FLS & """"
    End With
End Sub



---

---

References:

SysReAllocString function at MSDN

Hidden Gems for Free by Michel Rutten

[Benchmark] CopyMemory vs. __vbaCopyBytes by Henrik Ilgen

Using The Native Functions in VBs Runtime DLL by Voodoo Attack!!

VB6 - DirectShow WebCam Minimal Code

January 29, 2013, 10:56 pm

≫ Next: Missing Date

≪ Previous: [VB6] Dereferencing Pointers sans CopyMemory

$

0

0

There are a number of possible APIs in Windows for previewing and capturing from webcams. One of the most popular for its broad support on Windows versions and its relative ease of use when requirements are simple is the AviCap/Video for Windows API.

But a downside of VfW is that the driver model Windows uses to support video capture devices changed after the end of 16-bit Windows (Win3.1, etc.). This means several things, but most commonly frustrating is that instead of mapping multiple webcams as device 1, 2, ... 9 they work through a compatibility layer thats maps one of them as device 1.

This can make selecting the webcam to use difficult to impractical. And using more than one webcam at a time doesn't seem possible.

The usual answer has been: "Use DirectShow instead of VfW."


DirectShow vs. VB6

One problem with using DirectShow is that Microsoft seemed to have lost enthusiasm after providing only a partial implementation. The parts of DirectShow (also called ActiveMovie) we did get a VB6-friendly API for are implemented in the Quartz.dll which should be part of Windows in any recent version (and perhaps even back to most "late" Windows 95 versions like 95B or OSR2.x).

You can still do a lot of things using just what we have, but the finer points of using DirectShow in VB6 require a 3rd party DLL to wrap a few more DirectShow C++ interfaces.


This "Minimal Approach" to VB6, DirectShow, and WebCams

What I have done here is to try to stretch things as far as I could manage.

Here is what you can do:

• Choose among your webcams and display a live preview image.
• "Snap" and display a still image from the webcam feed.

Here is what you can't do:

• Get a "friendly" list of just the usable webcams.
• Control the capture resolution/dimensions or other capture settings or even raise the built-in dialogs to let the user do so.

The Demo

What I wanted to accomplish was to see how far I could get with the two tasks we can perform without using any 3rd party libraries.


Form1

This is the main UI Form, which uses Form2 as a dialog when requested via its menu ("Add new camera...").

There is a lot more code there than I'd like that does nothing except manage the menu. As you add cameras they are added to the menu. There is also code there to load and save "settings" which include the index of the selected camera and list of added cameras by name.

Basically a lot of UI-management code which I hope doesn't obscure the DirectShow-related logic itself.

The other ugly hunk of code in there is the BuildGraph() function, which is a small interpreter of a sort that processes a "filter script" and a "connection script" to add the necessary filters and connect them to create a webcam preview graph for DirectShow.


Form2

Since I can't find any way to find just the list of usuable webcams, the user has to pick them out from among the full list of available "filters" (as they are called)! Not practical at all for a real application, but it works for a test/demo program.

That's what Form2 in the demo Project is for, a dialog from which to pick new cameras.

Note that your camera might appear there once, twice, or even three or more times depending on how many "filters" of different kinds it supports. Just pick any of them, the demo program will just use the name and sort it out later.


Module1

This contains some GDI and OLE API calls to convert the captured frame from a "packed DIB" into a StdPicture object that can be used with PaintPicture, etc. This raw StdPicture is created using a "memory DC" so there are some limits on how you can use it, i.e. simply assigning it to a PictureBox.Picture has some issues.

But in this demo we need to scale it anyway since we can't control the actual capture dimensions.

You could rework this passing in the hDC of a Form, PictureBox etc. I suppose.


Running the DSMini1 Project

The attached ZIP archive contains the entire Project.

All you should need to do is unzip the archive, then open the Project in VB6. If you have a webcam connected, you can just go ahead and run it within the IDE.

From there you will have to "Add" your webcam by browsing the filter list.

After a valid add, the live preview starts immediately at the left.

Clicking on the Snap button should take a snapshot and display it in the PictureBox at the right.

If you have another webcam connectd you shuld be able to add that one too. Once you have two or more added you can choose among them via Form1's menu.

Settings are persisted in Settings.txt, so a subsequent run should save you the trouble of picking cameras again.


Remarks

I don't know what webcams this will work with, but I know it works with two very different ones I've tried so far.

Attached Images

   

Attached Files

• DSMini1.zip‎ (13.7 KB)

Missing Date

January 30, 2013, 1:21 am

≫ Next: Simple "Mass on Spring" Simulation

≪ Previous: VB6 - DirectShow WebCam Minimal Code

$

0

0

i have an issue with my date time picker not displaying month feb unless i set it equal to month feb on form load.

any ideas ?

Simple "Mass on Spring" Simulation

February 1, 2013, 12:40 pm

≫ Next: VB6 Real Unicode Display in Rich Edit without installing RICHTX32.OCX

≪ Previous: Missing Date

$

0

0

This code simulates oscillation of mass on a spring and graphs that motion. To use this code, just start a new project, place a picture box on the form, paste the code into the form's Load event, and run the program.

Code:

---

'set up the display------------------------------
Form1.ScaleMode = 3
With Picture1
.Appearance = 0
.BorderStyle = 0
.AutoRedraw = True
.Width = 257
.Height = 257
.ScaleMode = 0
.ScaleWidth = .Width
.ScaleHeight = -.Height
.ScaleLeft = 0
.ScaleTop = .Height \ 2
End With

'run the simulation------------------------------
Dim f As Double 'net force acting on mass
Dim a As Double 'acceleration
Dim v As Double 'velocity
Dim p As Double 'position
Dim k As Double 'spring constant
Dim d As Double 'damping factor
Dim m As Double 'mass
Dim i As Double 'time increment
Dim t As Double 'time

p = 100
k = 0.1
d = 0.15
m = 2
i = 0.01

For t = 0 To 257 Step i
f = (-p * k) + (-v * d)
a = f / m
v = v + a * i
p = p + v * i
Picture1.PSet (t, p)
Next t

---

---

VB6 Real Unicode Display in Rich Edit without installing RICHTX32.OCX

February 1, 2013, 2:25 pm

≫ Next: check if internet is connected or not

≪ Previous: Simple "Mass on Spring" Simulation

$

0

0

Hi Guys!

I combined two nice features for a part of my project and I decided to share it with you. Well, I had three challanges when I was doing this:

1. Use a RichTextBox for unicode display;
2. Use real unicode characters like superscript numbers (not fake offsets)
3. Not to use a setup which is nearly a must if you are using RichTextBox control to copy and register RICHTX32.OCX file. (because my project was only 380KB which looks stupid for a setup.)

Infact, I did a very small part of the job. This is a nice combination of two different modules written by some other hardworking people.

After a long research dilettante suggested me this project to display real unicode contents RTB Superscript.zip‎. It is written only "Superscript" but it does a quite well job with unicodes, too... However, only compatible RichText Box object...

At first I was very happy with this but then I realized that it causes error in computers which has no RICHTX32.OCX file in System 32 folder.
I sworn my not to use setup for a 380KB project.

Then in another thread ,again dilettante, suggested me a code (Naked RichEdit.zip‎) which draws it's own RichTextBox which is only depending on "riched20.dll", nearly found in any PC.

Then I made some tweaks, modifications and combined them, droped some notes into code to help for some basic features.

And TA-TAA:

Attachment 95963 !!!

I hope someone will find it useful, too...


PS: If anybody knows how to change the font in the code, please do let me know :D

Attached Files

• Real Unicode Display without RICHTX32.OCX.zip‎ (9.9 KB)

check if internet is connected or not

February 10, 2013, 4:51 pm

≫ Next: Form Window Setup With Pixel Perfect Accuracy

≪ Previous: VB6 Real Unicode Display in Rich Edit without installing RICHTX32.OCX

$

0

0

add this in module

Code:

---

Option Explicit
Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32

Public Type RASCONN95
      dwSize As Long
      hRasCon As Long
      szEntryName(RAS95_MaxEntryName) As Byte
      szDeviceType(RAS95_MaxDeviceType) As Byte
      szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Public Type RASCONNSTATUS95
      dwSize As Long
      RasConnState As Long
      dwError As Long
      szDeviceType(RAS95_MaxDeviceType) As Byte
      szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Public Function IsConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95

TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)

If RetVal <> 0 Then
    MsgBox "Error " & Err & " Has Occured!", vbOKOnly + vbCritical, "Error!"
    Exit Function
End If
     
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)

If Tstatus.RasConnState = &H2000 Then
    IsConnected = True
Else
    IsConnected = False
End If
End Function

---

Code:

---

Private Sub Command2_Click()
Text1.Text = IsConnected

End Sub

---

Form Window Setup With Pixel Perfect Accuracy

February 11, 2013, 11:35 pm

≫ Next: Getting data from an URL provided

≪ Previous: check if internet is connected or not

$

0

0

One of the biggest issues with setting up your form for doing graphical programming is to get it right perfectly. You searched on Google how to do it; you messed around with the Widths and Heights; setting the Scalemode to vbPixels; messed around with Screen.TwipsPerPixel X and Y; and....still no luck. It ends up never being the values you put in to begin with, not to mention the borders of the form as well as the top of your window throws off the values a notch. Luckily I created a function that does just that. This simple sub routine will allow you to set the window anywhere you want on screen and allows you to set the size of your form window with pixel perfect accuracy by just the interior of your form window. This assumes that you are using either a borderstyle of sizable, fixed single, or none. After running this small sample program, you will see that the scalewidth and scaleheights are exact as the values you wanted. And if you take a snapshot of it pressing your PrintScreen key, paste it in a paint program, and get the width and heights of within your window, you will see it'll be exactly the number of pixels you wanted. Enjoy as code like this is not easy to come by. It should be universal. If not, you can adjust the offsets. I tested it on a bunch of resolutions and its all the same so far.

[EDIT] Fixed the code shown below. Now it should be ok.

vb Code:

Option Explicit
 
Private Sub Window_Setup(Window As Form, Optional ByVal X As Long = -1, Optional ByVal Y As Long = -1, Optional ByVal Width As Long = -1, Optional ByVal Height As Long = -1, Optional Caption As String = " ", Optional Auto_Redraw As Boolean = False, Optional ByVal Back_Color As Long = -1)
    'Use -1 for default values and "" for default strings.
    With Window
        If Caption <> " " Then .Caption = Caption 'Else use current setting. Note: Some people may want "" as the caption.
        .AutoRedraw = Auto_Redraw
        .ScaleMode = vbPixels
        If X <> -1 Then .Left = X * Screen.TwipsPerPixelX 'Else use current setting.
        If Y <> -1 Then .Top = Y * Screen.TwipsPerPixelY 'Else use current setting.
        If .BorderStyle = vbSizable Then
            If Width <> -1 Then .Width = (Width * Screen.TwipsPerPixelX) + (16 * Screen.TwipsPerPixelX) 'Else use current setting.
            If Height <> -1 Then .Height = (Height * Screen.TwipsPerPixelY) + (38 * Screen.TwipsPerPixelY) 'Else use current setting.
        ElseIf .BorderStyle = vbFixedSingle Then
            If Width <> -1 Then .Width = (Width * Screen.TwipsPerPixelX) + (6 * Screen.TwipsPerPixelX) 'Else use current setting.
            If Height <> -1 Then .Height = (Height * Screen.TwipsPerPixelY) + (28 * Screen.TwipsPerPixelY) 'Else use current setting.
        ElseIf .BorderStyle = 0 Then
            If Width <> -1 Then .Width = (Width * Screen.TwipsPerPixelX) 'Else use current setting.
            If Height <> -1 Then .Height = (Height * Screen.TwipsPerPixelY) 'Else use current setting.
        End If
        If Back_Color <> -1 Then .BackColor = Back_Color 'Else use current setting.
        .Show
        .SetFocus
    End With
End Sub
 
Private Sub Form_Load()
    Window_Setup frmMain, 0, 0, 255, 255
    Print frmMain.ScaleWidth & ", " & frmMain.ScaleHeight
End Sub

Getting data from an URL provided

February 14, 2013, 7:01 am

≫ Next: VB6 - BasicBuffer, Binary Stream Class

≪ Previous: Form Window Setup With Pixel Perfect Accuracy

$

0

0

My task is to develop code in VB Classic, to open and URL (provided) and grab the information on the page and pass to application.

a) Open the URL site
b) Get the data on the page of the URL
c) Pass the data back to the appication

Appreciate your help

VB6 - BasicBuffer, Binary Stream Class

February 14, 2013, 11:50 am

≫ Next: Email Client Program

≪ Previous: Getting data from an URL provided

$

0

0

Description

A simple stream-style buffer class.

This is a kind of binary stream, similar to an ADO Steam object in Type = adBinary mode or an OLE IStream object. It accepts and returns Byte arrays, Integers, and Longs but not text String values.

It can be useful whenever you want a data structure that supports something similar to concatenating Byte arrays when you need to accumulate data arriving in bits and pieces and extract chunks for use. Things like Winsock control and MSComm control binary communication come to mind.

The properties and methods are similar to those of an ADO Stream.

This class has a lot of things in it to handle common needs. Remove anything you don't need in your programs.

I have done a lot of testing, but bug reports and fixes would be welcome.


Properties

ChunkSize As Long [R/W]
EOS As Boolean [RO]
HaveAtLeast(Length As Long) As Boolean [RO]
IsOpen As Boolean [RO]
Position As Long [R/W]
Size As Long [RO]


Methods

CloseBuf()
CurrentBytes() As Byte()
DeleteBytes(Optional ByVal Length As Long = -1)
ExtractBytes(Optional ByVal Length As Long = -1) As Byte()
ExtractInteger() As Integer
ExtractLong() As Long
OpenBuf()
ReadBytes(Optional ByVal Length As Long = -1) As Byte()
ReadInteger() As Integer
ReadLong() As Long
ScanForBytes(ByRef Target() As Byte) As Long
SetEOS()
ShrinkBuf()
WriteBytes(ByRef Bytes() As Byte)
WriteInteger(ByVal Value As Integer)
WriteLong(ByVal Value As Long)


Attachment

The attached archive contains BasicBuffer.cls as well as a testing Project.

It uses character data for easy reading/debugging here (converting to/from Unicode as needed) though BasicBuffers are normally for binary data.

This looks weird but tries to provide a test for correctness of as many operations as possible.


Requirements

No special requirements. You just need VB6. It may also work in Office VBA and VB5 (not tested).

See comments in the code for more help in understanding its use.

Attached Files

• BasicBuffer.zip‎ (6.5 KB)

Email Client Program

February 18, 2013, 11:02 am

≫ Next: Pure VB6 TreeView Control

≪ Previous: VB6 - BasicBuffer, Binary Stream Class

$

0

0

JACMail is an Email Client Program designed to allow fast and efficient recovery of email
from a POP3 server, and the sending of email through an SMTP server. It is primarily oriented
towards text based messaging with attachments, and does not directly support highly formatted
HTML based email or embedded objects. It receives and stores both "text/plain" and "text/html"
messages, and Web based emails can be sent to the default browser for viewing. It also
supports Plain Authentication based SMTP and multiple mailboxes. The mailboxes are stored in
an Access database utilising ODBC.

The code uses IP Version independent system calls, so it will only work on Windows systems
that actively support both IPv4 and IPv6. That more or less restricts it to Windows Vista or
later. It utilises the following standard components and references: RICHED32.DLL, RICHTX32.OCX,
COMDLG32.OCX, MSSTDFMT.DLL, MSBIND.DLL, MSADODC.OCX, MSDATGRD.OCX, which the user
must have available in order to compile the program. WS2_32.DLL is required to run the program.

J.A. Coutts

Attached Images

 

Attached Files

• JACMailD.zip‎ (237.8 KB)

Pure VB6 TreeView Control

February 19, 2013, 10:58 am

≫ Next: How to zip the backup file in folder

≪ Previous: Email Client Program

$

0

0

....or ListView if you set the 'Indentation' Property to zero.... ;-)


Why I created this:
I am developing a treeview control BUT this isn't it!

At this stage, I am just creating the classes that will provide the 'engine' for my final work. However, in the course of doing so, I knocked up a very basic VB6 User Control and a hosting form in order to test them. I do not intend to use this Control myself (I'll be writing a new one that draws the nodes and provides for 'proper' hit-tests etc) so may not develop it further unless I need to add functionality to the classes that I need to test. Therefore there may or may not be updates to this post. However, somebody might find it useful to learn from in its current state...

I'd also appreciate peer code review as I'm a self-taught coder and may be doing some things less efficiently than I could be (or making other glaring mistakes)!

FEATURES:

• full keyboard support

• Drag-And-Drop between nodes

• User-definable node caption colours

• User-definable Background colour or picture

WATCH OUT FOR:

• Barely any error handlers added as yet (cos I want to expose all errors during testing)

• Not extensively commented (since I'm re-writing, re-designing as I go along)

Please do not report errors/crashes with the demo form - it is just a demo. I am however interested in errors raised by the classes and, to a lesser extent, the User Control. I'll repeat; it's really the classes that I am submitting - the rest is just a way of demonstrating/testing them...

Attachment 96669

Attached Files

• Tree.zip‎ (28.8 KB)

---

How to zip the backup file in folder

February 19, 2013, 9:20 pm

≫ Next: VB6 - AllRGB

≪ Previous: Pure VB6 TreeView Control

$

0

0

Dear Expert,

I want to zip the backup file in target folder so how to do it, the code below is for backup the database in the target folder.

Code:

---

Private Sub Form_Load()
con.Close
End Sub

Private Sub cmdBackup_Click()
Set rs = Nothing
Set con = Nothing

If Dir$(App.Path & "\Backup", vbDirectory) = "" Then
    MkDir (App.Path & "\Backup")
End If


Dim MyDateTime As String

MyDateTime = Format(Date, "dd-mm-yyyy")  &  Format(DateTime.Time, "HH mm AMPM")


FileCopy App.Path & "\Test.mdb", App.Path & "\Backup\Test " & MyDateTime  & ".mdb"


MsgBox ("Backup completed")

End Sub

---

VB6 - AllRGB

February 25, 2013, 11:34 am

≫ Next: (VB6) richtextbox loop for read data help..

≪ Previous: How to zip the backup file in folder

$

0

0

This is a program I've been working on to convert a source image(currently it must be 2048x2048 pixels and file type: JPG, GIF, BMP(suggested)) to a 4096x4096(16777216 pixels/colors) AllRGB image. AllRGB means each color is used only once, none missing, none repeating.

Here are some of my very own examples produced with this very program(NOTE: some images may be slightly NSFW). Included is a RAR file with the latest compiled EXE, scanned by jotti.org with 20 out of 20 CLEAN results!

Here is the official AllRGB web page with dozens of more examples(SFW). I believe I have four on there, currently(all earlier works... I have newer submissions pending).

You can download the complete source code here: Attachment 96969

It's really easy to use:

1. Select a Sort By... method from the menu(NOTE: methods denoted with artifact will benefit from Limit Swapping disabled and using higher Depths)
2. Click Prepare Palette menu, enabling the Render menu upon completion(likely no more than 10-20 seconds on a modern PC)
3. Click Render menu, select image file(must be a 2048x2048 bmp, jpg, or gif) BMP suggested

Under the Options menu, Swap Pixels is what's responsible for 'faithfully' colorizing images. Limit Swapping and Depths configure the pixel swapping. Depth is the most critical factor, and you'll have to experiment(to maximize optimal quality/time; in my experiences this is usually around 2-3 minutes) with it for different pictures. I've found good to great results generally start to appear between Depths of 12 to 30, so that's the default. It'll iterate, incrementing the depth by 6, so that's 4 passes; generally, these 4 passes with Limit Swapping enabled take around 5 minutes(aggregate), and 7 to 8 minutes with Limit Swapping disabled. The extra time/passes has ensured a very wide compatibility across numerous test images I've used(colors probably won't be perfect, but they're usually quite good). Time estimates based on my AMD Phenom II @ 3.8 GHz.

Feel free to ask any questions or add any comments you may have.

Source code is licensed under a Creative Commons Attribution-NonCommercial-ShareAlike 3.0 United States License. Have fun, play with the code, and share your changes with us!

Attached Files

• allrgb.zip‎ (28.2 KB)

(VB6) richtextbox loop for read data help..

February 26, 2013, 6:26 pm

≫ Next: VB6 Spell Check using Word

≪ Previous: VB6 - AllRGB

$

0

0

i have some data in richtextbox like this..

00001 abcd 0001 efgh
00002 jklm 0002 nopq
00003 rstu 0003 vwxy
.............................
etc,

and i want it to produce it in this format..

abcd efgh
jklm nopq
rstu vwxy
.............
etc,

to get that i used this
mid(richtextbox.text, 7, 4) & mid(richtextbox.text, 17, 4)

but it only show the first line..
i dont know how to loop the function and the next line will show up too..
please help me.. i'm beginner for using VB6.
*sorry for my english

VB6 Spell Check using Word

February 27, 2013, 7:00 pm

≫ Next: monster packet vb6 codes , various type v1

≪ Previous: (VB6) richtextbox loop for read data help..

$

0

0

I cannot take credit for this routine, as the bulk of it comes courtesy of Microsoft. It utilizes the Spell Checker in Microsoft Word, and contains a couple of interesting techniques that I have not used before. One is the CoAllowSetForegroundWindow call, which enables the COM server process called to take focus away from the client
application. The other is moving the Word window off screen by setting the top of the window to a large negative number. This prevents it from interfering with the client program. I have tested it with Word 9.0 and word 12.0, and I have implemented it as a module for portability.

J.A. Coutts

Code:

---

Attribute VB_Name = "modSpell"
Option Explicit

Declare Function CoAllowSetForegroundWindow Lib "ole32.dll" (ByVal pUnk As Object, ByVal lpvReserved As Long) As Long

Public Function SpellChk() As String
    Dim WordApp As Object
    Dim objDoc As Object 'Word.Document
    Dim lOrigTop As Long
    Dim lErr As Long
    On Error GoTo SpellChkErr
    ' Create a Word document object
    Set WordApp = CreateObject("Word.Application")
    CoAllowSetForegroundWindow WordApp, 0
    Set objDoc = WordApp.Documents.Add
    ' Position Word off screen to avoid having document visible
    lOrigTop = WordApp.Top
    WordApp.WindowState = 0
    WordApp.Top = -3000
    WordApp.Visible = True
    WordApp.Activate
    ' Assign the text to the document and check spelling
    With objDoc
        .Content.Paste
        .Activate
        .CheckSpelling
        ' After the user has made changes, use the clipboard to
        ' transfer the contents back to the text box
        .Content.Copy
        SpellChk = Clipboard.GetText(vbCFText)
        ' Close the document and exit Word
        .Saved = True
        .Close
    End With
    Set objDoc = Nothing
    WordApp.Visible = False
    WordApp.Top = lOrigTop
    WordApp.Quit
    Set WordApp = Nothing
    Exit Function
SpellChkErr:
    lErr = err
    SpellChk = Clipboard.GetText(vbCFText)
    Screen.MousePointer = vbNormal
    Select Case lErr
        Case 91, 429
            MsgBox "MS Word cannot be found!", vbExclamation
        Case Else
            MsgBox "Error: " & err & " - " & Error$(err), vbExclamation, App.ProductName
    End Select
End Function

'Calling routine
Private Sub cmdSpell_Click()
    Clipboard.Clear
    Clipboard.SetText txtMessage.Text
    txtMessage.Text = SpellChk()
End Sub

---

monster packet vb6 codes , various type v1

March 4, 2013, 9:04 am

≫ Next: How To Set More Than 1 Minute To A Timer

≪ Previous: VB6 Spell Check using Word

$

0

0

monster packet source want to share that i found in pc

tried to upload , gone past size limits so cant add attachment

i uploaded to sendspace
http://www.sendspace.com/file/lij39l

em this is must se and have by me + had it very long time and want to share +

i will share mega pack 2 /3/4

also got paid planet source and i will share with u all its my licence so i can share