This is an excerpt of a Visual Basic program I wrote for a class project.
The program is an image viewer utility that displays a thumbnail of the
image, file details, and saves user preferences to the registry with an
easily re-usable class module.
Option Explicit
Public strPicPath As String 'holds the path of the picture to be displayed in frmDisplayImage
Dim FSO As FileSystemObject
Public Sub ListPicFiles()
On Error GoTo ErrTrap
Dim oFolder As Folder
ClearStuff 'calls the subroutine that clears the various controls
Set oFolder = FSO.GetFolder(dirFolderList.Path)
Search oFolder 'calls the Search subroutine, passing the current folder path
Set oFolder = Nothing 'when done, kill it
Exit Sub
ErrTrap:
WriteToLog 6, Err.Number, Err.Description
Resume Next
End Sub
Sub Search(oParentFolder As Folder)
On Error GoTo ErrTrap
Dim oFile As File
Dim i As Integer
'these check for image files in the selected folder
For Each oFile In oParentFolder.Files 'if found, puts it into the file list
If PicOptions.PicBmp = True Then 'if the user checked the file type in 'Options'
If LCase$(Right$(oFile.Path, 3)) = "bmp" Then 'compares the file extention to the constant
lstPics.AddItem oFile.ShortName 'that file is added to the listbox
End If
End If
If PicOptions.PicJpg = True Then 'if the user checked the file type in 'Options'
If LCase$(Right$(oFile.Path, 3)) = "jpg" Then 'compares the file extention to the constant
lstPics.AddItem oFile.ShortName 'that file is added to the listbox
End If
End If
If PicOptions.PicGif = True Then 'if the user checked the file type in 'Options'
If LCase$(Right$(oFile.Path, 3)) = "gif" Then 'compares the file extention to the constant
lstPics.AddItem oFile.ShortName 'that file is added to the listbox
End If
End If
Next
If lstPics.ListCount >= 1 Then ToggleMenu True 'if there were any images, call the subroutine that 'sets the condition of the menu and button items
Exit Sub
ErrTrap:
WriteToLog 7, Err.Number, Err.Description
Resume Next
End Sub
Private Sub cmdClose_Click()
On Error GoTo ErrTrap
Unload Me
Exit Sub
ErrTrap:
WriteToLog 8, Err.Number, Err.Description
Resume Next
End Sub
Private Sub dirFolderList_Change()
'this subroutine is called when the user selects a folder to look for images
On Error GoTo ErrTrap
ClearStuff 'this calls the subroutine that clears the varous controls
RememberFolder FSO.GetAbsolutePathName(dirFolderList.Path) 'this saves the current folder into the registry
ListPicFiles 'this calls the subroutine that starts the image searching
Exit Sub
ErrTrap:
WriteToLog 9, Err.Number, Err.Description
Resume Next
End Sub
Private Sub RememberFolder(CurrentFolder As String)
On Error GoTo ErrTrap
PicOptions.SaveFolder = CurrentFolder 'saves the current folder string to the user-type variable
Exit Sub
ErrTrap:
WriteToLog 10, Err.Number, Err.Description
Resume Next
End Sub
Private Sub drvDriveList_Change()
'this puts the user selected drive into the directory folder path
On Error GoTo ErrTrap
dirFolderList.Path = drvDriveList.Drive 'puts us on the right path
Exit Sub
ErrTrap:
Const strMessage As String = "Drive is not avaliable"
Dim intResponce As Integer
If Err.Number = 68 Then
intResponce = MsgBox(strMessage, vbRetryCancel + vbCritical, "PictureIT")
If intResponce = vbRetry Then
Resume
Else
drvDriveList.Drive = drvDriveList.List(1) 'make the A drive the default
End If
Else
intResponce = MsgBox(Err.Description, vbOKOnly + vbExclamation, "PictureIT")
intResponce = vbOKOnly
Resume Next
End If
WriteToLog 11, Err.Number, Err.Description
End Sub
Private Sub Form_Activate()
On Error GoTo ErrTrap
dirFolderList.Path = PicOptions.SaveFolder 'loads up the last folder we were in
Exit Sub
ErrTrap:
WriteToLog 12, Err.Number, Err.Description
Resume Next
End Sub
Private Sub Form_Load()
On Error GoTo ErrTrap
Set FSO = New FileSystemObject
Exit Sub
ErrTrap:
WriteToLog 14, Err.Number, Err.Description
Resume Next
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error GoTo ErrTrap
SaveUserSettings 'saves current settings to the registry
Unload frmDisplayImage
Unload frmOptions
Unload frmSplash
Exit Sub
ErrTrap:
WriteToLog 15, Err.Number, Err.Description
Resume Next
End Sub
Private Sub RightMousePopUp(theButton As Integer) 'this is called whenever a right mouse click is made
On Error GoTo ErrTrap
If theButton = vbRightButton Then 'brings up the PopUp menu
DeleteEnable
PopupMenu mnuPopUp
End If
Exit Sub
ErrTrap:
WriteToLog 13, Err.Number, Err.Description
Resume Next
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RightMousePopUp Button
End Sub
Private Sub fraDrive_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RightMousePopUp Button
End Sub
Private Sub fraFile_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RightMousePopUp Button
End Sub
Private Sub fraFolder_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RightMousePopUp Button
End Sub
Private Sub fraPreview_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RightMousePopUp Button
End Sub
Private Sub imgPreview_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RightMousePopUp Button
End Sub
Private Sub lblDetails_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RightMousePopUp Button
End Sub
Private Sub lstPics_DblClick()
DisplayImage
End Sub
Private Sub lstPics_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RightMousePopUp Button
End Sub
Private Sub dirFolderList_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RightMousePopUp Button
End Sub
Private Sub imgPreview_DblClick()
On Error GoTo ErrTrap
DisplayImage 'if the user double clicks on the preview image, the subroutine that
Exit Sub 'displays the full size image is called
ErrTrap:
WriteToLog 16, Err.Number, Err.Description
Resume Next
End Sub
Private Sub lstPics_Click()
On Error GoTo ErrTrap
ShowPhoto 'calls the subroutine that displays the Preview Image
FileDetails 'calls the subroutine that displays the file details
Exit Sub
ErrTrap:
WriteToLog 17, Err.Number, Err.Description
Resume Next
End Sub
Private Sub ShowPhoto()
On Error GoTo ErrTrap 'displays the Preview Image that is selected in the Picture List
imgPreview.Picture = LoadPicture(FSO.GetAbsolutePathName(dirFolderList.Path) & "\" & lstPics.Text)
strPicPath = FSO.GetAbsolutePathName(dirFolderList.Path) & "\" & lstPics.Text
Exit Sub
ErrTrap:
WriteToLog 18, Err.Number, Err.Description
Resume Next
End Sub
Public Sub ToggleMenu(Toggle As Boolean) 'this subroutine enables or disables various menu items
On Error GoTo ErrTrap
mnuFileDeleteFile.Enabled = Toggle
mnuDisplayImage.Enabled = Toggle
mnuPopDeleteFile.Enabled = Toggle
Me.tbImage.Buttons("display").Enabled = Toggle
Exit Sub
ErrTrap:
WriteToLog 19, Err.Number, Err.Description
Resume Next
End Sub
Private Sub mnuDisplayImage_Click() 'drop down menu item
DisplayImage
End Sub
Private Sub mnuFile_Click()
DeleteEnable
End Sub
Private Sub mnuFileDeleteFile_Click() 'drop down menu item
DeleteFile
End Sub
Private Sub mnuFileDisplay_Click() 'drop down menu item
DisplayImage
End Sub
Private Sub mnuFileExit_Click() 'drop down menu item
Unload Me
End Sub
Private Sub mnuOptionsUser_Click() 'drop down menu item
ShowOptions
End Sub
Private Sub mnuPopDeleteFile_Click() 'pop-up menu item
DeleteFile
End Sub
Private Sub mnuPopOptions_Click() 'pop-up menu item
ShowOptions
End Sub
Private Sub ClearStuff() 'this subroutine clears the various controls
On Error GoTo ErrTrap
imgPreview = Nothing
lstPics.Clear
lblDetails.Caption = ""
Exit Sub
ErrTrap:
WriteToLog 20, Err.Number, Err.Description
Resume Next
End Sub
Private Sub FileDetails() 'this subroutine displays details about the selected inage file
On Error GoTo ErrTrap
Dim ThisFile As File
Set ThisFile = FSO.GetFile(dirFolderList.Path & "\" & lstPics.Text)
If PicOptions.Details = True Then 'if the user wants to see the details
lblDetails.Visible = True
lblDetails.Caption = "CREATED: " & vbNewLine & _
" " & ThisFile.DateCreated & _
vbNewLine & _
"LAST ACCESSED: " & vbNewLine & _
" " & ThisFile.DateLastAccessed & _
vbNewLine & _
"LAST MODIFIED: " & vbNewLine & _
" " & ThisFile.DateLastModified & _
vbNewLine & _
"SIZE: " & vbNewLine & _
" " & ThisFile.Size & " bytes" & _
vbNewLine & _
"PATH: " & vbNewLine & _
" " & ThisFile.Path & _
vbNewLine & _
"FILE NAME: " & vbNewLine & _
" " & ThisFile.ShortName
Else: lblDetails.Visible = False 'or not
End If
Set ThisFile = Nothing 'make it & break it
Exit Sub
ErrTrap:
WriteToLog 21, Err.Number, Err.Description
Resume Next
End Sub
Private Sub DeleteFile() 'this subroutine allows the user to delete a file from the picture list box
On Error GoTo ErrTrap
Dim result As Integer
DeleteEnable
result = MsgBox("Do you want to delete this file? " & (dirFolderList.Path & "\" & lstPics.Text), vbOKCancel, "PictureIT")
If result = vbOK Then
FSO.DeleteFile (dirFolderList.Path & "\" & lstPics.Text)
lstPics.RemoveItem (lstPics.ListIndex)
imgPreview = Nothing
lblDetails.Caption = ""
End If
Exit Sub
ErrTrap:
WriteToLog 22, Err.Number, Err.Description
Resume Next
End Sub
Private Sub DisplayImage() 'this displays the selected image in a larger size
On Error GoTo ErrTrap
Me.Hide
frmDisplayImage.Show vbModal
Exit Sub
ErrTrap:
WriteToLog 23, Err.Number, Err.Description
Resume Next
End Sub
Private Sub ShowOptions()
frmOptions.Show vbModal 'displays the option form
End Sub
Private Sub tbImage_ButtonClick(ByVal Button As MSComctlLib.Button)
On Error GoTo ErrTrap
Select Case Button.Key 'this checks which tool bar button was clicked
Case "display"
DisplayImage
Case "options"
ShowOptions
End Select
Exit Sub
ErrTrap:
WriteToLog 24, Err.Number, Err.Description
Resume Next
End Sub
Private Sub DeleteEnable()
'this checks if anything was selected in the file list
If lstPics.SelCount <= 0 Then
mnuFileDeleteFile.Enabled = False
mnuPopDeleteFile.Enabled = False
Else
mnuFileDeleteFile.Enabled = True
mnuPopDeleteFile.Enabled = True
End If
End Sub
'clsRegistrySave*****************************************************************************
Option Explicit
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
'the API calls
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" _
(ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, _
ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, _
lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'the Constants the API calls need...
Private Const HKEY_CURRENT_USER = &H80000001
Private Const KEY_WRITE = &H20006
Private Const REG_SZ = 1
Private Const KEY_READ = &H20019
Private Const ERROR_SUCCESS = 0&
Private m_strRegistryKey As String 'this holds the string that is used for creating the subkey
Public Function ReadSettingsFromRegistry(strRegistryName As String) As String
'the value sent in holds the Key Name to the data stored in the registry
Dim hKey As Long 'receives handle to the registry key
Dim SubKey As String 'holds the name of the subkey to create or open
Dim NewOrUsed As Long 'receives flag for if the key was created or opened
Dim RetVal As Long 'return value from the API calls - whether the calls were sucessful or not
Dim strData As String 'receives data read from the registry
Dim datatype As Long 'receives data type of read value
Dim sLength As Long 'receives length of returned data
Dim SecAtt As SECURITY_ATTRIBUTES 'well we all know what this is (it didn't like being just 0&)
SubKey = m_strRegistryKey 'set the name of the new key
'create or open the registry key
RetVal = RegCreateKeyEx(HKEY_CURRENT_USER, SubKey, 0, "", 0, KEY_READ, SecAtt, hKey, NewOrUsed)
If RetVal <> ERROR_SUCCESS Then 'if it didn't work...
Debug.Print "ERROR: ReadSettingsFromRegistry - Unable to open the registry key!"
Exit Function
End If
strData = Space(100) 'make room in the buffer to receive the incoming data.
sLength = 100
'read the value from the registry key.
RetVal = RegQueryValueEx(hKey, strRegistryName, 0, datatype, ByVal strData, sLength)
If RetVal <> ERROR_SUCCESS Then 'if it didn't work...
Debug.Print "ERROR: ReadSettingsFromRegistry - Unable to query the registry key!"
Exit Function
End If
RetVal = RegCloseKey(hKey) 'close the registry key.
If RetVal <> ERROR_SUCCESS Then 'if it didn't work...
Debug.Print "ERROR: ReadSettingsFromRegistry - Unable to close the registry key!"
Exit Function
End If
strData = Left(strData, sLength) 'removes the empty space from the buffer
ReadSettingsFromRegistry = strData 'send the retreved information back from whence it came
End Function
Public Sub WriteSettingsToRegistry(strName As String, strWhatSaved As String)
Dim hKey As Long 'receives handle to the registry key
Dim SubKey As String 'name of the subkey to create or open
Dim NewOrUsed As Long 'receives flag for if the key was created or opened
Dim strData As String 'the string to put into the registry
Dim RetVal As Long 'return value
Dim SecAtt As SECURITY_ATTRIBUTES
SubKey = m_strRegistryKey 'the programmer supplied subkey string
'Open the registry key.
RetVal = RegCreateKeyEx(HKEY_CURRENT_USER, SubKey, 0, "", 0, KEY_WRITE, SecAtt, hKey, NewOrUsed)
If RetVal <> ERROR_SUCCESS Then 'if it didn't work...
Debug.Print "ERROR: WriteSettingsToRegistry - Unable to open the registry key!"
Exit Sub
End If
strData = strWhatSaved & vbNullChar 'the data to be written
RetVal = RegSetValueEx(hKey, strName, 0, REG_SZ, ByVal strData, Len(strData)) 'write the data
If RetVal <> ERROR_SUCCESS Then 'if it didn't work...
Debug.Print "ERROR: WriteSettingsToRegistry - Unable to write to the registry key!"
Exit Sub
End If
RetVal = RegCloseKey(hKey) 'close it all up
If RetVal <> ERROR_SUCCESS Then 'if it didn't work...
Debug.Print "ERROR: WriteSettingsToRegistry - Unable to close the registry key!"
Exit Sub
End If
End Sub
Public Property Let strRegistryKey(ByVal strNewKey As String)
'incoming string that holds the programmers registry subkey
m_strRegistryKey = strNewKey
End Property