MaXXSoFT
New member
Yedekleme Sihirbazı!
General Private Declare Function GetFileSize Lib "KERNEL32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function OpenFile Lib "KERNEL32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "KERNEL32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Const OFS_MAXPATHNAME = 128
Const OF_CREATE = &H1000
Const OF_READ = &H0
Const OF_WRITE = &H1
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260
Private Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type
Private Declare Function GetFileSize Lib "KERNEL32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function OpenFile Lib "KERNEL32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "KERNEL32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Const OFS_MAXPATHNAME = 128
Const OF_CREATE = &H1000
Const OF_READ = &H0
Const OF_WRITE = &H1
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260
Private Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Dim FileSize As Long
Dim action As Byte
Private Function FindDir() As String
On Error GoTo Handler
Dim iNull As Integer, lpIDList As Long, lResult As Long
Dim sPath As String, udtBI As BrowseInfo
With udtBI
'Set the owner window
.hwndOwner = Me.hwnd
'lstrcat appends the two strings and returns the memory address
.lpszTitle = lstrcat("C:\", "")
'Return only if the user selected a directory
.ulFlags = BIF_RETURNONLYFSDIRS
End With
'Show the 'Browse for folder' dialog
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
'Get the path from the IDList
SHGetPathFromIDList lpIDList, sPath
'free the block of memory
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
FindDir = sPath
Exit Function
Handler:
FindDir = ""
End Function
Private Sub cmdBackup_Click()
'This control uses zlib tool for backup purpose
On Error GoTo Handler
Dim handle As Long, lngLong As Long
Dim ofbuf As OFSTRUCT, DrvInfo As DriveInfo
Dim conServer As Connection
action = 0
Set DrvInfo = getDrives(1)
If Me.chkFormat.Value = vbChecked Then
If DrvInfo.DriveLetter = "A:\" Or DrvInfo.DriveLetter = "B:\" Then _
Call FormatDrive(0, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK, Me.hwnd)
End If
Me.ZlibTool1.InputFile = App.Path & "\Database\BengalB.mdb"
If Dir(Me.txtPath, vbDirectory) = "" Then
MsgBox "Invalid Backup Path", vbInformation, "Backup For Tea Manager"
Exit Sub
End If
'Hard disk Backup
Me.ZlibTool1.OutputFile = Me.txtPath & "\" & Format(Date, "d") & Format(Date, "mmm") & Format(Date, "yyyy") & ".Bkp"
Me.ZlibTool1.Compress
handle = OpenFile(Me.ZlibTool1.OutputFile, ofbuf, OF_READ)
FileSize = (GetFileSize(handle, lngLong) / 1024)
CloseHandle (handle)
'Floppy Backup Code
If Me.chkFolppy.Value = vbChecked Then
If DrvInfo.DriveType = Removable Then
If FileSize > ((DrvInfo.DriveSpace.TotalBytes * 10000) / 1024) Then
MsgBox "Floppy Backup Not Possible" & vbCrLf & _
"Backup File Size exceeds Total Size available on the Floppy" & vbCrLf & _
"Also Verify that there is Floppy in the Drive", vbInformation, "Backup Manager"
Exit Sub
ElseIf (FileSize > ((DrvInfo.DriveSpace.TotalFreeBytes * 10000) / 1024)) Then
MsgBox "There is not enough space on the Floppy " & vbCrLf & _
"Try creating space by deleting some items, or" & vbCrLf & _
"Check on Format Floppy to Format It Before taking Backup", vbInformation, "Backup Manager"
Exit Sub
End If
'Me.SProgressBar1.Value = 0
Me.ZlibTool1.OutputFile = DrvInfo.DriveLetter & Format(Date, "d") & Format(Date, "mmm") & Format(Date, "yyyy") & ".Bkp"
Me.ZlibTool1.Compress
Else
MsgBox "No Floppy Drives found on the System" & vbCrLf & _
"Please check that the Floppy Drive is Available" & vbCrLf & _
"Backup Manager is Bypassing Floppy Backup", vbInformation, "Backup Manager"
Exit Sub
End If
End If
'On Error Resume Next
Set conServer = New Connection
With conServer
.Provider = "Microsoft.Jet.OLEDB.3.51"
.ConnectionString = "Data Source=" & App.Path & "\Database\BengalB.mdb"
.Open
End With
conServer.Execute "Update BackupManager SET HardDiskPath='" & Me.txtPath & "', BackupDate='" & Format(Date & " " & Time, "dd/mmm/yyyy HH:MM:SS am/pm") & "'"
conServer.Close
Exit Sub
Handler:
MsgBox Err.Description
'Resume
Exit Sub
End Sub
Private Sub cmdBrowse_Click()
Dim str$
str = FindDir
If Not Len(str) = 0 Then
Me.txtPath = str
End If
End Sub
Private Sub cmdRestore_Click()
Dim strSPath, strTPath
action = 1
cmDlg.Filter = "Backup Files | *.bkp"
If Len(Me.txtPath) > 0 Then cmDlg.InitDir = Me.txtPath
cmDlg.DialogTitle = "Restore Database From Backup"
cmDlg.ShowOpen
strSPath = cmDlg.FileName
strTPath = FindDir
ZlibTool1.InputFile = strSPath
ZlibTool1.OutputFile = strTPath & "\BengalB.mdb"
ZlibTool1.Decompress
End Sub
Private Sub Form_Load()
On Error Resume Next
Dim OF As OFSTRUCT, lngHandle As Long, lngLong As Long
Me.txtBkDate = LookField("BackUpDate", "BackupManager", "", "None")
If IsDate(Me.txtBkDate) Then _
Me.txtBkDate = Format(Me.txtBkDate, "dd/mmm/yyyy HH:MM am/pm")
Me.txtPath = LookField("HardDiskPath", "BackupManager", "", "")
lngHandle = OpenFile(App.Path & "\Database\BengalB.mdb", OF, OF_READ)
Me.txtSize = str$(((GetFileSize(lngHandle, lngLong) / 1024) * 0.19)) & " KB"
CloseHandle (lngHandle)
End Sub
Private Sub ZlibTool1_Progress(ByVal percent_complete As Integer)
On Error Resume Next
Me.lblInfo.Caption = IIf(action = 0, "Taking Backup ", "Restoring Backup ") & "(" & percent_complete & "% Done)"
End Sub
Public Function LookField(FieldName$, Table$, Cond$, Optional OnErrVal = 0)
On Error GoTo Handler
Dim rst As Recordset
Dim conServer As Connection
Set conServer = New Connection
With conServer
.Provider = "Microsoft.Jet.OLEDB.3.51"
.ConnectionString = "Data Source=" & App.Path & "\Database\BengalB.mdb"
.Open
End With
Set rst = New Recordset
With rst
.ActiveConnection = conServer
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Open "SELECT " & FieldName & " FROM " & Table & IIf(Len(Cond) > 0, " WHERE " & Cond, "")
End With
If getRowsOk(rst) Then
rst.MoveFirst
LookField = rst.Fields(0)
Else
LookField = OnErrVal
End If
Exit Function
Handler:
LookField = OnErrVal
End Function
Public Function getRowsOk(ByVal rst As Recordset) As Boolean
On Error GoTo Handler
Dim varData
rst.MoveFirst
varData = rst.GetRows(1)
getRowsOk = True
Exit Function
Handler:
getRowsOk = False
Exit Function
End Function
Modül-1
Private Declare Function GetDiskFreeSpaceEx Lib "KERNEL32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long
Private Declare Function GetLogicalDrives Lib "KERNEL32" () As Long
Private Declare Function GetVolumeInformation Lib "KERNEL32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function GetDriveType Lib "KERNEL32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwndOwner As Long, ByVal iDrive As Long, ByVal iCapacity As Long, ByVal iFormatType As Long) As Long
Public Enum DriveTypeEnum
Removable = 2
FixedDrive = 3
Remote = 4
CDDrive = 5
RamDisk = 6
Unreconized = 0
End Enum
Public Enum FormatCapacityEnum
SHFD_CAPACITY_DEFAULT = 0 ' default drive capacity
SHFD_CAPACITY_360 = 3 ' 360KB, applies to 5.25" drives only
SHFD_CAPACITY_720 = 5 ' 720KB, applies to 3.5" drives only
End Enum
Public Enum FormatTypeEnum
SHFD_FORMAT_QUICK = 0 ' quick format
SHFD_FORMAT_FULL = 1 ' full format
SHFD_FORMAT_SYSONLY = 2 ' copies system files only (Win95 Only!)
End Enum
Public Function ListDrives() As Collection
On Error GoTo Handler
LDs = GetLogicalDrives
Set ListDrives = New Collection
For cnt = 0 To 25
If (LDs And 2 ^ cnt) <> 0 Then
ListDrives.Add Chr$(65 + cnt) & ":\"
End If
Next cnt
Exit Function
Handler:
Set ListDrives = Nothing
Exit Function
End Function
Public Function GetVolumeInfo(DriveName As String) As VolumeInfo
On Error Resume Next
Dim Serial As Long, VName As String, FSName As String
'Create buffers
VName = String$(255, Chr$(0))
FSName = String$(255, Chr$(0))
'Get the volume information
GetVolumeInformation DriveName, VName, 255, Serial, 0, 0, FSName, 255
'Strip the extra chr$(0)'s
VName = Left$(VName, InStr(1, VName, Chr$(0)) - 1)
FSName = Left$(FSName, InStr(1, FSName, Chr$(0)) - 1)
Set GetVolumeInfo = New VolumeInfo
With GetVolumeInfo
.FileSystem = FSName
.SerialNo = Serial
.VolumeName = VName
End With
End Function
Public Function getDriveSpace(DriveName As String) As DriveSpaceInfo
Dim r As Long, BytesFreeToCalller As Currency, TotalBytes As Currency
Dim TotalFreeBytes As Currency, TotalBytesUsed As Currency
'get the drive's disk parameters
Call GetDiskFreeSpaceEx(DriveName, BytesFreeToCalller, TotalBytes, TotalFreeBytes)
'show the results, multiplying the returned
'value by 10000 to adjust for the 4 decimal
'places that the currency data type returns.
Set getDriveSpace = New DriveSpaceInfo
getDriveSpace.TotalBytes = TotalBytes
getDriveSpace.TotalFreeBytes = TotalFreeBytes
getDriveSpace.BytesFreeToCaller = BytesFreeToCalller
getDriveSpace.TotalBytesUsed = (TotalBytes - TotalFreeBytes)
End Function
Public Function GetDriveTypes(DriveName As String) As DriveTypeEnum
GetDriveTypes = GetDriveType(DriveName)
End Function
Public Function getDriveInfo(DriveName As String) As DriveInfo
Set getDriveInfo = New DriveInfo
With getDriveInfo
Set .DriveSpace = getDriveSpace(DriveName)
.DriveType = GetDriveTypes(DriveName)
Set .DriveVolume = GetVolumeInfo(DriveName)
End With
End Function
Public Function getDrives() As Collection
Dim count As Integer
Dim DriveList As Collection
Dim drInfo As DriveInfo
Set DriveList = ListDrives
Set getDrives = New Collection
For count = 1 To DriveList.count
Set drInfo = getDriveInfo(CStr(DriveList.Item(count)))
drInfo.DriveNumber = count
drInfo.DriveLetter = CStr(DriveList(count))
getDrives.Add drInfo, CStr(DriveList(count))
Next
End Function
Public Sub FormatDrive(DriveNumber As Integer, FormatCapacity As FormatCapacityEnum, FormatType As FormatTypeEnum, hwnd As Long)
SHFormatDrive hwnd, DriveNumber, FormatCapacity, FormatType
End Sub
Class modül
İçerisindeki birinci modüle eklenecek kodlar
Modül-1
Public DriveSpace As DriveSpaceInfo
Public DriveType As DriveTypeEnum
Public DriveVolume As VolumeInfo
Public DriveNumber As Integer
Public DriveLetter As String
Modül-2
ublic BytesFreeToCaller As Currency
Public TotalBytes As Currency
Public TotalFreeBytes As Currency
Public TotalBytesUsed As Currency
Modül-3
Public SerialNo As Long
Public VolumeName As String
Public FileSystem As String
General Private Declare Function GetFileSize Lib "KERNEL32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function OpenFile Lib "KERNEL32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "KERNEL32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Const OFS_MAXPATHNAME = 128
Const OF_CREATE = &H1000
Const OF_READ = &H0
Const OF_WRITE = &H1
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260
Private Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type
Private Declare Function GetFileSize Lib "KERNEL32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function OpenFile Lib "KERNEL32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "KERNEL32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Const OFS_MAXPATHNAME = 128
Const OF_CREATE = &H1000
Const OF_READ = &H0
Const OF_WRITE = &H1
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260
Private Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Dim FileSize As Long
Dim action As Byte
Private Function FindDir() As String
On Error GoTo Handler
Dim iNull As Integer, lpIDList As Long, lResult As Long
Dim sPath As String, udtBI As BrowseInfo
With udtBI
'Set the owner window
.hwndOwner = Me.hwnd
'lstrcat appends the two strings and returns the memory address
.lpszTitle = lstrcat("C:\", "")
'Return only if the user selected a directory
.ulFlags = BIF_RETURNONLYFSDIRS
End With
'Show the 'Browse for folder' dialog
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
'Get the path from the IDList
SHGetPathFromIDList lpIDList, sPath
'free the block of memory
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
FindDir = sPath
Exit Function
Handler:
FindDir = ""
End Function
Private Sub cmdBackup_Click()
'This control uses zlib tool for backup purpose
On Error GoTo Handler
Dim handle As Long, lngLong As Long
Dim ofbuf As OFSTRUCT, DrvInfo As DriveInfo
Dim conServer As Connection
action = 0
Set DrvInfo = getDrives(1)
If Me.chkFormat.Value = vbChecked Then
If DrvInfo.DriveLetter = "A:\" Or DrvInfo.DriveLetter = "B:\" Then _
Call FormatDrive(0, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK, Me.hwnd)
End If
Me.ZlibTool1.InputFile = App.Path & "\Database\BengalB.mdb"
If Dir(Me.txtPath, vbDirectory) = "" Then
MsgBox "Invalid Backup Path", vbInformation, "Backup For Tea Manager"
Exit Sub
End If
'Hard disk Backup
Me.ZlibTool1.OutputFile = Me.txtPath & "\" & Format(Date, "d") & Format(Date, "mmm") & Format(Date, "yyyy") & ".Bkp"
Me.ZlibTool1.Compress
handle = OpenFile(Me.ZlibTool1.OutputFile, ofbuf, OF_READ)
FileSize = (GetFileSize(handle, lngLong) / 1024)
CloseHandle (handle)
'Floppy Backup Code
If Me.chkFolppy.Value = vbChecked Then
If DrvInfo.DriveType = Removable Then
If FileSize > ((DrvInfo.DriveSpace.TotalBytes * 10000) / 1024) Then
MsgBox "Floppy Backup Not Possible" & vbCrLf & _
"Backup File Size exceeds Total Size available on the Floppy" & vbCrLf & _
"Also Verify that there is Floppy in the Drive", vbInformation, "Backup Manager"
Exit Sub
ElseIf (FileSize > ((DrvInfo.DriveSpace.TotalFreeBytes * 10000) / 1024)) Then
MsgBox "There is not enough space on the Floppy " & vbCrLf & _
"Try creating space by deleting some items, or" & vbCrLf & _
"Check on Format Floppy to Format It Before taking Backup", vbInformation, "Backup Manager"
Exit Sub
End If
'Me.SProgressBar1.Value = 0
Me.ZlibTool1.OutputFile = DrvInfo.DriveLetter & Format(Date, "d") & Format(Date, "mmm") & Format(Date, "yyyy") & ".Bkp"
Me.ZlibTool1.Compress
Else
MsgBox "No Floppy Drives found on the System" & vbCrLf & _
"Please check that the Floppy Drive is Available" & vbCrLf & _
"Backup Manager is Bypassing Floppy Backup", vbInformation, "Backup Manager"
Exit Sub
End If
End If
'On Error Resume Next
Set conServer = New Connection
With conServer
.Provider = "Microsoft.Jet.OLEDB.3.51"
.ConnectionString = "Data Source=" & App.Path & "\Database\BengalB.mdb"
.Open
End With
conServer.Execute "Update BackupManager SET HardDiskPath='" & Me.txtPath & "', BackupDate='" & Format(Date & " " & Time, "dd/mmm/yyyy HH:MM:SS am/pm") & "'"
conServer.Close
Exit Sub
Handler:
MsgBox Err.Description
'Resume
Exit Sub
End Sub
Private Sub cmdBrowse_Click()
Dim str$
str = FindDir
If Not Len(str) = 0 Then
Me.txtPath = str
End If
End Sub
Private Sub cmdRestore_Click()
Dim strSPath, strTPath
action = 1
cmDlg.Filter = "Backup Files | *.bkp"
If Len(Me.txtPath) > 0 Then cmDlg.InitDir = Me.txtPath
cmDlg.DialogTitle = "Restore Database From Backup"
cmDlg.ShowOpen
strSPath = cmDlg.FileName
strTPath = FindDir
ZlibTool1.InputFile = strSPath
ZlibTool1.OutputFile = strTPath & "\BengalB.mdb"
ZlibTool1.Decompress
End Sub
Private Sub Form_Load()
On Error Resume Next
Dim OF As OFSTRUCT, lngHandle As Long, lngLong As Long
Me.txtBkDate = LookField("BackUpDate", "BackupManager", "", "None")
If IsDate(Me.txtBkDate) Then _
Me.txtBkDate = Format(Me.txtBkDate, "dd/mmm/yyyy HH:MM am/pm")
Me.txtPath = LookField("HardDiskPath", "BackupManager", "", "")
lngHandle = OpenFile(App.Path & "\Database\BengalB.mdb", OF, OF_READ)
Me.txtSize = str$(((GetFileSize(lngHandle, lngLong) / 1024) * 0.19)) & " KB"
CloseHandle (lngHandle)
End Sub
Private Sub ZlibTool1_Progress(ByVal percent_complete As Integer)
On Error Resume Next
Me.lblInfo.Caption = IIf(action = 0, "Taking Backup ", "Restoring Backup ") & "(" & percent_complete & "% Done)"
End Sub
Public Function LookField(FieldName$, Table$, Cond$, Optional OnErrVal = 0)
On Error GoTo Handler
Dim rst As Recordset
Dim conServer As Connection
Set conServer = New Connection
With conServer
.Provider = "Microsoft.Jet.OLEDB.3.51"
.ConnectionString = "Data Source=" & App.Path & "\Database\BengalB.mdb"
.Open
End With
Set rst = New Recordset
With rst
.ActiveConnection = conServer
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Open "SELECT " & FieldName & " FROM " & Table & IIf(Len(Cond) > 0, " WHERE " & Cond, "")
End With
If getRowsOk(rst) Then
rst.MoveFirst
LookField = rst.Fields(0)
Else
LookField = OnErrVal
End If
Exit Function
Handler:
LookField = OnErrVal
End Function
Public Function getRowsOk(ByVal rst As Recordset) As Boolean
On Error GoTo Handler
Dim varData
rst.MoveFirst
varData = rst.GetRows(1)
getRowsOk = True
Exit Function
Handler:
getRowsOk = False
Exit Function
End Function
Modül-1
Private Declare Function GetDiskFreeSpaceEx Lib "KERNEL32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long
Private Declare Function GetLogicalDrives Lib "KERNEL32" () As Long
Private Declare Function GetVolumeInformation Lib "KERNEL32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function GetDriveType Lib "KERNEL32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwndOwner As Long, ByVal iDrive As Long, ByVal iCapacity As Long, ByVal iFormatType As Long) As Long
Public Enum DriveTypeEnum
Removable = 2
FixedDrive = 3
Remote = 4
CDDrive = 5
RamDisk = 6
Unreconized = 0
End Enum
Public Enum FormatCapacityEnum
SHFD_CAPACITY_DEFAULT = 0 ' default drive capacity
SHFD_CAPACITY_360 = 3 ' 360KB, applies to 5.25" drives only
SHFD_CAPACITY_720 = 5 ' 720KB, applies to 3.5" drives only
End Enum
Public Enum FormatTypeEnum
SHFD_FORMAT_QUICK = 0 ' quick format
SHFD_FORMAT_FULL = 1 ' full format
SHFD_FORMAT_SYSONLY = 2 ' copies system files only (Win95 Only!)
End Enum
Public Function ListDrives() As Collection
On Error GoTo Handler
LDs = GetLogicalDrives
Set ListDrives = New Collection
For cnt = 0 To 25
If (LDs And 2 ^ cnt) <> 0 Then
ListDrives.Add Chr$(65 + cnt) & ":\"
End If
Next cnt
Exit Function
Handler:
Set ListDrives = Nothing
Exit Function
End Function
Public Function GetVolumeInfo(DriveName As String) As VolumeInfo
On Error Resume Next
Dim Serial As Long, VName As String, FSName As String
'Create buffers
VName = String$(255, Chr$(0))
FSName = String$(255, Chr$(0))
'Get the volume information
GetVolumeInformation DriveName, VName, 255, Serial, 0, 0, FSName, 255
'Strip the extra chr$(0)'s
VName = Left$(VName, InStr(1, VName, Chr$(0)) - 1)
FSName = Left$(FSName, InStr(1, FSName, Chr$(0)) - 1)
Set GetVolumeInfo = New VolumeInfo
With GetVolumeInfo
.FileSystem = FSName
.SerialNo = Serial
.VolumeName = VName
End With
End Function
Public Function getDriveSpace(DriveName As String) As DriveSpaceInfo
Dim r As Long, BytesFreeToCalller As Currency, TotalBytes As Currency
Dim TotalFreeBytes As Currency, TotalBytesUsed As Currency
'get the drive's disk parameters
Call GetDiskFreeSpaceEx(DriveName, BytesFreeToCalller, TotalBytes, TotalFreeBytes)
'show the results, multiplying the returned
'value by 10000 to adjust for the 4 decimal
'places that the currency data type returns.
Set getDriveSpace = New DriveSpaceInfo
getDriveSpace.TotalBytes = TotalBytes
getDriveSpace.TotalFreeBytes = TotalFreeBytes
getDriveSpace.BytesFreeToCaller = BytesFreeToCalller
getDriveSpace.TotalBytesUsed = (TotalBytes - TotalFreeBytes)
End Function
Public Function GetDriveTypes(DriveName As String) As DriveTypeEnum
GetDriveTypes = GetDriveType(DriveName)
End Function
Public Function getDriveInfo(DriveName As String) As DriveInfo
Set getDriveInfo = New DriveInfo
With getDriveInfo
Set .DriveSpace = getDriveSpace(DriveName)
.DriveType = GetDriveTypes(DriveName)
Set .DriveVolume = GetVolumeInfo(DriveName)
End With
End Function
Public Function getDrives() As Collection
Dim count As Integer
Dim DriveList As Collection
Dim drInfo As DriveInfo
Set DriveList = ListDrives
Set getDrives = New Collection
For count = 1 To DriveList.count
Set drInfo = getDriveInfo(CStr(DriveList.Item(count)))
drInfo.DriveNumber = count
drInfo.DriveLetter = CStr(DriveList(count))
getDrives.Add drInfo, CStr(DriveList(count))
Next
End Function
Public Sub FormatDrive(DriveNumber As Integer, FormatCapacity As FormatCapacityEnum, FormatType As FormatTypeEnum, hwnd As Long)
SHFormatDrive hwnd, DriveNumber, FormatCapacity, FormatType
End Sub
Class modül
İçerisindeki birinci modüle eklenecek kodlar
Modül-1
Public DriveSpace As DriveSpaceInfo
Public DriveType As DriveTypeEnum
Public DriveVolume As VolumeInfo
Public DriveNumber As Integer
Public DriveLetter As String
Modül-2
ublic BytesFreeToCaller As Currency
Public TotalBytes As Currency
Public TotalFreeBytes As Currency
Public TotalBytesUsed As Currency
Modül-3
Public SerialNo As Long
Public VolumeName As String
Public FileSystem As String
