I have an MS SQL Database from a customer with an Access Application.
This application stores files within this MS SQL database.
I tried to just get the bytes from the database and just save them to the disk.
With some of the files this works and with some it does not.
(images don't work, zips work, wordfiles are to open but word has to recover them)
I found out that Access saves the files within an OLE Object.
So i need to get out the Original Files from the OLE Object!
It seems that this is quite difficult.
I tried to find a .NET library which can seperate the files from the OLE Object.. found nothing...
Now i am trying to get the files out with Access...
It seems that i neet a getChunk Function to do that...
Found this page with a WriteBlob Code... it is said that it would to what i need..
https://support.microsoft.com/en-us/help/210486/acc2000-reading--storing--and-writing-binary-large-objects-blobs
Now i can write Files to the Harddisc... but the files are still not able to open!
Something's wrong here...
My complete VBA Code is this:
Option Compare Database
Const BlockSize = 32768
Sub xxx()
Dim id As Integer
Debug.Print "****************************************************"
Debug.Print "****************************************************"
Debug.Print "****************************************************"
Debug.Print "****************************************************"
Dim unnoetig As Variant
Dim dok() As Byte
Dim sql As String
sql = "select top 1 idCaseDetail, idCase, Dokument from dbo_law_tbl_CaseHistory where idCaseDetail = ""1"""
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset(sql)
If Not rst.EOF Then
Do While Not rst.EOF
Debug.Print "idcasehistory: " & rst.Fields(0)
Debug.Print "idcase: " & rst.Fields(1)
If Not IsNull(rst.Fields(2).Value) Then
dok = rst.Fields(2)
unnoetig = WriteBLOB(rst, "Dokument", "c:\temp\ole.doc")
End If
rst.MoveNext
Loop
End If
End Sub
'**************************************************************
' FUNCTION: WriteBLOB()
'
' PURPOSE:
' Writes BLOB information stored in the specified table and field
' to the specified disk file.
'
' PREREQUISITES:
' The specified table with the OLE object field containing the
' binary data must be opened in Visual Basic code and the correct
' record navigated to prior to calling the WriteBLOB() function.
'
' ARGUMENTS:
' T - The table object containing the binary information.
' sField - The OLE object field in table T containing the
' binary information to write.
' Destination - The path and filename to write the binary
' information to.
'
' RETURN:
' The number of bytes written to the destination file.
'**************************************************************
Function WriteBLOB(T As DAO.Recordset, sField As String, _
Destination As String)
Dim NumBlocks As Integer, DestFile As Integer, i As Integer
Dim FileLength As Long, LeftOver As Long
Dim FileData As String
Dim RetVal As Variant
On Error GoTo Err_WriteBLOB
' Get the size of the field.
FileLength = T(sField).FieldSize()
If FileLength = 0 Then
WriteBLOB = 0
Exit Function
End If
' Calculate number of blocks to write and leftover bytes.
NumBlocks = FileLength \ BlockSize
LeftOver = FileLength Mod BlockSize
' Remove any existing destination file.
DestFile = FreeFile
Open Destination For Output As DestFile
Close DestFile
' Open the destination file.
Open Destination For Binary As DestFile
' SysCmd is used to manipulate the status bar meter.
RetVal = SysCmd(acSysCmdInitMeter, _
"Writing BLOB", FileLength / 1000)
' Write the leftover data to the output file.
FileData = T(sField).GetChunk(0, LeftOver)
Put DestFile, , FileData
' Update the status bar meter.
RetVal = SysCmd(acSysCmdUpdateMeter, LeftOver / 1000)
' Write the remaining blocks of data to the output file.
For i = 1 To NumBlocks
' Reads a chunk and writes it to output file.
FileData = T(sField).GetChunk((i - 1) * BlockSize _
+ LeftOver, BlockSize)
Put DestFile, , FileData
RetVal = SysCmd(acSysCmdUpdateMeter, _
((i - 1) * BlockSize + LeftOver) / 1000)
Next i
' Terminates function
RetVal = SysCmd(acSysCmdRemoveMeter)
Close DestFile
WriteBLOB = FileLength
Exit Function
Err_WriteBLOB:
WriteBLOB = -Err
Exit Function
End Function
Do you have any suggestions?
Important to say is:
It is an MS SQL Database... not an Access Database.. there are some tools which maybe could word with access-Databases.. but not mit ms sql
Is there a .NET way or an VBA way to save the files to disc?
An easy alternative to using DAO for saving OLE objects, is to use the ADODB.Stream object:
Public Sub SaveOLEObject(OleObjectField As Field, Filelocation As String)
Dim adoStream As Object 'ADODB.Stream
Set adoStream = CreateObject("ADODB.Stream")
adoStream.Type = 1 'adTypeBinary
adoStream.Open
adoStream.Write OleObjectField.Value
adoStream.SaveToFile Filelocation, adSaveCreateOverWrite
adoStream.Close
End Sub
Call it:
SaveOLEObject(rst.Fields("Dokument"), "c:\temp\ole.doc")
Note that, of course, your documents might just be corrupt, and that might explain the problem.
If your objects are stored in SQL Server, I'd prefer directly opening an ADO recordset containing the binary data from SQL server over creating a linked table and opening a DAO recordset from the linked table.
In Access, create a corresponding Access Form with all relevant fields. Use the VBA code provided in the link and you should be able to export some of the most common file types in an automated fashion. Good luck.
https://medium.com/#haggenso/export-ole-fields-in-microsoft-access-c67d535c958d
Related
I try to load chunks of a (really) large file in VBA:
Set dataStream = CreateObject("ADODB.Stream")
dataStream.Type = adTypeBinary
dataStream.Open
dataStream.LoadFromFile localDirectory & "\" & objFile.Name
byteBuffer = dataStream.Read(bufferSize)
If I understand correctly, the only amount of memory needed at a given time is bufferSize. Still, Access crashes at the LoadFromFile statement.
Is there a more robust way to read chunks from large files in VBA than ADODB.Stream?
I already tried How to Transfer Large File from MS Word Add-In (VBA) to Web Server? (but that has problems with large files, too. Get fails unpredictably with Error 63).
Ok, here's how I solved it
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(localDirectory)
Set sourceFile = objFSO.OpenTextFile(localDirectory & "\" & objFile.Name)
strChunk = sourceFile.Read(bufferSize)
and then convert the string to a byte array:
Function StringToByteArray(str As String) As Byte()
Dim i As Long
Dim b() As Byte
ReDim b(Len(str) - 1) As Byte
For i = 1 To Len(str)
b(i - 1) = Asc(Mid(str, i, 1))
Next i
StringToByteArray = b
End Function
The usual StrConv method does not work correctly! Therefore the method.
Command dataStream.LoadFromFile tries to load the entire file into RAM. You can check it yourself through the Task Manager.
Simple methods give more opportunities, so I suggest it be simpler. Below is the code that I applied to a 50GB file – and my computer didn't experience any problems, except that processing such a file will take a lot of time. But nothing freezes, and the process can be controlled as you like.
Dim fname As String
Dim fNo As Integer
Const bufferSize = 1024
Dim nextBytes(bufferSize) As Byte
Dim offset As Variant
fname = "C:\Path\BinaryFile.vdi"
fNo = FreeFile()
Open fname For Binary Access Read As #fNo
offset = 1
Do
Get #fNo, offset, nextBytes
offset = offset + bufferSize
' Do Something
If EOF(fNo) Then Exit Do
Loop
Close #fNo
I am a student in computer science and for a project I need to be able to read from a text file in a way that each line is assigned to a space within an array. This should happen so that each line of text file is read in the order that it appears in the text file. I would also appreciate any methods of writing to a text file as well.
If this question is already explained, could you please direct me to the existing answer.
Things to note:
1) I am coding in a console application in VB.NET
2) I am relatively new at coding
You can do it like this:
Dim sFile As String = "D:\File.txt"
Dim aLines As String() = System.IO.File.ReadAllLines(sFile)
System.IO.File.WriteAllLines(sFile, aLines)
Here's a sample from the official documentation:
Imports System.IO
Public Class Test
Public Shared Sub Main()
Dim path As String = "c:\temp\MyTest.txt"
Dim sw As StreamWriter
' This text is added only once to the file.
If File.Exists(path) = False Then
' Create a file to write to.
Dim createText() As String = {"Hello", "And", "Welcome"}
File.WriteAllLines(path, createText)
End If
' This text is always added, making the file longer over time
' if it is not deleted.
Dim appendText As String = "This is extra text" + Environment.NewLine
File.AppendAllText(path, appendText)
' Open the file to read from.
Dim readText() As String = File.ReadAllLines(path)
Dim s As String
For Each s In readText
Console.WriteLine(s)
Next
End Sub
End Class
Remarks
This method opens a file, reads each line of the file, then adds each line as an element of a string array. It then closes the file. A line is defined as a sequence of characters followed by a carriage return ('\r'), a line feed ('\n'), or a carriage return immediately followed by a line feed. The resulting string does not contain the terminating carriage return and/or line feed.
Module Module1
Sub Main()
'Declare four variables
Dim oReader As New System.IO.StreamReader(".\archive01.txt") 'This file has to exist in the aplication current directory.
Dim oWriter As New System.IO.StreamWriter(".\archive02.txt") 'This file will be created by the software.
Dim oArray() As String = {}
Dim oString As String = Nothing
'For reading from .\archive01.txt and to load in oArray().
oString = oReader.ReadLine
While Not oString Is Nothing
If UBound(oArray) = -1 Then 'Ubound = Upper Bound, also exist LBound = Lower Bound.
ReDim oArray(UBound(oArray) + 1)
Else
ReDim Preserve oArray(UBound(oArray) + 1)
End If
oArray(UBound(oArray)) = New String(oString)
oString = oReader.ReadLine
End While
oReader.Close()
'For writing from oArray() to .\archive02.txt.
For i = 0 To oArray.Count - 1 Step 1
oWriter.WriteLine(oArray(i))
Next
oWriter.Close()
End Sub
End Module
Hi, try with this code. It works well. I hope that this helps to you to learn how to do this kind of things. Thank you very much. And happy codding!. :)
This searches for the end of a file name removes it's current file type of .docm and converts it to a .docx. Works great.
ActiveDocument.SaveAs2 Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1), WdSaveFormat.wdFormatXMLDocument
However, I noticed a little bug. If there is a . in the file name, it finds that first and obviously creates a file that is incorrect.
For example:
TestFileV1.2AlexTest.docm
Becomes the file
TestFileV.2AlextTest Where the new file type is a .2ALEXTEST file.
Kind of a funny error, but still a bug none the less.
Best course of action for validation?
Thanks!
Try the VBA.Strings.Split() function, which splits a string into an array.
Split the File name on '.' and the last element in the array will be your extension:
Public Function GetExtension(FileName As String) As String
'Returns a file's extension
' This does not go to the filesystem and get the file:
' The function parses out the string after the last '.'
' Useful for situations where a file does not yet exist
' Nigel Heffernan Excellerando.Blogspot.com
' **** THIS CODE IS IN THE PUBLIC DOMAIN ****
'Print GetExtension("C:\Temp\data.txt1.docx")
'Returns docx
Dim arrayX() As String
Dim iLast As Integer
arrayX = Split(FileName, ".")
iLast = UBound(arrayX)
GetExtension = arrayX(iLast)
Erase arrayX
End Function
If you don't care about readability, the quick-and-dirty answer is:
strExt = Split(strFile, ".")(UBound(Split(strFile, ".")))
However... I think you're looking for something more sophisticated than a string parser to extract the file extension.
Are you actually looking to validate the file extension?
I'm not coding up a registry lookup for the ShellExt application command to open your file, but I had a closely-related issue to yours a year or two ago, when I needed to populate a file dialog's filter list with a list of arbitrary file extensions.
It doesn't 'validate' as such, but unknown extensions will return a string containing 'unknown file type', and you can test for that:
VBA and the Registry: Returning a File Type from a File Extension
Public Function GetExtensionType(strExt As String) As String
' Return a file extension type descriptor, if the OS knows it
' Parses out the string after the last "." and reads the registry
' GetExtensionType("txt") Returns 'Text Document'
' GetExtensionType("SystemORA.user.config") 'XML Configuration File'
' GetExtensionType("Phishy.vbs") 'VBScript Script File'
' Nigel Heffernan Excellerando.Blogspot.com
' **** THIS CODE IS IN THE PUBLIC DOMAIN ****
On Error GoTo ErrSub
Dim strType As String
Dim strTyp1 As String
Dim strTyp2 As String
strExt = Trim(strExt)
' Set a default return: if an error is raised, return this value
GetExtensionType = Trim(strExt & " (unknown file type)")
strExt = Split(strExt, ".")(UBound(Split(strExt, "."))) '
If strExt = "" Then
Exit Function
End If
With CreateObject("WScript.Shell")
' This will go to error if there's no key for strExt in HKCR
strTyp1 = .RegRead("HKCR." & strExt & "\")
If strTyp1 = "" Then
strType = strExt & " File"
Else
' This value isn't very readable, eg: Access.ACCDEFile.14
' But we can use it to retrieve a descriptive string:
strTyp2 = .RegRead("HKCR\" & strTyp1 & "\")
If strTyp2 = "" Then
' So we didn't get a descriptive string:
' Parse some readability out of strType1:
strType = strTyp1
strType = Replace(strType, "File", " File")
strType = Replace(strType, ".", " ")
Else
strType = strTyp2
End If
End If
End With
If strType <> "" Then
GetExtensionType = strType
End If
ExitSub:
Exit Function
ErrSub:
Resume ExitSub
End Function
I made it error-tolerant but I didn't bother idiot-proofing it because someone, somewhere, is building a better idiot; and it's entirely possible that the user was actually right insofar as there really are files called that, and my system didn't have a registry entry for the file type in question.
There is an obvious source of errors in the code: GetExtensionType("docx") will give you 'Microsoft Word Document' on an English-Language workstation. If your user base are working with other languages and locales, they will see the descriptive name 'Microsoft Word Document' in their chosen language; and any validation logic you've coded up will fail to match that string (unless, of course, your string literals are internationalised in a conditional compiler block).
So any validation against a predefined application name or file type needs to be at the language-independent layer of the registry, using 'strTyp1' from the root instead of the locale-dependent strings passed into 'strTyp2'.
Use the FileSystemObject from the Scripting Runtime - it has a .GetBaseName() method to extract the basename from a file path:
'Early bound (reference to Microsoft Scripting Runtime):
Dim fso As New FileSystemObject
ActiveDocument.SaveAs2 fso.GetBaseName(ActiveDocument.Name), WdSaveFormat.wdFormatXMLDocument
'Late bound:
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
ActiveDocument.SaveAs2 fso.GetBaseName(ActiveDocument.Name), WdSaveFormat.wdFormatXMLDocument
You can also retrieve the extension with the .GetExtensionName() method, the path with .GetParentFolderName(), and the drive letter with GetDriveName() (which also works with UNC paths).
If you need to find the registered name of the extension in the current Windows install, you can either use the registry method #Nile answered with or an API call to AssocQueryStringA:
Const ASSOCSTR_FRIENDLYDOCNAME = 3
Private Declare Function AssocQueryString Lib "shlwapi.dll" _
Alias "AssocQueryStringA" ( _
ByRef Flags As Long, _
ByVal str As Long, _
ByVal pszAssoc As String, _
ByVal pszExtra As String, _
ByVal pszOut As String, _
ByRef pcchOut As Long) As Long
Sub Main()
Dim buffer As String
buffer = String$(255, " ")
Dim hresult As Long
hresult = AssocQueryString(0, ASSOCSTR_FRIENDLYDOCNAME, ".docm", _
vbNullString, buffer, 255)
If hresult = 0 Then
'Should be something like "Microsoft Word Macro-Enabled Document"
Debug.Print Trim$(buffer)
End If
End Sub
Note that you can also retrieve addition information about the associated file type by passing different values for the str parameter. See the ASSOCSTR enumeration.
I have a VB.NET program which lists some text files in a directory and loops through them. For each file, the program calls notepad.exe with the /p parameter and the filename to print the file, then copies the file to a history directory, sleeps for 5 seconds(to allow notepad to open and print), and finally deletes the original file.
What's happening is, instead of printing every single text file, it is only printing "random" files from the directory. Every single text file gets copied to the history directory and deleted from the original however, so I know that it is definitely listing all of the files and attempting to process each one. I've tried adding a call to Thread.Sleep for 5000 milliseconds, then changed it to 10000 milliseconds to be sure that the original file wasn't getting deleted before notepad grabbed it to print.
I'm more curious about what is actually happening than anything (a fix would be nice too!). I manually moved some of the files that did not print to the original directory, removing them from the history directory, and reran the program, where they DID print as they should, so I know it shouldn't be the files themselves, but something to do with the code.
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Dim f() As String = ListFiles("l:\", "997")
Dim i As Integer
Try
For i = 0 To f.Length - 1
If Not f(i) = "" Then
System.Diagnostics.Process.Start("Notepad.exe", " /p l:\" & f(i))
My.Computer.FileSystem.CopyFile("l:\" & f(i), "k:\" & f(i))
'Thread.Sleep(5000)
Thread.Sleep(10000)
My.Computer.FileSystem.DeleteFile("l:\" & f(i))
End If
Next
'Thread.Sleep(5000)
Thread.Sleep(10000)
Catch ex As Exception
End Try
End Sub
Public Function ListFiles(ByVal strFilePath As String, ByVal strFileFilter As String) As String()
'finds all files in the strFilePath variable and matches them to the strFileFilter variable
'adds to string array strFiles if filename matches filter
Dim i As Integer = 0
Dim strFileName As String
Dim strFiles(0) As String
Dim strExclude As String = ""
Dim pos As Integer = 0
Dim posinc As Integer = 0
strFileName = Dir(strFilePath)
Do While Len(strFileName) > 0
'check to see if filename matches filter
If InStr(strFileName, strFileFilter) Then
If InStr(strFileName, "997") Then
FileOpen(1, strFilePath & strFileName, OpenMode.Input)
Do Until EOF(1)
strExclude = InputString(1, LOF(1))
Loop
pos = InStr(UCase(strExclude), "MANIFEST")
posinc = posinc + pos
pos = InStr(UCase(strExclude), "INVOICE")
posinc = posinc + pos
FileClose(1)
Else : posinc = 1
End If
If posinc > 0 Then
'add file to array
ReDim Preserve strFiles(i)
strFiles(i) = strFileName
i += 1
Else
My.Computer.FileSystem.MoveFile("l:\" & strFileName, "k:\" & strFileName)
End If
'MsgBox(strFileName & " " & IO.File.GetLastWriteTime(strFileName).ToString)
pos = 0
posinc = 0
End If
'get the next file
strFileName = Dir()
Loop
Return strFiles
End Function
Brief overview of the code above. An automated program fills the "L:\" directory with text files, and this program needs to print out certain files with "997" in the filename (namely files with "997" in the filename and containing the text "INVOICE" or "MANIFEST"). The ListFiles function does exactly this, then back in the Form1_Load() sub it is supposed to print each file, copy it, and delete the original.
Something to note, this code is developed in Visual Studio 2013 on Windows 7. The machine that actually runs this program is still on Windows XP.
I can see a few issues. the first and most obvious is the error handling:
You have a Try.. Catch with no error handling. You may be running in to an error without knowing it!! Add some output here, so you know if that is the case.
The second issue is to do with the way you are handling Process classes.
Instead of just calling System.Diagnostics.Process.Start in a loop and sleeping you should use the inbuilt method of handling execution. You are also not disposing of anything, which makes me die a little inside.
Try something like
Using p As New System.Diagnostics.Process
p.Start("Notepad.exe", " /p l:\" & f(i))
p.WaitForExit()
End Using
With both of these changes in place you should not have any issues. If you do there should at least be errors for you to look at and provide here, if necessary.
I want to store a unicode string in a flat file on a windows box from an excel/vba macro. The macro converts normal string to unicode representation, need to store it in a file and retrieve later.
As mentioned, you can use the Microsoft Scripting Runtime (scrrun.dll). I have posted some examples below. Some people also like the native file IO features. There is an extensive (and fairly comprehensive thread) thread here: http://www.xtremevbtalk.com/showthread.php?t=123814
However for Unicode files it's probably the least painful to use Textstreams:)
Public Sub StringToTextFile(ByVal path As String, ByVal value As String)
'Requires reference to scrrun.dll
Dim fso As Scripting.FileSystemObject
Dim ts As Scripting.TextStream
Set fso = New Scripting.FileSystemObject
Set ts = fso.CreateTextFile(path, False, True)
ts.Write value
ts.Close
End Sub
Public Sub LazyMansWay(ByVal path As String, ByVal value As String)
'Reference counting will cause the objects to be destroyed. The termination
'events of the classes will cause the connections to be closed.
CreateObject("Scripting.FileSystemObject").CreateTextFile(path, False, True).Write value
End Sub
Add a reference to "Microsoft Scripting Runtime" COM component (scrrun.dll).
It has all the classes (specifically FileSystemObject/TextStream) to create/read/write files.
The best solution I could figure is read the string in to a byte array and write each byte to a binary file
Private Function WriteBinaryFile(ByRef szData As String)
Dim bytData() As Byte
Dim lCount As Long
bytData = szData
Open PwdFileName For Binary As #1
For lCount = LBound(bytData) To UBound(bytData)
Put #1, , bytData(lCount)
Next lCount
Close #1
End Function
Read it back by opening the file in binary mode and reading each byte into a byte array and then converting it to a string.
Sub ReadBinaryFile(ByRef gszData As String)
Dim aryBytes() As Byte
Dim bytInput As Byte
Dim intFileNumber
Dim intFilePos
intFileNumber = FreeFile
Open PwdFileName For Binary As #intFileNumber
intFilePos = 1
Do
Get #intFileNumber, intFilePos, bytInput
If EOF(intFileNumber) = True Then Exit Do
ReDim Preserve aryBytes(intFilePos - 1)
aryBytes(UBound(aryBytes)) = bytInput
intFilePos = intFilePos + 1
Loop While EOF(intFileNumber) = False
Close #intFileNumber
gszData = aryBytes
End Sub