[VB6] BTEnum - Enumerate Bluetooth devices

December 23, 2017, 11:06 am

≫ Next: Linear Algebra for 3D Space

≪ Previous: VB6 - User SID/Path

$

0

0

This uses the Microsoft Bluetooth APIs to get a list of remembered and in-range visible Bluetooth devices.

Requires Windows XP SP 2 or later, and a Bluetooth adapter/radio supporting the Microsoft Bluetooth stack.


A search can take a while, so you can specify the timeout. Shorter timeouts might miss some devices.

Demo using the BTEnum class is attached. Sample run:




Only tested on Windows 10 1709.

There were some tricky aspects to getting this working. There might still be flaws and it might not work right on older OSs due to changes in structs over time.

Attached Images

 

Attached Files

• BTEnum Demo.zip (5.8 KB)

---

Linear Algebra for 3D Space

January 3, 2018, 4:01 pm

≫ Next: Migrating RichTextBox (RTB) Control to InkEdit Control

≪ Previous: [VB6] BTEnum - Enumerate Bluetooth devices

$

0

0

I'm not sure who will actually benefit from these procedures, but I suspect a few people will occasionally find them through Google. I've just got quite a bit of work into them, and wanted to share.

Also, for those versed in linear algebra, let me provide a few definitions and some context.

1) Everything follows the right-hand-rule.

2) In the attached module, the concept of a "Segment" is actually just an ordered basis. It's basically four 3D vectors. One defines the origin, one defines the X (forward, East) axis, one defines the Y (left, North) axis, and one defines the Z (up) axis. These three axes are orthonormal (i.e., orthogonal with one unit length). The origin is not built into the three orthonormal axes. In other words, these three axes are setup as if the origin is always <0,0,0>. This makes rotations of these Segments much easier.

3) When using quaternions, they always follow the JPL convention and are unit quaternions (i.e., no built-in scaling).

4) There are some functions that are specific to emulating functions found in the BodyBuilder language by Vicon. These may be a bit unusual for a "pure" mathematician, but they serve my purposes.

5) When converting from Euler angles to quaternions (and vice-versa), many procedures found on the web will only do it in one angle order (typically ZYX). However, the attached procedures will do it in any order of your choosing. The only online reference for this that I could find was an old scanned 1977 NASA document, specifically Appendix A.

6) If you actually start studying this code, note that all the rotations are actually performed using quaternions. In other words, Euler angles aren't used directly for anything other than reporting results.

7) I'm also wondering if there's possibly some graphical API interface that I could be using to do some of this faster. Any ideas on that front are more than welcome. Don't forget though that I'll always need to specify the angle order when moving between Euler angles and quaternions, and not have it pre-defined.

The BAS module was too large to put into a CODE block, so it's attached. However, here's a list of functions.

Code:

---


'
' List of functions herein:
'
'  Make Segment (ordered basis) Functions:
'
'      SegFrom5Pts
'      SegFrom3Pts
'      SegFromLines
'
'  Conversion Functions:
'
'      Euler2Quat
'      Quat2Euler
'      Seg2Quat                ' Abandons origin.
'      Quat2Seg                ' Leaves origin as <0,0,0>.
'      Seg2Euler              ' Abandons origin.
'      Euler2Seg              ' Leaves origin as <0,0,0>
'
'      Rad2Deg
'      Deg2Rad
'      VecRad2Deg
'      VecDeg2Rad
'
'      Axes2Quat              ' Similar to Seg2Quat.
'      Quat2Fwd                ' Forward (x) axis of quat. Same as X axis of segment.
'      Quat2Left              ' Left (y) axis of quat.    Same as Y axis of segment.
'      Quat2Up                ' Up (z) axis of quat.      Same as Z axis of segment.
'      AxisAngle2Quat          ' This is the rotation axis, not any segment axis.
'      QuatAxis                ' This returns the rotation axis.
'      QuatAngle              ' This returns the rotation angle.
'
'  Rotation Functions:
'
'      RotSeg (with axis & angle)
'      RotSegByQuat
'      RotVec (with axis & angle)
'      RotVecByQuat
'      RotQuat (by quat)
'      UnRotQuat (by quat)    ' Same as a QuatBetween function: UnRotQuat(q2, q1).
'
'  Angles Between Functions:
'
'      EulerBetweenSegs        = -<seg1, seg2, order> (BodyBuilder)
'      FixedBetweenSegs        =  <seg1, seg2, order> (BodyBuilder)
'      EulerBetweenQuats
'      (QuatBetweenQuats)      ' Do UnRotQuat(q2, q1).
'
'  Quick Functions:
'
'      XProd
'      DotProd
'
'      VecAvg
'      VecSum
'      VecDif
'      VecAddNum
'      VecDivNum
'      VecMultNum
'      VecMag
'      NegVec
'      UnitVec
'
'      NegQuat
'
'      MakeLine
'      MakeVec
'      MakeQuat
'
'  Trigonometry Functions:
'
'      ACos
'      ASin
'      ATan2
'
'  Debugging Functions:
'
'      AngString
'      PntString
'
'      VecString
'      QuatString
'      SegString
'


---

Enjoy,
Elroy


EDIT1: Just to mention it, when doing Euler2Quat (or Quat2Euler), there are actually twelve possible orders, and I've only covered six of them. The six I've covered are: xyz, xzy, yzx, yxz, zxy, & zyx. There's also a way to get from Euler angles to a quaternion whereby you do the rotation on the first axis, then the second, and then finish up by returning to the first axis. In other words, these rotation orders would be denoted as: xyx, xzx, yxy, yzy, zxz, & zyz. At present, I've got no need for this approach, and they're not currently covered in the attached code.

Attached Files

• LinearAlgebraFor3D.bas (33.4 KB)

Migrating RichTextBox (RTB) Control to InkEdit Control

January 4, 2018, 9:55 am

≫ Next: [VB6] Class to show a standard Explorer-style progress window

≪ Previous: Linear Algebra for 3D Space

$

0

0

The purpose of this thread will be to describe the process of moving existing RTB code to use the InkEdit control.

MSDN states this about the InkEdit control here, so the chances of a successful migration seem good:

Quote:

---

The InkEdit control is a super class of the RichEdit control. Every RichEdit message is passed on, directly in most cases, and has exactly the same effect as in RichEdit. This also applies to event notification messages.

---

Let's hope that's the case!

If you are unfamiliar with the InkEdit control, Dilettante has done a lot of work demonstrate its various improvements over the VB6 RTB control in threads such as these:

http://www.vbforums.com/showthread.p...ows-SpellCheck

---

Event Gotchas

Mouse Events
The Mouse* events in the InkEdit have different signatures than the RTB. Namely, all parameters are passed ByVal instead of ByRef, and last 2 parameters (x and y) are Long instead of Single. You will need to change the RTB events to match the InkEdit event signatures in your source code.

For example:

Code:

---

Private Sub RichTextBox1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

---

Becomes:

Code:

---

Private Sub InkEdit1_MouseMove(ByVal Button As Integer, ByVal ShiftKey As Integer, ByVal xMouse As Long, ByVal yMouse As Long)

---

According to MSDN, InkEdit always passes Pixels via the X & Y parameters. If you have old Mouse* RTB code that always uses Twips, you will need to make the appropriate modifications when migrating the code. See: https://msdn.microsoft.com/en-us/lib...(v=vs.85).aspx

OLE* Events

The OLECompleteDrag, OLEDragDrop, OLEDragOver, OLEGiveFeedback, OLESetData, and OLEStartDrag events all appear to be missing from the InkEdit control, so you'll have to use another method to use OLE features with the control (maybe Fafalone's or Edanmo's OLE TLB(s) or similar?)

---

Property Gotchas

SelStrikeThru

The SelStrikeThru property appears to be missing from the InkEdit control, so another approach will have to be found to replicate the functionality of this property. Solution: Use TOM to get/set the current selection's font StrikeThrough state. e.g.:

Code:

---

  ' Where mo_Tom is a properly initialized TOM reference linked to the InkEdit control
  mo_Tom.TextDocument.Selection.Font.Strikethrough = tomTrue ' or tomFalse

---

RightMargin

The RightMargin property appears to be missing from the InkEdit control, so another approach is necessary. The EM_SETMARGINS and EM_GETMARGINS messages can be used instead (thank LaVolpe!)

Code:

---

' Note that this is quick "air code" - it should work, but I haven't tested it specifically
' Since I use various other HiWord/LoWord/Dword/ScaleMode conversion methods, helper libraries, etc...

Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal _
lParam As Long) As Long

Private Const EM_GETMARGINS As Long = &HD4
Private Const EM_SETMARGINS As Long  = &HD3

Private Const EC_RIGHTMARGIN As Long = &H2

Public Property Get RightMargin() As Long
  RightMargin = SendMessage InkEdit1.Hwnd, EM_GETMARGINS, 0, 0

  RightMargin = (RightMargin / &H10000) And &HFFFF&  ' Get HiWord of Return Value

  RightMargin = RightMargin * Screen.TwipsPerPixelX  ' Convert Pixels to Twips - may need other approach for HighDPI in UserControl
End Property

Public Property Let RightMargin(ByVal p_Twips As Long)
  p_Twips = p_Twips / Screen.TwipsPerPixelX  ' Convert Twips to Pixels
  p_Twips = p_Twips * &H10000  ' Move Pixels to HiWord
 
  SendMessage InkEdit1.Hwnd, EM_SETMARGINS, EC_RIGHTMARGIN, p_Twips
End Property

---

---

Message Gotchas

EM_FORMATRANGE

In my initial tests EM_FORMATRANGE always appears to return -1 instead of the last character index +1 that fit in the bounding box if the FORMATRANGE.hDC parameter is 0. The RTB works OK when FORMATRANGE.hDC = 0. The solution is to pass a valid DC handle to FORMATRANGE.hDC before sending the EM_FORMATRANGE message.

---

Other Gotchas

VSSpell OCX Incompatibility

The CheckWindow method of the old VSSpell spell-checker OCX doesn't work with the InkEdit control (or newer RichEdit window based controls). I've put together a (lightly tested) solution in the following post: http://www.vbforums.com/showthread.p...=1#post5250241

[VB6] Class to show a standard Explorer-style progress window

January 4, 2018, 7:08 pm

≫ Next: VB6 Icon Maker

≪ Previous: Migrating RichTextBox (RTB) Control to InkEdit Control

$

0

0

cProgressWindow

Windows provides a simple interface that allows you to use an asychronous Explorer-style progress dialog with just a few lines of code. So I thought I'd wrap up this functionality in a class to make it a bit easier to use, especially with automating checking for cancel, raising an event for it, and closing the dialog.

It's all pretty self-explanatory... the class comes with a demo project that shows usage of the most basic options, and the class itself implements all the functionality (except setting an animation, because that's only supported in XP).

Requirements
Windows XP or newer
oleexp.tlb, any version (or olelib)

Future Work
If you're working with files, you may want the more detailed progress window that you get with IFileOperation and Explorer in Windows 7... you can manually control such a progress dialog in a manner similar to this one with another interface supported by the same ProgressDialog object, IOperationsProgressDialog. You can then use it like this or as the custom dialog from IFileOperation.SetProgressDialog.
I'll be putting up a demo of using that interface in a few days, but if you wanted to experiment in the mean time, all the definitions are already in oleexp (but this one isn't XP compatible and not present in olelib), and you can create an instance of it via

Code:

---

Dim cProg As IOperationsProgressDialog
Set cProg = New ProgressDialog

---

Note that with this version, your first call must be .StartProgressDialog, or you get a 'catastrophic error' message. Also always use .SetMode, or the dialog might just flash at the end of the operation instead of show throughout.

---

Attached Files

• cProgWindow.zip (3.4 KB)

VB6 Icon Maker

January 11, 2018, 10:22 pm

≫ Next: Memory Blt

≪ Previous: [VB6] Class to show a standard Explorer-style progress window

$

0

0

I was having difficulty finding appropriate Icons that could be added to VB6 programs, and using online Icon tools was a real pain. So I found an older Bmp2Icon program code, but it was overly complex, difficult to use, and contained a lot of unused code (4 forms, 4 modules, 2 Classes, and 2 User Controls). Attached is my attempt at a much simplified version.

The sample shown below used 3DLRSIGN.WMF from the VB6 graphics collection, changed the aspect ratio to make it square, changed the background from white to red, shrunk it to the size of a 32 x 32 icon, and saved it in Icon format. It was then used as the Icon for the program.

I have very little graphic experience, and I expect that the code could be simplified further. Even though I changed the background to red, the Icon showed up with a translucent background, and when I viewed the Icon with Paint, it showed up as a red dollar sign with a white background (?????).

J.A. Coutts

Attached Images

  

Attached Files

• IconVB.zip (5.8 KB)

Memory Blt

January 14, 2018, 12:32 am

≫ Next: [vb6]Common Dialog Class (Yet Another One)

≪ Previous: VB6 Icon Maker

$

0

0

In order to copy graphics, you typically use BitBlt which works on DCs containing Bitmap objects. But the problem with that is that you have to keep track of all your DCs and Bitmaps (and dispose of them when done, to prevent memory leaks), and color conversions can happen behind the scenes. For example, if I use LoadImage API on an older machine with 8bit graphics, it will automaticlally convert any bitmap (even a 32bit bitmap file) into either an 8bit bitmap, or a 32bit bitmap who's color values correspond to the colors of the default 8bit system palette. This causes significant loss in color depth, so any images saved after that, will be permanently lowered in color depth, and look very ugly.

So I need to avoid using the Windows APIs altogether for loading 32bit bitmaps (only using the API functions to display bitmaps to the screen after any processing is done) if I want my program to be compatible on nearly all computers (both new and very old). I will need to write my own code for loading the image data from 32bit BMP files into RGBQuad arrays. But then when I do that, I have the other problem of losing all of the API functions like BitBlt that work with bitmaps and DCs. Those don't work with arrays. So that is why I have written my own Memory Blt functions. These copy images (or parts of images) from one RGBQuad array to another. I have 2 such functions. Below is the code for these, that you can put in any VB6 Module.

Code:

---

Public Declare Sub CopyBytes Lib "msvbvm60.dll" Alias "__vbaCopyBytes" (ByVal ByteCount As Long, ByRef Dest As Any, ByRef Src As Any)

Public Type RGBQuad
    B As Byte
    G As Byte
    R As Byte
    unused As Byte
End Type

Public Sub MemBlt( _
    ByVal Width As Long, _
    ByVal Height As Long, _
    ByVal SrcX As Long, _
    ByVal SrcY As Long, _
    ByVal DestX As Long, _
    ByVal DestY As Long, _
    ByRef Src() As RGBQuad, _
    ByRef Dest() As RGBQuad)
   
    Dim UBXSrc As Long
    Dim UBYSrc As Long
    Dim UBXDest As Long
    Dim UBYDest As Long
    Dim y As Long
    Dim y1 As Long
    Dim y2 As Long
    Dim ByteWidth As Long
   
    UBXSrc = UBound(Src, 1)
    UBYSrc = UBound(Src, 2)
    UBXDest = UBound(Dest, 1)
    UBYDest = UBound(Dest, 2)
   
    If SrcX < 0 Then
        Width = Width + SrcX
        SrcX = 0
    ElseIf SrcX > UBXSrc Then
        Exit Sub
    End If
    If SrcX + Width - 1 < 0 Then
        Exit Sub
    ElseIf SrcX + Width - 1 > UBXSrc Then
        Width = (UBXSrc - SrcX) + 1
    End If
    If SrcY < 0 Then
        Height = Height + SrcY
        SrcY = 0
    ElseIf SrcY > UBYSrc Then
        Exit Sub
    End If
    If SrcY + Height - 1 < 0 Then
        Exit Sub
    ElseIf SrcY + Height - 1 > UBYSrc Then
        Height = (UBYSrc - SrcY) + 1
    End If
   
    If DestX < 0 Then
        Width = Width + DestX
        DestX = 0
    ElseIf DestX > UBXDest Then
        Exit Sub
    End If
    If DestX + Width - 1 < 0 Then
        Exit Sub
    ElseIf DestX + Width - 1 > UBXDest Then
        Width = (UBXDest - DestX) + 1
    End If
    If DestY < 0 Then
        Height = Height + DestY
        DestY = 0
    ElseIf DestY > UBYDest Then
        Exit Sub
    End If
    If DestY + Height - 1 < 0 Then
        Exit Sub
    ElseIf DestY + Height - 1 > UBYDest Then
        Height = (UBYDest - DestY) + 1
    End If
   
    ByteWidth = Width * 4
   
    For y = 0 To Height - 1
        y1 = SrcY + y
        y2 = DestY + y
        CopyBytes ByteWidth, Dest(DestX, y2), Src(SrcX, y1)
    Next y
End Sub


Public Sub MemBlt2( _
    ByVal Width As Long, _
    ByVal Height As Long, _
    ByVal SrcX As Long, _
    ByVal SrcY As Long, _
    ByVal DestX As Long, _
    ByVal DestY As Long, _
    ByRef Src() As RGBQuad, _
    ByRef Dest() As RGBQuad)
    Dim temppix() As RGBQuad
    ReDim temppix(Width - 1, Height - 1)
    MemBlt Width, Height, SrcX, SrcY, 0, 0, Src(), temppix()
    MemBlt Width, Height, 0, 0, DestX, DestY, temppix(), Dest()
End Sub

---

The two Memory Blt subs are MemBlt and MemBlt2.

MemBlt does all required bounds checking, and changes as necessary the size of the copied region so that it fits within both of the RGBQuad arrays. If the copied region is completely outside of either the source or the destination, then it exits immediately. It uses __vbaCopyBytes instead of RtlMoveMemory (aka CopyMemory), because __vbaCopyBytes is faster (no memory region overlap compensating), and also because the overlap compensating done by RtlMoveMemory only works in a 1D memory region. It fails to prevent the problems produced by overlap of source and destination when working in a 2D memory region. So why slow it down when the slower function isn't even effective in the situation it's being used in?

Of course the overlap problem does need a solution. While MemBlt is fine for use as-is when the source array and destination array are different, or when they are the same but the regions are different (and in fact MemBlt is better in these cases, because it's faster), there is still the problem of what to do when the source and destination arrays are the same and the regions overlap. To fix that, I created MemBlt2. It creates a temporary RGBQuad array, and performs 2 calls to MemBlt. First call to MemBlt copies a region from the source array to the temporary array, and the second call to MemBlt copies from the temporary array to the destination array. This is slower, but effective at preventing the problems that can occur when the source and destination arrays are the same, and source and destination regions overlap. This is the 2D equivalent to RtlMoveMemory.

[vb6]Common Dialog Class (Yet Another One)

January 21, 2018, 3:55 pm

≫ Next: VB6 - Port Tester

≪ Previous: Memory Blt

$

0

0

This class combines the Windows XP/Win2000 Open/Save dialog that uses APIs to generate the dialog with the IFileDialog interface used in Vista and higher. Basically, the class is a unicode-friendly dialog option as a drop-in, self-contained class. Do note that the class has been hard-coded to not run on any O/S less than XP/Win2000.

Though the class makes heavy use of calling to interfaces not known to VB, it does not use type libraries (TLBs). However, I have made every effort to make it compatible to TLBs you may be using in your project. In other words, objects returned by this class through its events or functions should be 100% compatible with a TLB that defines interfaces that this class is using. Anything less would be an oversight by me and considered a "bug report".

This class has absolutely no real benefit over existing code you may already be using unless you want more advanced options. Some of those options include:
- XP/Win2000: class-generated thunks for hooking the dialog. Those thunks result in raised events from the class to its host, i.e., form, usercontrol, other class, etc.
- Vista and higher
-- Customize by adding additional controls to the dialog and receive events for those controls
-- Add a read-only checkbox back to the dialog that populates the common OFN_ReadOnly flag
-- Interact with the dialog via class-generated thunks that raise events from the class to its host
-- Use embedded custom configurations. There are currently 7 of those.
1. Browse for Folders while showing file names too
2. Navigate into compressed folders (zips) while being able to select the zip itself or one of its contained files
3. Show both files and folder and be able to select either folders or files or both
4. Four "basket mode" settings which allows selecting files/folders across multiple directories. Similar to "Add to my Basket" button.
-- All custom mode button captions can be assigned by you or default to locale-aware captions (see screenshot below)

Nearly all of the advanced Vista options are incorporated into this class, but not all. If you find you need anything more that is not offered, modify as needed.

If you just want a simple Open/Save dialog where the filter is: All Files, the code needed for the dialog is as simple as:

Code:

---

    Dim cBrowser As OSDialogEx
    Set cBrowser = New OSDialogEx
    If cBrowser.ShowOpen(Me.hWnd) = True Then
        MsgBox "File Selected: " & cBrowser.FileName
    End If

---

Want to add the "Read-Only" checkbox back to the dialog?

Code:

---

    Dim cBrowser As OSDialogEx
    Set cBrowser = New OSDialogEx
    cBrowser.Controls_AddReadOnlyOption 100    ' << user-defined Control ID
    If cBrowser.ShowOpen(Me.hWnd) = True Then
        MsgBox "File Selected and Read-Only opted for: " & CBool(cBrowser.Flags And Dlg_ReadOnly)
    End If

---

Want a "Browse for Folder" like dialog that also shows files (not doable with newer dialog using standard options)?

Code:

---

    Dim cBrowser As OSDialogEx
    Set cBrowser = New OSDialogEx
    cBrowser.Controls_SetCustomMode cm_BrowseFoldersShowFiles
    If cBrowser.ShowOpen(Me.hWnd) = True Then
        MsgBox "Selected Folder: " & cBrowser.FileName
    End If

---

The screenshot below highlights locale-aware captions. The only one I haven't been able to find is a locale-aware caption like: All Files. That would be a nice-touch. But since I haven't found it yet in a common DLL, the dialog filter is hard-coded as "All Files" if you do not provide your own filter.


The sample project offers examples of several dialog variations. The class itself is heavily commented.

Attached Images

 

Attached Files

• SampleProject.zip (49.0 KB)

VB6 - Port Tester

January 28, 2018, 9:20 am

≫ Next: VB6 - NAT Helper

≪ Previous: [vb6]Common Dialog Class (Yet Another One)

$

0

0

The normal way to find your real external IP address is to use your browser to go to a site such as "WhatsMyIP". I needed to do this programatically without the burden of using HTML. What I came up with is a way to verify a forwarding port within a NAT router, while at the same time discovering your public IP address.

Port forwarding can be somewhat onerous for the casual user, and verifying that it is successful is part of the task. To accomplish this, we run a proxy type server on the other side of the NAT router. You send the port number that you want tested to that outside server, and the outside server tries to establish a TCP connection with your router on that port. If the router is properly configured, it will forward that request to your computer and the router's public IP address that was used to make the initial connection with the server will be sent to you.

Port forwarding usually requires that you use fixed IP addressing on your computer rather than DHCP, although it is sometimes possible to configure a NAT router to assign a fixed IP address using DHCP.

Even with the router properly configured, you can still have problems with your firewall. If you are running the Microsoft Firewall, it will prompt you to allow the outside connection.

Last but not least, most ISPs will block some problematic ports such as port 21(FTP), 25(SMTP), 80(WWW), 110(POP3), 6667(IRCD), 135-139(DCOM/NETBIOS), 443(SSL), 445(MS-DS), and 1433-1434(MS-SQL) on residential connections, and there is nothing you can do about it except use a different port or get a business connection.

If there is sufficient interest, I can later supply a service version of the server software.

Note: Both programs use SimpleSock, which requires operating systems that actively support both IPv4 & IPv6. This more or less restricts them to Windows Vista or better.

J.A. Coutts

Attached Images

 

Attached Files

• PortTest.zip (21.4 KB)

---

VB6 - NAT Helper

January 31, 2018, 12:28 pm

≫ Next: (VB6) Replace VB's Circle method with API's

≪ Previous: VB6 - Port Tester

$

0

0

Attached is an application called ExtIP. The original intent was to simply recover the External IP address used by a NAT router, but it ended up being much more. In order to use this program, your router must support Universal Plug and Play (UPnP), which most home routers do. However, not all routers support all functions, as evidenced by the descriptions below. Our own router does not support querying of the Mapping Collection, so some of the functions have not been fully tested.

If your router does not support UPnP, or it has not been turned on, executing any of the functions will produce a message stating "UPnPNAT not Found!".

If you know the external port number of an existing mapping, you can enter that number and recover the External IP address used on the WAN (Wide Area Network), as well as the Internal IP address and the Internal port. The older "GetIpAddrTable" is used to recover the Internal IP address, and uses the last address in the table. If you have more than one active Network Interface, it could produce a wrong result. It will also not produce a correct External IP address if you are using a double NAT configuration (not recommended). (tested)

If you would like to find out the External IP address and you do not know the port number used, you can leave the port number blank, and the program will scroll through the mapping collection and return the first one it finds. (not tested)

Clicking on the Get Ports button will scroll through the port mapping collection and add the External ports to the list box. Clicking on one of them will add it to the External Port box. (not tested)

You can also add a port mapping by entering an External Port number and clicking on the "Add Port Map" button. Normally the Internal Port number matches the External Port, and it will default to that, or you can add a different number. If the port mapping already exists, it will error out. (tested)

You should also be able to delete a port mapping, but our router does not support that function. (not tested)

This program does not support IPv6, because IPv6 does not require the use of NAT.

J.A. Coutts

Attached Images

 

Attached Files

• ExtIP.zip (3.1 KB)

(VB6) Replace VB's Circle method with API's

February 1, 2018, 7:07 am

≫ Next: VB6 Webbrowser and Java problems

≪ Previous: VB6 - NAT Helper

$

0

0

Code:

---

Private Declare Function Arc Lib "gdi32" (ByVal hDc As Long, ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long, ByVal nXStartArc As Long, ByVal nYStartArc As Long, ByVal nXEndArc As Long, ByVal nYEndArc As Long) As Long
Private Declare Function Ellipse Lib "gdi32" (ByVal hDc As Long, ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nDrawStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long

' Sub Circle(Step As Integer, iX As Single, iY As Single, Radius As Single, Color As Long, StartArc As Single, EndArc As Single, Aspect As Single)
' When an arc or a partial circle or ellipse is drawn, StartArc and EndArc specify (in radians) the beginning and end positions of the arc.
' The range for both is 2 pi radians to 2 pi radians. The default value for StartArc is 0 radians; the default for EndArc is 2 * pi radians.
Sub DrawCircle(x As Single, y As Single, Radius As Single, Optional Color, Optional Aspect As Single = 1, Optional StartArc, Optional EndArc, Optional Step As Boolean)
    Dim iXStartArc As Long, iYStartArc As Long, iXEndArc As Long, iYEndArc As Long
    Dim iAspectX As Single
    Dim iAspectY As Single
    Dim iStartArc As Single
    Dim iEndArc As Single
    Dim iDontDraw As Boolean
    Dim iFilledFigure As Boolean
    Dim iColor As Long
    Dim iPen As Long
    Dim iPenPrev As Long
    Dim iX As Long
    Dim iY As Long
   
    If Step Then
        iX = Picture2.CurrentX + x
        iY = Picture2.CurrentY + y
    Else
        iX = x
        iY = y
    End If
   
    Picture2.Cls
   
    If IsMissing(Color) Then
        iColor = Picture2.ForeColor
    Else
        iColor = Color
    End If
    TranslateColor iColor, 0, iColor

    If IsMissing(StartArc) And IsMissing(EndArc) Then
        If Picture2.FillStyle = vbSolid Then
            iFilledFigure = True
        End If
    End If
   
    If Aspect > 1 Then
        iAspectX = 1 / Aspect
        iAspectY = 1
    Else
        iAspectX = 1
        iAspectY = 1 * Aspect
    End If
   
    If IsMissing(StartArc) Then
        iStartArc = 0
    Else
        iStartArc = StartArc
    End If
    If IsMissing(EndArc) Then
        iEndArc = 0
        ' Note: 0 (zero) for EndArc seems to be handled as 2 * Pi by the API (in fact they are the same point)
    Else
        iEndArc = EndArc
    End If
   
    If Not IsMissing(EndArc) Then ' VB's Circle behaves like this: if StartArc and EndArc parameters are supplied and define an entire circle or ellipse, VB does not draw it
    End If
   
    If Not iDontDraw Then
        iXStartArc = Radius * iAspectX * Cos(iStartArc) + iX
        iYStartArc = Radius * iAspectY * Sin(iStartArc) * -1 + iY
        iXEndArc = Radius * iAspectX * Cos(iEndArc) + iX
        iYEndArc = Radius * iAspectY * Sin(iEndArc) * -1 + iY
       
        If iColor <> Picture2.ForeColor Then
            iPen = CreatePen(Picture2.DrawStyle, Picture2.DrawWidth, iColor)
            iPenPrev = SelectObject(Picture2.hDc, iPen)
        End If
       
        If iFilledFigure Then
            Ellipse Picture2.hDc, iX - Radius * iAspectX, iY - Radius * iAspectY, iX + Radius * iAspectX, iY + Radius * iAspectY
        Else
            Arc Picture2.hDc, iX - Radius * iAspectX, iY - Radius * iAspectY, iX + Radius * iAspectX, iY + Radius * iAspectY, iXStartArc, iYStartArc, iXEndArc, iYEndArc
        End If
        Picture2.Refresh
   
        If iPenPrev <> 0 Then
            Call SelectObject(Picture2.hDc, iPenPrev)
        End If
        If iPen <> 0 Then
            DeleteObject iPen
        End If
   
    End If
   
    Picture2.CurrentX = iX
    Picture2.CurrentY = iY
End Sub

---

Attached Files

• Circle_API_Replacement.zip (2.6 KB)

VB6 Webbrowser and Java problems

February 1, 2018, 12:42 pm

≫ Next: [VB6] Last Seen Feature

≪ Previous: (VB6) Replace VB's Circle method with API's

$

0

0

Hi everyone,

I see this work here and I like this forum so much. Found so many things that helped me.

Now I need your guide to me. I am using ieframe.dll(webbrowser) for vb6 and when I am trying to navigate my webbrowser to "twitch.tv" adress. Theres so many things went wrong. Errors in my page and doesnt run website well.

For example How can I make my webbrowser open "https://www.twitch.tv/eleaguetv" this site. And run without problems? Is there any other webbrowser ocx or anyway that I can upgrade my webbrowser. And any other helps? :P

[VB6] Last Seen Feature

February 2, 2018, 1:02 am

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

≪ Previous: VB6 Webbrowser and Java problems

$

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

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

February 6, 2018, 3:35 am

≫ Next: Form Min-Max size and Fixed-size

≪ Previous: [VB6] Last Seen Feature

$

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.

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

• SSTabEx_source_060216.zip (119.4 KB)

Form Min-Max size and Fixed-size

February 8, 2018, 9:13 am

≫ Next: HTA as HTML UI for VB6 code

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

$

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

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

≪ Previous: Form Min-Max size and Fixed-size

$

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.




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!





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

• UPrinterDemo HTA.zip (45.4 KB)

---

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

February 12, 2018, 11:13 am

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

≪ Previous: HTA as HTML UI for VB6 code

$

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.

Menu populated by demo's Form1




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




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

• EnumPorts.zip (8.5 KB)

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

February 15, 2018, 10:38 pm

≫ Next: Vb6 - netmask calculator

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

$

0

0

hi i want show font icons like webgings font or other fonts and use in label or textbox or ...


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

≫ Next: Works well in VB4 show run time error 53 with VB6

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

$

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

• MaskCalc.zip (2.8 KB)

Works well in VB4 show run time error 53 with VB6

February 18, 2018, 6:55 pm

≫ Next: SuperTrim Function for strings

≪ Previous: Vb6 - netmask calculator

$

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

• FileAPI.bas (10.5 KB)

SuperTrim Function for strings

February 23, 2018, 8:27 am

≫ Next: VB6 API Viewer Database Editor

≪ Previous: Works well in VB4 show run time error 53 with VB6

$

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

• SuperTrim Class.zip (11.8 KB)