How to sort the text file

May 1st, 2009

Here is the vb6 code to sort the text file:

Option Explicit
Option Compare Text

Public Sub SortTextFile(pstrFile As String)
   Dim strLine() As String

   strLine = Split(LoadFileToString(pstrFile), vbNewLine)
   QuickSort1 strLine
   SaveStringToFile Join(strLine, vbNewLine), pstrFile
End Sub

Public Function LoadFileToString(pstrFile As String) As String
   Dim bytArray() As Byte
   Dim strReturn as String
   Dim FileNumber As Long

   FileNumber = FreeFile
   Open pstrFile For Binary Access Read As #FileNumber
   ReDim bytArray(LOF(FileNumber) - 1)
   Get #FileNumber, 1, bytArray
   Close #FileNumber
   strReturn = StrConv(bytArray, vbUnicode)
   Erase bytArray
   Do While Instr(strReturn, vbNewLine & vbNewline)
       strReturn = Replace(strReturn, vbNewLine & vbNewline, vbNewLine)
   Loop
   Do While Right(strReturn, 2) = vbNewLine
       strReturn = Left(strReturn, Len(strReturn) - 2)
   Loop
   LoadFileToString = strReturn
End Function

Public Sub SaveStringToFile(pstrText As String, pstrFile As String)
   Dim FileNumber As Long

   If Len(Dir(pstrFile)) Then Kill pstrFile
   FileNumber = FreeFile()
   Open pstrFile For Output As #FileNumber
   Print #FileNumber, pstrText
   Close
End Sub

' Omit plngLeft & plngRight; they are used internally during recursion
Public Sub QuickSort1(ByRef pvarArray As Variant, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
   Dim lngFirst As Long
   Dim lngLast As Long
   Dim varMid As Variant
   Dim varSwap As Variant

   If plngRight = 0 Then
       plngLeft = LBound(pvarArray)
       plngRight = UBound(pvarArray)
   End If
   lngFirst = plngLeft
   lngLast = plngRight
   varMid = pvarArray((plngLeft + plngRight) \ 2)
   Do
       Do While pvarArray(lngFirst) < varMid And lngFirst < plngRight
           lngFirst = lngFirst + 1
       Loop
       Do While varMid < pvarArray(lngLast) And lngLast > plngLeft
           lngLast = lngLast - 1
       Loop
       If lngFirst <= lngLast Then
           varSwap = pvarArray(lngFirst)
           pvarArray(lngFirst) = pvarArray(lngLast)
           pvarArray(lngLast) = varSwap
           lngFirst = lngFirst + 1
           lngLast = lngLast - 1
       End If
   Loop Until lngFirst > lngLast
   If plngLeft < lngLast Then QuickSort1 pvarArray, plngLeft, lngLast
   If lngFirst < plngRight Then QuickSort1 pvarArray, lngFirst, plngRight
End Sub

'How to use this routine:
'call SortTextFile ("C:\Temp\testFile.txt")

How to pause/sleep the application for the given number of milliseconds

January 5th, 2009
'System & API - How to pause/sleep the application for the given number of milliseconds
Option Explicit

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Sub Pause(ByVal seconds As Single)
    Call Sleep(Int(seconds * 1000#))
End Sub

How to Draw Rotated Text directly on Screen

January 5th, 2009
'Graphics - How to Draw Rotated Text directly on Screen

Option Explicit

'Add a Text Box and a Command Button to your form.

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, _
    ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Const TRANSPARENT = 1
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor& Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long)
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT)
Const LF_FACESIZE = 32
Const OUT_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const DEFAULT_CHARSET = 1
Const FF_DONTCARE = 0
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type

Private Sub Command1_Click()
    Dim ldc As Long
    ldc = GetDC(0)
    DrawWithFont ldc, Text1.text
End Sub

Private Sub DrawWithFont(ldc As Long, sMessage As String)
    Dim FontToUse As Long
    Dim lf As LOGFONT
    Dim dl&, x%, ByteArrayLimit&, oldhdc&
    Dim TempByteArray() As Byte
    With lf
        'height of the text
        .lfHeight = 90
        'width of the text
        .lfWidth = 90
        'rotation angle
        .lfEscapement = 600
        'thickness of the text
        .lfWeight = 400
        .lfOutPrecision = OUT_DEFAULT_PRECIS
        .lfClipPrecision = OUT_DEFAULT_PRECIS
        .lfQuality = DEFAULT_QUALITY
        .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
        .lfCharSet = DEFAULT_CHARSET
    End With
    TempByteArray = StrConv("Arial" & Chr$(0), vbFromUnicode)
    ByteArrayLimit = UBound(TempByteArray)
    For x% = 0 To ByteArrayLimit
        lf.lfFaceName(x%) = TempByteArray(x%)
    Next x%
    FontToUse = CreateFontIndirect(lf)
    If FontToUse = 0 Then Exit Sub
    oldhdc = SelectObject(ldc, FontToUse)
    SetTextColor ldc, vbRed
    SetBkMode ldc, TRANSPARENT
    TextOut ldc, 300, 600, sMessage, Len(sMessage)
    oldhdc = SelectObject(ldc, FontToUse)
    SelectObject ldc, oldhdc
End Sub

How to list all sub directories in a given directory

January 5th, 2009
'File/Folder Handling - How to list all sub directories in a given directory
Public Function GetDirectories(path As String, Optional Attributes As VbFileAttribute, _
    Optional IncludePath As Boolean) As String()
    Dim result() As String
    Dim DirName As String, lngCount As Long, Path2 As String
    Const ALLOC_CHUNK = 50
    ReDim result(ALLOC_CHUNK) As String
    ' Build the path name + backslash.
    Path2 = path
    If Right$(Path2, 1) <> "\" Then Path2 = Path2 & "\"
    DirName = Dir$(Path2 & "*.*", vbDirectory Or Attributes)
    Do While Len(DirName)
        If DirName = "." Or DirName = ".." Then
            ' Exclude the "." and ".." entries.
        ElseIf (GetAttr(Path2 & DirName) And vbDirectory) = 0 Then
            ' This is a regular file.
        Else
            ' This is a directory.
            lngCount = lngCount + 1
            If lngCount > UBound(result) Then
                ' Resize the result array if necessary.
                ReDim Preserve result(lngCount + ALLOC_CHUNK) As String
            End If
            ' Include the path if requested.
            If IncludePath Then DirName = Path2 & DirName
            result(lngCount) = DirName
        End If
        DirName = Dir$
    Loop
    ' Trim the result array.
    ReDim Preserve result(lngCount) As String
    GetDirectories = result
End Function

'How can I call this function
'Sub ListAllDirectories()
'    Dim results() As String
'    Dim intCount As Integer
'    results = GetDirectories("C:\Temp")
'    For intCount = LBound(results) To UBound(results)
'        Debug.Print results(intCount)
'    Next intCount
'End Sub

How to return the create date/time, last accessed date/time, last modified date/time of a given file

January 5th, 2009
'System & API - How to return the create date/time, last accessed date/time, last modified date/time of a given file
Option Explicit

Private Type FileTime
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FileTime, _
    lpLastAccessTime As FileTime, lpLastWriteTime As FileTime) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FileTime, _
    lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FileTime, _
    lpLocalFileTime As FileTime) As Long

Public Sub FileDateTime(strFileName As String)
    'This function returns create date and time of the given file.
    Dim lngHandle As Long
    Dim Ft1 As FileTime, Ft2 As FileTime, Ft3 As FileTime, Ft4 As FileTime, SysTime As SYSTEMTIME
    'Open the file
    lngHandle = CreateFile(strFileName, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
    'Get the file time
    GetFileTime lngHandle, Ft1, Ft2, Ft3

    'Convert the file time to the local file time
    FileTimeToLocalFileTime Ft1, Ft4
    'Convert the file time to system file time
    FileTimeToSystemTime Ft4, SysTime
    Debug.Print "Date Created       : " & Str$(SysTime.wMonth) & "/" & LTrim(Str$(SysTime.wDay)) & "/" & LTrim(Str$(SysTime.wYear)) & " " & Str$(SysTime.wHour) & ":" & LTrim(Str$(SysTime.wMinute)) & ":" & LTrim(Str$(SysTime.wSecond))

    'Convert the file time to the local file time
    FileTimeToLocalFileTime Ft3, Ft4
    'Convert the file time to system file time
    FileTimeToSystemTime Ft4, SysTime
    Debug.Print "Date Last Modified : " & Str$(SysTime.wMonth) & "/" & LTrim(Str$(SysTime.wDay)) & "/" & LTrim(Str$(SysTime.wYear)) & " " & Str$(SysTime.wHour) & ":" & LTrim(Str$(SysTime.wMinute)) & ":" & LTrim(Str$(SysTime.wSecond))

    'Convert the file time to the local file time
    FileTimeToLocalFileTime Ft2, Ft4
    'Convert the file time to system file time
    FileTimeToSystemTime Ft4, SysTime
    Debug.Print "Date Last Accessed : " & Str$(SysTime.wMonth) & "/" & LTrim(Str$(SysTime.wDay)) & "/" & LTrim(Str$(SysTime.wYear)) & " " & Str$(SysTime.wHour) & ":" & LTrim(Str$(SysTime.wMinute)) & ":" & LTrim(Str$(SysTime.wSecond))

    'Close the file
    CloseHandle lngHandle
End Sub

'How can I call this sub-routine:
'Call FileDateTime("C:\Temp\Test.txt")
'Returns:
'Date Created       :  3/24/2007  9:19:28
'Date Last Modified :  1/9/2007  14:57:10
'Date Last Accessed :  3/25/2007  2:27:8