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
Related
I want to decode a string (which I got via readAsDataUrl()) to bytes.
At first, I remove the data:*/*;base64, then I call the following:
Option Explicit
Private Const CRYPT_STRING_BASE64 As Long = &H1&
Private Declare Function CryptStringToBinaryW Lib "Crypt32.dll" ( _
ByVal pszString As Long, _
ByVal cchString As Long, _
ByVal dwFlags As Long, _
ByVal pbBinary As Long, _
ByRef pcbBinary As Long, _
ByVal pdwSkip As Long, _
ByVal pdwFlags As Long) As Long
Public Function DecodeBase64(ByVal strData As String) As Byte()
Dim Buffer() As Byte
Dim dwBinaryBytes As Long
dwBinaryBytes = LenB(strData)
ReDim Buffer(dwBinaryBytes - 1) As Byte
'within the following call, VB6 crashes:
If CryptStringToBinaryW(StrPtr(strData), LenB(strData), CRYPT_STRING_BASE64, _
VarPtr(Buffer(0)), dwBinaryBytes, 0, 0) Then
ReDim Preserve Buffer(dwBinaryBytes - 1) As Byte
DecodeBase64 = Buffer
End If
Erase Buffer
End Function
Now I call this:
Dim s$
'code to get base64 string
'code to strip for example "data:image/jpeg;base64,"
Dim nBytes() As Byte
nBytes = DecodeBase64(s) 'Here VB6 crashes
Edit:
I am using the following alternative version now, and it works, but I wonder what the error is:
Public Function DecodeBase64(ByVal sBase64Buf As String) As Byte()
Const CRYPT_STRING_BASE64 As Long = 1
Const CRYPT_STRING_NOCRLF As Long = &H40000000
Dim bTmp() As Byte
Dim lLen As Long
Dim dwActualUsed As Long
'Get output buffer length
If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, StrPtr(vbNullString), lLen, 0&, dwActualUsed) = 0 Then
'RaiseEvent Error(Err.LastDllError, CSB, Routine)
GoTo ReleaseHandles
End If
'Convert Base64 to binary.
ReDim bTmp(lLen - 1)
If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, VarPtr(bTmp(0)), lLen, 0&, dwActualUsed) = 0 Then
'RaiseEvent Error(Err.LastDllError, CSB, Routine)
GoTo ReleaseHandles
Else
'm_bData = bTmp
End If
ReleaseHandles:
DecodeBase64 = bTmp
End Function
Edit:
In version 1, dwBinaryBytes is 156080 in this line:
dwBinaryBytes = LenB(strData)
and in version 2, lLen is 58528 in this line:
ReDim bTmp(lLen - 1)
Why the discrepancy, and why didn't the author notice that?
The "CryptStringToBinaryW" requires the number of characters in the string as a parameter. That is returned by the "Len" function. You used the "LenB" function which returns the number of bytes in the string which is larger than the number of characters in the string so the function attempted to access memory past the end of the string which caused the crash.
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?
Public Declare Function FindMimeFromData Lib "urlmon.dll" ( _
ByVal pbc As Long, _
ByVal pwzUrl As String, _
pBuffer As Any, _
cbSize As Long, _
ByVal pwzMimeProposed As String, _
dwMimeFlags As Long, _
ppwzMimeOut As Long, _
dwReserved As Long) As Long
In VB6, I can't seem to figure out how to pass the pBuffer parameter of the first 256 characters of a file. When I try to use a Dim buffer() As Byte and populate that, and pass it as the parameter, it throws the error of wrong param even those of the definition is Any.
I've tried to use this example, but passing the entire file name from a file system doesn't seem to work. so I have to try sending it like the C# example with the first 256 bytes of the file.
Can anyone help?
I played around with the following Declare, and built up some code around it. There are two wrappers, GetMimeTypeFromUrl() and GetMimeTypeFromData(). I found the former only worked when you used simple URLs such as http://host.com/file.xtn. You may have to play around with the other flags.
However, the other wrapper function sounds like what you need.
Note that all the string pointers are declared As Long, and I pass the underlying UTF-16 VB string as a pointer using StrPtr().
Also note that you have to use CoTaskMemFree() to free the output ppwzMimeOut string pointer, otherwise you will leak memory.
Option Explicit
Private Declare Function FindMimeFromData Lib "Urlmon.dll" ( _
ByVal pBC As Long, _
ByVal pwzUrl As Long, _
ByVal pBuffer As Long, _
ByVal cbSize As Long, _
ByVal pwzMimeProposed As Long, _
ByVal dwMimeFlags As Long, _
ByRef ppwzMimeOut As Long, _
ByVal dwReserved As Long _
) As Long
'
' Flags:
'
' Default
Private Const FMFD_DEFAULT As Long = &H0
' Treat the specified pwzUrl as a file name.
Private Const FMFD_URLASFILENAME As Long = &H1
' Internet Explorer 6 for Windows XP SP2 and later. Use MIME-type detection even if FEATURE_MIME_SNIFFING is detected. Usually, this feature control key would disable MIME-type detection.
Private Const FMFD_ENABLEMIMESNIFFING As Long = &H2
' Internet Explorer 6 for Windows XP SP2 and later. Perform MIME-type detection if "text/plain" is proposed, even if data sniffing is otherwise disabled. Plain text may be converted to text/html if HTML tags are detected.
Private Const FMFD_IGNOREMIMETEXTPLAIN As Long = &H4
' Internet Explorer 8. Use the authoritative MIME type specified in pwzMimeProposed. Unless FMFD_IGNOREMIMETEXTPLAIN is specified, no data sniffing is performed.
Private Const FMFD_SERVERMIME As Long = &H8
' Internet Explorer 9. Do not perform detection if "text/plain" is specified in pwzMimeProposed.
Private Const FMFD_RESPECTTEXTPLAIN As Long = &H10
' Internet Explorer 9. Returns image/png and image/jpeg instead of image/x-png and image/pjpeg.
Private Const FMFD_RETURNUPDATEDIMGMIMES As Long = &H20
'
' Return values:
'
' The operation completed successfully.
Private Const S_OK As Long = 0&
' The operation failed.
Private Const E_FAIL As Long = &H80000008
' One or more arguments are invalid.
Private Const E_INVALIDARG As Long = &H80000003
' There is insufficient memory to complete the operation.
Private Const E_OUTOFMEMORY As Long = &H80000002
'
' String routines
'
Private Declare Function lstrlen Lib "Kernel32.dll" Alias "lstrlenW" ( _
ByVal lpString As Long _
) As Long
Private Declare Sub CopyMemory Lib "Kernel32.dll" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal nCount As Long)
Private Declare Sub CoTaskMemFree Lib "Ole32.dll" ( _
ByVal pv As Long _
)
Private Function CopyPointerToString(ByVal in_pString As Long) As String
Dim nLen As Long
' Need to copy the data at the string pointer to a VB string buffer.
' Get the length of the string, allocate space, and copy to that buffer.
nLen = lstrlen(in_pString)
CopyPointerToString = Space$(nLen)
CopyMemory StrPtr(CopyPointerToString), in_pString, nLen * 2
End Function
Private Function GetMimeTypeFromUrl(ByRef in_sUrl As String, ByRef in_sProposedMimeType As String) As String
Dim pMimeTypeOut As Long
Dim nRet As Long
nRet = FindMimeFromData(0&, StrPtr(in_sUrl), 0&, 0&, StrPtr(in_sProposedMimeType), FMFD_DEFAULT, pMimeTypeOut, 0&)
If nRet = S_OK Then
GetMimeTypeFromUrl = CopyPointerToString(pMimeTypeOut)
CoTaskMemFree pMimeTypeOut
Else
Err.Raise nRet
End If
End Function
Private Function GetMimeTypeFromData(ByRef in_abytData() As Byte, ByRef in_sProposedMimeType As String) As String
Dim nLBound As Long
Dim nUBound As Long
Dim pMimeTypeOut As Long
Dim nRet As Long
nLBound = LBound(in_abytData)
nUBound = UBound(in_abytData)
nRet = FindMimeFromData(0&, 0&, VarPtr(in_abytData(nLBound)), nUBound - nLBound + 1, StrPtr(in_sProposedMimeType), FMFD_DEFAULT, pMimeTypeOut, 0&)
If nRet = S_OK Then
GetMimeTypeFromData = CopyPointerToString(pMimeTypeOut)
CoTaskMemFree pMimeTypeOut
Else
Err.Raise nRet
End If
End Function
Private Sub Command1_Click()
Dim sRet As String
Dim abytData() As Byte
sRet = GetMimeTypeFromUrl("http://msdn.microsoft.com/en-us/library/ms775107%28v=vs.85%29.aspx", vbNullString)
Debug.Print sRet
abytData() = StrConv("<HTML><HEAD><TITLE>Stuff</TITLE></HEAD><BODY>Test me</BODY></HTML>", vbFromUnicode)
sRet = GetMimeTypeFromData(abytData(), vbNullString)
Debug.Print sRet
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.
I am displaying Japanese characters in a VB6 application with the system locale set to Japan and the language for non Unicode programs as Japanese. A call to GetACP() correctly returns 932 for Japanese. When I insert the Japanese strings into my controls they display as “ƒAƒtƒŠƒJ‚Ì—‰¤” rather than “アフリカの女王”. If I manually set the Font.Charset to 128 then they display correctly.
What is the best way to determine the correct Charset for a given LCID in VB6?
Expanding Bob's answer, here's some code to get the current default charset.
Private Const LOCALE_SYSTEM_DEFAULT As Long = &H800
Private Const LOCALE_IDEFAULTANSICODEPAGE As Long = &H1004
Private Const TCI_SRCCODEPAGE = 2
Private Type FONTSIGNATURE
fsUsb(4) As Long
fsCsb(2) As Long
End Type
Private Type CHARSETINFO
ciCharset As Long
ciACP As Long
fs As FONTSIGNATURE
End Type
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" ( _
ByVal Locale As Long, _
ByVal LCType As Long, _
ByVal lpLCData As String, _
ByVal cchData As Long _
) As Long
Private Declare Function TranslateCharsetInfo Lib "GDI32" ( _
lpSrc As Long, _
lpcs As CHARSETINFO, _
ByVal dwFlags As Long _
) As Long
Public Function GetCharset() As Long
On Error GoTo ErrorHandler
Dim outlen As Long
Dim lCodepage As Long
Dim outBuffer As String
Dim cs As CHARSETINFO
outBuffer = String$(10, vbNullChar)
outlen = GetLocaleInfo(LOCALE_SYSTEM_DEFAULT, LOCALE_IDEFAULTANSICODEPAGE, outBuffer, Len(outBuffer))
If outlen > 0 Then
lCodepage = val(Left$(outBuffer, outlen - 1))
If TranslateCharsetInfo(ByVal lCodepage, cs, TCI_SRCCODEPAGE) Then
GetCharset = cs.ciCharset
End If
End If
Exit Function
ErrorHandler:
GetCharset = 0
End Function
See http://www.microsoft.com/globaldev/drintl/columns/014/default.mspx#E5B
The second best way is to use a database of fonts, font.charsets, and heuristics, such as is done here:
http://www.example-code.com/vb/vb6-display-unicode.asp
(The best way is to get off the sinking ship that is VB6)