Throwback on an old project and needing to use VB6. I'm having an issue in referencing the appropriate DLL that contains System.IO in the old VB6 IDE.
I have tried to reference: C:\Windows\Microsoft.NET\Framework\v2.0.50727\mscorlib.dll - error: Can't add reference to specified file
Added a reference to C:\Windows\Microsoft.NET\Framework\v2.0.50727\mscorlib.tlb - doesn't work.
Added reference to C:\Windows\Microsoft.NET\Framework\v2.0.50727\System.tlb - there is no System.IO from the intellisense.
Can someone please post the step-by-step instructions?
Got this somewhat working with:
Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
Dim info As DiskInformation
Dim lAnswer As Long
Dim lpRootPathName As String
Dim lpSectorsPerCluster As Long
Dim lpBytesPerSector As Long
Dim lpNumberOfFreeClusters As Long
Dim lpTotalNumberOfClusters As Long
Dim lBytesPerCluster As Long
Dim lNumFreeBytes As Double
Dim dPercentFreeClusters As Double
Dim sString As String
lpRootPathName = "c:\"
lAnswer = GetDiskFreeSpace(lpRootPathName, lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters)
lBytesPerCluster = lpSectorsPerCluster * lpBytesPerSector
' Throws overflow exception - I guess there were no Terabyte drives when VB6 came around
' lNumFreeBytes = lBytesPerCluster * lpNumberOfFreeClusters
'sString = "Number of Free Bytes : " & lNumFreeBytes & vbCr & vbLf
'sString = sString & "Number of Free Kilobytes: " & (lNumFreeBytes / 1024) & "K" & vbCr & vbLf
'sString = sString & "Number of Free Megabytes: " & Format(((lNumFreeBytes / 1024) / 1024), "0.00") & "MB"
dPercentFreeClusters = Round(lpNumberOfFreeClusters / lpTotalNumberOfClusters * 100, 2)
There is, however, an Overflow exception being thrown when trying to calculate the number of free bytes.
I would like to get this working with My.Computer.FileSystem. Suggestions?
Related
In antiquated VB6, I am trying to calculate the free and use disk space:
Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
Dim info As DiskInformation
Dim lAnswer As Long
Dim lpRootPathName As String
Dim lpSectorsPerCluster As Long
Dim lpBytesPerSector As Long
Dim lpNumberOfFreeClusters As Long
Dim lpTotalNumberOfClusters As Long
Dim lBytesPerCluster As Long
Dim lNumFreeBytes As Double
Dim dPercentFreeClusters As Double
Dim sString As String
lpRootPathName = "c:\"
lAnswer = GetDiskFreeSpace(lpRootPathName, lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters)
lBytesPerCluster = lpSectorsPerCluster * lpBytesPerSector
' Throws overflow exception - I guess there were no Terabyte drives when VB6 came around
lNumFreeBytes = lBytesPerCluster * lpNumberOfFreeClusters
lBytesPerCluster = 4096 | lpNumberOfFreeClusters = 474304894
I have tried wrapping the multiplication with CLng still get the overflow exception.
How can I resolve ? lBytesPerCluster * lpNumberOfFreeClusters ??
Conversion to Variant data type:
Dim v1, v2, v3 As Variant
v1 = lBytesPerCluster
v2 = lpNumberOfFreeClusters
' this now works:
? v1*v2
I tried With below code
Dim pthName As String
Dim Parms As String
Dim RpNo As Integer
Dim glngbr As Long
Dim PrtVw As String
pthName = "D:\Sample.exe"
RpNo = 1
PrtVw = "V"
glngbr = 84003
Shell pthName & Parms
I am getting error "Run time error 53 ".
i tried without parameter its working
Shell pthName
You can use like this,
Shell "D:\Sample.exe" & " " & Param_1, Param_2
Try this:
Shell "D:\Sample.exe" & " " & RpNo & " " & PrtVw & " " & glngbr
Use the api shellexecute http://support.microsoft.com/kb/238245
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Private Const SW_HIDE As Long = 0
Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const SW_SHOWMINIMIZED As Long = 2
private Sub exec_program()
ShellExecute App.hInstance, "Open", "D:\Sample.exe", "Parms", "C:\", SW_SHOWNORMAL
End Sub
You don't need to use the Shell command, or ShellExecute either for that matter. There's a simpler solution: the global VBA.Command object contains whatever string you added when you called your exe file. For example, if you enter myproject.exe hello world on the command line, VBA.Command will contain the string hello world.
If you want multiple command line arguments, you can just put them all on the command line separated by a known delimiter such as /. Then you can use the Split function to break them up.
Read This. It will tell you all about it, including how to use it in the IDE without having to test against a compiled version.
Well... I think the title says all. I wanna check if a pc exists on my network, for example "JOAN-PC".
Now I'm doing something like this:
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
MsgBox Not CBool(oShell.NameSpace(CVar("\\JOAN-PC")) Is Nothing)
Works good, but is slow, and my program have to call it a lot of times.
Some of you know a fast way to do the same thing?
Thanks in advance.
Perhaps you could use NetRemoteTOD or a related simple network API, even a "ping" request.
Here's a small example you might adapt. Give it a try, the timeout for machines that don't respond doesn't seem too long (7 or 8 seconds). For legit uses this probably won't be an issue, but it is long enough to discourage malicious "scanners" trying to sweep whole networks by IP address for victim machines.
Option Explicit
'Fetch and display Net Remote Time Of Day from a
'remote Windows system. Supply a UNC hostname,
'DNS name, or IP address - or empty string for
'the local host's time and date.
'
'Form has 3 controls:
'
' txtServer TextBox
' cmdGetTime CommandButton
' lblTime Label
Private Const NERR_SUCCESS As Long = 0
Private Type TIME_OF_DAY_INFO
tod_elapsedt As Long
tod_msecs As Long
tod_hours As Long
tod_mins As Long
tod_secs As Long
tod_hunds As Long
tod_timezone As Long
tod_tinterval As Long
tod_day As Long
tod_month As Long
tod_year As Long
tod_weekday As Long
End Type
Private Declare Function NetApiBufferFree Lib "netapi32" ( _
ByVal lpBuffer As Long) As Long
Private Declare Function NetRemoteTOD Lib "netapi32" ( _
ByRef UncServerName As Byte, _
ByRef BufferPtr As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef pTo As Any, _
ByRef uFrom As Any, _
ByVal lSize As Long)
Private Function GetTOD(ByVal Server As String) As Date
Dim bytServer() As Byte
Dim lngBufPtr As Long
Dim todReturned As TIME_OF_DAY_INFO
bytServer = Trim$(Server) & vbNullChar
If NetRemoteTOD(bytServer(0), lngBufPtr) = NERR_SUCCESS Then
CopyMemory todReturned, ByVal lngBufPtr, LenB(todReturned)
NetApiBufferFree lngBufPtr
With todReturned
GetTOD = DateAdd("n", _
-.tod_timezone, _
DateSerial(.tod_year, .tod_month, .tod_day) _
+ TimeSerial(.tod_hours, .tod_mins, .tod_secs))
End With
Else
Err.Raise vbObjectError Or &H2000&, _
"GetTOD", _
"Failed to obtain time from server"
End If
End Function
Private Sub cmdGetTime_Click()
Dim dtServerTime As Date
On Error Resume Next
dtServerTime = GetTOD(txtServer.Text)
If Err.Number <> 0 Then
lblTime.Caption = Err.Description
Else
lblTime.Caption = CStr(dtServerTime)
End If
On Error GoTo 0
txtServer.SetFocus
End Sub
Is there any way to convert from \Device\HarddiskVolume1\programfile\explorer.exe to C:\programfile\explorer.exe in visual basic 6?
thanks
Try this
Option Explicit
Private Declare Function QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" (ByVal lpDeviceName As String, ByVal lpTargetPath As String, ByVal ucchMax As Long) As Long
Private Sub Command1_Click()
Debug.Print pvReplaceDevice("\Device\HarddiskVolume1\aaa.txt")
End Sub
Private Function pvReplaceDevice(sPath As String) As String
Dim sDrive As String
Dim sDevice As String
Dim lIdx As Long
For lIdx = 0 To 25
sDrive = Chr$(65 + lIdx) & ":"
sDevice = Space(1000)
If QueryDosDevice(sDrive, sDevice, Len(sDevice)) <> 0 Then
sDevice = Left$(sDevice, InStr(sDevice, Chr$(0)) - 1)
' Debug.Print sDrive; "="; sDevice
If LCase$(Left$(sPath, Len(sDevice))) = LCase$(sDevice) Then
pvReplaceDevice = sDrive & Mid$(sPath, Len(sDevice) + 1)
Exit Function
End If
End If
Next
pvReplaceDevice = sPath
End Function
If you want an efficient use of API functions, create a class - "DiskDevice"
Option Explicit
Private Declare Function GetLogicalDriveStrings Lib "Kernel32" Alias "GetLogicalDriveStringsW" ( _
ByVal nBufferLength As Long, _
ByVal lpBuffer As Long _
) As Long
Private Declare Function QueryDosDevice Lib "Kernel32.dll" Alias "QueryDosDeviceW" ( _
ByVal lpDeviceName As Long, _
ByVal lpTargetPath As Long, _
ByVal ucchMax As Long _
) As Long
Private m_colDrivesKeyedByDevice As VBA.Collection
Private Sub Class_Initialize()
Dim sDriveStrings As String
Dim vasDriveStrings As Variant
Dim nIndex As Long
Dim sDrive As String
' Allocate max size buffer [A-Z]:\\\0 and retrieve all drives on the system.
sDriveStrings = Space$(105)
GetLogicalDriveStrings 1000, StrPtr(sDriveStrings)
' Split over the null chars between each substring.
vasDriveStrings = Split(sDriveStrings, vbNullChar)
Set m_colDrivesKeyedByDevice = New VBA.Collection
' Iterate through each drive string (escaping later if any item is null string).
For nIndex = 0 To UBound(vasDriveStrings)
sDrive = Left$(vasDriveStrings(nIndex), 2) ' Ignore the backslash.
If Len(sDrive) = 0 Then
Exit For
End If
' Create mapping from Drive => Device
m_colDrivesKeyedByDevice.Add sDrive, GetDeviceForDrive(sDrive)
Next nIndex
End Sub
' Retrieve the device string \device\XXXXXX for the drive X:
Private Function GetDeviceForDrive(ByRef the_sDrive As String)
Const knBufferLen As Long = 1000
Dim sBuffer As String
Dim nRet As Long
sBuffer = Space$(knBufferLen)
nRet = QueryDosDevice(StrPtr(the_sDrive), StrPtr(sBuffer), knBufferLen)
GetDeviceForDrive = Left$(sBuffer, nRet - 2) ' Ignore 2 terminating null chars.
End Function
Public Function GetFilePathFromDevicePath(ByRef the_sDevicePath As String) As String
Dim nPosSecondBackslash As Long
Dim nPosThirdBackslash As Long
Dim sDevice As String
Dim sDisk As String
' Path is always \Device\<device>\path1\path2\etc. Just get everything before the third backslash.
nPosSecondBackslash = InStr(2, the_sDevicePath, "\")
nPosThirdBackslash = InStr(nPosSecondBackslash + 1, the_sDevicePath, "\")
sDevice = Left(the_sDevicePath, nPosThirdBackslash - 1)
sDisk = m_colDrivesKeyedByDevice.Item(sDevice) ' Lookup
' Reassemble, this time with disk.
GetFilePathFromDevicePath = sDisk & Mid$(the_sDevicePath, nPosThirdBackslash)
End Function
Now, you use code like:
Set m_oDiskDevice = New DiskDevice
...
sMyPath = m_oDiskDevice.GetFilePathFromDevicePath("\Device\HarddiskVolume1\programfile\explorer.exe")
That way you don't have to call the API functions multiple times - you just do a collection lookup.
How to find if the directory is available or not?
Using VB 6.0
databasetext = network path available
If Len(Dir(databasetext)) = False Then
MsgBox "Database Path Not Available"
End if
I am selecting the file from the network path, if the network path is not available, it showing error "bad file name or number"
How to solve this problem?
Need VB 6 code Help
I use PathIsDirectory from Shlwapi.dll. Here is some VB6 code:
Private Declare Function PathIsDirectory Lib "Shlwapi" _
Alias "PathIsDirectoryW" (ByVal lpszPath As Long) As Long
Function DirExists(ByVal sDirName As String) As Boolean
'NB The shlwapi.dll is built into Windows 2000 and 98 and later: '
' it comes withInternet Explorer 4 on NT 4 and 95. '
'NB Calling "Wide" (Unicode) version. Always available. '
DirExists = (PathIsDirectory(StrPtr(Trim$(sDirName))) <> 0)
End Function
EDIT: You can also use FileSystemObject, but I prefer to avoid the Microsoft Scripting Runtime (including FileSystemObject). In my experience it's occasionally broken on user machines, perhaps because their IT department are paranoid about viruses.
From my stock library. I think I included all the declarations needed.
Private Declare Function FindClose Lib "Kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFile Lib "Kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Public Function FolderExists(ByVal FolderSpec As String) As Boolean
Dim rst As Long
Dim udtW32FindD As WIN32_FIND_DATA
Dim lngFHandle As Long
Dim strFolder As String 'set to FolderSpec parameter so I can change it
strFolder = FolderSpec
If Right$(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
strFolder = strFolder & "*" 'add the wildcard allows finding share roots
lngFHandle = FindFirstFile(strFolder, udtW32FindD)
If lngFHandle INVALID_HANDLE_VALUE Then
Call FindClose(lngFHandle)
FolderExists = True
End If
End Function