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

[VB6] Bi-Color Dot/Dash using drawing methods

$
0
0
Most of us are already aware of the limitations of DrawStyle with the VB6 drawing methods (Line and Circle). The main one being that even a "dot" is more of a "dash" and more importantly that these are really just for "hairline" drawing (DrawWidth = 1).

But I have seen few examples showing how you can draw such dotted/dashed hairlines using two colors instead of a single interrupted ForeColor. Well there is a fairly simple trick that involves using one GDI call along with assigning FontTransparent = False.

Here is some code that draws a bunch of randomly placed and sized bi-colored circles against a contrasting checkerboard background. Getting it all working right is a little tricky because it requires some guessing about the GDI calls that VB6 does under the covers statement by statement:

Code:

Option Explicit

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long

Private Unit As Single

Private Function ColorRGB(ByVal Color As OLE_COLOR) As Long
    ColorRGB = Color
    If Color < 0 Then ColorRGB = GetSysColor(Color And &HFFFF&)
End Function

Private Sub Form_Load()
    Unit = ScaleWidth / 100
    DrawWidth = 1
    DrawStyle = vbDot
    ForeColor = vbBlue
    FillColor = vbYellow
    tmrCircle.Enabled = True
End Sub

Private Sub tmrCircle_Timer()
    Dim CenterX As Single
    Dim CenterY As Single
    Dim Radius As Single
   
    AutoRedraw = True
    'Use our FillColor as a "second ForeColor" for drawing:
    FontTransparent = False
    SetBkColor hDC, ColorRGB(FillColor)
    CenterX = (Int(Rnd() * 50) + 25) * Unit
    CenterY = (Int(Rnd() * 30) + 15) * Unit
    Radius = (Int(Rnd() * 25) + 15) * Unit
    Circle (CenterX, CenterY), Radius
    AutoRedraw = False
End Sub

Name:  sshot.png
Views: 144
Size:  12.5 KB

After letting it run a while

Why might you want to do this? Well the possibilities abound, but I was making use of the new capability starting in Windows 8 of layered child windows to draw and display a "reticle" over preview windows from USB imaging instruments such as microscopes. Here's a snippet of a screen capture from a microscope aimed at a metal ruler:

Name:  sshot snippet.png
Views: 136
Size:  37.2 KB


Requirements

As far as I can tell this is just plain old GDI and works all the way back to Windows 95's original release.

Of course to use it for something like a transparent reticle over a webcam preview you'd need Windows 8 or later.
Attached Images
  
Attached Files

FormatNumber Function for Other VB6

$
0
0
If anyone can improve it, feel free, and please post your improved function this thread.

Code:

Private Function FormatNumber(Expression As String, _
      Optional NumDigitsAfterDecimal As Integer, Optional IncludeLeadingDigit As Boolean, _
      Optional UseParensForNegativeNumbers As Boolean, Optional GroupDigits As Boolean) As String
'NOTE:  Param Expression is defined as Object in VB6
'VB5 Implementation for VB6 equivalent

  Const kPound As String = "#"
  Const kZero As String = "0"
  Const kPeriod As String = "."
  Const kComma As String = ","
 
  Dim blnIsFloat As Boolean
  Dim i As Integer
  Dim iLen As Integer
  Dim iPos As Integer
  Dim strFormat As String
  Dim sLeft As String
  Dim sRight As String

  'Check for Period in Expression
  iPos = InStr(1, Expression, kPeriod)
  If iPos > 0 Then blnIsFloat = True

  If Not blnIsFloat Then
  'Expression is Integer or Long
  'Rare for leading 0 so just use #
      For i = 0 To Len(Expression)
        strFormat = strFormat & kPound
      Next
  End If

  '--------------------------------
  'Leading Zero
  'Use All Zeros instead of # signs
  '--------------------------------
  If IncludeLeadingDigit Then
      If blnIsFloat Then
        For i = 0 To iPos - 1
            strFormat = strFormat & kZero
        Next
      Else
          strFormat = kZero & Right$(strFormat, Len(strFormat) - 1)
      End If
     
  Else
      If blnIsFloat Then
        'No leading Zero so use #
        For i = 0 To iPos - 1
            strFormat = strFormat & kPound
        Next
      End If
  End If
   
  '-------------------------
  'If Float
  '  Append Decimal Formatting
  '------------------------
  If blnIsFloat Then
      'Insert the Period
      strFormat = strFormat & kPeriod
 
      'Add Number Digits After Decimal
      For i = 1 To NumDigitsAfterDecimal
        strFormat = strFormat & kZero
      Next
  End If
   
  '---------------------------------
  'If Parantheses If Negative Number
  '---------------------------------
  If UseParensForNegativeNumbers Then
      If CSng(Expression) < 0 Then
        Expression = Right$(Expression, Len(Expression) - 1)
        strFormat = "(" & strFormat & ")"
      End If
  End If
   
  '--------------
  'Insert Commas
  '--------------
  If GroupDigits Then
  'This can Apply to Integer, Long, and Floats
  'Put commas in Expression For 1000's, etc
  'how many depends on Expression value
      iLen = Len(Expression)
      If blnIsFloat Then
        For i = ((iPos - 1) - 3) To iLen Step 3
          'get left section before insert
          sLeft = Left$(strFormat, i)
         
          'get right section after insert
          sRight = Right$(strFormat, Len(strFormat) - i)
         
          'Construct Format with commas
          strFormat = sLeft & kComma & sRight
        Next
       
      Else
        For i = 4 To iLen Step 3
          'get left section before insert
          sLeft = Left$(strFormat, i)
         
          'get right section after insert
          sRight = Right$(strFormat, Len(strFormat) - i)
         
          'Construct Format with commas
          strFormat = sLeft & kComma & sRight
        Next
       
      End If
 
  End If  'GroupDigits

  'Return the Formatted Number
  FormatNumber = Format(Expression, strFormat)

End Function

VB6 - IPWhois V3

$
0
0
IPWhois is a utility program that can be used to query Whois servers to find out where and to whom an IP address is assigned. Now why would you want to do that? There are some instances when all you have to go on is the IP address. For example, you live in North America and you receive an email from your financial institution requesting some action. Is this a phishing attempt, or is the email genuine? Virtually the only thing that cannot be spoofed on an email is the originating IP address. To determine if the email is legitimate, you can find the originating IP address in the header and do a Whois lookup on it. If the originating IP is assigned to Europe, Asia, or South America, you can be pretty certain that the email is not genuine.

There are many online utilities available that will perform this function (and more), but IPWhois accesses the primary Whois servers directly through TCP port 43. The default is the ARIN server, which offers a Referral Service. IPWhois has an option that allows it to follow that referral to the other primary servers, or even to a private Whois server. At the present time, ARIN does not always offer a referral to whois.afrinic.net.

The current version of IPWhois supports both IPv4 and IPv6 transport. You do not need to use IPv6 transport to query an IPv6 address. You can query it over IPv4. But because IPWhois uses system calls that are IP version independent, it will not run or compile on Windows operating systems that do not support dual stack. This pretty much restricts it to Windows Vista or better.

IPWhois uses the newest version of SimpleSock, which has been updated to permit simple DNS queries. That post will be updated separately.

J.A. Coutts
Attached Images
 
Attached Files

Utility to generate code to create Access databases using DAO, based on a model file

$
0
0
This utility can be used to generate the code to create an Access *.mdb database using DAO, based on a model database file.

If you want to avoid shipping an empty database with your program, then you can create the new database by code.

This utility generates the code based on an existing MDB database file.
It produces the code to create all the tables, Indexes, Fields and Relations (not the particular Access objects like Modules, Queries or Forms).

Also, the Access description of the fields is preserved.

There are two caveats that you may want to know:
1) The UnicodeCompression for Text fields is lost.
2) The visual position of the tables in the Relations design window of Access is lost.

You can use the generated code even if you don't use DAO in your program, but you will need to add the reference to "Microsoft DAO 3.6 Object Library".
Don't worry about the new reference added because it's already installed in all current Windows, so you don't need to add any new file for distribution (as it is also for ADO).
Attached Files

VB6 - Base64 Encoding

$
0
0
Below is a class to encode strings or files in Base64. The data can be sent to the class as an ANSI string, a Unicode string, or a Byte Array. The sample program provided demonstrates the usage.

J.A. Coutts
Code:

Option Explicit

Private Const CBS As String = "CryptBinaryToString"
Private Const CSB As String = "CryptStringToBinary"
Private Const CRYPT_STRING_BASE64 As Long = 1

Private sBase64Buf As String
Private m_bData() As Byte

Private Declare Function CryptBinaryToString Lib "Crypt32.dll" Alias "CryptBinaryToStringW" (ByRef pbBinary As Byte, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As Long, ByRef pcchString As Long) As Long
Private Declare Function CryptStringToBinary Lib "Crypt32.dll" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByRef pcbBinary As Long, ByRef pdwSkip As Long, ByRef pdwFlags As Long) As Long

'================================
'EVENTS
'================================
Public Event Error(ByVal Number As Long, Description As String, ByVal Source As String)

Public Property Get bBuffer() As Byte()
    bBuffer = m_bData
End Property

Public Property Let bBuffer(bNewValue() As Byte)
    m_bData = bNewValue
End Property

Public Property Get Base64Buf() As String
    Base64Buf = sBase64Buf
End Property

Public Property Let Base64Buf(sNewValue As String)
    sBase64Buf = sNewValue
End Property

Public Sub Base64Decode()
    Const Routine As String = "Base64.Base64Decode"
    Const CRYPT_STRING_BASE64 As Long = 1
    Const CRYPT_STRING_NOCRLF As Long = &H40000000
    Dim bTmp() As Byte
    Dim lLen As Long
    Dim dwActualUsed As Long
    'Get output buffer length
    If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, StrPtr(vbNullString), lLen, 0&, dwActualUsed) = 0 Then
        RaiseEvent Error(Err.LastDllError, CSB, Routine)
        GoTo ReleaseHandles
    End If
    'Convert Base64 to binary.
    ReDim bTmp(lLen - 1)
    If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, VarPtr(bTmp(0)), lLen, 0&, dwActualUsed) = 0 Then
        RaiseEvent Error(Err.LastDllError, CSB, Routine)
        GoTo ReleaseHandles
    Else
        m_bData = bTmp
    End If
ReleaseHandles:
End Sub

Public Sub Base64Encode()
    Const Routine As String = "Base64.Base64Encode"
    Dim lLen As Long
    'Determine Base64 output String length required.
    If CryptBinaryToString(m_bData(0), UBound(m_bData) + 1, CRYPT_STRING_BASE64, StrPtr(vbNullString), lLen) = 0 Then
        RaiseEvent Error(Err.LastDllError, CBS, Routine)
        GoTo ReleaseHandles
    End If
    'Convert binary to Base64.
    sBase64Buf = String$(lLen - 1, Chr$(0))
    If CryptBinaryToString(m_bData(0), UBound(m_bData) + 1, CRYPT_STRING_BASE64, StrPtr(sBase64Buf), lLen) = 0 Then
        RaiseEvent Error(Err.LastDllError, CBS, Routine)
        GoTo ReleaseHandles
    End If
ReleaseHandles:
End Sub

Public Property Get sBuffer() As String
    sBuffer = ByteToStr(m_bData)
End Property

Public Property Let sBuffer(sNewValue As String)
    Dim bTmp() As Byte
    bTmp = StrToByte(sNewValue)
    m_bData = bTmp
End Property

Public Property Get uBuffer() As String
    uBuffer = ByteToUni(m_bData)
End Property

Public Property Let uBuffer(sNewValue As String)
    Dim bTmp() As Byte
    bTmp = sNewValue
    uBuffer = bTmp
End Property

Attached Files

VB6 - File Transfer

$
0
0
During the process of upgrading my JACMail program to use SimpleSock, I ran into an issue when transferring large attachments. The program became noticeably faster using SimpleSock, but that speed caused some other issues. So I modified the SimpleSock demonstration program to test file transfers. Where you run into this issue will depend on the system you are using, as well as the other end and the network in between.

Outbound data is placed in a binary buffer, and dished out to Operating System in blocks that it can handle. On my Windows Vista, that block is 8,192 bytes, and on my Win 8.1, that block is 65,536 bytes. From there, the operating system will further break it down into the network packet size (about 1,500 bytes) before sending it out. Binary file transfer is actually simpler than formatted data transfer. Since disk I/O is buffered, as the binary data is received, it is added directly to the file. To retain the texting capabilities of the demonstration program, I used the EncrDataArrival event for file transfer. The data is not encrypted, it is just convenient.

To keep it simple, I sent out the file name in the first block, and the file data in the subsequent blocks. That required a 100 ms delay between blocks to prevent them from being added together. 10 ms worked in one direction, but not the other. Upon completion, there is also a 1 second (1000 ms) delay before issuing the Close Socket command to give the last packet time to reach it's destination.

The same demonstration program is used for both the sender and receiver ends. The receiver end needs a "Downloads" sub-directory off the application directory to store the received files. The port number is entered and the "Listen for File" is clicked to put the receiver in the listen mode. On the sender end, the user selects a file to transfer using the "Get File" button. At this point, the user can optionally Base64 encode the file. If so, a ".B64" extension is added to the file name. Clicking on send establishes a connection with the destination/port, sends the file name, waits 100 ms, and then sends the file data. The receiver receives the file name and creates a file by that name in the "Downloads" directory. The subsequent file data is added to the file as it is received. When the sender closes the socket, the receiver closes the file. If the file is encoded, the received file can be decoded using the "Decode File" button. The result is stored under the original file name.

While building this demonstration program, I discovered a bug in SimpleSock in the binary "DeleteByte" function. How this escaped detection is beyond me, but I suspect that I was only dealing with single block transfers.

This demonstration program has been tested with various binary files up to 1,439,974 bytes. There is no reason that encrypted files could not be transferred as well, but the issue of key transfer has to be solved.

J.A. Coutts
Attached Images
 
Attached Files

[vb6] Unicode Browse For Folder

$
0
0
This is a unicode-compatible "Browse For Folder" dialog implementation. It offers options to customize the dialog beyond simple examples you may have seen. I have moved this to its own thread from the Unicode File Open/Save Dialog thread. It was becoming a bit confusing whether posts were talking about that solution or this solution.

Before I go too far into this, let me link an example from dilettante where CreateObject can be used. If you don't need any special customization, that is a fine solution and very simple to code.

The attached class has lots of methods/properties and nearly all of them are well-commented within the class. Therefore, not going to list them in this thread with few exceptions:

SelectedFolder contains a path/filename and/or PIDL of the item selected by the user.
InitialDirectory will attempt to select that as the folder first displayed/selected by the dialog
PathToPIDL is a convenience function to convert a path to a PIDL
PIDLtoPath is a convenience function to convert a PIDL to a path, if possible
ShowBrowseForFolder is the function that activates the dialog

BrowseForFolderMsgEnum lists common messages that can be sent to dialog via SendMessage
BrowseForFolderCallBackEnum lists common messages received in the dialog callback procedure
BrowseForFolderDialogFlagsEnum lists all the available flags the dialog may support (version limited)

Sample call might look like this:
Code:

Dim cb As UnicodeBrowseFolders
Set cb = New UnicodeBrowseFolders
With cb
    .DialogTitle = "Select Folder To Save Report"
    .Flags = BIF_RETURNONLYFSDIRS Or BIF_NEWDIALOGSTYLE
    .InitialDirectory = "C:\blah\blah\blah\Reports"
End With
If f.ShowBrowseForFolder(Me.hWnd) = True Then
    ' do what you need with the selection
    ' f.SelectedFolder() returns selected path if a non-virtual path selected
    ' f.SelectedFolder(True) returns a PIDL whether virtual path selected or not
End If

A note about selecting 2 or more of the Flags property values. OR them together DO NOT add them together. The following returns different results:
Code:

(BIF_DONTGOBELOWDOMAIN Or BIF_USENEWUI Or BIF_NEWDIALOGSTYLE) = 82
(BIF_DONTGOBELOWDOMAIN + BIF_USENEWUI + BIF_NEWDIALOGSTYLE) = 146 << wrong

Here's an example of asking for events. The class can self-hook the dialog and send events that it receives to your form if you choose. There are three events that can be sent:
1) Initialized. The dialog's hWnd is provided. You are kinda unlimited to what you can do in this event.
2) SelectionChanged. Event sent whenever the dialog folder selection changes
3) CallBackMsg. Catch-all of other events forwarded from the dialog

Just one note. WantEvents property is ignored if you set the CustomHookProc property which means you are hooking the dialog and the class will not.
Code:

' you must declare the dialog using: WithEvents
Private WithEvents FolderBrowser As UnicodeBrowseFolders

' setup your dialog
Private Sub ShowBrowser()
    Set FolderBrowser = New UnicodeBrowseFolders
    With FolderBrowser
        .WantEvents = True
        ... set other properties
    End With
    If FolderBrowser.ShowBrowseForFolder(Me.hWnd) = True Then
        ' handle selected folder
    End If
End Sub


' respond/review events, i.e.,
Private Sub FolderBrowser_CallBackMsg(ByVal hWnd As Long, ByVal Message As Long, ByVal lParam As Long, ByVal UserParam As Long, CloseDialog As Boolean)

End Sub

Private Sub FolderBrowser_Initialized(ByVal hWnd As Long, ByVal UserParam As Long)

End Sub

Private Sub FolderBrowser_SelectionChanged(ByVal hWnd As Long, ByVal pPIDL As Long, ByVal UserParam As Long)

End Sub

Attached Files

[vb6] Block execution until Async method finishes

$
0
0
This is a different approach and has a niche. Won't be a solution in all cases.

If you are calling a function that is asynchronous, but you want to wait until it finishes before the next line of code continues, this may be a workaround for you. This alternative is useful in a GUI environment and may not apply otherwise.

The class provided below enters a modal loop and won't return until a condition is met or the class Abort method is called. This in effect, locks up the calling routine until the loop finishes. It does not prevent re-entrance (like DoEvents doesn't prevent it) unless specified. Do note that if you don't want re-entrance, you need to provide a way out of the loop. That includes giving yourself the ability to call the class Abort method.

Here is the class and I'll include some sample usage afterwards. It only has a few methods. Additionally, each of the 2 Wait methods has an optional parameter array where you can include hWnds that must always be able to receive messages. That list allows you to specify which controls remain active while the modal loop is in effect.

WaitOnObject
Does not release modality until an object's property value changes to a specific value (case-sensitivity applies). If re-entrance is prevented, you must ensure the object's property value can change and you should also ensure you can call the Abort method if needed
WaitUntilAbort
Does not release modality until the class Abort method is called. Same notes above apply here.
Abort
Releases the modal loop and optionally sets a return value for the 2 above methods
IsActive
Simply returns whether the modal loop is active or not
Code:

Option Explicit

Private Declare Function DispatchMessage Lib "user32.dll" Alias "DispatchMessageA" (lpMsg As MSG) As Long
Private Declare Function GetMessage Lib "user32.dll" Alias "GetMessageA" (lpMsg As MSG, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Private Declare Function TranslateMessage Lib "user32.dll" (ByRef lpMsg As MSG) As Long

Private Declare Function SetTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Const WM_TIMER As Long = &H113
Private Const WM_PAINT As Long = &HF&
Private Const WM_PRINT As Long = &H317
Private Const WM_PRINTCLIENT As Long = &H318

Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Type MSG
    hWnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Public Enum ReEntryEnum
    reEntry_NoChildren = 0
    reEntry_None = 1
    reEntry_All = 2
End Enum

Private m_Object As Object
Private m_PropName As String
Private m_PropValue As Variant
Private m_hWndActive As Collection
Private m_Abort As Long

' This function waits on some object's property value to change to a specific value
' if AllowReEntry parameter is other than reEntry_ALL, then
'  if the property is set as a result of a button click or any other action regarding a
'  control, ensure you include that control's hWnd in the ParamArray. If not, that
'  control is also blocked and cannot trigger an event.
Public Function WaitOnObject(ByVal mainHwnd As Long, _
                    triggerObject As Object, _
                    ByVal triggerPropName As String, _
                    triggerPropValue As Variant, _
                    AllowReEntry As ReEntryEnum, _
                    ParamArray UnblockedHWNDs() As Variant) As Long
                   
    ' function returns:
    '  -1 = invalid parameter, 0 = property value set, any other value = Abort called

    If mainHwnd = 0& Then
        WaitOnObject = -1&: Exit Function
    End If
    If (triggerObject Is Nothing) Or (triggerPropName = vbNullString) Then
        WaitOnObject = -1&: Exit Function
    End If
    If triggerObject Is Me Then
        WaitOnObject = -1&: Exit Function
    End If
   
    Dim n As Long
    Set m_Object = triggerObject
    m_PropName = triggerPropName
    m_PropValue = triggerPropValue
    m_Abort = Empty
   
    If UBound(UnblockedHWNDs) > -1& Then
        On Error Resume Next
        Set m_hWndActive = New Collection
        For n = 0& To UBound(UnblockedHWNDs)
            m_hWndActive.Add 0&, CStr(UnblockedHWNDs(n))
        Next
        On Error GoTo 0
    End If
   
    DoModalLoop mainHwnd, AllowReEntry
    If IsEmpty(m_Abort) = False Then WaitOnObject = m_Abort
   
    Set m_Object = Nothing
    m_PropValue = Empty
    m_PropName = vbNullString
    Set m_hWndActive = Nothing

End Function

' This function waits until this class' Abort method is called
' if AllowReEntry parameter is other than reEntry_ALL, then
'  if the Abort method is called as a result of a button click or any other action regarding a
'  control, ensure you include that control's hWnd in the ParamArray. If not, that
'  control is also blocked and cannot trigger an event; therefore, can't call the Abort method.
Public Function WaitUntilAbort(ByVal mainHwnd As Long, AllowReEntry As ReEntryEnum, ParamArray UnblockedHWNDs() As Variant) As Long

    ' function returns:
    '  -1 = invalid parameter, any other value Abort called

    If mainHwnd = 0& Then
        WaitUntilAbort = -1&: Exit Function
    End If
   
    Dim n As Long
    Set m_Object = Me
    If UBound(UnblockedHWNDs) > -1& Then
        On Error Resume Next
        Set m_hWndActive = New Collection
        For n = 0& To UBound(UnblockedHWNDs)
            m_hWndActive.Add 0&, CStr(UnblockedHWNDs(n))
        Next
        On Error GoTo 0
    End If
   
    m_Abort = Empty
    DoModalLoop mainHwnd, AllowReEntry
    If IsEmpty(m_Abort) = False Then WaitUntilAbort = m_Abort
    Set m_Object = Nothing
    Set m_hWndActive = Nothing
   
End Function

Public Sub Abort(Optional ByVal AbortCode As Long = 1&)
    ' releases the modal loop
    ' Optionally set an Abort code to be returned by the Wait[xxx] methods
    '  if set, suggest not using -1 as that is a value to indicate the
    '  Wait[xxx] methods failed due to an invalid parameter
    m_Abort = AbortCode
    Set m_Object = Nothing
End Sub

Public Property Get IsActive() As Boolean
    ' informs you if modal loop is active
    IsActive = Not (m_Object Is Nothing)
End Property

Private Sub DoModalLoop(hWnd As Long, AllowReEntry As ReEntryEnum)

    If SetTimer(hWnd, ObjPtr(Me), 250, 0&) = 0 Then Exit Sub

    ' function freezes current executable line in calling window
    ' until our window loses focus or is closed
    On Error Resume Next
    Dim myMsg As MSG, bEat As Boolean
   
    'SetCapture m_hWnd
    Do While GetMessage(myMsg, 0, 0, 0) > 0 ' Read a message into msg
        If myMsg.message = WM_TIMER Then
            If myMsg.wParam = ObjPtr(Me) Then
                If m_Object Is Nothing Then
                    KillTimer hWnd, ObjPtr(Me)
                    If IsEmpty(m_Abort) Then m_Abort = 1&
                    Exit Do
                ElseIf m_PropName <> vbNullString Then
                    If CallByName(m_Object, m_PropName, VbGet) = m_PropValue Then
                        KillTimer hWnd, ObjPtr(Me)
                        If IsEmpty(m_Abort) Then m_Abort = 1&
                        Exit Do
                    End If
                End If
            End If
        End If
        If AllowReEntry = reEntry_None Then
            bEat = Not (myMsg.hWnd = WM_TIMER)
        ElseIf AllowReEntry = reEntry_NoChildren Then
            If myMsg.hWnd = hWnd Then
                bEat = False
            Else
                Select Case myMsg.message
                Case WM_PAINT, WM_PRINT, WM_PRINTCLIENT, WM_TIMER
                    bEat = False
                Case Else
                    bEat = True
                End Select
            End If
        End If
        If bEat Then
            If Not m_hWndActive Is Nothing Then
                bEat = Not (m_hWndActive.Item(CStr(myMsg.hWnd)) = 0&)
                If Err Then Err.Clear
            End If
        End If
        If bEat = False Then
            TranslateMessage myMsg
            DispatchMessage myMsg
            If Err Then Err.Clear
        End If
    Loop
   
End Sub

There are 3 modality options. These options apply to the mainHwnd parameter passed to the Wait methods.
- reEntry_NoChildren. No controls will be allowed to receive messages
- reEntry_None. Absolutely no messages will be allowed to be received by any window (some exceptions)
- reEntry_All. All messages are allowed to flow through

In the examples, we will use a form-level class. Our class above is named: cWaitOnAsync. We will also assume there is a command button or menu that offers option to exit modal loop.
Code:

Private m_AsyncPauser As cWaitOnAsync
Example 1. We'll say we are calling some DLL function that is asynchronous and we do not want the next line of code to continue until the async method finishes. Of course this means that the async method must have a way (an event) to inform you that it failed or succeeded. In that event, we can simply call the class Abort method
Code:

Private Sub Command1_Click()
    Set m_AsyncPauser = New cWaitOnAsyc
    ' call the async method which has events giving you status of its progress
    ourAsyncObject.DoSomeAsyncCall

    Select Case m_AsyncPauser.WaitUntilAbort(Me.hWnd, reEntry_NoChildren, cmdAbort.hWnd)
    Case -1 ' bad parameter passed above
    Case 0 ' async method finished normally
    Case Else ' cWaitOnAsync.Abort was called
    End Select
    Set m_AsyncPauser = Nothing
End Sub
Private Sub ourAsyncMethodEvent_Finished()
    m_AsyncPauser.Abort 0
End Sub
Private Sub ourAsyncMethodEvent_Failed()
    m_AsyncPauser.Abort 1
End Sub
Private Sub cmdAbort_Click()
    ' user aborting, so call the method of the async object to abort it, then...
    m_AsyncPauser.Abort 1&  ' any non-zero value to indicate aborting vs succeeding
End Sub

Example 2. Let's say the object you are calling an async method from, has a property value that turns True when it is completely finished...
Code:

Private Sub Command1_Click()
    Set m_AsyncPauser = New cWaitOnAsyc
    ' call the async method which has a "State" property that changes to -1 when done
    ourAsyncObject.DoSomeAsyncCall

    ' wait on above call
    Select Case m_AsyncPauser.WaitOnObject(Me.hWnd, ourAsyncObject, "State", -1, _
                                            reEntry_NoChildren, cmdAbort.hWnd)
    Case -1 ' bad parameter passed above
    Case 0 ' async method finished normally
    Case Else ' cWaitOnAsync.Abort was called
    End Select
    Set m_AsyncPauser = Nothing
End Sub
Private Sub cmdAbort_Click()
    ' user aborting, so call the method of the async object to abort it, then...
    m_AsyncPauser.Abort 1&  ' any non-zero value to indicate aborting vs succeeding
End Sub

Example 3. You allow the main window to receive messages. That means someone can close the window before the async method finishes. What to do? Here's one possible scenario:
Code:

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If Not m_AsyncPauser Is Nothing Then
        If m_AsyncPauser.IsActive = True Then
            MsgBox "Application is busy. Cancel current operation and try again", vbInformation + vbOKOnly
            Cancel = True
        End If
    End If
End Sub

Last but not least, if you allow any re-entrance, you need to address that. Just like you would if you were using DoEvents within some loop. While testing, if you did not give yourself the ability to cancel the modal loop, press Ctrl+Break

ColourPicker [vbRichClient]

$
0
0
Replacement/alternative to the CommonDialog colour picker, requires a reference to Olaf's vbRichClient5.dll.

Might have implemented this differently (i.e. fully RC5 widget-ified) but I was in a bit of a hurry. As it stands it's a dll that offers up a form containing a UserControl. Based on a minimalistic version of the same thing posted by Olaf some time ago.

Requested here:

http://www.vbforums.com/showthread.p...83#post5196083



You can use the keys R, G, B, H, L and S to increment the corresponding values or with Shift down to decrement them.

Name:  ColourPicker.jpg
Views: 68
Size:  56.3 KBColour Picker.zip
Attached Images
 
Attached Files

LDB Viewer

$
0
0
I need to add a LDB/LACCDB viewer on a client site, in order to check which are the users connected to an Access DB.
I have implemented such as follow (this code was made 10 years ago)

You call it like this and gives the result in a string (No = Not connected, but information kept in the ldb file. Yes = connected)
In the real project, I manage the string to send a message to the final users to close the application

Code:

? Global_ReadAccessLockFile("D:\VB6\Test.ldb")
THIERRY(69.69.69.69):Admin ->NO
THIERRY(69.69.69.69):Admin ->YES

Code:

' #VBIDEUtils#************************************************************
' * Author          :
' * Web Site        :
' * E-Mail          :
' * Date            : 10/11/2008
' * Module Name      : LDB_Module
' * Module Filename  : ldb.bas
' * Purpose          :
' * Purpose          :
' **********************************************************************
' * Comments        :
' *
' *
' * Example          :
' *
' * See Also        :
' *
' * History          :
' *
' *
' **********************************************************************

Option Explicit

Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, _
  ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, _
  ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, _
  ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
  ByVal hTemplateFile As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Declare Function LockFile Lib "kernel32" (ByVal hFile As Long, ByVal dwFileOffsetLow As Long, _
  ByVal dwFileOffsetHigh As Long, ByVal nNumberOfBytesToLockLow As Long, _
  ByVal nNumberOfBytesToLockHigh As Long) As Long

Private Declare Function UnlockFile Lib "kernel32" (ByVal hFile As Long, ByVal dwFileOffsetLow As Long, _
  ByVal dwFileOffsetHigh As Long, ByVal nNumberOfBytesToUnlockLow As Long, _
  ByVal nNumberOfBytesToUnlockHigh As Long) As Long

Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const START_LOCK = &H10000001      ' *** Start of locks

Private Type HOSTENT
  hName                As Long
  hAliases            As Long
  hAddrType            As Integer
  hLength              As Integer
  hAddrList            As Long
End Type

Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal sHostName As String) As Long
Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Any, ByVal Length As Long)

Public Function Global_ReadAccessLockFile(Optional sFile As String = vbNullString) As String
  ' #VBIDEUtils#***********************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 10/11/2008
  ' * Module Name      : LDB_Module
  ' * Module Filename  : ldb.bas
  ' * Procedure Name  : Global_ReadAccessLockFile
  ' * Purpose          :
  ' * Parameters      :
  ' *                    Optional sFile As String = vbNullString
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_HANDLER

  Dim hFile            As Long
  Dim nReturn          As Long
  Dim nBytesRead      As Long
  Dim sComputer        As String
  Dim sUser            As String
  Dim nUsers          As Long

  Dim sUsersLock      As String

  sUsersLock = vbNullString

  If LenB(sFile) = 0 Then GoTo EXIT_HANDLER

  ' *** Open file in protected mode
  hFile = CreateFile(ByVal sFile, _
      ByVal GENERIC_READ Or GENERIC_WRITE, _
      ByVal FILE_SHARE_READ Or FILE_SHARE_WRITE, _
      ByVal 0&, ByVal OPEN_EXISTING, ByVal 0&, ByVal 0&)

  If hFile <> -1 Then
      Do
        nUsers = nUsers + 1

        ' *** Retrieve the computer name
        sComputer = Space(32)
        nReturn = ReadFile(hFile, ByVal sComputer, 32, nBytesRead, ByVal 0&)
        sComputer = Left$(sComputer, InStr(sComputer, Chr(0)) - 1)
        If (nReturn = 0) Or (nBytesRead = 0) Then Exit Do

        ' *** Retrieve the user name
        sUser = Space(32)
        nReturn = ReadFile(hFile, ByVal sUser, 32, nBytesRead, ByVal 0&)
        sUser = Left$(sUser, InStr(sUser, Chr(0)) - 1)
        If nReturn = 0 Or nBytesRead = 0 Then Exit Do

        ' *** Check if the user is still connected by lock the file, and log with computer name, IP adress and User name
        If LockFile(hFile, START_LOCK + nUsers - 1, 0, 1, 0) = 0 Then
            ' *** An error occured, so it is still locked by the user
            sUsersLock = sUsersLock & sComputer & "(" & Global_IPFromHostName(sComputer) & "):" & sUser & " ->YES" & vbCrLf
        Else
            ' *** Nothing special, the user isn't locking
            sUsersLock = sUsersLock & sComputer & "(" & Global_IPFromHostName(sComputer) & "):" & sUser & " ->NO" & vbCrLf
            Call UnlockFile(hFile, START_LOCK + nUsers - 1, 0, 1, 1)
        End If
      Loop

      CloseHandle hFile
  End If

EXIT_HANDLER:
  On Error Resume Next

  Global_ReadAccessLockFile = sUsersLock

  Exit Function

  ' #VBIDEUtilsERROR#
ERROR_HANDLER:
  Resume EXIT_HANDLER
  Resume

End Function

Public Function Global_IPFromHostName(sHostName As String) As String
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 10/11/2008
  ' * Module Name      : LDB_Module
  ' * Module Filename  : ldb.bas
  ' * Procedure Name  : Global_IPFromHostName
  ' * Purpose          :
  ' * Parameters      :
  ' *                    sHostName As String
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************
  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_HANDLER

  Dim nHostAdress      As Long
  Dim oHost            As HOSTENT
  Dim nHostIP          As Long
  Dim byIPAdress()    As Byte
  Dim nI              As Long
  Dim sIPAdress        As String

  nHostAdress = gethostbyname(sHostName)

  If nHostAdress = 0 Then GoTo EXIT_HANDLER

  CopyMemory oHost, nHostAdress, LenB(oHost)
  CopyMemory nHostIP, oHost.hAddrList, 4

  ReDim byIPAdress(1 To oHost.hLength)
  CopyMemory byIPAdress(1), nHostIP, oHost.hLength

  For nI = 1 To oHost.hLength
      sIPAdress = sIPAdress & byIPAdress(nI) & "."
  Next
  sIPAdress = Mid$(sIPAdress, 1, Len(sIPAdress) - 1)

EXIT_HANDLER:
  On Error Resume Next

  Global_IPFromHostName = sIPAdress

  Exit Function

  ' #VBIDEUtilsERROR#
ERROR_HANDLER:
  Resume EXIT_HANDLER
  Resume

End Function

[VB6] Exclude file types from Open/Save Dialogs ('all except...'): IShellItemFilter

$
0
0

IShellItemFilter Demo

Normally with an Open/Save dialog, you supply filters of a list of file types you want to display. But what if instead of 'only x', you wanted to filter by 'all except x' or similar, excluding only a specific file type? Or even show all files of a particular type, except those that met some other criteria (like created before a certain date)? It's entirely possible to get this level of control using a backend filter supported on the newer IFileDialog, the .SetFilter method with the IShellItemFilter class.

This is a followup to an earlier project that used a similar principle on the SHBrowseForFolder dialog: [VB6] SHBrowseForFolder - Custom filter for shown items: BFFM_IUNKNOWN/IFolderFilter

You can do this on Open/Save (and the new folder picker too) also, using a different but similar interface: IShellItemFilter.

IFileDialog includes a .SetFilter method, this project shows how to create the class for it. It uses a return so has to be swapped out, so the class itself is small:
Code:

Option Explicit

Implements IShellItemFilter
Private mOld4 As Long

Private Sub Class_Initialize()
Dim pVtable As IShellItemFilter
Set pVtable = Me
mOld4 = SwapVtableEntry(ObjPtr(pVtable), 4, AddressOf IncludeItemVB)

End Sub

Private Sub Class_Terminate()
Dim pVtable As IShellItemFilter
Set pVtable = Me
mOld4 = SwapVtableEntry(ObjPtr(pVtable), 4, mOld4)

End Sub

Private Sub IShellItemFilter_IncludeItem(ByVal psi As IShellItem)
End Sub
Private Sub IShellItemFilter_GetEnumFlagsForItem(ByVal psi As IShellItem, pgrfFlags As SHCONTF)
End Sub

The IncludeItem function is what we're interested in. Each item to be displayed is passed to this first by a pointer to its IShellItem, so you can easily decide to exclude/include it based on any criteria you want. In this demo, we exclude if it matches the filter on the form's textbox, but the options are limitless. Note that unlike normal filters, this cannot be overridden by the user typing in their own filter; items hidden by the IncludeItem function will always be hidden. They can still be selected by manually entering their name†, but will never be shown in the list.
Code:

Public Function IncludeItemVB(ByVal this As IShellItemFilter, ByVal psi As IShellItem) As Long
Dim lpName As Long, sName As String
Dim dwAtr As Long

If (psi Is Nothing) = False Then
    psi.GetAttributes SFGAO_FILESYSTEM Or SFGAO_FOLDER, dwAtr
    If ((dwAtr And SFGAO_FILESYSTEM) = SFGAO_FILESYSTEM) And ((dwAtr And SFGAO_FOLDER) = 0) Then 'is in normal file system, is not a folder
        psi.GetDisplayName SIGDN_PARENTRELATIVEPARSING, lpName
        sName = LPWSTRtoStr(lpName)
'        Debug.Print "IShellItemFilter_IncludeItem?" & sName & "|" & gSpec
        If PathMatchSpecW(StrPtr(sName), StrPtr(gSpec)) Then
            IncludeItemVB = S_FALSE 'should not show
        Else
            IncludeItemVB = S_OK 'should show
        End If
    End If
Else
    Debug.Print "IncludeItemVB.NoItem"
End If
End Function

Think of the other possibilities here... instead of the file name, you could exclude by attribute, or by date, or anything you want.

Also note that this overrides the normal 'include' filters that you're used to using, like if instead of all files *.* you had *.exe, then set the exclude filter to *a*.exe, the dialog would show all .exe files except for ones with an 'a' in their name.

Adding the filter to a normal Open call is simple:
Code:

Dim fod As New FileOpenDialog
Set cSIFilter = New cShellItemFilter 'declared as a Public in the module
Dim psi As IShellItem
Dim tFilt() As COMDLG_FILTERSPEC
ReDim tFilt(0)
tFilt(0).pszName = "All Files"
tFilt(0).pszSpec = "*.*"
With fod
    .SetFileTypes UBound(tFilt) + 1, VarPtr(tFilt(0))
    .SetTitle "Browse away"
    .SetOptions FOS_DONTADDTORECENT
    .SetFilter cSIFilter
    .Show Me.hWnd
    .GetResult psi
    If (psi Is Nothing) = False Then
        Dim lp As Long, sRes As String
        psi.GetDisplayName SIGDN_FILESYSPATH, lp
        Label2.Caption = LPWSTRtoStr(lp)
    End If
End With

And that's all there is to it. You can use the .SetFilter method whether it's an Open dialog or Save dialog.

Requirements
-Windows Vista or newer (the new dialogs weren't available in XP)
-oleexp v4.0 or newer (only for the IDE, not needed for compiled exe)


† - If you wanted to refuse to let the user select an excluded file, even manually, you could also do that without closing the dialog by using an events class, and not allowing the dialog to close on the OnFileOk event. See the original IFileDialog project which implements the event sink.
Attached Files

[VB6] VBZeep: An abandoned SOAP Client written in VB6

$
0
0
VBZeep is completely unrelated to the "Zeep: Python SOAP client" which it predates by many, many years.

VBZeep is basically some "abandonware" - code I was developing over 6 years ago but never got around to completely finishing and certainly never got around to cleaning up. Ideally the numerous ZeepXXX classes within it would have been radically cleaned up and then moved into a separate DLL Project.

Rather than just let it continue to molder away in my backup server I thought I might throw it out here for others to take a look at. After all, though it has many small things that are incomplete it does work after a fashion - at least with some kinds of SOAP services.

If nothing else it might help others understand a little more about SOAP and why most people have completely abandoned it in favor for RESTful and REST-like techniques that don't have all of the horrible issues of SOAP.


The VBZeep Project attached contains Zeep itself (those classes) wrapped up in a "testbed" Project with a user interface. This VBZeep testbed has a settings.dat text file that contains its main window size and position as well as a list of some known web services to test against. That list gets loaded into a ComboBox at the top of the Form.

Sample run:

Name:  sshot1.png
Views: 56
Size:  11.6 KB

Name:  sshot2.png
Views: 45
Size:  8.7 KB


Take a look. Have fun. Cringe at the very rough code, and the gymnastics required of an interpretive SOAP client.

One thing not attempted in VBZeep is generation of SOAP Proxy classes to be compiled into VB6 applications. But as far as I can tell few people ever bothered to do that even using the old unsupported Microsoft SOAP Toolkits anyway.

Almost everything needed to create proxy classes after digesting a WSDL is here though. But note that Zeep doesn't handle all of the kinds of WSDL that exist and doesn't handle any of the advanced kinds of SOAP security and authentication.
Attached Images
  
Attached Files

VB6 - SimpleServer Stress Test

$
0
0
I have been fairly satisfied with the performance of SimpleSock, but even though SimpleServer is being used successfully in a couple of server routines, I have not been able to stress test it. I would like to thank dilettante for providing the test routine for MSWinSck. After modifying the routines to use SimpleSock and SimpleServer, the SimpleServer routine failed the test miserably. It ran fine when tested with the default conditions (5 Clients, 100 Sends, same machine), but when I moved the client to a different machine, it failed at 3 Clients. The mode of failure was an incorrect calculation of the record length, which left the server waiting for the rest of the record. The point at which the failure occurred was not consistent, which made it difficult to troubleshoot. This is the relative debug output from one such failure.
-----------------------------------------------
FD_READ 664 = (socket 3)
InBuff 0
OK Bytes obtained from buffer: 5840 (4 x 1460)
Header:
01 01 00 00 00 00 28 57 (10327)
FD_READ 860 (socket 1)
InBuff 5832
OK Bytes obtained from buffer: 8192
Header:
87 88 89 8A 8B 8C 8D 8E
FD_READ 664 = (socket 3)
InBuff 3689
OK Bytes obtained from buffer: 4495
-----------------------------------------------
Socket 3 received 5,840 bytes. This represents 4 packets of 1,460 bytes each. Socket 1 then received 8,192 bytes. This represents the maximum Winsock buffer size this particular machine can handle. But that buffer already contained 5,832 bytes. This is equal to what socket 3 received less the header bytes.

To understand this situation better, I ran a packet sniffer and captured a different failure.
Code:

socket packet
65460 398 - sending 10327 bytes -  1513-61 = 1452 bytes
65460 399 - 1513-53 = 1460 bytes
65460 401 - 1513-53 = 1460 bytes
65460 402 - 1513-53 = 1460 bytes
65460 404 - 1513-53 = 1460 bytes
65460 405 - 1513-53 = 1460 bytes
65460 407 - 1513-53 = 1460 bytes
65460 408 - 168-53 = 115 bytes    Total = 10327 bytes

65461 416 - sending 10327 bytes -  1513-61 = 1452 bytes
65459 417 - sending 10768 bytes -  1513-61 = 1452 bytes
65459 418 - 1513-53 = 1460 bytes
65459 420 - 1513-53 = 1460 bytes
65459 421 - 1513-53 = 1460 bytes
65459 423 - 1513-53 = 1460 bytes
65459 424 - 1513-53 = 1460 bytes
65459 426 - 1513-53 = 1460 bytes
65459 427 - 609-53 = 556 bytes    Total = 10768 bytes
65461 429 - 1513-53 = 1460 bytes
65461 437 - 1513-53 = 1460 bytes
65461 438 - 1513-53 = 1460 bytes
65461 440 - 1513-53 = 1460 bytes
65461 441 - 1513-53 = 1460 bytes
65461 443 - 1513-53 = 1460 bytes
65461 444 - 168-53 = 115 bytes    Total = 10327 bytes

The first transfer (socket 65460) represents a normal transfer (8 packets totaling 10,327 bytes. On the second transfer, socket 65461 received a single packet, and was then interrupted by a transfer to socket 65459. This is what caused the failure, and is a real world scenario. This is because the sending programs are 3 separate applications operating independently.

SimpleServer originally extracted all the bytes received by a socket, and accumulated and analyzed them in the "DataArrival" routine. Any left over bytes were retained, to be included in the next record. This worked well in SimpleSock because it only supported a single socket. Even though there are independent routines for each socket (defined by Index), the variables defined within each routine appear to be common. The solution was to define those variables (RecLen/Type) as an array, and let the local buffer in the class instance (m_bRecvBuffer) accumulate bytes until the entire record is received. This uses a feature that has always existed in SimpleServer that allows you to extract a restricted number of bytes (maxLen). This is used to extract the header, which I used to define the length of the following record. If you decide that the length will include the header, a routine called PeekData was added that allows you to copy the number of bytes needed, but leave them in place.

J.A. Coutts
Attached Files

.HLP file loader

$
0
0
There's some issues when loading Help files in windows 10.

I upgraded from windows 7 to 10, and maybe this is where this problem lies. But I saw all over the same questions on the internet how to fix it.

You can convert it, with a lot of trouble and in the end you're just more frustrated than when you started.

Or you can download winhlp32.exe and open the help files trough it. The problem is, you have to open the exe first, then search for the help file you want to open.

This is what I have done:
I have placed the winhlp32.exe file in my own "Help Loader" folder.
Then I right clicked on any .hlp file and select the "Opened with..."
I set the program to "Always open" with the Help Loader

Just a simple program (with Option Explicit (pun intended)). The form will never been seen anyway, as just after the help file was loaded, the Loader end.

...and Sam, I still love my chr$(34)...:D

Help Loader.zip

The Readme file will give more info where the winhelp32.exe can be downloaded from one of my domains.

Oh. I forgot: No attachments.

So here it is:

Code:

Option Explicit

Private Sub Form_Load()
     
  Dim BlaV As String, aD$, aKa$, xX, MP$, i
     
  If Right$(App.Path, 1) = "\" Then
      MP$ = App.Path
  Else
      MP$ = App.Path + "\"
  End If
 
  If Len(Command) > 4 Then
      If Command = "" Then
        End
      End If
     
      aD$ = Chr$(34)
     
      If Left$(Command, 1) = aD$ Then
        aKa$ = Mid$(Command, 2, Len(Command) - 2)
      Else
        aKa$ = Command
      End If
  Else
      End
  End If
 
  xX = Shell(MP$ + "winhlp32.exe " + aKa$, vbNormalFocus)
 
  End

End Sub


...and forgot again:

Quote:

Winhelp is here and can be downloaded as is, or as a zip file:

http://thezir.com/winhelp/winhlp32.exe
http://thezir.com/winhelp/winhlp32.zip

Paste the winhelp file into the same folder as the help loader. It will not work otherwise, unless of course, if you change the program accordingly.

Coding will be here:

http://thezir.com/winhelp/Help Loader.zip (This file have a normal space between the words. VBForums does not accept it as an URL)
http://thezir.com/winhelp/Help%20Loader.zip (This file have two words splitted by a chr$(255). VBForums accept it as one URL. Funny? No. Just a fact)

Attached Files

VB^ - SimpleServer

$
0
0
CSocket was originally developed by Oleg Gdalevich as a replacement for MSWinSck. Emiliano Scavuzzo improved upon it with CSocketMaster, and I converted it to support IPv6 with cSocket2. With NewSocket, I attempted to streamline the code. SimpleSock is a complete rewrite designed to further simplify and streamline socket code. SimpleServer is designed to allow a single listening socket to support multiple connections without having to resort to using a control array. Like all socket tools, it must be used properly to be effective.

In theory, SimpleServer could be used for all socket access, but for only a few sockets, SimpleSock is simpler and easier to use. Understanding how SimpleServer works will allow you to make better use of it. There are 8 events or call-backs associated with a socket.
1. CloseSck
2. Connect
3. ConnectionRequest
4. DataArrival
5. EncrDataArrival
6. Error
7. SendComplete
8. SendProgress
In SimpleServer, there is another one called WndProc, but it is not used and only provides access to the other events. With one exception (CloseSck), these routines are not called directly. They simply provide information to the calling program.

The calling program Implements SimpleServer. That means that any procedure declared as Public in SimpleServer will be implemented in the calling program, and that includes the 8 routines noted above. When SimpleServer is first implemented, the individual routines have to be activated. This is accomplished by clicking on each one. As you do so, they will go from plain to bold text. Routines that we want to access from the calling program but we do not want to implement, are declared as Friend instead of Public.

When we add an instance of a class with call-backs, we simply define the procedure "WithEvents" and add a new instance. With Implements, we can't do that. So we have to do the following instead:
Code:

Implements SimpleServer
Private mServer() As New SimpleServer

    Dim lNum As Long
    ReDim mServer(MaxClients)
    For lNum = 0 To MaxClients
        Set mServer(lNum).Callback(lNum) = Me
        mServer(lNum).IPvFlg = 4
    Next
    ReDim RecLen(MaxClients)
    ReDim RecType(MaxClients)

Adding the IPvFlg is not strictly necessary, because SimpleServer defaults to IPv4. But it is a good practice to get into. With SimpleServer, the listening socket is always the first instance.
Code:

mServer(0).Listen(PortListen)
If SimpleServer was to be used to make a connection to another host, it would call "mServer(lIndex).TCPConnect Destination, PortConnect". Once the connection is established, SimpleServer would receive an "FD_CONNECT" and fire off a "Connect" message to the calling program. That would leave the calling program ready to start sending data.

When a client attempts to connect, an "FD_ACCEPT" is received by SimpleServer, and it fires off a "ConnectionRequest" message to the calling program. If acceptable, the calling program sends "mServer(lIndex).Accept(requestID, RemotePort, RemoteHostIP)". If it is not acceptable, it sends "mServer(lIndex).Accept(requestID, 0, "")", and SimpleServer interprets the "0" port as invalid.

Data is received by a socket in packets of approximately 1500 bytes. Of this, a maximum of 1460 bytes is actual data. Winsock assembles those packets into blocks of data that vary with the system. Windows Vista has a block size of 8,192 bytes, and Win 8.1 has a block size of 65,536 bytes. Winsock doesn't necessarily use all that space, it is just a maximum. Whatever criteria the OS uses, when it is ready it will send an "FD_READ" message to SimpleServer. For TCP, SimpleServer will add that data to it's own buffer (m_bRecvBuffer) and remove it from the Winsock buffer. It then fires off a "DataArrival"/"EncrDataArrival" message to the calling program along with the number of bytes just received. For UDP, SimpleServer will leave the data in the Winsock buffer, and notify the calling program of the bytes received.

How the calling program handles this information depends on the program itself. SimpleServer will keep adding data to "m_bRecvBuffer" (TCP) until the calling program gives it instructions. In the sample program I have provided, I have used a header to provide more information about the data being sent. It includes a Record Type and Record Length. The Record Length tells the receiving program how much data to expect. Because the data length does not include the header itself, the header is removed from the buffer using the statements "Call mServer(Index).RecoverData(8)" & "RecHeader = mServer(Index).bInBuffer". The (8) is an optional number telling SimpleServer to only remove 8 bytes. If it was left out, SimpleServer would remove all bytes. If the Record Length includes the header, it can be recovered using the "PeekData" command and left in the buffer.

All the data could be removed and analyzed in the "DataArrival"/"EncrDataArrival" routines, but that would mean separate buffers would be required for each connection, and I don't know how to create an array of byte arrays. Instead, we simply allow the data to accumulate in the "m_bRecvBuffer" in each instance of SimpleServer, and remove the desired amount when it is exceeded.

Sending of data is similar. All the data is added to "m_bSendBuffer" regardless of size. When the calling program issues a TCPSend, it enters a loop. SimpleServer copies from "m_bSendBuffer" a maximum of the block size of the Winsock output buffer and forwards it to the Winsock API. If the API is successful in sending the data, it returns the number of bytes sent and they are removed from "m_bSendBuffer". It remains in the loop until all the bytes are sent. Should the API return an error "WSAEWOULDBLOCK", it means that the API is still busy sending the previous block. A message is sent to "SendProgress" with the total bytes sent and the bytes remaining, and the loop exited. When the Winsock output buffer is once again ready to send data, it sends an "FD_WRITE" message to SimpleServer, and SimpleServer calls TCPSend once again. When all the data has been sent, messages are sent to both "SendProgress" and "SendComplete".

All SimpleServer errors (with the exception of "WSAEWOULDBLOCK") are forwarded to the calling program for action. Normally, in a server application errors are logged, so as to prevent holding up the program itself.

That leaves the "CloseSck" event. There are 2 ways of closing the socket. Should the far end close the socket, Winsock will send an "FD_CLOSE" message to SimpleServer. SimpleServer will forward a message to "CloseSck" and change the socket state to "sckClosing". CloseSck will call "mServer(Index).CloseSocket" which will actually close the socket on the server side and change the socket state to "sckClosed". To close the socket from the server end, users should refrain from calling "CloseSocket" directly. This can cause the socket to remain in the "sckClosing" state and become unusable. Always call "CloseSck" in the calling program. As an added note, always include a routine in the "Form_Unload" event to close all sockets. Failure to do so can cause a port to become unusable.

J.A. Coutts
Attached Files

[VB6] Dynamic Resize: Use a slider to change ListView icon/thumbnail size on the fly

$
0
0

One of the features of the Vista and newer Explorer views is the icon size slider; you can do more than just pick between a couple sizes- you can set it to any value in the icon range. Previously to do this in VB was quite a lot of work; you'd have to manually resize each image and rebuild each ImageList since you can't scale up without quality loss... so it's not something that could be rapidly changed without any lag. This project, however, takes advantage of a feature of the new IImageList2 COM interface: it has a .Resize command that can scale down the entire ImageList at once with the speed of Windows API. To avoid quality loss, we load the maximum size images into a primary ImageList, then we dynamically generate the API-made duplicate in the smaller size that the user is looking for, always scaling down instead of up.

Right now this project is focused on standard image file thumbnails; really small images that need to be grey-boxed and standard file icons will be addressed in a future version of this demo.

Here's the key function:
Code:

Private Sub ResizeThumbView(cxNew As Long)
ImageList_Destroy himl
himl = ImageList_Duplicate(himlMax)
HIMAGELIST_QueryInterface himl, IID_IImageList2, pIML
If (pIML Is Nothing) = False Then
    pIML.Resize cxNew, cxNew
End If
himl = ObjPtr(pIML)
bSetIML = True
ListView_SetImageList hLVS, himl, LVSIL_NORMAL
bSetIML = False
ListView1.Refresh
End Sub

While it's certainly possible to forgo the standard HIMAGELIST and entirely use IImageList, I wanted to retain some (hopefully) more familiar territory by using that and the 5.0 VB ListView control. As the API HIMAGELIST_QueryInterface indicates, they're pretty much interchangable anyway, as the ObjPtr returns the same handle as when we made it with ImageList_Create.

Requirements
-Windows Vista or newer
-Common Controls 6.0 Manifest - The demo project has a manifest built into its resource file. Your IDE may have to be manifested to run it from there. If you need to manifest your IDE or a new project, see LaVolpe's Manifest Creator
-oleexp.tlb v4.0 or newer - Only needed in the IDE; not needed once compiled.
-oleexp addon mIID.bas - Included in the oleexp download. Must be added to the demo project the first time you open it.

Scrolling
To make it truly like Explorer, where it sizes while you move the mouse, you can move the code in Slider1_Change over to Slider1_Scroll:
Code:

Private Sub Slider1_Change()
'cxThumb = Slider1.Value
'Label1.Caption = cxThumb & "x" & cxThumb
'ResizeThumbView cxThumb
End Sub

Private Sub Slider1_Scroll()
cxThumb = Slider1.Value
Label1.Caption = cxThumb & "x" & cxThumb
ResizeThumbView cxThumb
End Sub

It works perfectly with the small number of images currently there, but I'm hesitant to trust the stability if there's hundreds or thousands of list items, at least without it being a virtual ListView. I'll take a look at it for future versions; if anyone experiments with it before then let me know! :)
Attached Files

Add a little Pizazz to Your Menus & Toolbar Dropdowns

$
0
0
Here's a project to add Menu Bitmaps and Toolbar Dropdown bitmaps.
I have included a companion project to create menu bitmaps (14x14) from
other graphic file types and icons (24 bit & lower)

Enjoy.


Name:  ScreenShot.JPG
Views: 43
Size:  12.8 KB
Attached Images
 
Attached Files

A small, no fancy checkbox

$
0
0
Someone ask for a simple checkbox with click and value. Nothing professional...
Small and to the point:

Code:

Option Explicit

Const m_def_Value = True
Dim m_Value As Boolean
Event Click()
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event Change()


Public Property Get Value() As Boolean
  Value = m_Value
End Property

Public Property Let Value(ByVal New_Value As Boolean)
  m_Value = New_Value
  PropertyChanged "Value"
  True_or_False
End Property

Private Sub FalseVal_Click()
 
  RaiseEvent Click
  True_or_False

End Sub

Private Sub TrueVal_Click()
 
  RaiseEvent Click
  True_or_False
 
End Sub

Private Sub UserControl_Initialize()

  UserControl.Width = TrueVal.Width
  UserControl.Height = TrueVal.Height
     
  TrueVal.Visible = False

End Sub

Function True_or_False()

  If TrueVal.Visible = False Then
      TrueVal.Visible = True
      FalseVal.Visible = False
      m_Value = False
  Else
      TrueVal.Visible = False
      FalseVal.Visible = True
      m_Value = True
  End If

End Function

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

  m_Value = PropBag.ReadProperty("Value", m_def_Value)
 
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

  Call PropBag.WriteProperty("Value", m_Value, m_def_Value)
 
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub FalseVal_Change()
  RaiseEvent Change
End Sub

Private Sub TrueVal_Change()
  RaiseEvent Change
End Sub

I have two .gif's, created within excel, Paste it into Irfanview, Auto crop, save as .GiF

The pictures can be any size of your choice. One picture have a mark (TrueVal) and the other just an open block(FalseVal).
Place the images to 0,0 No matter which is above or not.

Others can make the code more useful as I'm not experienced in this kind of coding :)

Splitter;- or Separator lines Control

$
0
0
I get tired of making splitter lines for programs, therefore I decided to make a control.

Very basic as it's not really my field of expertise, but something that I can use horizontal as well as vertical. What I mean is this:

Name:  Seperator.png
Views: 30
Size:  2.3 KB

This is what's on the form:
Name:  Image 045.png
Views: 22
Size:  4.5 KB
Name:  Image 046.png
Views: 22
Size:  4.5 KB

The code is:

Code:


'Default Property Values:
Const m_def_DarkColour = &H0&
Const m_def_LightColour = &HC0C0C0
Const m_def_Horizonthal = -1
'Property Variables:
Dim m_DarkColour As OLE_COLOR
Dim m_LightColour As OLE_COLOR
Dim m_Horizonthal As Boolean

Private Sub UserControl_Resize()
 
  If Horizonthal = True Then
      Line1.X1 = 0
      Line1.X2 = UserControl.Width
      Line1.Y1 = 0
      Line1.Y2 = 0
     
      Line2.X1 = 0
      Line2.X2 = UserControl.Width
      Line2.Y1 = 20
      Line2.Y2 = 20
      UserControl.Height = 40
  ElseIf Horizonthal = False Then
      Line1.X1 = 0
      Line1.X2 = 0
      Line1.Y1 = 0
      Line1.Y2 = UserControl.Height
     
      Line2.X1 = 20
      Line2.X2 = 20
      Line2.Y1 = 0
      Line2.Y2 = UserControl.Height
      UserControl.Width = 40
  End If
 
End Sub

Public Property Get Enabled() As Boolean
  Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
  UserControl.Enabled() = New_Enabled
  PropertyChanged "Enabled"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&H00000000&
Public Property Get DarkColour() As OLE_COLOR
  DarkColour = m_DarkColour
End Property

Public Property Let DarkColour(ByVal New_DarkColour As OLE_COLOR)
  m_DarkColour = New_DarkColour
  PropertyChanged "DarkColour"
  Line1.BorderColor = m_DarkColour
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,&H00C0C0C0&
Public Property Get LightColour() As OLE_COLOR
  LightColour = m_LightColour
End Property

Public Property Let LightColour(ByVal New_LightColour As OLE_COLOR)
  m_LightColour = New_LightColour
  PropertyChanged "LightColour"
  Line2.BorderColor = m_LightColour
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0,0,0,-1
Public Property Get Horizonthal() As Boolean
  Horizonthal = m_Horizonthal
End Property

Public Property Let Horizonthal(ByVal New_Horizonthal As Boolean)
  m_Horizonthal = New_Horizonthal
  PropertyChanged "Horizonthal"
End Property

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
  m_DarkColour = m_def_DarkColour
  m_LightColour = m_def_LightColour
  m_Horizonthal = m_def_Horizonthal
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

  UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
  m_DarkColour = PropBag.ReadProperty("DarkColour", m_def_DarkColour)
  m_LightColour = PropBag.ReadProperty("LightColour", m_def_LightColour)
  m_Horizonthal = PropBag.ReadProperty("Horizonthal", m_def_Horizonthal)
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

  Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
  Call PropBag.WriteProperty("DarkColour", m_DarkColour, m_def_DarkColour)
  Call PropBag.WriteProperty("LightColour", m_LightColour, m_def_LightColour)
  Call PropBag.WriteProperty("Horizonthal", m_Horizonthal, m_def_Horizonthal)
End Sub

Attached Images
   

Value Counter User Control

$
0
0
A small value counter:
Name:  Image 047.png
Views: 25
Size:  373 Bytes

What's on the form:
Name:  Image 049.png
Views: 24
Size:  458 Bytes

What is it?
Name:  Image 048.png
Views: 23
Size:  2.9 KB

The coding:
Code:


'Default Property Values:
Const m_def_Value = 0
'Property Variables:
Dim m_Value As Integer
'Event Declarations:
Event DownClick(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=ThisCountDown,ThisCountDown,-1,MouseUp
Event UpClick(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=ThisCountUp,ThisCountUp,-1,MouseUp

Public Property Get Value() As Integer
  Value = m_Value
End Property

Public Property Let Value(ByVal New_Value As Integer)
  m_Value = New_Value
  PropertyChanged "Value"
  CounterLabel.Text = m_Value
End Property

Private Sub UserControl_InitProperties()
  m_Value = m_def_Value
  UserControl.Height = ThisCountUp.Height - 20
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

  m_Value = PropBag.ReadProperty("Value", m_def_Value)
  CounterLabel.BackColor = PropBag.ReadProperty("BackColor", &H80000005)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

  Call PropBag.WriteProperty("Value", m_Value, m_def_Value)
  Call PropBag.WriteProperty("BackColor", CounterLabel.BackColor, &H80000005)
End Sub

Public Property Get BackColor() As OLE_COLOR
  BackColor = CounterLabel.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
  CounterLabel.BackColor() = New_BackColor
  PropertyChanged "BackColor"
End Property

Private Sub ThisCountDown_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  RaiseEvent DownClick(Button, Shift, X, Y)
  CounterLabel.Text = Val(CounterLabel.Text) - 1
  m_Value = Val(CounterLabel.Text)

End Sub

Private Sub ThisCountUp_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  RaiseEvent UpClick(Button, Shift, X, Y)
  CounterLabel.Text = Val(CounterLabel.Text) + 1
  m_Value = Val(CounterLabel.Text)
End Sub

The user can enlarge the textbox size manually or add code to it, as well as forecolor which I did not need.
Attached Images
   
Viewing all 1324 articles
Browse latest View live




Latest Images