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

[VB6] Last Seen Feature

February 2, 2018, 1:02 am
$
0
0
Hello Everyone
I am new here, I wish this is the correct place to post in..
I am Hasan M. al-Fahl, known as Eng27 in programming, I have been learning VB6 for 4 years, without courses, without teachers, and I am now good enough to help others..
This is my first post, as you see. and I want to talk about a feature, which shows last seen if other users (if your program is multiuser), Like one in whatsapp :)
I made it and I want some help to make it better:

Private Sub Timer1_Timer()
' This will save last seen for your user
' Dim x, y in General
' Timer1.Interval = 777
x = Format$(Now, "Short Time")
y = Format$(Now. "Short Date")
Open "C:\MyLastSeen.dat" For Output As 1
Write #1, x, y
Close
End Sub
Private Sub Timer2_Timer()
' This will load someone's last seen
' Dim xx, yy, zz in General
' Timer2.Interval = 777
On Error Resume Next
Open "c:\User1.dat" For Input As 1
Input #1, xx, yy
Close
zz = DateDiff ("d", yy, Date)
if zz = 0 Then
Label1.Caption = "Last Seen Today at " & xx
ElseIf zz = = Then
Label1.Caption = "Last Seen Yesterday at " & xx
ElseIf zz > 1 Then
Label1.Caption = "Last Seen at " & xx & " on Date " & yy
End if
End Sub
↧
Search

(VB6) SSTabEx: SSTab replacement. Themed and with new features

February 6, 2018, 3:35 am
$
0
0
This control is a direct replacement of the SSTab control.

Some enhancements are:

  • It supports Windows styles or themes
  • The background color of the tabs can be changed (property TabBackColor)
  • Another Style has been added (along with the two available in the original): it can be also rendered with the TabStrip look alike.
  • Several new events and properties available
  • More control at design time, for example the controls can be moved from one tab to another (that is available in a property page)
  • Since many properties that define the appearance can be customized, the customized values can be saved (from a property page) and restored into another SSTabEx control.
  • It fixes the focus to hidden controls issue that the original SSTab suffers when navigating with the tab key.


Name: SSTabEx1b.JPG Views: 97 Size: 15.5 KB

Name: SSTabEx2.JPG Views: 101 Size: 13.6 KB

One note: if you use the Tab property of the control in code, you'll have to change it to TabSel.
I couldn't use Tab as a property name because it is a VB6 reserved keyword.

It should work in any Windows version from Windows 2000.
(Not tested, just tested on XP SP3).

For documentation, there are two files:

  • _Readme - Notes.txt that is in the root folder, and explains things related to the component development and compiling.
  • And [root folder]/others/Help SSTabEx control.txt that is the control documentation, from the point of view of using the control. The same information is in a property page.
Attached Images
  
Attached Files
↧
↧

Form Min-Max size and Fixed-size

February 8, 2018, 9:13 am
$
0
0
Ok, people seem to like this one (via "ratings"), so I'll post it here. I'm sure there are others, but this one is mine.

Basically, it's two subclassing procedures. The one that sparked interest was the SubclassFormMinMaxSize. However, I also included my SubclassFormFixedSize because it seemed related to me.

Here's the subclass code for both (to be placed in a BAS module). I also included all of my standard subclassing stuff. As a note, to use subclassing my way, be sure to turn on the gbAllowSubclassing variable first thing.

Code:
'
' Notes on subclassing with Comctl32.DLL:
'
'  1.  A subclassed function will get executed even AFTER the IDE "Stop" button is pressed.
'      This gives us an opportunity to un-subclass everything if things are done correctly.
'      Things that will still crash the IDE:
'
'      *  Executing the "END" statement in code.
'      *  Clicking IDE "Stop" on modal form loaded after something else is subclassed.
'      *  Clicking the "End" button after a runtime error on the "End", "Debug", "Help" form.
'
'  2.  "Each subclass is uniquely identified by the address of the pfnSubclass and its uIdSubclass"
'      (quote from Microsoft.com).
'
'  3.  For a particular hWnd, the last procedure subclassed will be the first to execute.
'
'  4.  If we call SetWindowSubclass repeatedly with the same hWnd, same pfnSubclass,
'      same uIdSubclass, and same dwRefData, it does nothing at all.
'      Not even the order of the subclassed functions will change,
'      even if other functions were subclassed later, and then SetWindowSubclass was
'      called again with the same hWnd, pfnSubclass, uIdSubclass, and dwRefData.
'
'  5.  Similar to the above, if we call SetWindowSubclass repeatedly,
'      and nothing changes but the dwRefData, the dwRefData is changed like we want,
'      but the order of execution of the functions still stays the same as it was.
'        "To change reference data you can make subsequent calls to SetWindowSubclass"
'      (quote from Microsoft.com).
'
'  6.  When un-subclassing, we can call RemoveWindowSubclass in any order we like, with no harm.
'
'  7.  We don't have to call DefSubclassProc in a particular subclassed function, but if we don't,
'      all other "downstream" subclassed functions won't execute.
'
'  8.  In the subclassed function, if uMsg = WM_DESTROY we should absolutely call
'      DefSubclassProc so that other possible "downstream" procedures can also un-subclassed.
'
'  9.  Things that are cleared BEFORE the subclass proc is executed again when the
'      IDE "Stop" button is clicked (i.e., before "uMsg = WM_DESTROY"):
'      *  All COM objects are uninstantiated (including Collections).
'      *  All dynamic arrays are erased.
'      *  All static arrays are reset (i.e., set to zero, vbNullString, etc.)
'      *  ALL variables are reset, including local Static variables.
'
'  10. Continuing on the above, even after all that is done, we can still make use of
'      variables, just recognizing that they'll be "fresh" variables.
'
'  11. The dwRefData can be used for whatever we want.  It's stored by Comctl32.DLL and is
'      returned everytime the subclassed procedure is called, or when explicitly requested by
'      a call to GetWindowSubclass.
'
Option Explicit
'
Public gbAllowSubclassing As Boolean    ' Be sure to turn this on if you're going to use subclassing.
'
Private Const WM_DESTROY As Long = &H2&
'
Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function GetWindowSubclass Lib "comctl32.dll" Alias "#411" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, pdwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function NextSubclassProcOnChain Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'
Dim bSetWhenSubclassing_UsedByIdeStop As Boolean ' Never goes false once set by first subclassing, unless IDE Stop button is clicked.
'
Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Dest As Any, ByRef Source As Any, ByVal Bytes As Long)
'
'**************************************************************************************
' The following MODULE level stuff is specific to individual subclassing needs.
'**************************************************************************************
'
Private Enum ExtraDataIDs
    ' These must be unique for each piece of extra data.
    ' They just give us 4 bytes each managed by ComCtl32.
    ID_ForMaxSize = 1
End Enum
#If False Then  ' Intellisense fix.
    Dim ID_ForMaxSize
#End If
'
Public Type POINTAPI
    X As Long
    Y As Long
End Type
Private Type MINMAXINFO
    ptReserved As POINTAPI
    ptMaxSize As POINTAPI
    ptMaxPosition As POINTAPI
    ptMinTrackSize As POINTAPI
    ptMaxTrackSize As POINTAPI
End Type
'

'**************************************************************************************
'**************************************************************************************
'**************************************************************************************
'
' Generic subclassing procedures (used in many of the specific subclassing).
'
'**************************************************************************************
'**************************************************************************************
'**************************************************************************************

Public Function RTrimNull(s As String) As String
    Dim i As Integer
    i = InStr(s, vbNullChar)
    If i Then
        RTrimNull = Left$(s, i - 1)
    Else
        RTrimNull = s
    End If
End Function

Private Sub SubclassSomeWindow(hWnd As Long, AddressOf_ProcToSubclass As Long, Optional dwRefData As Long)
    ' This just always uses hWnd for uIdSubclass, as we never have a need to subclass the same window to the same proc.
    ' The uniqueness is pfnSubclass and uIdSubclass (2nd and 3rd argument below).
    '
    ' This can be called AFTER the initial subclassing to update dwRefData.
    '
    If Not gbAllowSubclassing Then Exit Sub
    '
    bSetWhenSubclassing_UsedByIdeStop = True
    Call SetWindowSubclass(hWnd, AddressOf_ProcToSubclass, hWnd, dwRefData)
End Sub

Private Sub SubclassExtraData(hWnd As Long, dwRefData As Long, ID As ExtraDataIDs)
    ' This is used solely to store extra data.
    '
    If Not gbAllowSubclassing Then Exit Sub
    '
    bSetWhenSubclassing_UsedByIdeStop = True
    Call SetWindowSubclass(hWnd, AddressOf DummyProcForExtraData, ID, dwRefData)
End Sub

Private Function GetSubclassRefData(hWnd As Long, AddressOf_ProcToSubclass As Long) As Long
    ' This one is used only to fetch the optional dwRefData you may have specified when calling SubclassSomeWindow.
    ' Typically this would only be used by the subclassed procedure, but it is available to anyone.
    Call GetWindowSubclass(hWnd, AddressOf_ProcToSubclass, hWnd, GetSubclassRefData)
End Function

Private Function GetExtraData(hWnd As Long, ID As ExtraDataIDs) As Long
    Call GetWindowSubclass(hWnd, AddressOf DummyProcForExtraData, ID, GetExtraData)
End Function

Private Function IsSubclassed(hWnd As Long, AddressOf_ProcToSubclass As Long) As Boolean
    ' This just tells us we're already subclassed.
    Dim dwRefData As Long
    IsSubclassed = GetWindowSubclass(hWnd, AddressOf_ProcToSubclass, hWnd, dwRefData) = 1&
End Function

Private Sub UnSubclassSomeWindow(hWnd As Long, AddressOf_ProcToSubclass As Long)
    ' Only needed if we specifically want to un-subclass before we're closing the form (or control),
    ' otherwise, it's automatically taken care of when the window closes.
    '
    ' Be careful, some subclassing may require additional cleanup that's not done here.
    Call RemoveWindowSubclass(hWnd, AddressOf_ProcToSubclass, hWnd)
End Sub

Private Sub UnSubclassExtraData(hWnd As Long, ID As ExtraDataIDs)
    Call RemoveWindowSubclass(hWnd, AddressOf DummyProcForExtraData, ID)
End Sub

Private Function ProcedureAddress(AddressOf_TheProc As Long)
    ' A private "helper" function for writing the AddressOf_... functions (see above notes).
    ProcedureAddress = AddressOf_TheProc
End Function

Private Function DummyProcForExtraData(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
    ' Just used for SubclassExtraData (and GetExtraData and UnSubclassExtraData).
    If uMsg = WM_DESTROY Then Call RemoveWindowSubclass(hWnd, AddressOf_DummyProc, uIdSubclass)
    DummyProcForExtraData = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
End Function

Private Function AddressOf_DummyProc() As Long
    AddressOf_DummyProc = ProcedureAddress(AddressOf DummyProcForExtraData)
End Function

Private Function IdeStopButtonClicked() As Boolean
    ' The following works because all variables are cleared when the STOP button is clicked,
    ' even though other code may still execute such as Windows calling some of the subclassing procedures below.
    IdeStopButtonClicked = Not bSetWhenSubclassing_UsedByIdeStop
End Function

'**************************************************************************************
'**************************************************************************************
'**************************************************************************************
'
' The following are our functions to be subclassed, along with their AddressOf_... function.
' All of the following should be Private to make sure we don't accidentally call it,
' except for the first procedure that's actually used to initiate the subclassing.
'
'**************************************************************************************
'**************************************************************************************
'**************************************************************************************

Public Sub SubclassFormFixedSize(frm As VB.Form)
    '
    ' This fixes the size of a window, even if it won't fit on a monitor.
    '
    ' On this one, we use dwRefData on the first time through so we can do some setup (see FixedSize_RefData).
    ' We can't use GetWindowRect.  It reports an already resized value.
    '
    ' NOTE: If done in the form LOAD event, the form will NOT have been resized from a smaller monitor.
    '      If done in form ACTIVATE or anywhere else, we're too late, and the form will have been resized.
    '
    ' ALSO: If you're in the IDE, and the monitors aren't big enough, do NOT open the form in design mode.
    '      So long as you don't open it, everything is fine, although you can NOT compile in the IDE.
    '      If you're compiling without large enough monitors, you MUST do a command line compile.
    '
    ' This can simultaneously be used by as many forms as will need it.
    '
    ' NOTICE:  Be sure the window is moved (possibly centered) AFTER this is call, or we may not see WM_GETMINMAXINFO until a bit later.
    '
    SubclassSomeWindow frm.hWnd, AddressOf FixedSize_Proc, FixedSize_RefData(frm)
End Sub

Private Function FixedSize_Proc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
    If uMsg = WM_DESTROY Then
        UnSubclassSomeWindow hWnd, AddressOf_FixedSize_Proc
        FixedSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
        Exit Function
    End If
    If IdeStopButtonClicked Then ' Protect the IDE.  Don't execute any specific stuff if we're stopping.  We may run into COM objects or other variables that no longer exist.
        FixedSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
        Exit Function
    End If
    '
    Dim PelWidth As Long
    Dim PelHeight As Long
    Dim MMI As MINMAXINFO
    Const WM_GETMINMAXINFO As Long = &H24&
    '
    ' And now we force our size to not change.
    If uMsg = WM_GETMINMAXINFO Then
        ' Force the form to stay at initial size.
        PelWidth = dwRefData And &HFFFF&
        PelHeight = (dwRefData And &H7FFF0000) \ &H10000
        '
        CopyMemory MMI, ByVal lParam, LenB(MMI)
        '
        MMI.ptMinTrackSize.X = PelWidth
        MMI.ptMinTrackSize.Y = PelHeight
        MMI.ptMaxTrackSize.X = PelWidth
        MMI.ptMaxTrackSize.Y = PelHeight
        '
        CopyMemory ByVal lParam, MMI, LenB(MMI)
        Exit Function ' If we process the message, we must return 0 and not let more subclassed procedures execute.
    End If
    '
    ' Give control to other procs, if they exist.
    FixedSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
End Function

Private Function FixedSize_RefData(frm As VB.Form) As Long
    ' We must use this to pass the form's initial width and height.
    ' Note that using GetWindowRect absolutely doesn't work.  It reports an already resized value.
    '
    Dim PelWidth As Long
    Dim PelHeight As Long
    '
    PelWidth = frm.Width \ Screen.TwipsPerPixelX
    PelHeight = frm.Height \ Screen.TwipsPerPixelY
    '
    ' Push PelHeight to high two-bytes, and add PelWidth.
    ' This will easily accomodate any monitor in the foreseeable future.
    FixedSize_RefData = (PelHeight * &H10000 + PelWidth)
End Function

Private Function AddressOf_FixedSize_Proc() As Long
    AddressOf_FixedSize_Proc = ProcedureAddress(AddressOf FixedSize_Proc)
End Function

'**************************************************************************************
'**************************************************************************************
'**************************************************************************************

Public Sub SubclassFormMinMaxSize(frm As VB.Form, Optional ByVal MinWidth As Long, Optional ByVal MinHeight As Long, Optional ByVal MaxWidth As Long, Optional ByVal MaxHeight As Long)
    ' It's PIXELS.
    '
    ' MUST be done in Form_Load event so Windows doesn't resize form on small monitors.
    ' Also, move (such as center) the form after calling so that WM_GETMINMAXINFO is fired.
    ' Can be called repeatedly to change MinWidth, MinHeight, MaxWidth, and MaxHeight with no harm done.
    ' Although, all must be supplied that you wish to maintain.
    '
    ' Not supplying an argument (i.e., leaving it zero) will cause it to be ignored.
    '
    ' Some validation before subclassing.
    If MinWidth > MaxWidth And MaxWidth <> 0 Then MaxWidth = MinWidth
    If MinHeight > MaxHeight And MaxHeight <> 0 Then MaxHeight = MinHeight
    '
    SubclassSomeWindow frm.hWnd, AddressOf MinMaxSize_Proc, CLng(MinHeight * &H10000 + MinWidth)
    SubclassExtraData frm.hWnd, CLng(MaxHeight * &H10000 + MaxWidth), ID_ForMaxSize
End Sub

Private Function MinMaxSize_Proc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
    If uMsg = WM_DESTROY Then
        UnSubclassSomeWindow hWnd, AddressOf_MinMaxSize_Proc
        MinMaxSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
        Exit Function
    End If
    If IdeStopButtonClicked Then ' Protect the IDE.  Don't execute any specific stuff if we're stopping.  We may run into COM objects or other variables that no longer exist.
        MinMaxSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
        Exit Function
    End If
    '
    Dim MinWidth As Long
    Dim MinHeight As Long
    Dim MaxWidth As Long
    Dim MaxHeight As Long
    Dim MMI As MINMAXINFO
    Const WM_GETMINMAXINFO As Long = &H24&
    '
    Select Case uMsg
    Case WM_GETMINMAXINFO
        MinWidth = dwRefData And &HFFFF&
        MinHeight = (dwRefData And &H7FFF0000) \ &H10000
        dwRefData = GetExtraData(hWnd, ID_ForMaxSize)
        MaxWidth = dwRefData And &HFFFF&
        MaxHeight = (dwRefData And &H7FFF0000) \ &H10000
        '
        CopyMemory MMI, ByVal lParam, LenB(MMI)
        If MinWidth <> 0 Then MMI.ptMinTrackSize.X = MinWidth
        If MinHeight <> 0 Then MMI.ptMinTrackSize.Y = MinHeight
        If MaxWidth <> 0 Then MMI.ptMaxTrackSize.X = MaxWidth
        If MaxHeight <> 0 Then MMI.ptMaxTrackSize.Y = MaxHeight
        CopyMemory ByVal lParam, MMI, LenB(MMI)
        Exit Function ' If we process the message, we must return 0 and not let more subclass procedures execute.
    End Select
    '
    ' Give control to other procs, if they exist.
    MinMaxSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
End Function

Private Function AddressOf_MinMaxSize_Proc() As Long
    AddressOf_MinMaxSize_Proc = ProcedureAddress(AddressOf MinMaxSize_Proc)
End Function
And here's a patch of code to throw into a Form1 for testing the SubclassFormMinMaxSize piece:

Code:

Option Explicit

Private Sub Form_Load()
    gbAllowSubclassing = True
    SubclassFormMinMaxSize Me, 300, 400, 500, 0
    Me.Top = (Screen.Height - Me.Height) / 2
    Me.Left = (Screen.Width - Me.Width) / 2
End Sub
As a note, there's no need to un-subclass. That's all taken care of in the subclassing procedures.

As another note, that SubclassFormMinMaxSize procedure makes rather unique use of the ComCtl32's subclassing ability to store a bit of extra data. Each subclassing can store 4 bytes. I needed 8, so I created a second "dummy" subclassing for the extra 4 bytes. All of this has the advantage of being attached to a particular subclassing. In other words, this SubclassFormMinMaxSize can simultaneously be executed on as many different forms as you like (all different sizes), and everything will be tracked correctly. This totally obviates the need to keep track of anything in your code.

I'll let you sort out how to use the SubclassFormFixedSize, but it's extremely straightforward. Just call it in Form_Load and a form will stay that size, even if it's bigger than the monitor it's on. If it's bigger than the monitor, you will probably need to work out a way to move it around other than the title-bar, as the title-bar could very well be off the screen. In fact, the exact same situation can come up with the SubclassFormMinMaxSize.

Enjoy,
Elroy

EDIT1: And here's a fairly nice way to drag a form around by other than the title bar. But there are many other approaches to this, but some don't allow you to shove the title bar completely off the screen.
↧

HTA as HTML UI for VB6 code

February 11, 2018, 7:16 pm
$
0
0
This is probably more of a stunt than something there is a need for. But it shows one of the ways that VB6 code can be "behind" an HTML/CSS front end.

The provided stylesheet basically duplicates the look of a plain old VB6 Form. However you could tweak the CSS and add more HTML to have garish colors, gauche behaviors, spinning flaming logos, and popup ads galore.

Name: sshot.png Views: 35 Size: 3.9 KB


Here is UPrinterDemo.hta itself:

Code:
<html>
  <head>
    <hta:application
      id=HTA
      applicationName="UPrinter Demo"
      icon="Resources/UPrinterDemo.ico"
      singleInstance=no
      border=thin
      borderStyle=raised
      sysMenu=yes
      maximizeButton=no
      minimizeButton=no
      contextMenu=no
      showInTaskBar=yes
      scroll=no
      scrollFlat=no
      navigable=no
      selection=no
      windowState=normal
      version=1.0>
    <title>UPrinter Demo</title>
    <link rel=stylesheet href="Resources/UPrinterDemo.css">
    <script language="vbscript">
      Option Explicit

      Private UPrinterDemo

      Private Sub Continue()
        UPrinterDemo.Continue
      End Sub

      Private Sub window_onload()
        'These need to be assigned to match the layout that the
        'stylesheet defines:
        Const WIDTH = 320
        Const HEIGHT = 241
        With window
          .resizeTo WIDTH, HEIGHT
          .moveTo (screen.availWidth - WIDTH ) \ 2, _
                  (screen.availHeight - HEIGHT ) \ 2
        End With
        With CreateObject("Microsoft.Windows.ActCtx")
          .Manifest = "Resources\UPrinterDemo.manifest"
          Set UPrinterDemo = .CreateObject("UPrinterDemo.Demo")
        End With
        With UPrinterDemo
          Set .Document = document
          .Initialize
        End With
      End Sub
    </script>
  </head>
  <body>
    <div    id=Label1>Choose a printer</div>
    <!--    Note: select element with size > 1 means "not a dropdown" -->
    <select  id=lstPrinters size=2></select>
    <button  id=cmdPrint disabled>Print</button>
    <div    id=lblStatus class=StatusBar>Ready</div>
  </body>
</html>
That's pretty much it. All of the heavy lifting happens in UPrinterDemo.dll's Demo class which is clean burning, eco-friendly, high performance, VB6 native machine code!


Name: Packaged.jpg Views: 40 Size: 27.6 KB


Requirements

No megalithic "framework" libraries required. Fully registration-free XCopy deployment.

This is supposed to work as far back as Windows XP, however I am uncertain whether XP SP3 is required and it probably works on XP SP2 but I have doubts about XP SP1 or before.

Only tested on Windows 10 1709.


The required DLLAsm 2.1 utility is included in VB6 source code form so you'll have to compile that first. Please see the ReadMe.txt file.
Attached Images
  
Attached Files
↧

EnumPorts - Find the system's COM and/or LPT ports

February 12, 2018, 11:13 am
$
0
0
The EnumPorts class will find the COM ports, LPT ports, or both. If a new device arrives or leaves the list of devices gets refreshed.

The information you can retrieve is:

  • PortDescription
  • PortName
  • PortNumber
  • PortType


These can be retrieved by index from 1 to Count or by key (PortName, e.g. "COM1:").

Each refresh raises the Refresh event so you can update a menu, etc.


Name: sshot1.png Views: 27 Size: 2.7 KB

Menu populated by demo's Form1


Name: sshot2.png Views: 24 Size: 3.2 KB

Plugged in a USB serial IoT device. Got a Refresh event.
Menu updated to show the current list


Name: sshot3.png Views: 26 Size: 2.0 KB

Menu item clicked on, Form1 printed some of its info


No special requirements, but Windows 2000 or newer is required. Only tested on Windows 10 1709.
Attached Images
   
Attached Files
↧
↧

how can create user control like charachter map for show on form?

February 15, 2018, 10:38 pm
$
0
0
hi i want show font icons like webgings font or other fonts and use in label or textbox or ...
Name: 001.jpg Views: 25 Size: 118.2 KB

but my problem is about limited ascii code from 0 to 255 and i can not use from 0x21 to 0xb325 and sometime icons will be display like unknown.
i did try for chrw$ or like this,but not work yet.

i want create a user control or use label ( transparnet background is matter for me). for show a charachter or charachters on label or textbox or ... .

any body can send a simple user control or code to work ?
Attached Images
 
↧

Vb6 - netmask calculator

February 18, 2018, 6:53 pm
$
0
0
Normally a netmask is used to define a network, but I ran into a problem that required the use of a mask. Let me explain.

For some time now, I have had a problem with excessive DNS queries theoretically originating from Amazon IP ranges. I say theoretical, because the origin of UDP requests can be spoofed. In this case however, I believe them to be real because sometimes a rash of UDP requests will end with TCP requests, and TCP requests are much harder to spoof. There was literally more than a hundred thousand requests per day from hundreds of different servers. All attempts to get Amazon to address the issue have failed.
02/14/2018
Total queries processed - 127900
Queries forwarded to DNS - 14528
Queries dropped by filter - 0
Unsupported Domain Queries - 1396
Unsupported Type Queries - 88820
Duplicate Queries - 23156
These are the stats reported by our firewall, and the bulk of those are from Amazon IP addresses. Of the 14,528 requests forwarded to the DNS for processing, 12,840 were from Amazon. Even with most of the address ranges blocked within the DNS server itself, it was struggling at times to keep up (it is an older multi-use server).

To relieve the pressure on the server, I decided to move the address blocks from the DNS server to the Firewall. That meant redesigning the Firewall software because it was only designed to block individual addresses, and there were hundreds that needed to be blocked. The only feasible approach was to block entire IP ranges, and that's where Netmasks come into the picture.

Unlike the DNS Server, the Firewall does not log individual attempts, so it was imperative that the blocks be accurate. Calculating them by hand was time consuming and error prone, so I wrote a program to do it for me.

For an explanation of how Netmasks work, see:
http://www.yellowhead.com/mask.htm

Our situation is a little more complex. IP ranges do not often get assigned in nice full class ranges. The sample program wants a starting IP number and an ending IP number, and that is how they are generally found in a Whois server. For example:
Amazon Technologies Inc. AT-88-Z (NET-18-144-0-0-1) 18.144.0.0 - 18.144.255.255
But it also reports:
Amazon Technologies Inc. AT-88-Z (NET-18-145-0-0-1) 18.145.0.0 - 18.145.255.255
The input should be 18.144.0.0 - 18.145.255.255 and this yields a Netmask of:
255.254.0.0
11111111.11111110.00000000.00000000
This verifies, but within the same class network we find 18.194.0.0 - 18.197.255.255. Calculating a Netmask for these numbers reveals:
255.248.0.0
11111111.11111000.00000000.00000000
but it does not verify. Why not? Lets look at the starting and ending addresses in binary.
00010010.11000010.00000000.00000000
00010010.11000101.00000000.00000000
The zeros in the Netmask for the 1,2,& 4 bits tells us that 11000110 & 11000111 are permissible, when in fact 198 & 199 are outside the defined range. To accomplish this one, we have to use 2 separate masks.
Address - 18.194.0.0
Netmask - 255.254.0.0
Address - 18.196.0.0
Netmask - 255.254.0.0
These will verify.

Netmasks pretty well have to be contiguous. In other words, no zeros between the ones. If we attempt to define the network 54.144.0.0 - 54.255.255.255, we get:
Netmask - 255.144.0.0
Binary - 11111111.10010000.00000000.00000000
with a warning that it probably will not pass the verify test. And indeed it doesn't. It has to be broken up into smaller blocks.

J.A. Coutts
Attached Images
 
Attached Files
↧

Works well in VB4 show run time error 53 with VB6

February 18, 2018, 6:55 pm
$
0
0
Hi, I'm trying convert an old VB4 program to VB6, and show a running error 53, please see the full code attached.
Thanks

Function OpenFileInputRead(tFileName$) As Integer
OpenFileInputRead = FreeFile
Open tFileName$ For Input Access Read As OpenFileInputRead
End Function
Attached Files
↧
Search

SuperTrim Function for strings

February 23, 2018, 8:27 am
$
0
0
I created the "SuperTrim" function, quoted by Gary Cornell in "Visual Basic 6 from the Ground Up": the function removes excess spaces in a string.
Compared to the example found in the book, I have adapted the class, with the code by Marzo Junior (WordWrap_02 found in VbSpeed of Donald Lessau) obtaining excellent results. Here is the source code. To work requires FastString.tlb (In the Zip folder).
Regards.
Attached Files
↧
↧

VB6 API Viewer Database Editor

February 26, 2018, 7:21 am
$
0
0
Here is a small utility i wrote that allows you to edit the api files that come with the API Viewer 2004.

The APIViewer2004 is a nice upgrade from MS's old api viewer made by Christoph Von Wittich, but both are getting long in the tooth. I still use APIViewer2004 to this day but it hasnt been updated since 2008 (that i know of). Many new api calls, constants, enums, and types have been added to the Win32 API since that time. However, the APIViewer2004 has no ability to edit or add to the existing file databases. I decided to write this small utility to be able to add functions, types, consts, and enums to the existing APIViewer2004 files. So i sat down and reverse-engineered that database format and cobbled together this little utility. It only uses Intrinsic VB controls and could use some help on the GUI design. But as this was intended originally just for my own use so i wasnt that worried about the looks. I thought others might find it useful so i went through, tidied up the code a bit and decided to release it. After figuring out the database format, i think i will come up with a better database format and perhaps a new Add-In unless someone else beats me to it, it is not high on the list of priorities but i may do it sometime.

What this code can help you with:

1. Show how to load and save the api databases
2. Add more API calls to your own api viewer
3. how not to design a GUI

Name: screenshot.jpg Views: 65 Size: 32.3 KB


If any bugs are found, improvements made etc, i would appreciate a heads up! enjoy...
Attached Images
 
Attached Files
↧

Simple Statistics

March 1, 2018, 4:56 pm
$
0
0
I've started a similar CodeBank thread before, but I'm now thinking I went too complex, as there was no interest. Just looking around earlier today, I saw a request under a CodeBank entry by The Trick. I didn't address all the requests in that entry, but I did address some of them. Maybe, if this has some interest, I'll develop some quartile/percentile functions as well as others.

Basically, I've just provided some one-sample statistical functions. I've also made a decision on how to handle missing values. I've struggled with this in VB6. One option is certainly the use of Variant. However, I've never been terribly happy with that option. Therefore, I've decided on sticking with Double arrays for my data, and using the IEEE Double NaN value to denote missing values. This can be seen in the code.

Now, for the uninitiated, NaN values can be a bit tricky. They're somewhat similar to the Null value, but even more restrictive. Once you get a NaN, you can continue to do math with it, but the results will be NaN (similar to Null in Variants). However, you can't do Boolean comparisons with a NaN. In other words, they'll crash if used in an If statement. Therefore, anyone using these functions, needs to develop a practice of checking return values with the IsNan() function. This will keep you out of trouble.

Now, most of what I did today is straight-forward. However, I did dip into calculating a p-value (and confidence intervals), which requires "distributions". I've leaned on the ALGLIB project to derive my PDF (probability distribution function [not portable document format]) and CDF (cumulative distrubution function) values.

The first part doesn't require this though. I've attached a complete project. All is tested, but I didn't really develop much of an interface. If you're interested, focus first on the modSimpleStats module. Here's the part of that module that doesn't use distributions. It's stand-alone:

Code:
Option Explicit
'
Private Declare Sub GetMem1 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any)
Private Declare Sub GetMem2 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any)
Private Declare Sub GetMem4 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any)
Private Declare Sub GetMem8 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any)
Private Declare Function ArrPtr Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
'

' *******************************************
' *******************************************
'
' We start with some "helper" functions.
'
' *******************************************
' *******************************************

Public Function NaN() As Double
    ' Math can be done on these, but nothing changes.
    ' They can NOT be used in "if NaN = NaN Then", or an overflow will result.  Use IsNaN().
    '
    Const bb7 As Byte = &HF8
    Const bb8 As Byte = &HFF
    '
    GetMem1 bb7, ByVal VarPtr(NaN) + 6&
    GetMem1 bb8, ByVal VarPtr(NaN) + 7&
End Function

Public Function IsNaN(d As Double) As Boolean
    ' Infinity also returns TRUE, but we shouldn't be running across infinities.
    '
    Static bb(1 To 8) As Byte
    Const bb7 As Byte = &HF0    ' High 4 bits of byte #7. \
    Const bb8 As Byte = &H7F    ' Low  7 bits of byte #8. /  If all on, it's NaN (or Inf if all other non-sign bits are zero).
    '
    GetMem8 d, bb(1)
    IsNaN = ((bb(7) And bb7) = bb7) And ((bb(8) And bb8) = bb8)
End Function

Public Sub ChangeMissingToNaN(d() As Double, Optional MissingValue As Double = 0&)
    ' This changes the array "in place" to save memory.
    ' Just call:    ChangeMissingToNaN YourArray
    ' Or:          Call ChangeMissingToNaN(YourArray, MissingValue)
    '
    Dim i As Long
    '
    If DblDims(d) <> 1 Then Exit Sub
    For i = LBound(d) To UBound(d)
        If Not IsNaN(d(i)) Then If d(i) = MissingValue Then d(i) = NaN
    Next i
End Sub

Public Function DblDims(dArray() As Double) As Integer
    ' Works on both Static and Dynamic arrays.
    Dim pSA As Long
    '
    GetMem4 ByVal ArrPtr(dArray), pSA
    If pSA <> 0& Then GetMem2 ByVal pSA, DblDims
End Function

' *******************************************
' *******************************************
'
' And now, just some simple statistics.
'
' *******************************************
' *******************************************

Public Function Count(d() As Double) As Long
    ' Returns 0 if not dimensioned.
    ' Skips any NaNs and INFs in the array.
    '
    Dim i As Long
    '
    If DblDims(d) <> 1 Then Exit Function
    For i = LBound(d) To UBound(d)
        If Not IsNaN(d(i)) Then Count = Count + 1&
    Next i
End Function

Public Function Sum(d() As Double) As Double
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim i As Long
    Dim cnt As Long
    '
    If DblDims(d) <> 1 Then Sum = NaN: Exit Function
    For i = LBound(d) To UBound(d)
        If Not IsNaN(d(i)) Then
            cnt = cnt + 1
            Sum = Sum + d(i)
        End If
    Next i
    If cnt = 0& Then Sum = NaN
End Function

Public Function Mean(d() As Double) As Double
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim cnt As Long
    '
    cnt = Count(d)
    If cnt = 0& Then Mean = NaN: Exit Function
    Mean = Sum(d) / cnt
End Function

Public Function SumSq(d() As Double) As Double
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim i As Long
    Dim cnt As Long
    '
    If DblDims(d) <> 1 Then SumSq = NaN: Exit Function
    For i = LBound(d) To UBound(d)
        If Not IsNaN(d(i)) Then
            cnt = cnt + 1
            SumSq = SumSq + d(i) * d(i)
        End If
    Next i
    If cnt <> 0 Then SumSq = NaN
End Function

Public Function SumSqDiff(d() As Double) As Double
    ' This one is the sum-of-squared-differences-from-the-mean.
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim i As Long
    Dim m As Double
    '
    m = Mean(d)
    If IsNaN(m) Then SumSqDiff = NaN: Return
    For i = LBound(d) To UBound(d)
        If Not IsNaN(d(i)) Then
            SumSqDiff = SumSqDiff + (d(i) - m) * (d(i) - m)
        End If
    Next i
End Function

Public Function VariancePop(d() As Double) As Double
    VariancePop = MeanSqPop(d)
End Function

Public Function MeanSqPop(d() As Double) As Double
    ' Mean of squared differences based on POPULATION of numbers.
    ' This is also know as the VARIANCE.
    ' This one is for population (all items counted).
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    Dim cnt As Long
    '
    cnt = Count(d)
    If cnt = 0& Then MeanSqPop = NaN: Exit Function
    MeanSqPop = SumSqDiff(d) / cnt
End Function

Public Function VarianceSamp(d() As Double) As Double
    VarianceSamp = MeanSqSamp(d)
End Function

Public Function MeanSqSamp(d() As Double) As Double
    ' Mean of squared differences based on SAMPLE of numbers.
    ' This is also know as the VARIANCE.
    ' This one is for sample of items (sampled from some population).
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are less than 2 valid numbers, NaN is returned.  Valid N must be > 1 to calculate for SAMPLE.
    '
    Dim cnt As Long
    '
    cnt = Count(d)
    If cnt < 2& Then MeanSqSamp = NaN: Exit Function
    MeanSqSamp = SumSqDiff(d) / (cnt - 1&)
End Function

Public Function StDevPop(d() As Double) As Double
    ' Standard deviation based on POPULATION of numbers.
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are no valid numbers, NaN is returned.
    '
    StDevPop = MeanSqPop(d)
    If IsNaN(StDevPop) Then Exit Function
    StDevPop = Sqr(StDevPop)
End Function

Public Function StDevSamp(d() As Double) As Double
    ' Standard deviation based on SAMPLE of numbers.
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are less than 2 valid numbers, NaN is returned.  Valid N must be > 1 to calculate for SAMPLE.
    '
    StDevSamp = MeanSqSamp(d)
    If IsNaN(StDevSamp) Then Exit Function
    StDevSamp = Sqr(StDevSamp)
End Function

Public Function StErr(d() As Double) As Double
    ' Standard error of the mean (aka, standard error).
    ' This has no population equivalent.
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are less than 2 valid numbers, NaN is returned.  Valid N must be > 1 to calculate.
    '
    StErr = MeanSqSamp(d)
    If IsNaN(StErr) Then Exit Function
    StErr = Sqr(StErr / Count(d))
End Function

Public Function OneSampleStudentT(d() As Double, Optional TestVal As Double = 0&) As Double
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are less than 2 valid numbers, NaN is returned.  Valid N must be > 1 to calculate.
    '
    Dim se As Double
    '
    se = StErr(d)
    If IsNaN(se) Then OneSampleStudentT = NaN: Exit Function
    OneSampleStudentT = (Mean(d) - TestVal) / se
End Function
And here's a continuation of that module, but this part does require distributions:

Code:
' *******************************************
' *******************************************
'
' From here down requires the distributions.
' Most of which were developed from the ALGLIB project.
'
' *******************************************
' *******************************************

Public Function OneSampleTTestPValue(d() As Double, Optional TestVal As Double = 0&, Optional Tails As Long = 2&) As Double
    ' A T-test can be performed either ONE-tailed or TWO-tailed.
    ' This returns the p value, the probability of observing these data if the null hypothesis is true.
    ' If you specify ONE-tailed, you should evaluate the mean, and only consider changes in ONE-DIRECTION from your TestVal as statistically significant.
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are less than 2 valid numbers, NaN is returned.  Valid N must be > 1 to calculate.
    '
    Dim t As Double
    '
    If Tails < 1& Or Tails > 2& Then Error 6
    t = OneSampleStudentT(d, TestVal)
    If IsNaN(t) Then OneSampleTTestPValue = NaN: Exit Function
    OneSampleTTestPValue = (1# - StudentTCdf(t, Count(d) - 1&)) * Tails
End Function

Public Sub OneSampleConfInt(d() As Double, LoValOut As Double, HiValOut As Double, Optional pCrit As Double = 0.05, Optional Tails As Long = 2&)
    ' As with a T-test, confidence intervals can be constructed either ONE-tailed or TWO-tailed.
    ' However, if you specify ONE-tailed, you should either use LoValOut or HiValOut, but not both.
    ' If TWO-tailed is specified, you would use both LoValOut and HiValOut to construct your confidence interval.
    '
    ' pCrit is the equivalent p-value for your confidence intervals.
    ' For instance, for a 95% CI, we'd specify pCrit = .05.
    '              for a 90% CI, we'd specify pCrit = .10.
    ' pCrit must be in the range of 0 < pCrit < .5 for TWO-tailed; and 0 < pCrit < 1 for ONE-Tailed.
    '
    ' Returns NaN if d() isn't dimensioned.
    ' Skips any NaNs and INFs in the array.
    ' If there are less than 2 valid numbers, NaN is returned.  Valid N must be > 1 to calculate.
    '
    Dim cnt As Long
    Dim tCrit As Double
    Dim se As Double
    Dim m As Double
    '
    ' Validations.
    If Tails < 1& Or Tails > 2& Then Error 6
    If pCrit <= 0# Then Error 6
    If pCrit >= 1# Then Error 6
    If Tails = 2& And pCrit >= 0.5 Then Error 6
    '
    cnt = Count(d)
    If cnt < 2& Then LoValOut = NaN: HiValOut = NaN: Exit Sub
    tCrit = StudentTCdfInv(1# - (pCrit / Tails), cnt - 1&)
    se = StErr(d)
    m = Mean(d)
    '
    LoValOut = m - tCrit * se
    HiValOut = m + tCrit * se
End Sub
And, as stated, complete "run-able" project is attached.

Please feel free to make additional requests, and I'll possibly add them.

Take Care,
Elroy
Attached Files
↧

URLEncode in UTF-8 with Visual Basic 6 (Sending Unicode SMS message)

March 3, 2018, 12:04 am
$
0
0
After searching this forum and the internet for a few days and did not get what I am looking for I stumbled upon this and tweaked it a little bit because it had a problem with encoding vbCrLf.

It all started when I tried to add SMS capability to an old VB6 application using ClickaTell service but unfortunately it only uses CURL or JavaScript!
Sending Unicode SMS from VB6 app wasn't possible till I found this and I thought I'd share as it may come handy to others.

Code:
Private Declare Sub CopyToMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Public Function URLEncode_UTF8( _
      ByVal Text As String _
  ) As String
 
  Dim Index1 As Long
  Dim Index2 As Long
  Dim Result As String
  Dim Chars() As Byte
  Dim Char As String
  Dim Byte1 As Byte
  Dim Byte2 As Byte
  Dim UTF16 As Long
 
  For Index1 = 1 To Len(Text)
      CopyToMemory Byte1, ByVal StrPtr(Text) + ((Index1 - 1) * 2), 1
      CopyToMemory Byte2, ByVal StrPtr(Text) + ((Index1 - 1) * 2) + 1, 1
 
      UTF16 = Byte2
      UTF16 = UTF16 * 256 + Byte1
      Chars = GetUTF8FromUTF16(UTF16)
      For Index2 = LBound(Chars) To UBound(Chars)
        Char = Chr(Chars(Index2))
        If Char Like "[0-9A-Za-z]" Then
            Result = Result & Char
        Else
            If Asc(Char) < 16 Then
                Result = Result & "%0" & Hex(Asc(Char))
            Else
                Result = Result & "%" & Hex(Asc(Char))
            End If
        End If
      Next
  Next
 
  URLEncode_UTF8 = Result
 
End Function
 
Private Function GetUTF8FromUTF16( _
      ByVal UTF16 As Long _
  ) As Byte()
 
  Dim Result() As Byte
  If UTF16 < &H80 Then
      ReDim Result(0 To 0)
      Result(0) = UTF16
  ElseIf UTF16 < &H800 Then
      ReDim Result(0 To 1)
      Result(1) = &H80 + (UTF16 And &H3F)
      UTF16 = UTF16 \ &H40
      Result(0) = &HC0 + (UTF16 And &H1F)
  Else
      ReDim Result(0 To 2)
      Result(2) = &H80 + (UTF16 And &H3F)
      UTF16 = UTF16 \ &H40
      Result(1) = &H80 + (UTF16 And &H3F)
      UTF16 = UTF16 \ &H40
      Result(0) = &HE0 + (UTF16 And &HF)
  End If
  GetUTF8FromUTF16 = Result
End Function

VB6 code to use CURL is as follow after adding a reference to Microsoft Internet Controls :

Code:
Inet1.Execute "https://platform.clickatell.com/messages/http/send?apiKey=YourKey&to=MobileNo&content=" & URLEncode_UTF8(YourMessage)
Enjoy!
↧

Round Function

March 9, 2018, 5:29 am
$
0
0
This round function round at 0 to 13 places, and a -1.5 turn to -2 and 1.5 to 2
While upgrading M2000 Interpreter to work with Currency and Decimals, I make this function to work with decimals, currency and doubles. The problem with old code was the automatic convertion of all to double.
To eliminate this problem, i thought to place an expression which the biggest number has to be the type of interest. The most problematic type is the Currency, because it has automatic convertion to double. So here is a Testnow sub to show that. Expression Fix(pos * v3 + v4) / v3 has all members as Currency, and return Double. Expression MyRound = Fix(x) + Fix((x - Fix(x)) * 10 + N) / 10 has members as variants, and constant 10, which is as vb want to be as a value, and the return is Currency.


Code:
Sub testnow()
Dim pos As Currency, v As Variant, v1 As Variant, v3 As Currency, v4 As Currency
v3 = 10
v4 = 0.5
pos = 33123.25
v = Fix(pos * v3 + v4) / v3
Debug.Print Typename(v), v  ' Double  33123.3
v1 = MyRound(pos, 1)
Debug.Print Typename(v1), v1 ' Currency 33123.3
End Sub


Function MyRound(ByVal x, Optional d As Variant = 0#) As Variant
Dim i, N
  i = Abs(Int(d)): If i > 13 Then i = 13
  N = Sgn(x) * 0.5
On Error GoTo there
Select Case i
Case 0
MyRound = Fix(x + N)
Case 1
MyRound = Fix(x) + Fix((x - Fix(x)) * 10 + N) / 10
Case 2
MyRound = Fix(x) + Fix((x - Fix(x)) * 100 + N) / 100
Case 3
MyRound = Fix(x) + Fix((x - Fix(x)) * 1000 + N) / 1000
Case 4
MyRound = Fix(x) + Fix((x - Fix(x)) * 10000 + N) / 10000
Case 5
MyRound = Fix(x) + Fix((x - Fix(x)) * 100000 + N) / 100000
Case 6
MyRound = Fix(x) + Fix((x - Fix(x)) * 1000000 + N) / 1000000
Case 7
MyRound = Fix(x) + Fix((x - Fix(x)) * 10000000 + N) / 10000000
Case 8
MyRound = Fix(x) + Fix((x - Fix(x)) * 100000000 + N) / 100000000
Case 9
MyRound = Fix(x) + Fix((x - Fix(x)) * 1000000000 + N) / 1000000000
Case 10
MyRound = Fix(x) + Fix((x - Fix(x)) * 10000000000# + N) / 10000000000#
Case 11
MyRound = Fix(x) + Fix((x - Fix(x)) * 100000000000# + N) / 100000000000#
Case 12
MyRound = Fix(x) + Fix((x - Fix(x)) * 1000000000000# + N) / 1000000000000#
Case 13
MyRound = Fix(x) + Fix((x - Fix(x)) * 10000000000000# + N) / 10000000000000#
End Select

Exit Function
there:
Err.Clear
MyRound = x

End Function
↧
↧

Copy data from external Listview/Treeview/Listbox/ComboBox/IE Window

March 10, 2018, 3:47 am
$
0
0
This is handy code to have around in case you have to scrape data from an external application for some reason.

Drag the cross hairs over the target window in an external application (or in the demo controls on the main form). You will see the window class name in the title bar to confirm type, then you can clone it. It will also dump it as text to the lower textbox.

The IE window dump can even nab the source for things like the XP add remove programs interface or embedded browser panes like skype advertisements (used to anyway)

Everything is easily accessible from the CWindow class

This pulls in code from various authors:
Jim White, t/as MathImagical Systems,
Dr Memory,
Arkadiy Olovyannikov,
Eduardo A. Morcillo
Attached Files
↧

VB6 - Personal Chat

March 10, 2018, 9:44 pm
$
0
0
PChat is a 2 part program consisting of a server component and a client component. The client component (PChat.vbp) runs as a Desktop Application, whereas the Server component can run as a Service or a Desktop Application.

PChat is short for Personal Chat, as it provides for a single connection between two independent parties. Each client must have a UserID, but the UserID is not password protected and the messages are not encrypted. The Client component utilizes SimpleSock acting either as a listening socket, or as a connecting socket. The Server component utilizes SimpleServer acting as a single listening socket open to as many clients as the user chooses to support. It also utilizes NTSVC.OCX to support operating as a service. The server component is open to anyone, and only serves to allow the two independent parties to connect. Each party logs into the server and stays connected. A Heart Beat signal is periodically sent to the server to maintain the connection. If the server fails to receive the Heart Beat, the user is removed from the Connect list.

The first time the Client program is run, there are enough defaults to allow the program to start, but "Setup" from the menu needs to be run. You will be prompted to enter a UserID of 3 to 10 characters. Any UserID can be used, but if it conflicts with another user, it will have to be changed. Next, you will be asked for a "Server". The server can be a properly registered Domain Name, or an IP address. Although the program is capable of handling IPv6, it is currently only configured for IPv4. Next you will be asked for a "Server Port number". Any port number can be used, but it has to be the same as the server (default is 259). Next you will be asked for an "External Port number". This one is slightly more complex. More on that later. Next you will be asked if you want to activate Spell Check (Yes or No). Both components utilize the Microsoft InkEdit Control 1.0, which provides support for Spell Check and Unicode wide characters. That's it for the Setup.

In order for 2 parties to connect, one of them has to have an open port listening for a connection. Most IPv4 clients are sitting behind a NAT router, and an internal Firewall. Therefore, you must configure your router to either forward the connection request on the External Port number you entered in the "Setup" process, or configure it to use Port Triggering on that Port number. Port Triggering does not require fixed IP addressing, but Port Forwarding does. Fixed IP addressing can be accomplished by configuring your network adapter, or in most modern routers, by using DHCP to provide the same function. You can still use Personal Chat without setting up your router, but you will not be able to initiate the connection. To initiate the connection, you click on the "Get Connected Users" button. This will recover the currently connected users from the server.

Note: The address to connect to is supplied by the server. That is how the External IP address is recovered. As long as the server is operating on a network separate from either client, that address will be the Public IP address of the client. If a client is operating on the same network as the server, the server will only see the Private IP address. If both clients are on the same network as the server, those 2 clients will be able to connect to each other, but neither will be able to connect to an outside client. However, if you choose to provide the server setup with an External IP address, and the requesting client is on the same network as the server, the External IP address will be supplied to the requested client.

Clicking on one of the User Names will send that User Name, your External IP Address, and your External Port number to the server, and open the chat socket in the listening mode. The server will then forward that Address and Port information to the selected user. The selected user will receive this information and display it in several boxes. If PChat is minimized when the request is received, it will be restored to a normal window. Clicking on the green User Name box will attempt to establish a connection with the user at the Address and Port displayed. The Client receiving the connection request is given 5 minutes to respond to the request. At the end of that period, the request is withdrawn and the listening socket closed.

Note: The party listening for the connection must allow that connection through the Firewall. If the Microsoft Firewall is being used, on the first connection attempt you will be asked if you want to allow that connection. Responding to that question may cause the first attempt to time out.

The two sides can then carry on a conversation.

The server component (PChatS.vbp) runs as a Service, and must be accessible from the WAN (Wide Area Network, aka Internet) on a listening port of your choosing (default 259). The service has no visible components and operates with system privileges in Session 0. It comes with a small management program (prjInterface.vbp) to provide the necessary interface between the Service Manager (services.msc) and the service itself. The server component will compile as a Desktop Application as supplied. To compile as a Service, change "frmHidden.Visible" to "False", and the "IsService" flag to "True". I used "PChatS.exe" for the Desktop version, and "PChatSvc.exe" for the Service version. The server component requires "NTSVC.OCX" and a location for the log files. The "Desktop" uses a sub directory of the application directory called "Logs", and the Service uses "\Windows\System32\Logfiles\PChat\".
Attached Images
  
Attached Files
↧
Search

how can use winsock or xml or other way for upload file field+strings.then get json

March 11, 2018, 9:42 pm
$
0
0
hi
i hv a html like this:

Code:
        <form method="POST" action="destionation" enctype="multipart/form-data">
            <label>
                <span>chat_id :</span>
                <input id="field1" type="text" name="chat_id" value="11" />
            </label>
            <label>
                <span>caption :</span>
                <input id="field2" type="text" name="caption"/>
            </label>
            <label>
                <span>photo</span>
                <input id="photo" type="file" name="photo" />
            </label>     
            <label>
                <span>&nbsp;</span>
                <input id="send" type="submit" class="button" value="senddata" />
            </label>   
        </form>
i always use web browser for post these data but i hv problem like : (downlod json dialoge result after posted or i can not get event completed)

now i want use other way to can get result and events too like json reulst after post or event for complete after result retunred.


i hv sample with xml or winsock like this :

Code:
sEntityBody = "----boundary" & vbCrLf
sEntityBody = sEntityBody & "Content-Disposition: form-data; name=fileInputElementName; filename=""" + sFileName + """" & vbCrLf
sEntityBody = sEntityBody & "Content-Transfer-Encoding: base64" & vbCrLf
sEntityBody = sEntityBody & "Content-Type: application/pdf" &  vbCrLf & vbCrLf
sEntityBody = sEntityBody & sPDFBase64 & vbCrLf
sEntityBody = sEntityBody & "-----boundary--" & vbCrLf & vbCrLf

Set xhr = New MSXML2.XMLHTTP30
xhr.setRequestHeader("Content-Type", "multipart/form-data; boundary=-----boundary")
xhr.Open "POST", sUrl, False
xhr.send sEntityBody
but not worked .

any body here can help me to can post both strings and file fields?
↧

Round Colorful Forms

March 14, 2018, 3:14 am
$
0
0
Ok in its raw form this is really quite useless but it contains several interesting parts that can be put to greater use

With this code you can create a round, color changing form that can be moved freely.

Thank you SamOscarBrown for your circle code and Microsoft for helping me get the form movable

you will need a form with a text box and a timer. I named the form frmRound

seeing it work really blew my mind!
PHP Code:
Private Declare Function SendMessage Lib "User32" _
                         Alias "SendMessageA" (ByVal hWnd As Long, _
                                               ByVal wMsg As Long, _
                                               ByVal wParam As Long, _
                                               lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "User32" ()

      Const WM_NCLBUTTONDOWN = &HA1
      Const HTCAPTION = 2

    Option Explicit
    Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function SetWindowRgn Lib "User32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
   

    
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
                                 X As Single, Y As Single)
         Dim lngReturnValue As Long

         If Button = 1 Then
            Call ReleaseCapture
            lngReturnValue = SendMessage(frmRound.hWnd, WM_NCLBUTTONDOWN, _
                                         HTCAPTION, 0&)
         End If
      End Sub

    Private Sub Form_DblClick()
       Unload Me
    End Sub
    Private Sub Form_Load()
        Dim lngRegion As Long
        Dim lngReturn As Long
        Dim lngFormWidth As Long
        Dim lngFormHeight As Long
        Me.Width = Me.Height
        
        lngFormWidth = Me.Width / Screen.TwipsPerPixelX
        lngFormHeight = Me.Height / Screen.TwipsPerPixelY
        lngRegion = CreateEllipticRgn(0, 0, lngFormWidth, lngFormHeight)
        lngReturn = SetWindowRgn(Me.hWnd, lngRegion, True)
Label1.Left = (Me.Width / 2) - (Label1.Width / 2)
Label1.Top = (Me.Height / 2) - (Label1.Height / 2)
    End Sub
    Private Sub Label1_Click()
       Unload frmRound
    End Sub
    Private Sub Timer1_Timer()
  Static iColor As Integer
  Select Case iColor
  Case 0: Me.BackColor = RGB(255, 0, 0)   ' Red
  Case 1: Me.BackColor = RGB(255, 165, 0) ' Orange
  Case 2: Me.BackColor = RGB(255, 255, 0) ' Yellow
  Case 3: Me.BackColor = RGB(0, 128, 0)   ' Green
  Case 4: Me.BackColor = RGB(0, 0, 255)   ' Blue
  Case 5: Me.BackColor = RGB(128, 0, 128) ' Purple
  End Select
  iColor = iColor + 1
  If iColor > 5 Then iColor = 0
End Sub 
↧
↧

IEEE Doubles: NaN, Infinity, etc.

March 14, 2018, 8:20 am
$
0
0
When doing math that may have problems, I've traditionally resorted to Variants and returned a Null or Empty when things didn't go correctly. However, that's never felt totally clean. Lately, I've been relying on the NaN of an IEEE Double (and forgoing any use of Variants).

Basically, to summarize, I can think of five different "states" an IEEE Double may be in:
  • Zero
  • A typical floating point number.
  • A sub-normal floating point number.
  • A NaN
  • Infinity

And, there's also the sign-bit. However, the way IEEE Doubles are specified, the sign-bit is independent of all five of those "states". In other words, we can have -NaN or +NaN, -Inf, or +Inf. We can even have -0 or +0.

Also, just to quickly define them, the sub-normal numbers are numbers very close to zero. With the typical 11-bit exponent, this exponent can range from approximately 10+308 to 10-308. However, with a bit of trickery (i.e., using the mantissa as more exponent, and sacrificing mantissa precision), we can push on the negative exponent side, making it go to approximately 10-324 (the sub-normals). These sub-normal numbers are always very close to zero. I don't do anything special with these sub-normal numbers herein, but I just wanted to be complete.

Also, I list "Zero" separately from "A typical floating point number". This is because Zero is not handled (i.e., binary coded) the same way as other numbers. Zero just has all the bits off (with the possible exception of the sign bit).

Now, NaN is a special value that means "not-a-number". It's what you get when you try to divide 0#/0# (with error trapping turned on so you don't crash). There are also other ways to get it.

Infinity (or just Inf) is another one of these special values. You can get it by dividing any non-zero number by zero, such as 1#/0# (again, with error trapping).

There's a good Wikipedia page about these IEEE Doubles (which is just a Double type in VB6).

It's mostly these NaN and Inf values about which I post this entry. I've begun using them (instead of Variant) to handle special situations, and I thought I'd share. Also, the way I did things, there's no need for error trapping, which should keep things very fast.

Here's the code (possibly best in a BAS module):
Code:

Option Explicit
'
Public Declare Function GetMem2 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
Public Declare Function GetMem4 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
Public Declare Function GetMem8 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
'

Public Function NaN() As Double
    ' Math (add, subtract, multiply, divide) can be done on these, but nothing changes.
    ' They can NOT be used in "if NaN = NaN Then", or an overflow will result.  Use IsNaN().
    ' Also, most math-with-functions (Sin(), Round(), etc) causes overflow error.
    '
    GetMem2 &HFFF8, ByVal PtrAdd(VarPtr(NaN), 6&)
End Function

Public Function Inf() As Double
    GetMem2 &HFFF0, ByVal PtrAdd(VarPtr(Inf), 6&)
End Function

Public Function IsNaN(d As Double) As Boolean
    IsNaN = IsNanOrInf(d) And Not IsInf(d)
End Function

Public Function IsInf(d As Double) As Boolean
    Const ii As Integer = &H7FF0    ' High 4 bits of byte #7 (F0), Low 7 bits of byte #8 (7F). If all on, it's NaN (or Inf if all other non-sign bits are zero).
    Static i(1 To 4) As Integer
    GetMem8 d, i(1)
    IsInf = (i(4) And ii) = ii And i(1) = &H0 And i(2) = &H0 And i(3) = &H0 And (i(4) And &HF) = &H0
End Function

Public Function IsNeg(d As Double) As Boolean
    ' This works even on NaN and Inf.
    Static i(1 To 4) As Integer
    GetMem8 d, i(1)
    IsNeg = i(4) < 0    ' The sign bit will be the same sign bit for i(4).
End Function

Public Function IsNanOrInf(d As Double) As Boolean
    Const ii As Integer = &H7FF0    ' High 4 bits of byte #7 (F0), Low 7 bits of byte #8 (7F). If all on, it's NaN (or Inf if all other non-sign bits are zero).
    Static i(1 To 4) As Integer
    GetMem8 d, i(1)
    IsNanOrInf = (i(4) And ii) = ii
End Function

Public Function PtrAdd(ByVal Pointer As Long, ByVal Offset As Long) As Long
    ' For adding (or subtracting) a small number from a pointer.
    ' Use PtrAddEx for adding (or subtracting) large numbers from a pointer.
    Const SIGN_BIT As Long = &H80000000
    PtrAdd = (Pointer Xor SIGN_BIT) + Offset Xor SIGN_BIT
End Function
Just as an example of one place you may use these ... let's say you want to average a set of numbers. However, there may be cases where there are no numbers to average. What do you return? It's a problem, but returning a NaN can solve it so long as we remember to test for NaN before using it.

The following isn't complete code, but it's an example of where I'm using it. The caller then uses the IsNaN() function:

Code:

Private Function ParamSideAvg(iRow As Long, sSideLetter As String) As Double
    ' Returns NaN if nothing to average.
    Dim n As Double
    Dim iCnt As Long
    Dim iCol As Long
    '
    Select Case sSideLetter
    Case "L": iCol = ColNumberFromLetter("H")  ' This is the MEAN column.  Subtractions are made to get cycle data.
    Case "R": iCol = ColNumberFromLetter("N")  ' This is the MEAN column.  Subtractions are made to get cycle data.
    Case Else:  Exit Function
    End Select
    '
    If Len(Trim$(wsh.Cells(iRow, iCol - 3))) > 0 Then n = n + val(wsh.Cells(iRow, iCol - 3)): iCnt = iCnt + 1
    If Len(Trim$(wsh.Cells(iRow, iCol - 2))) > 0 Then n = n + val(wsh.Cells(iRow, iCol - 2)): iCnt = iCnt + 1
    If Len(Trim$(wsh.Cells(iRow, iCol - 1))) > 0 Then n = n + val(wsh.Cells(iRow, iCol - 1)): iCnt = iCnt + 1
    If iCnt > 0 Then
        ParamSideAvg = n / iCnt
    Else
        ParamSideAvg = NaN
    End If
End Function

Also, I suppose I could have also done all this for IEEE Singles, but I don't currently have the need.

Enjoy,
Elroy
↧

VB6 Select list item

March 18, 2018, 4:54 am
$
0
0
Hi. To begin with let me tell you that I'm using VB6. So here's my question. I have a list and a button, When I click the button it removes the top most entry in the list, how do I get it to select and highlight the next item in the list? By the way I'm new to this.

Thanks in advance.
↧

[vb6] Enhancing VB's StdPicture Object to Support GDI+

March 19, 2018, 10:05 am
$
0
0
This is my second version of the logic first introduced here. That version will no longer be supported.

This version offers so much more:
1. GDI+ can be used for improved scaling for all image formats
2. Better (far more complex) thunk used for managing stdPictures
3. Callbacks can be requested so you can respond to the entire rendering process
4. Can attach GDI+ image attributes (grayscaling/blending) to managed images
5. Can modify GDI+ graphics object during callbacks, i.e., rotation (sample in attached zip)
6. Can cache original image format and retrieve for saving to file
7. Can return embedded image DPI value
8. Written to address backward and future version compatibility
9. Only affects those stdPicture objects that are managed

As with the previous version of this class, many image formats are supported:
- BMP. Those with valid alpha channels can be rendered with transparency. VB-unsupported formats are supported and include: those with v4/v5 bitmap headers and those with JPG/PNG compression
- JPG. CMYK color-space supported via GDI+. Camera-orientation correction supported
- ICO. Alphablended and PNG-encoded icons are supported
- CUR. Same as icons and also color cursors can be returned while in IDE, unlike VB
- WMF/EMF. Not directly managed, no need. Non-placeable WMFs are supported
- PNG. Supported via GDI+, APNG is not
- TIF. Supported via GDI+, multi-page navigation supported
- GIF. Rendering of individual frames (animated GIF) supported via GDI+
- For any other format, if you can convert it to bitmap (alpha channel or not), then supported

The enclosed class offers several methods for managing stdPictures, among those:
- LoadPictureEx creates a new stdPicture object by file, array or handle and supports unicode file names
- LoadResPictureEx is a slightly extended version of VB's LoadResPicture function
- ManageStdPicture manages/un-manages existing stdPicture objects
- CopyStdPicture can copy/create/convert icons and bitmaps with/without alpha channels
- PaintPictureEx is a substitute for VB's PaintPicture based on the stdPicture.Render method
- SetCallBacks enables receiving one or more of the 4 available callbacks
- SetImageAttributesHandle associates user-provided GDI+ attributes with a managed image
- PictureTypeEx can return the actual image format, i.e., PNG, JPG, TIF, etc
- SetFrameGIF/GetGifAnimationInfo applies for animated GIFs when managed
- SetPageTIF applies for muliti-page TIFs when managed
- GetFramePageCount will return count for managed GIF/TIF
- several other methods are available for optional settings

--------------------------------------------------------------------------
The attachments below are the sample project (all in one zip is over 500k & forum rejected it). The 1st three below must be unzipped in same folder. The stdPicEx2 class is a stand-alone class. The rest of the files are to show-off some of its capabilities. The 4th one below is documentation that you may be interested in. It also includes the thunk raw source before I compiled it with NASM.

Project not guaranteed to be compatible with systems lower than XP, but XP/Win2K and above should be supported.

The sample project includes GIF animation, PNG/TIF support, alphablended icon support, JPG camera-orientation correction and more. Just FYI: If the StdPicEx2 class is ever included as its own attachment below, it will be an updated version that may not be in the sample project.

Latest changes...
Found minor bug when owner-drawn style attempted to be unmanaged. Fixed and updated the testProject.zip.
Attached Files
↧
Viewing all 1476 articles
Browse latest View live
Search