SAMPLES
!!! IMPORTANT NOTICE!!!
To use these samples works, Please consider to plug every components which should be plug within your form. For example : when you found list1.Clear in any lines of the samples, it means that you should have LISTBOX component pluged in your form.
Printing
Graphics
Network
DDE
ActiveX
FILES
Private Function FileExist(ByValue fName As string) As Boolean 'Checking If File Exist
FileExist = (Len(Dir(fName)) > 0) ' simple way on returning boolean
End Function
Private Sub WriteToFileTxt_Click()
Dim hFile As Integer
hFile = FreeFile ' get free file handle number
Open "File.Txt" For Output As #hFile
Write #hFile, "hello world", 1999
Close #hFile
End Sub
Private Sub ReadFromFileTxt_Click()
Dim hFile, vYear As Integer
Dim MyData As String
IF FileExist("File.Txt") Then
hFile = FreeFile ' get free file handle number
Open "File.Txt" For Input As #hFile
Do While Not EOF(hFile)
Input #hFile, MyData, vYear
Debug.Print MyData & vYear ' display data in debug window
Loop
Close #hFile
Else
MsgBox "File Not Exist !"
End IF
End Sub
Private Sub WriteToFileBin_Click()
Dim hFile As Integer
hFile = FreeFile ' get free file handle number
Open Fn For Binary Access Write As #hFile
Put #hFile, , b()
Close #hFile
End Sub
Private Sub ReadFromFileBin_Click()
Dim hFile As Integer
Dim vFileName As String
hFile = FreeFile ' get free file handle number
vFileName = "c:\command.com"
IF FileExist(vFileName) Then
Dim MyData(1024) As Byte ' alocate 1024 bytes to read !
Open vFileName For Binary Access Read As #hFile
Get #hFile, ,MyData
Close #hFile ' Close file.
End If
End Sub
Type Record ' Define user-defined type.
ID As Integer
Name As String * 20
End Type
Private Sub WriteToFileType_Click()
Dim hFile As Integer
hFile = FreeFile ' get free file handle number
Dim MyRecord As Record, RecordNumber ' Declare variables.
Open "File.Dat" For Random As #hFile Len = Len(MyRecord)
For RecordNumber = 1 To 5 ' Loop 5 times.
MyRecord.ID = RecordNumber ' Define ID.
MyRecord.Name = "My Name" & RecordNumber ' Create a string.
Put #hFile, RecordNumber, MyRecord ' Write record to file.
Next RecordNumber
Close #hFile ' Close file.
End Sub
Private Sub ReadFromFileType_Click()
Dim hFile As Integer
hFile = FreeFile ' get free file handle number
Dim MyRecord As Record, Position ' Declare variables.
Position =3
Open "File.Dat" For Random As #hFile Len = Len(MyRecord)
Get #hFile, Position, MyRecord ' Read third record.
Close #hFile ' Close file.
End Sub
Option Explicit
Private Declare Function tapiRequestMakeCall& Lib "TAPI32.DLL" (ByVal DestAddress$, ByVal AppName$, ByVal CalledParty$, ByVal Comment$)
Private Const TAPIERR_NOREQUESTRECIPIENT = -2&
Private Const TAPIERR_REQUESTQUEUEFULL = -3&
Private Const TAPIERR_INVALDESTADDRESS = -4&
Private Sub cmdDial_Click()
Dim buff As String
Dim nResult As Long
Dim txtNumber As String
txtNumber = "32323211" ' Put the number to Dial Here
'Invoke tapiRequestMakeCall. If tapiRequestMakeCall returns 0, the
'request has been accepted. It is up to the call manager application
'to do any further work. The second-to-last argument should be
'changed to be the name of the person you are dialing.
nResult = tapiRequestMakeCall&(Trim$(txtNumber), CStr(Caption), "Test Dial", "")
'Display message if error
If nResult <> 0 Then
buff = "Error dialing number : "
Select Case nResult
Case TAPIERR_NOREQUESTRECIPIENT
buff = buff & "No Windows Telephony dialing application is running and none could be started."
Case TAPIERR_REQUESTQUEUEFULL
buff = buff & "The queue of pending Windows Telephony dialing requests is full."
Case TAPIERR_INVALDESTADDRESS
buff = buff & "The phone number is not valid."
Case Else
buff = buff & "Unknown error."
End Select
MsgBox buff
End If
End Sub
Usage :
LookForFiles "*.pas", "d:\luckdat\", True
For i = 1 To FoundFiles.Count
Debug.Print FoundFiles.Item(i)
Next
Implementation : (Put in a Modul)
Public Const MAX_PATH = 255
Public Const INVALID_HANDLE_VALUE = -1
Option Explicit
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal _
lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal _
hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type WIN32_FIND_DATA
FileAttributes As Long
CreationTime As FILETIME
LastAccessTime As FILETIME
LastWriteTime As FILETIME
FileSizeHigh As Long
FileSizeLow As Long
Reserved0 As Long
Reserved1 As Long
FileName As String * 255
Alternate As String * 14
End Type
Global FoundFiles As New Collection
Sub LookForFiles(LookForFileName As String, startDir As String, Optional _
lookAtSubdirs As Boolean = False)
' Statics for less memory use in recursive procedure
Static fileData As WIN32_FIND_DATA
Dim hFiles As Long, f As Boolean
If startDir = Empty Then
startDir = CurDir$
End If
If LookForFileName <> "*.*" Then
hFiles = FindFirstFile(startDir & LookForFileName, fileData)
f = (hFiles <> INVALID_HANDLE_VALUE)
Do While f
fileData.FileName = CleanUp(fileData.FileName)
FoundFiles.Add Trim(startDir & fileData.FileName)
f = FindNextFile(hFiles, fileData)
Loop
f = FindClose(hFiles)
End If
' Find first file (get handle to find)
hFiles = FindFirstFile(startDir & "*.*", fileData)
f = (hFiles <> INVALID_HANDLE_VALUE)
Do While f
' Skip . and ..
If Left$(fileData.FileName, 1) <> "." Then
fileData.FileName = CleanUp(fileData.FileName)
If (fileData.FileAttributes And vbDirectory) Then
' Call recursively on each directory
If lookAtSubdirs Then
LookForFiles LookForFileName, (Trim(startDir) & _
Trim(fileData.FileName)) & "\", True
End If
Else
If LookForFileName = "*.*" Then
FoundFiles.Add Trim(startDir & fileData.FileName)
End If
End If
End If
' Keep looping until no more files
f = FindNextFile(hFiles, fileData)
Loop
f = FindClose(hFiles)
' Return the matching files in collection
End Sub
Function CleanUp(CheckStr As String) As String
Dim BadChar As Integer
Dim X As Integer
For X = 1 To Len(CheckStr)
If Mid(CheckStr, X, 1) < " " Then
BadChar = X
X = Len(CheckStr)
End If
Next X
CleanUp = Mid(CheckStr, 1, BadChar - 1)
End Function
Usage :
MsgBox "Window Directory : " & GetWindowsDir()
Implementation : (Put in a modul)
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Function GetWindowsDir() As String
' Calls the windows API to get the windows directory
Dim Temp$, x As Integer
Temp$ = String$(145, 0) ' Size Buffer
x = GetWindowsDirectory(Temp$, 145) ' Make API Call
Temp$ = Left$(Temp$, x) ' Trim Buffer
If Right$(Temp$, 1) <> "\" Then ' Add \ if necessary
GetWindowsDir$ = Temp$ + "\"
Else
GetWindowsDir$ = Temp$
End If
End Function
Usage :
FloatingWindow (Form2.hwnd), (Me.hwnd)
Implementation : (Put in a modul)
Declare Function SetWindowWord Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal wNewWord As Long) As Long
Sub FloatingWindow(FrmChildhWnd%, FrmParenthWnd%)
Call SetWindowWord(FrmChildhWnd%, -8, FrmParenthWnd%)
End Sub
Usage :
MsgBox "Win Version : " & GetWindowsVersion()
Implementation :
Declare Function GetVersion Lib "kernel32" Alias "GetVersion" () As Long
Function MakeNybble(HexCharacter As String)
' This routine is called from the GetWindowsVersion routine
Select Case Left$(HexCharacter, 1)
Case "0": MakeNybble = "0000"
Case "1": MakeNybble = "0001"
Case "2": MakeNybble = "0010"
Case "3": MakeNybble = "0011"
Case "4": MakeNybble = "0100"
Case "5": MakeNybble = "0101"
Case "6": MakeNybble = "0110"
Case "7": MakeNybble = "0111"
Case "8": MakeNybble = "1000"
Case "9": MakeNybble = "1001"
Case "A": MakeNybble = "1010"
Case "B": MakeNybble = "1011"
Case "C": MakeNybble = "1100"
Case "D": MakeNybble = "1101"
Case "E": MakeNybble = "1110"
Case "F": MakeNybble = "1111"
End Select
End Function
Function DecimalValue(BinaryByte As String) As Integer
' This routine is called from the GetWindowsVersion routine
Dim x As Integer
Dim v As Integer
Dim TempVal As Integer
v = 128
For x = 1 To 8
If Mid$(BinaryByte, x, 1) = "1" Then TempVal = TempVal + v
v = v / 2
Next x
DecimalValue = TempVal
End Function
Function GetWindowsVersion() As String
' This routine determines what version of Windows is being used
' This routine also requires the following two functions:
' MakeNybble()
' DecimalValue()
Dim x As Long
Dim y As String
Dim z As Integer
Dim T As String
Dim HN As String
Dim LN As String
x = GetVersion()
x = x - 117440512 ' Don't need High Word returned for Windows version
T = Hex$(x) ' Make the numeric value a Hexadecimal string
y = Str$(Val(Right$(T, 2))) + "." ' Hold the Major release # (ie 3.xx)
HN = MakeNybble(Left$(T, 1))
LN = MakeNybble(Mid$(T, 2, 1))
z = DecimalValue(HN + LN)
If z = 95 Then
GetWindowsVersion = "Windows 95"
Else
GetWindowsVersion = "Windows " + y + Trim$(Str$(z))
End If
End Function
Usage:
MsgBox "Windows Syste Dir : " & GetSystemDir()
Implementation: (Put in a modul)
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Function GetSystemDir()
Dim Sys As String * 256
Dim x As Integer
x = GetSystemDirectory(Sys, Len(Sys))
x = InStr(1, Sys, Chr$(0))
GetSystemDir = Left$(Sys, InStr(Sys, Chr$(0)) - 1)
End Function
Usage :
CreateProgManGroup Me, "VB Library", GetWindowsDir()
Implementation : (Put in a modul)
Sub CreateProgManGroup(x As Form, GroupName$, GroupPath$)
'-------------------------------------------------------------
' Procedure: CreateProgManGroup
' Arguments: X The Form where a Label1 exist
' GroupName$ A string that contains the group name
' GroupPath$ A string that contains the group file
' name ie 'myapp.grp'
'-------------------------------------------------------------
Dim i%, z%
Screen.MousePointer = 11
'----------------------------------------------------------------------
' Windows requires DDE in order to create a program group and item.
' Here, a Visual Basic label control is used to generate the DDE messages
'----------------------------------------------------------------------
On Error Resume Next
'--------------------------------
' Set LinkTopic to PROGRAM MANAGER
'--------------------------------
x.Label1.LinkTopic = "ProgMan|Progman"
x.Label1.LinkMode = 2
For i% = 1 To 10 ' Loop to ensure that there is enough time to
z% = DoEvents() ' process DDE Execute. This is redundant but needed
Next ' for debug windows.
x.Label1.LinkTimeout = 100
'---------------------
' Create program group
'---------------------
x.Label1.LinkExecute "[CreateGroup(" + GroupName$ + Chr$(44) + GroupPath$ + ")]"
'-----------------
' Reset properties
'-----------------
x.Label1.LinkTimeout = 50
x.Label1.LinkMode = 0
Screen.MousePointer = 0
End Sub
Usage :
CreateProgManItem Me, App.Path + "\library", "VB Library"
Implementation : ( Put in a modul)
Sub CreateProgManItem(x As Form, CmdLine$, IconTitle$)
'----------------------------------------------------------
' Procedure: CreateProgManItem
'
' Arguments: X The form where Label1 exists
'
' CmdLine$ A string that contains the command
' line for the item/icon.
' ie 'c:\myapp\setup.exe'
'
' IconTitle$ A string that contains the item's
' caption
'----------------------------------------------------------
Dim i%, z%
Screen.MousePointer = 11
'----------------------------------------------------------------------
' Windows requires DDE in order to create a program group and item.
' Here, a Visual Basic label control is used to generate the DDE messages
'----------------------------------------------------------------------
On Error Resume Next
'---------------------------------
' Set LinkTopic to PROGRAM MANAGER
'---------------------------------
x.Label1.LinkTopic = "ProgMan|Progman"
x.Label1.LinkMode = 2
For i% = 1 To 10 ' Loop to ensure that there is enough time to
z% = DoEvents() ' process DDE Execute. This is redundant but needed
Next ' for debug windows.
x.Label1.LinkTimeout = 100
'------------------------------------------------
' Create Program Item, one of the icons to launch
' an application from Program Manager
'------------------------------------------------
x.Label1.LinkExecute "[AddItem(" + CmdLine$ + Chr$(44) + IconTitle$ + Chr$(44) + ",,)]"
'-----------------
' Reset properties
'-----------------
x.Label1.LinkTimeout = 50
x.Label1.LinkMode = 0
Screen.MousePointer = 0
End Sub