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")
Tags: sort text file, vb6 code, vb6 code to sort text file
Posted in Text File Handling | 1 Comment »
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
Tags: active x code, activex project, application, given, how to database, how to visual basic 6, milliseconds, number, pause, sleep, System & API, visual basic 6 source codes, visual basic 6 tutorials, visual basic 6.0 source code, visual basic net, visual basic net help, visual basic tools
Posted in System & API | 1 Comment »
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
Tags: activex 6.0, beginner, component visual basic 6, database programming, directly, draw, Graphics, how to programs, microsoft visual basic application, rotated, screen, source, text, vb6, vb6 freeware, visual basic net code
Posted in Graphics | No Comments »
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
Tags: activex application, class, code visual basic, directories, directory, File/Folder Handling, functions, given, how to library, how to visual basic, list, ocx programming, programming, sample code library, sub, visual basic net
Posted in File/Folder Handling | No Comments »
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
Tags: accessed, create, Database, date, file, given, last, modified, program, return, subroutine, System & API, time, tips, tutorial, vb learn, visual basic, visual basic net source code, visual basics
Posted in System & API | No Comments »