I need to open (and close) multiple files. That's why I wrote a little Function FileOpen. The code works perfectly in my subroutines where I am using the byte array B but getting an error message in the function. I pass the full name "FN" of the file. The file exists. The ReDim works fine, but I get the
error 94 "Invalid use of null"
on the Get statement.
Sub main()
Dim FN As String: FN = "c:\tmp\test.docx"
Dim B() As Byte
If FileOpen(FN, B) < 0 Then Debug.Print " Error"
End Sub
Function FileOpen(FN, ByRef B) As Long
Dim nFile As Integer
nFile = FreeFile
Open FN For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim B(LOF(nFile) - 1)
Get nFile, , B
Close nFile
FileOpen = 0
Else
Close nFile
FileOpen = -1
End If
End Function
How can I correct it?
Related
I need to find the first 20,000 random numbers generated by RND -1. I have written the following code, which allows me to see those numbers in the Immediate Window:
Sub xx()
Dim i As Long
Rnd -1
For i = 1 To 20000
Debug.Print Rnd
Next i
End Sub
However, only the last 199 lines are stored there for me to copy and paste. How can I write the entire output to a text file instead?
Many thanks
Since your goal seems to be to get a lot of random numbers in the clipboard, you can do the following:
in the VBA editor under tools/references, add a reference to Microsoft Forms 2.0 Object Library and then use:
Sub RandToClip(n As Long)
Dim clip As New DataObject
Dim A As Variant
Dim i As Long
ReDim A(1 To n)
Randomize
For i = 1 To n
A(i) = Rnd()
Next i
clip.SetText Join(A, vbCrLf)
clip.PutInClipboard
End Sub
If you then e.g. enter RandToClip 20000 in your clipboard available for pasting somewhere else.
You can easily write to a text file (file stream) by using a FileSystemObject. See example below for working code in a module:
Global fso As New FileSystemObject
Public Function GenRandomNumbers(ByVal n As Long) As String
Dim i As Long
Dim res As String
Rnd -1
For i = 1 To n
res = res & CStr(Rnd()) & vbCrLf
Next i
GenRandomNumbers = res
End Function
Public Sub WriteRandomNumbers(ByVal n As Long, ByVal filename As String)
Dim fs As TextStream
Set fs = fso.CreateTextFile(filename, Overwrite:=True)
fs.Write GenRandomNumbers(n)
fs.Close
End Sub
In the immediate window you can write:
WriteRandomNumbers 20000, "Result.txt"
Answering your question: here is the basic function for that task. Make sure to add checks of whether file exists, not locked, etc. But take a look at the solution provided by John Coleman as it may be a better solution for your task.
Public Function WritetoTXT (Byval Text as String, byval FilePath as String)
Dim TextFile As Long
TextFile = FreeFile
Open Path For Append As TextFile
Print #TextFile, Text
Close TextFile
End Function
In your code:
Sub xx()
Dim i As Long
Rnd -1
For i = 1 To 20000
WritetoTXT Rnd, "your file path here"
Next
End Sub
Edit:
As pointed out in comments to decrease overhead you can combine your code to the following:
Sub xx()
Dim i As Long
Rnd -1
Dim TextFile As Long
TextFile = FreeFile
Open "your file path here" For Append As TextFile
For i = 1 To 20000
Print #TextFile, Rnd
Next
Close TextFile
End Sub
I have an embedded OLE object in word as "InlineShape". I would like to access this object as a data stream / string. at the moment, I can see some ideas for Excel via OLEObject, but it seems that there is no solution for Word that I can see.
The following code achieves what I want:
' from here: https://stackoverflow.com/questions/1356118/vba-ws-toolkit-how-to-get-current-file-as-byte-array
Public Function GetFileBytes(ByVal path As String) As Byte()
Dim lngFileNum As Long
Dim bytRtnVal() As Byte
lngFileNum = FreeFile
If LenB(Dir(path)) Then ''// Does file exist?
Open path For Binary Access Read As lngFileNum
ReDim bytRtnVal(LOF(lngFileNum) - 1&) As Byte
Get lngFileNum, , bytRtnVal
Close lngFileNum
Else
Err.Raise 53
End If
GetFileBytes = bytRtnVal
Erase bytRtnVal
End Function
Sub TestMe()
Dim shapeIndex As Integer: shapeIndex = 1
Dim ns As Object
Dim folderItem
Const namePrefix = "site-visit-v2.5"
Const nameSuffix = ".dat"
Dim fileBytes() As Byte
Dim tempDir As String: tempDir = Environ("TEMP")
' first embedded Item - you may need adjust if you have more shapes
ActiveDocument.InlineShapes.Item(shapeIndex).Range.Copy
' paste it to temp dir
Set ns = CreateObject("Shell.Application").namespace((tempDir))
ns.Self.InvokeVerb ("Paste")
' find the file now
Dim Item As Object
Dim rightItem As Object
Set rightItem = Nothing
' find the file that was pasted
' because when files are pasted and name exists, you could get a name such as "site-visit-v2.5 (10).dat"
' we pick the most recent that matches
For Each Item In ns.Items
If Item.Name Like namePrefix & "*" & nameSuffix Then
If rightItem Is Nothing Then
Set rightItem = Item
Else
If Item.modifyDate > rightItem.modifyDate Then 'a more recent date is found
Set rightItem = Item
End If
End If
End If
Next
fileBytes = GetFileBytes(tempDir & "\" & rightItem.Name)
MsgBox "Read " & UBound(fileBytes) + 1 & " bytes"
End Sub
I have the following functions to generate md5-hashes for files. The functions work great for small files, but crashes and generate Run-time error 7 - Out of memory when I try to hash files over ~250 MB (I don't actually know at which exact size it breaks, but files below 200 MB work fine).
I don't understand why it breaks at a certain size, so if anyone could shed some light on that I would appreciate it a lot.
Also, is there anything I can do to make the functions handle larger files? I intend to use the functions in a larger tool where I will need to generate hashes for files of unknown sizes. Most will be small enough for the current functions to work, but I will have to be able to handle large files as well.
I got my current functions from the most upvoted answer this post How to get the MD5 hex hash for a file using VBA?
Public Function FileToMD5Hex(ByVal strFileName As String) As String
Dim varEnc As Variant
Dim varBytes As Variant
Dim strOut As String
Dim intPos As Integer
Set varEnc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
'Convert the string to a byte array and hash it
varBytes = GetFileBytes(strFileName)
varBytes = varEnc.ComputeHash_2((varBytes))
'Convert the byte array to a hex string
For intPos = 1 To LenB(varBytes)
strOut = strOut & LCase(Right("0" & Hex(AscB(MidB(varBytes, intPos, 1))), 2))
Next
FileToMD5Hex = strOut
Set varEnc = Nothing
End Function
Private Function GetFileBytes(ByVal strPath As String) As Byte()
Dim lngFileNum As Long
Dim bytRtnVal() As Byte
lngFileNum = FreeFile
'If file exists, get number of bytes
If LenB(Dir(strPath)) Then
Open strPath For Binary Access Read As lngFileNum
ReDim bytRtnVal(LOF(lngFileNum)) As Byte
Get lngFileNum, , bytRtnVal
Close lngFileNum
Else
MsgBox "Filen finns inte" & vbCrLf & "Avbryter", vbCritical, "Filen hittades inte"
Exit Function
End If
GetFileBytes = bytRtnVal
Erase bytRtnVal
End Function
Thank you
It looks like you reached the memory limit.
A better way would be to compute the MD5 of the file by block:
Public Function ComputeMD5(filepath As String) As String
Dim buffer() As Byte, svc As Object, hFile%, blockSize&, i&
blockSize = 2 ^ 16
' open the file '
If Len(Dir(filepath)) Then Else Err.Raise 5, , "file not found" & vbCr & filepath
hFile = FreeFile
Open filepath For Binary Access Read As hFile
' allocate buffer '
If LOF(hFile) < blockSize Then blockSize = ((LOF(hFile) + 1024) \ 1024) * 1024
ReDim buffer(0 To blockSize - 1)
' compute hash '
Set svc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
For i = 1 To LOF(hFile) \ blockSize
Get hFile, , buffer
svc.TransformBlock buffer, 0, blockSize, buffer, 0
Next
Get hFile, , buffer
svc.TransformFinalBlock buffer, 0, LOF(hFile) Mod blockSize
buffer = svc.Hash
' cleanup '
svc.Clear
Close hFile
' convert to an hexa string '
ComputeMD5 = String$(32, "0")
For i = 0 To 15
Mid$(ComputeMD5, i + i + 2 + (buffer(i) > 15)) = Hex(buffer(i))
Next
End Function
This is an extension to FlorentB's answer, which worked brilliantly for me until my files surpassed the 2GB LOF() size limit.
I tried to adapt for getting file length by alternate means as follows:
Public Function ComputeMD5(filepath As String) As String
If Len(Dir(filepath)) Then Else Err.Raise 5, , "File not found." & vbCr & filepath
Dim blockSize As Long: blockSize = 2 ^ 20
Dim blockSize_f As Double
Dim buffer() As Byte
Dim fileLength As Variant
Dim hFile As Integer
Dim n_Reads As Long
Dim i As Long
Dim svc As Object: Set svc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
fileLength = DecGetFileSize(filepath)
If fileLength < blockSize Then blockSize = ((fileLength + 1024) \ 1024) * 1024
ReDim buffer(0 To blockSize - 1)
n_Reads = fileLength / blockSize
blockSize_f = fileLength - (CDbl(blockSize) * n_Reads)
hFile = FreeFile
Open filepath For Binary Access Read As hFile
For i = 1 To n_Reads
Get hFile, i, buffer
svc.TransformBlock buffer, 0, blockSize, buffer, 0
Next i
Get hFile, i, buffer
svc.TransformFinalBlock buffer, 0, blockSize_f
buffer = svc.Hash
svc.Clear
Close hFile
ComputeMD5 = String$(32, "0")
For i = 0 To 15
Mid$(ComputeMD5, i + i + 2 + (buffer(i) > 15)) = Hex(buffer(i))
Next
End Function
Public Function DecGetFileSize(fname As String) As Variant
Dim fso As New FileSystemObject
Dim f: Set f = fso.GetFile(fname)
DecGetFileSize = CDec(f.Size)
Set f = Nothing
Set fso = Nothing
End Function
This all runs fine, returning a string, however that string does not equal the MD5 calculated using other tools on the same file.
I can't work out where the discrepancy is originating.
I've checked and double checked filelength, n_reads, blockSize and blockSize_f and I'm sure those values are all correct.
I had some trouble with the Get function, where if I didn't explicitly tell it the block number, it dies at block 2048.
Any ideas / pointers would be much appreciated.
I don't have any understanding of VBA. I have excel file which contains File path and I want to find existence of file in that location.
I tried the following but need something better than this
Sub Test_File_Exist_With_Dir()
Dim FilePath As String
Dim TestStr As String
FilePath = ActiveSheet.Range("A7").Value
TestStr = ""
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
If TestStr = "" Then
ActiveSheet.Range("B7").Value = 0
Else
ActiveSheet.Range("B7").Value = 1
End If
End Sub
Expected output
File path Existence
C:\Users\Desktop\Excel\Jan15.txt 1
C:\Users\Desktop\Excel\Feb15.txt 1
C:\Users\Desktop\Excel\Mar15.txt 1
C:\Users\Desktop\Excel\Apr15.txt 0
C:\Users\Desktop\Excel\May15.txt 0
If I add new row to data then its existence should automatically populate.
Yau can use this as a function directly in your workbook as a classic Excel formula, just type =File_Exist(A1) and this will work as a normal function (you can autofill next rows easily).
Public Function File_Exist(ByVal FilePath As String) As Integer
On Error Resume Next
Dim TestStr As String
TestStr = Dir(FilePath)
On Error GoTo 0
If TestStr <> "" Then
File_Exist = 1
Else
File_Exist = 0
End If
End Function
If you want to test existence automatically and populate every time you add new row to data then you'll have to use Worksheet_SelectionChange but it'll be more difficult than this and not so useful if you have a practical function!
Would it be easy to convert the following function so that instead of just 0 or 1 it gave the following three outputs:
0 - means file closed
1 - means file is already open
2 - means file does not exist
Here's the Function
Function IsFileReadOnlyOpen(FileName As String)
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileReadOnlyOpen = 0
Case 70: IsFileReadOnlyOpen = 1
Case Else: Error iErr
End Select
End Function
You could add this at the beginning of your function:
If Dir(FileName) = "" Then 'File does not exist
IsFileReadOnlyOpen = 2
Exit Function 'Or not - I don't know if you want to create the file or exit in that case.
End If
I agree with the comment that you should use enum to make it easier to understand.
PS: As commented by Martin Milan this might cause issues. Alternatively, you can use this:
With New FileSystemObject
If .FileExists(FileName) Then
IsFileReadOnlyOpen = 2
Exit Function 'Or not - I don't know if you want to create the file or exit in that case.
End If
End With
You can use the FileSystemObject to test for the existence of a file explicitly, if that is your difficulty.
You'll need to add a reference to the Microsoft Scripting Runtime library though in order to do that, and I tend to try to avoid that.
You can use FindFirstFile from the Win32API to test this, but that's a little more involved - and also won't help you if the user is actually running on a Mac...
have ended up with:
Enum FileOpenState
ExistsAndClosed = 0
ExistsAndOpen = 1
NotExists = 2
End Enum
Function IsFileReadOnlyOpen(FileName As String)
With New FileSystemObject
If Not .FileExists(FileName) Then
IsFileReadOnlyOpen = 2 ' NotExists = 2
Exit Function 'Or not - I don't know if you want to create the file or exit in that case.
End If
End With
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileReadOnlyOpen = 0
Case 70: IsFileReadOnlyOpen = 1
Case Else: IsFileReadOnlyOpen = 1 'Error iErr
End Select
End Function