Fuzzy Search Demo [VB6/vbRichClient5]

October 23, 2013, 7:45 pm

≪ Previous: VB6 Png-Alpha-Rendering with GDI+ (alternatively per WIA)

The vbRichClient5 library for VB6 includes support for the SQLite database engine, and acts as a wrapper for the user defined collation (sort) and user-defined functions features of SQLite. Thanks to the work of Olaf Schmidt, it is really easy to create standard VB6 classes that extend the functionality of SQLite.

I've been experimenting with some "fuzzy" search routines using my own custom collation and ranking code (modified Metaphone), intertwined with the vbRC5 ranking code (RatCliff), and have put together a little demo here:

RC5SearchDemo.zip

Before you can use this demo, you will need to download and register the vbRichClient5 library from http://www.vbrichclient.com/#/en/Downloads.htm

"Search" is a really interesting (and constantly evolving) area of human>computer interaction, and I think VB6 is somewhat lacking (no native regex, no built-in fuzzy algorithms like metaphone, ratcliff, etc...). I'm really hoping for some input from the community on how to make this fuzzy matching better, under more search/language scenarios - for the benefit of all. Please feel free to hack away with the above demo and report back with your results, and let's see if we can create a search algorithm (or suite of algorithms) that produce consistently useful results.

Attached Files

RC5SearchDemo.zip (19.6 KB)

↧

DNS Filter

October 24, 2013, 11:23 am

≫ Next: Changing The Shape of your Form and Showing Transparent animation on the Desktop

≪ Previous: Fuzzy Search Demo [VB6/vbRichClient5]

Our DNS server was being used as an attack vector against primarily Chinese servers. DNS by preference uses UDP packets instead of TCP packets. The UDP protocol is much faster than TCP, but unlike TCP it does not perform a handshake. It is essentially one way communication with no confirmation of receipt. Because of that, it is possible to fake the sender IP address, and this is what the attackers were doing. A 128 byte request was causing a 388 byte invalid response to be sent to the target server. By enlisting many hacked computers, the attackers could overwhelm the target. Because the hackers were sending false source information to legitimate DNS servers, it was difficult to track the actual source.

Our DNS server has the capability to block source addresses that send too many requests per second, but it was getting to be a pain to update the list, and the list itself was getting quite long. So I set about to design a filter. For this purpose I am using the Windows Packet Filter Kit from NT Kernel Resources. This high performance packet filtering framework hooks the NDIS (Network Driver Interface Specification) driver in your Windows Operating System. This allows me to inspect each packet and only target incoming Port 53 UDP packets for further processing. A 20 element cache is maintained with the Source IP Address, the Question Type, the Question, and a Timeout. When a DNS request is received, the program checks the cache and if does not exist or is timed out, it is added with the maximun timeout. If it already exists, the timeout is reset to the maximum and the record dropped. A timer decrements the timeout values every second.

I had considered building this progam some time ago because some abusive DNS servers were using brute force by sending multiple requests for the same thing. The worst offender was Yahoo, which not only sent multiple requests from the same server, but also used multiple servers for the same thing. These hackers only served to elevate the priority.

This program is a work in progress, and once it has proven itself, I will convert it to run as a Service. To run as a Service, I must ensure that the program makes no attempt to display to the Desktop, as this can cause the operating system to get into an endless loop when the user is logged off and the desktop is not available. All potential errors must be trapped, and logged to the Event or other log.

J.A. Coutts
Edit: When the filter was put into production, a bug was discovered that caused Overflow errors in the PacketRead routine. The problem was caused by Message Types greater than 32,767, which got interpreted as negative numbers. The problem was resolved by changed the data type to long integer from integer. To facilitate this resolution, Error Trapping and a logging function was added.

Attached Files

DNSFilter.zip (17.0 KB)

↧

Changing The Shape of your Form and Showing Transparent animation on the Desktop

October 25, 2013, 10:56 am

≫ Next: DNS Filter Service

≪ Previous: DNS Filter

This is a simple Form transparency demo. It simply demonstrates how you can make your Form any shape you want and show pictures and animation on the desktop in the shape of your Form. It basically shows you how to change the shape of your Form to almost anything or shape you would want and to show animation (using animated gif) on the desktop

Left mouse down to move the Form

Right mouse down for options

Attached Files

Desktop Transparencies.zip (148.0 KB)

↧

DNS Filter Service

November 1, 2013, 11:10 am

≫ Next: Alphablending - A Simple Demo

≪ Previous: Changing The Shape of your Form and Showing Transparent animation on the Desktop

This is the Service Version of the Filter program previously posted. The Service version of DNS Filter not only requires the WinpkFilter from NT Kernel Resources (free for personal use) but also the NT Service Control from Microsoft (freely available). So far it has been tested on Server 2000 and Windows Vista.

It consists of 2 programs; one is the actual service, and the other to load and manage the Service. Although the service can install itself, the management program is needed to store a couple of parameters. Because the Service runs in Session 0, the Registry values must be placed in the Registry in a location that allows System access. Because the management program runs in Session 1 or more, it has no actual interaction with the service. It deals entirely with the Service Manager (services.msc). I used to use the System Tray for interaction between a service and the desktop, but that is now difficult to do with Session Isolation. I also used to use the Dart Service Control (which I prefer), but that requires the user to purchase a license.

J.A. Coutts

Note: DNSFilSvc was designed to be run in Development mode as well as a Service. To compile the service, change the IsService flag to True. In order to get the logging routine to function on Server 2000, I had to manually create the DNS sub-directory in the Logfiles directory. Server 2000 would not automatically create it.

Addendum: I finally got the low level filtering in WinpkFilter working. This allowed me to only process Port 53 UDP requests, thereby reducing the amount of code needed and theoretically reducing system resources required. The problem turned out to be bad type declarations in the sample code provided.

Bug Fix 11/12/2013: A bug was discovered that randomly allowed some duplicated queries to get through the filter. A fixed length buffer (128 bytes) was maintained to receive incoming query names. This string information was of variable length, but always ended in a null character. When the name was added to the string array, VB only recognized up to the null character. If the previous query was longer than the current one, extra characters got left behind in the fixed length buffer. For example, if "12345678.com" was followed by "123456.com", what was shown in the buffer was "123456.com m", which of course did not compare to what was already in cache. This was corrected by clearing the fixed length buffer after every query. At the same time, table updates were sped up by maintaining an end of cache pointer.

Attached Files

DNSFilSvc.zip (23.3 KB)

↧

Alphablending - A Simple Demo

November 2, 2013, 12:38 pm

≫ Next: Slot Machine

≪ Previous: DNS Filter Service

This small demo shows you how you can alpha blend one picture onto another. In this demo only part of the target picture is alpha blended.

Attached Files

Alphablending.zip (233.4 KB)

↧

Slot Machine

November 6, 2013, 1:59 pm

≫ Next: Desktop Digital Clock

≪ Previous: Alphablending - A Simple Demo

This is a simple demo of a slot machine. It has three spinners that simulate a slot machine when the handle is pulled down (this uses a button instead of a handle).

Attached Files

Slot Machine.zip (34.8 KB)

↧

Desktop Digital Clock

November 7, 2013, 11:31 am

≫ Next: Simple way to Export FlexGrid to Excel

≪ Previous: Slot Machine

This small digital clock can be moved anywhere on the desktop. It is transparent, only the digits show.

Attached Files

Desktop Digital Clock.zip (9.2 KB)

↧

Simple way to Export FlexGrid to Excel

November 8, 2013, 6:07 am

≫ Next: Excel Writer

≪ Previous: Desktop Digital Clock

I see many people asking how to export a VB6 MSFlexgrid to an Excel workbook....this short code with a couple of simple For-Loops is an easy way to do it (Make sure you have a REFERENCE to MS Excel in your project).

Code:

Private Sub smnuExportExcel_Click()

    Dim oExcel As excel.Application

    Dim oWb As excel.Workbook

    Dim oSheet As excel.Worksheet

    Dim x As Integer

    Dim y As Integer

    Set oExcel = New excel.Application

    Set oExcel = CreateObject("Excel.Application")

    Set oWb = oExcel.Workbooks.Add

    Set oSheet = oWb.Worksheets("Sheet1")

    With oSheet

    For x = 0 To flexgrid1.Rows - 1  

        For y = 0 To 6

            .Cells(x + 1, y + 1) = flexgrid1.TextMatrix(x, y) 'Note, "x + 1" as Excel refers to rows and columns beginning with 1, whereas VB6's flexgrids start with 0.

        Next y

    Next x

    oWb.SaveAs FileName:=App.Path & "\myExcelFile.xlsx"

    oExcel.Visible = True

    Set oWb = Nothing

    Set oExcel = Nothing

End Sub

↧

Excel Writer

November 8, 2013, 7:17 am

≫ Next: Color Management (ICC Profile) support in VB6: guide and sample project

≪ Previous: Simple way to Export FlexGrid to Excel

Project to create an ActiveX DLL which is capable of writing Excel 2007 xlsx files directly.
No need for Excel to be installed.
An xlsx is just a ZIP archive with all kind of XML files and bunch of tables.
After a few weeks of reverse engineering I was able to create this project.

There are no pivot-tables or charts!

This project uses source code written by:

Andrew McMillan -> clsZipClass and clsZipFile
Steve McMahon -> clsStringBuilder
LaVolpe -> Collection Key routines

Also needed is the zlibwapi.dll which can be found in the zlib125dll.zip

Sample code (needs a reference to the created ActiveX DLL)

Code:

Option Explicit



Private Sub Command1_Click()

  Dim cExcel As clsExcel2007

  Dim cWS As clsWorksheet2007

  Dim tCell As tpExcelCell2007

  

  Set cExcel = New clsExcel2007

  

  ' Add the first Worksheet

  Set cWS = cExcel.AddWorkSheet("My first sheet")

  

  tCell = cExcel.NewCellType

  tCell.Row = 1: tCell.Column = 1:  tCell.Value = "A1"

  cWS.AddCellType tCell

  

  tCell = cExcel.NewCellType

  tCell.Row = 2: tCell.Column = 1:  tCell.Value = "A2"

  cWS.AddCellType tCell

  

  tCell = cExcel.NewCellType

  tCell.Row = 3: tCell.Column = 1:  tCell.Value = "A3"

  cWS.AddCellType tCell

  

  tCell = cExcel.NewCellType

  tCell.Row = 4: tCell.Column = 1:  tCell.Value = "A4"

  cWS.AddCellType tCell

  

  tCell = cExcel.NewCellType ' using empty values

  tCell.Row = 1: tCell.Column = 2: tCell.Value = "B1":  tCell.BackColor = vbRed

  cWS.AddCellType tCell

  

  tCell = cExcel.NewCellType ' using empty values

  tCell.Row = 2: tCell.Column = 2: tCell.Value = "B2":  tCell.FontBold = True

  tCell.Comment = "Font Bold"

  cWS.AddCellType tCell

  

  tCell = cExcel.NewCellType ' using empty values

  tCell.Row = 3: tCell.Column = 2: tCell.Value = "B3":  tCell.ForeColor = RGB(0, 127, 0)

  cWS.AddCellType tCell

  

  tCell = cExcel.NewCellType ' using empty values

  tCell.Row = 4: tCell.Column = 2: tCell.Value = "B4":  tCell.BorderLeftColor = vbBlue

  tCell.Comment = "Blue border"

  cWS.AddCellType tCell

  

  ' Add a second WorkSheet

  Set cWS = cExcel.AddWorkSheet("Sheet 2")

  

  tCell = cExcel.NewCellType

  tCell.Row = 1: tCell.Column = 1:  tCell.Value = Atn(1) * 4

  tCell.FormatString = "0.00"

  cWS.AddCellType tCell

  

  tCell = cExcel.NewCellType

  tCell.Row = 2: tCell.Column = 1:  tCell.Value = Date

  tCell.FormatString = "dd MMM yyyy"

  tCell.Comment = tCell.FormatString



  

  tCell = cExcel.NewCellType

  tCell.Row = 2: tCell.Column = 1:  tCell.Value = TimeSerial(25, 34, 12)

  tCell.FormatString = "[h]:mm"

  tCell.Comment = tCell.FormatString

  cWS.AddCellType tCell





  tCell = cExcel.NewCellType

  tCell.Row = 1: tCell.Column = 2: tCell.Value = "MergeCell"

  cWS.AddCellType tCell

  

  tCell = cExcel.NewCellType

  tCell.Row = 2: tCell.Column = 2: tCell.Value = "MergeCell"

  cWS.AddCellType tCell

  

  tCell = cExcel.NewCellType

  tCell.Row = 3: tCell.Column = 2: tCell.Value = "B3"

  tCell.HorizontalAlignment = chaCenter

  cWS.AddCellType tCell



  tCell = cExcel.NewCellType

  tCell.Row = 4: tCell.Column = 2: tCell.Value = "right"

  tCell.HorizontalAlignment = chaRight

  cWS.AddCellType tCell





  cWS.MergeCells 1, 2, 2, 2

  

  cExcel.Save "D:\Excel 2007 files\Reports\Test1.xlsx"

  

  cExcel.Terminate

  

  Set cWS = Nothing

  Set cExcel = Nothing

End Sub



Private Sub Command2_Click()

  Dim cExcel As clsExcel2007

  Dim cWS As clsWorksheet2007

  Dim tCell As tpExcelCell2007

  Dim lRow As Long, lCol As Long

  

  Set cExcel = New clsExcel2007

  

  Set cWS = cExcel.AddWorkSheet("Single sheet")

  For lRow = 1 To 200

    For lCol = 1 To 500

      tCell = cExcel.NewCellType

      tCell.Row = lRow

      tCell.Column = lCol

      tCell.Value = lRow * lCol

      cWS.AddCellType tCell

    Next lCol

  Next lRow

      

  cExcel.Save "D:\Excel 2007 files\Reports\Test2.xlsx"



  cWS.Terminate

  cExcel.Terminate

  

  Set cWS = Nothing

  Set cExcel = Nothing



End Sub

Attached Files

Excel2007Writer.zip (22.6 KB)

↧

Color Management (ICC Profile) support in VB6: guide and sample project

November 9, 2013, 10:09 am

≫ Next: [VB6] Lock ListView Columns

≪ Previous: Excel Writer

Name: Color_Management_Screenshot.jpg
Views: 75
Size: 108.4 KB

Download the sample project (250kb, including sample images)

VB6_ColorManagement.zip

What does the sample project include?

Color_Management (module). This contains all the necessary code for adding color management to your VB project.
pdLayer (class). A DIB wrapper borrowed from this vb6 project (hence the "pd" prefix). Useful if you want to load JPEG/PNG/TIFF files with embedded profiles. Not necessary if your application won't support loading images at run-time.
frmColorManagement (form). Sample form. Demonstrates use of the included module.
cCommonDialog (class). Code-only common dialog wrapper by Steve McMahon. Included to make loading images easier.

Acknowledgments

Many thanks to LaVolpe for this helpful post and sample code, which provided a great starting point for this topic.

What is color management and why does it matter?

Short answer: if your application uses images (and especially if it lets the user load or modify images), those images won't look 100% correct without color management.

Long answer: Color Management article on Wikipedia.

Do I need color management in my application?

It depends. If you do not use images in your application, then no - color management is a waste of your time.

If you do use images in your application, then color management is worth considering.

Most importantly, if you allow users to load their own images, I would consider color management a "must-have". Without it, you risk images not looking the same way they do in other software (including Windows photo viewer, PhotoShop, GIMP, etc). Users may think your software is broken, when really, it is just not color managed.

Is it hard to support color management in a VB6 app?

Yes and no, with an emphasis on "mostly no". Color management can be broken into two broad categories:

+ Color management for your forms and picture boxes. Retrieving the stock system color profile, assigning it to VB picture boxes and forms, then activating color management is extremely simple. With the sample project, you can do it in two lines of code. (Note that image boxes cannot be easily color managed, because they do not expose an hDC property.)

+ Color management for imported images. This is trickier, and it requires the use of GDI+ (or some other imaging library, like FreeImage) to parse the image data and extract any embedded ICC profile. The sample project simplifies the process to a few lines of code, but it assumes GDI+ is present (something that should be true for most anyone on Win XP SP2 or later, but which may not be guaranteed for earlier XP users). It also requires the use of DIBs, for which I provide a comprehensive wrapper, but which may complicate your project more than you want.

Can I drop your code into my project and assume everything is color managed?

Mostly. As I said, you'll need to manually activate color management for any forms or picture boxes that display images. This is done using two lines of code:

Code:

assignColorProfileToDC PictureBox.hDC

setColorManagementForDC PictureBox.hDC, True

Please note that if your picture boxes and/or forms use AutoRedraw, you may need to re-activate color management prior to drawing on the picture box, because AutoRedraw can cause the hDC of the picture box to change. (There is no measurable performance overhead in reapplying color management settings.)

If you allow the user to load images in your software, it will take more work to ensure color management for said images. Refer to the sample project for details.

What versions of Windows are supported?

Anything XP or later, assuming GDI+ is present on the target machine. If you don't care about supporting ICC profiles embedded in images, the code should work for Windows 2000 as well, though I haven't tested this.

Are any special dependencies required?

Nope! Windows itself provides a very capable color management engine, so you don't need to add any DLLs or other references to your project. Everything is accomplished by flat function calls to mscms.dll

Does this code provide the same level of color management as PhotoShop?

No, but it's closer than you might think. This project makes a number of assumptions in order to keep things simple and fast (like using the sRGB working space by default, rather than providing a choice). PhotoShop provides much more granular control over every step of the color management chain. That said, you should not notice any difference between images loaded via this sample project and images loaded via PhotoShop, assuming your copy of PhotoShop uses recommended settings.

Attached Images

Attached Files

VB6_ColorManagement.zip (251.2 KB)

↧

[VB6] Lock ListView Columns

November 17, 2013, 3:43 pm

≫ Next: VB 6 Input Date format

≪ Previous: Color Management (ICC Profile) support in VB6: guide and sample project

This code prevents the specified column(s) of a ListView control from being resized by the user. It does that by subclassing the ListView control and watching for the HDN_BEGINTRACK and HDN_DIVIDERDBLCLICK notification codes. Additionally, it also provides appropriate feedback to the user by displaying the "Unavailable" cursor when the mouse is over the locked column divider. That is done by subclassing the ListView's Header control and handling the WM_SETCURSOR message.

The modLockLVCols.bas file in the attached project below has been inspired by the codes in the following threads:

Preventing certain Listview columns from sizing...

[RESOLVED] Prevent User From Resizing Column Width in ListView

Also included in the attachment is frmLockLVColsDemo.frm:

Name: Lock ListView Columns.png
Views: 128
Size: 14.0 KB

Attached Images

Attached Files

Lock ListView Columns.zip (4.5 KB)

↧

VB 6 Input Date format

November 19, 2013, 1:12 am

≫ Next: Keeping VScroll Always At Bottom

≪ Previous: [VB6] Lock ListView Columns

Hi

I have a Date textfield, that describes to the user the format of the date (YYYY/MM) then I would use that date on my WHERE clause to update database. my Date in the database is also in the same format (YYYY/MM).

I need to write a code that will validate first if the input date is in the correct format before I can apply it on my WHERE clause. I have this code below, I need to extend it to cater for newly date column.

please help

If Len(txtSalary.Text) = 0 Or Len(txtmCover.Text) = 0 Or Len(txtMember.Text) = 0 Or Len(txtmRate.Text) = 0 Or Len(txtDate.Text) = 0 Then

MsgBox "Enter All The Fields Values"

Else
tsql = "UPDATE Hpacc4 SET SalaryBill = '" & txtSalary.Text & "', Rate = '" & txtmRate.Text & "', RateType = '" & comboRate.Text & "', Membership = '" & txtMember.Text & "', Cover = ' " & txtmCover & " ' Where Scheme = ' " & txtSCode & " ' AND RunMonth = ' " & txtDate & " ' AND AccCode = '110'"
MsgBox "Updated"

cnHPtest.Execute (tsql)

End If

↧

Keeping VScroll Always At Bottom

November 21, 2013, 1:08 pm

≫ Next: Hmac

≪ Previous: VB 6 Input Date format

This simple example shows how you can keep the Vertical Scroll bar always at bottom

Attached Files

VScroll Always At Bottom.zip (1.6 KB)

↧

Hmac

November 28, 2013, 6:04 pm

≫ Next: Fade Picture in Picturebox from One Picture to Another

≪ Previous: Keeping VScroll Always At Bottom

According to Wikipedia and verified with online HMAC routines, HMAC_SHA1("key", "The quick brown fox jumps over the lazy dog") should produce an HMAC of:
DE 7C 9B 85 B8 B7 8A A6 BC 8A 7A 36 F7 0A 90 70 1C 9D B4 D9
However, when I use the Example C Program: Creating an HMAC on MSDN:
http://msdn.microsoft.com/en-us/libr...=vs.85%29.aspx
I get:
41 4E 4C 89 33 30 47 9B 9E F1 85 DF 40 6A 66 33 49 D6 3A C7

The problem seems to be in the derivation of the Key itself (TestHMAC1). Microsoft requires that the key be hashed before deriving an actual key. The Key produced can be replicated and works if both ends are using the same process, but unfortunately it can't be used to communicate with remote servers using standard HMAC. As I have demonstrated in TestHMAC3, the correct HMAC can be produced using the MS Crypto API if you import the key rather than deriving it.

In the process of determing what was wrong with the MS routine, I wrote my own HMAC routine without the use of the Crypto API (TestHMAC2). In my humble opinion, this routine is far simpler than using the API, but you can judge for yourself. The only drawback is that you need the actual unencrypted key, and not just the handle to it. For keys created by the API, that means declaring the key as CRYPT_EXPORTABLE and exporting and decrypting it.

The program uses RSA/Schannel in a custom Container. If no Exchange key pair is available for the Container, it will create them. Schannel does not support a Signature key pair, so it will not create them.

J.A. Coutts

Attached Files

TestHMAC.zip (6.2 KB)

↧

Fade Picture in Picturebox from One Picture to Another

November 30, 2013, 7:18 am

≫ Next: VB Export Project

≪ Previous: Hmac

'Need 2 pictureboxes (Picture1 & Picture2)
'Set both pictureboxes AutoRedraw to True
'Set both pictureboxes ScaleMode to vbPixels
'Paste the following code in the Decs

Private Const AC_SRC_OVER = &H0

Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type

Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private BF As BLENDFUNCTION, lBF As Long, fade As Byte
Private FadeInProgress As Boolean

Public Function FadeThePicture(fromPicture As PictureBox, toPicture As PictureBox)
If FadeInProgress Then Exit Function

For fade = 1 To 60 Step 2
With BF
.BlendOp = AC_SRC_OVER
.BlendFlags = 0
.SourceConstantAlpha = fade
.AlphaFormat = 0
End With
RtlMoveMemory lBF, BF, 4
AlphaBlend toPicture.hdc, 0, 0, toPicture.ScaleWidth, toPicture.ScaleHeight, fromPicture.hdc, 0, 0, fromPicture.ScaleWidth, fromPicture.ScaleHeight, lBF
toPicture.Refresh
Sleep 25
Next fade

DoEvents
End Function

↧

VB Export Project

December 3, 2013, 1:21 am

≫ Next: VB6 Date Validation

≪ Previous: Fade Picture in Picturebox from One Picture to Another

Hi

I have a code below to export data from sql server db "Hpacc4" to Excel. my code just error at: rsHPData.MoveFirst, with error "Either BOF or EOF is True, or the current record has been deleted"

Please help

Code:



Private Sub btnRecon_Click() 'Export to Excel Button

  

   Dim tsql As String

 Dim oExcel As Object

 Dim oWB As Object

 Dim oWS As Object

  

  ' // ----------------------------------- //

  ' // Set up a connection to the DataBase //

  ' // ----------------------------------- //



   Set cnHPtest = New ADODB.Connection

   Set rsHPData = New ADODB.Recordset



  With cnHPtest

    .Provider = strDBProv

    .ConnectionString = strDBString

    .CommandTimeout = 1000

    .Open

  End With

 

 Screen.MousePointer = vbHourglass

    Dim x As Integer, numRecs As Integer



    Set oExcel = CreateObject("Excel.Application")

    Set oWB = oExcel.Workbooks.Add

    Set oWS = oWB.Worksheets("Sheet1")



        With rsHPData

            .CursorLocation = adUseClient

            .LockType = adLockReadOnly

            .Open "Select RunMonth, SalaryBill, Rate from Hpacc4 where Scheme = '" & frmLogin.MaskEdBox1.Text & "' AND RunMonth = '" & MaskEdDate.Text & "' AND AccCode = '110'", cnHPtest, adOpenForwardOnly, adLockReadOnly

        End With

        

        If rsHPData.EOF And rsHPData.BOF Then

        

        'Set rs = cmd.Execute()

        numRecs = rsHPData.RecordCount

        rsHPData.MoveFirst

         

         With oWS

           'SET THE TOP ROWS WITH TITLES--Change Font to Bold and Make The Font RED

            .Range("A1:C1").Font.Bold = True 'sets top row (stuff below) in bold print

            .Range("A1:C1").Font.ColorIndex = 3 'change font color to red

              .Cells(1, 1).Value = "STATE NAME"

              .Cells(1, 2).Value = "STATE ABBREVIATION"

              .Cells(1, 3).Value = "DATE ENTERED UNION"

         'Run through the RECORDSET, stating in ROW 2, until end of the RECORDSET

         For x = 2 To numRecs + 1  ' You can do this differently without using numRecs (do while not rs.eof)

              .Cells(x, 1).Value = Trim(rsHPData!RunMonth)   'State is a TEXT Field in my db

              .Cells(x, 2).Value = Trim(rsHPData!SalaryBill)       'St is a TEXT Field in my db

              .Cells(x, 3).Value = Trim(rsHPData!Rate)  'date_orig is a DATE Field in my db

         rsHPData.MoveNext  'Move through the RECORDSET

         Next x

         End With

         End If

         'This for-loop makes the columns just wide enough for the largest 'string' in each column

         For x = 1 To 3 'where 3, in my case is three columns  (State Name, State Abbreviation and Date Entered Union

              oWS.Columns(x).AutoFit

           Next x

        'close down the rs and connection

        rsHPData.Close

        cnHPtest.Close

        oExcel.Visible = True  'so you can see what you did

        'set up the active excel sheet

        Set oWS = oExcel.ActiveSheet

        Set oWB = oExcel.ActiveWorkbook

        oWB.SaveAs FileName:=App.Path + "\testfile.xlsx"  'use whatever name you want here

    Screen.MousePointer = vbDefault

End Sub

↧

VB6 Date Validation

December 10, 2013, 11:08 pm

≫ Next: convert numbers to words (SPANISH)

≪ Previous: VB Export Project

Hi

I'm using maskEdBox to accept date from the user in this format yyyymmdd, Now I want to validate this date to be a valid date, (i.e the user might input 1234/12/12), and also the date shouldn't be any future date, either with a month or a year, max date should be the current date. please help.

↧

convert numbers to words (SPANISH)

December 16, 2013, 4:36 am

≫ Next: Command() - Unicode aware

≪ Previous: VB6 Date Validation

Here is a function to convert an integer to Spanish words. Maybe it will be of some use to somebody. There is probably a much more elegant way to do this but this worked for me and is correct as far as I can see.

Code:

Private Function ConvertToWords(ByRef Value As Integer) As String

Dim Strng As String     'holds string representation of Value

Strng = CStr(Value)

Dim Txt As String       'holds the word string as it is being built

Dim Curr As String      'holds the currency word

Curr = "Euros"

Dim Temp As String     'used to work on a single digit at a time



Dim Units(12) As String

Units(0) = "zero"

Units(1) = "uno"

Units(2) = "dos"

Units(3) = "tres"

Units(4) = "cuatro"

Units(5) = "cinco"

Units(6) = "seis"

Units(7) = "siete"

Units(8) = "ocho"

Units(9) = "nueve"

Units(10) = "nove"

Units(11) = "sete"

Units(12) = "quin"



Dim Tens(9) As String

Tens(0) = ""

Tens(1) = "diez"

Tens(2) = "veinte"

Tens(3) = "treinta"

Tens(4) = "cuarenta"

Tens(5) = "cincuenta"

Tens(6) = "sesenta"

Tens(7) = "setenta"

Tens(8) = "ochenta"

Tens(9) = "noventa"



Dim Teens(5)

Teens(1) = "once"

Teens(2) = "doce"

Teens(3) = "trece"

Teens(4) = "catorce"

Teens(5) = "quince"



   Txt = ""

'hundreds

   If Len(Strng) = 3 Then  'there are hundreds

      Temp = Left(Right(Strng, 3), 1)     'take the "hundreds" digit

      If Temp = "5" Then Temp = "12"      'set stem for 500s as "quin"

      If Temp = "7" Then Temp = "11"      'account for siete-sete change in 700's

      If Temp = "9" Then Temp = "10"      'account for nueve-nove change in 900's

      Txt = Units(CInt(Temp))             'set the hundreds word according to units list

      If Temp = "1" Then                  'the 100's is a special case. Only say "hundred" not "one hundred"

         If Right(Strng, 2) = "00" Then   'also exactly 100 is a special case.

            Txt = "Cien"

         Else

            Txt = "ciento"                'not exactly 100 so add correct "hundreds" word

         End If

      Else

         If Temp = "12" Then

            Txt = Txt & "ientos"          'add correct ending for 500's

         Else

            Txt = Txt & "cientos"            'more than 100 so make 200,300,400 etc

         End If

      End If

   End If

'tens

   If Len(Strng) <= 3 Then                'ignore numbers over 999

      Temp = Right(Strng, 2)              'take the tens and units

      If Temp >= "11" And Temp <= "15" Then

         Txt = Txt & " " & Teens(CInt(Temp) - 10) '11 to 15 are special words. Take them from Teens array

      Else

         'tens

         If Len(Temp) > 1 Then            'take the tens digit

            Txt = Txt & " " & Tens(CInt(Left(Temp, 1)))  'and add it to the word list

         End If

         'units

         If Len(Temp) > 1 Then            'deal if the value is 10 or more

            If CInt(Right(Temp, 1)) <> "0" Then

               If CInt(Left(Temp, 1)) = "1" Then     'if the tens begin with "1" need to change the spelling

                  Txt = Left(Txt, Len(Txt) - 1) & "ci" & Units(CInt(Right(Temp, 1)))

               ElseIf CInt(Left(Temp, 1)) = "2" Then  'if tens begins with "2" change spelling differently

                  Txt = Left(Txt, Len(Txt) - 1) & "i" & Units(CInt(Right(Temp, 1)))

               Else

                  If Left(Temp, 1) = "0" Then   'check for whole 10's

                     Txt = Txt & Units(CInt(Right(Temp, 1)))

                  Else

                     Txt = Txt & " y " & Units(CInt(Right(Temp, 1))) 'if not divisible by 10, add the units

                  End If

               End If

            End If

         Else

            Txt = Txt & Units(CInt(Temp))       'this adds units to the hundreds

         End If

      End If

   End If

   If Temp = "1" Then

      Txt = Txt & " " & Left(Curr, Len(Curr) - 1)  'remove the "s" for just a single Euro

   Else

      Txt = Txt & " " & Curr

   End If

   Txt = Trim(Txt)         'remove surplus spaces before and after string

   Txt = UCase(Left(Txt, 1)) & Right(Txt, (Len(Txt) - 1))   'capitalise the first letter

   ConvertToWords = Txt    'return the string

End Function

↧

Command() - Unicode aware

December 22, 2013, 5:00 pm

≫ Next: [VB6] SNTPClient UserControl

≪ Previous: convert numbers to words (SPANISH)

Usually when you want to get the argument portion of the command line you use the intrinsic Command$() function.
But that function is not supporting unicode. In order to supply your .exe with a unicode command line it is necessary to use the "GetCommandLineW" and "PathGetArgsW" API.

Code:

Option Explicit

Private Declare Function GetCommandLine Lib "kernel32" Alias "GetCommandLineW" () As Long

Private Declare Function PathGetArgs Lib "shlwapi" Alias "PathGetArgsW" (ByVal lpszPath As Long) As Long

Private Declare Function SysReAllocString Lib "oleaut32" (ByVal pbString As Long, ByVal pszStrPtr As Long) As Long



' (VB-Overwrite)

Public Function Command() As String

If InIDE() = False Then

    SysReAllocString VarPtr(Command), PathGetArgs(GetCommandLine())

    Command = LTrim$(Command)

Else

    Command = VBA.Command$()

End If

End Function



Public Function InIDE(Optional ByRef B As Boolean = True) As Boolean

If B = True Then Debug.Assert Not InIDE(InIDE) Else B = True

End Function

↧

[VB6] SNTPClient UserControl

December 27, 2013, 10:34 am

≫ Next: VB6 - Web Service Calls via WinHTTP POST

≪ Previous: Command() - Unicode aware

This is a basic Simple Network Time protocol (SNTP) client UserControl based on a Winsock control that can be used to retrieve time from NIST Internet Time Servers or local NTP servers on your LAN.

It includes a 4 second "delay" to prevent overuse (minimum of 4.1 seconds between Query method calls) with an Unblock event to signal when another request can be made. See the NIST page linked above.

Since NTP servers return UTC (GMT) time, there is also a method to convert the UTC result returned through the Response event to local time. Response also returns the Source of the time as reported by the time server (if any). Typical values are listed in RFC 5905 as:

Code:

     +------+----------------------------------------------------------+

     | ID   | Clock Source                                             |

     +------+----------------------------------------------------------+

     | GOES | Geosynchronous Orbit Environment Satellite               |

     | GPS  | Global Position System                                   |

     | GAL  | Galileo Positioning System                               |

     | PPS  | Generic pulse-per-second                                 |

     | IRIG | Inter-Range Instrumentation Group                        |

     | WWVB | LF Radio WWVB Ft. Collins, CO 60 kHz                     |

     | DCF  | LF Radio DCF77 Mainflingen, DE 77.5 kHz                  |

     | HBG  | LF Radio HBG Prangins, HB 75 kHz                         |

     | MSF  | LF Radio MSF Anthorn, UK 60 kHz                          |

     | JJY  | LF Radio JJY Fukushima, JP 40 kHz, Saga, JP 60 kHz       |

     | LORC | MF Radio LORAN C station, 100 kHz                        |

     | TDF  | MF Radio Allouis, FR 162 kHz                             |

     | CHU  | HF Radio CHU Ottawa, Ontario                             |

     | WWV  | HF Radio WWV Ft. Collins, CO                             |

     | WWVH | HF Radio WWVH Kauai, HI                                  |

     | NIST | NIST telephone modem                                     |

     | ACTS | NIST telephone modem                                     |

     | USNO | USNO telephone modem                                     |

     | PTB  | European telephone modem                                 |

     +------+----------------------------------------------------------+

These are not particularly useful in most programs though.

The attached demo shows use of the SNTPClient control, which is included in the attached archive.