I have a pretty simple code snippet here that is causing me a lot of problems. I also want to mention that using statements should be used, but the code was not originally authored by me. I'll likely fix this at some point
Dim dbShippableOpenOrders As New sqlCommand(sqlText, objConn)
Dim rsShippableOpenOrders As sqlDataReader = dbShippableOpenOrders.executeReader
...
If IsDBNull(rsShippableOpenOrders("cost")) Then
cost = 0
Else
cost = rsShippableOpenOrders("cost")
End If
I can't seem to figure out why this code is producing the following error message:
Conversion overflows.
Description: An unhandled exception occurred
during the execution of the current web request. Please review the
stack trace for more information about the error and where it
originated in the code.
Exception Details: System.OverflowException: Conversion overflows.
Source Error:
Line 355: End If
Line 356:
Line 357: If IsDBNull(rsShippableOpenOrders("cost")) Then
Line 358: cost = 0
Line 359: Else
Try the following:
Dim cost As Decimal = 0
Dim dbShippableOpenOrders As New SqlCommand(sqlText, objConn)
Dim rsShippableOpenOrders As SqlDataReader = dbShippableOpenOrders.ExecuteReader()
If rsShippableOpenOrders.HasRows Then
While rsShippableOpenOrders.Read()
If rsShippableOpenOrders("cost") IsNot Nothing AndAlso Not IsDBNull(rsShippableOpenOrders("cost")) Then
cost = CDec(rsShippableOpenOrders("cost"))
Else
cost = 0
End If
End While
End If
Here's a sample method:
Public Sub GetDataTblProduct(connectionStr As String)
Dim sqlText As String = "Select * from Product"
Dim cost As Decimal = 0
Using con As SqlConnection = New SqlConnection(connectionStr)
'open
con.Open()
Using dbShippableOpenOrders As SqlCommand = New SqlCommand(sqlText, con)
Using rsShippableOpenOrders As SqlDataReader = dbShippableOpenOrders.ExecuteReader
If rsShippableOpenOrders.HasRows Then
While rsShippableOpenOrders.Read()
If rsShippableOpenOrders("cost") IsNot Nothing AndAlso Not IsDBNull(rsShippableOpenOrders("cost")) Then
cost = CDec(rsShippableOpenOrders("cost"))
Else
cost = 0
End If
'Debug.WriteLine("cost: " & cost)
End While
End If
End Using
End Using
End Using
End Sub
I have an executable that I call using the shell command:
Shell (ThisWorkbook.Path & "\ProcessData.exe")
The executable does some computations, then exports results back to Excel. I want to be able to change the format of the results AFTER they are exported.
In other words, i need the Shell command first to WAIT until the executable finishes its task, exports the data, and THEN do the next commands to format.
I tried the Shellandwait(), but without much luck.
I had:
Sub Test()
ShellandWait (ThisWorkbook.Path & "\ProcessData.exe")
'Additional lines to format cells as needed
End Sub
Unfortunately, still, formatting takes place first before the executable finishes.
Just for reference, here was my full code using ShellandWait
' Start the indicated program and wait for it
' to finish, hiding while we wait.
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Const INFINITE = &HFFFF
Private Sub ShellAndWait(ByVal program_name As String)
Dim process_id As Long
Dim process_handle As Long
' Start the program.
On Error GoTo ShellError
process_id = Shell(program_name)
On Error GoTo 0
' Wait for the program to finish.
' Get the process handle.
process_handle = OpenProcess(SYNCHRONIZE, 0, process_id)
If process_handle <> 0 Then
WaitForSingleObject process_handle, INFINITE
CloseHandle process_handle
End If
Exit Sub
ShellError:
MsgBox "Error starting task " & _
txtProgram.Text & vbCrLf & _
Err.Description, vbOKOnly Or vbExclamation, _
"Error"
End Sub
Sub ProcessData()
ShellAndWait (ThisWorkbook.Path & "\Datacleanup.exe")
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
End Sub
Try the WshShell object instead of the native Shell function.
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim errorCode As Long
errorCode = wsh.Run("notepad.exe", windowStyle, waitOnReturn)
If errorCode = 0 Then
MsgBox "Done! No error to report."
Else
MsgBox "Program exited with error code " & errorCode & "."
End If
Though note that:
If bWaitOnReturn is set to false (the default), the Run method returns immediately after starting the program, automatically returning 0 (not to be interpreted as an error code).
So to detect whether the program executed successfully, you need waitOnReturn to be set to True as in my example above. Otherwise it will just return zero no matter what.
For early binding (gives access to Autocompletion), set a reference to "Windows Script Host Object Model" (Tools > Reference > set checkmark) and declare like this:
Dim wsh As WshShell
Set wsh = New WshShell
Now to run your process instead of Notepad... I expect your system will balk at paths containing space characters (...\My Documents\..., ...\Program Files\..., etc.), so you should enclose the path in "quotes":
Dim pth as String
pth = """" & ThisWorkbook.Path & "\ProcessData.exe" & """"
errorCode = wsh.Run(pth , windowStyle, waitOnReturn)
What you have will work once you add
Private Const SYNCHRONIZE = &H100000
which your missing. (Meaning 0 is being passed as the access right to OpenProcess which is not valid)
Making Option Explicit the top line of all your modules would have raised an error in this case
Shell-and-Wait in VBA (Compact Edition)
Sub ShellAndWait(pathFile As String)
With CreateObject("WScript.Shell")
.Run pathFile, 1, True
End With
End Sub
Example Usage:
Sub demo_Wait()
ShellAndWait ("notepad.exe")
Beep 'this won't run until Notepad window is closed
MsgBox "Done!"
End Sub
Adapted from (and more options at) Chip Pearson's site.
The WScript.Shell object's .Run() method as demonstrated in Jean-François Corbett's helpful answer is the right choice if you know that the command you invoke will finish in the expected time frame.
Below is SyncShell(), an alternative that allows you to specify a timeout, inspired by the great ShellAndWait() implementation. (The latter is a bit heavy-handed and sometimes a leaner alternative is preferable.)
' Windows API function declarations.
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCodeOut As Long) As Integer
' Synchronously executes the specified command and returns its exit code.
' Waits indefinitely for the command to finish, unless you pass a
' timeout value in seconds for `timeoutInSecs`.
Private Function SyncShell(ByVal cmd As String, _
Optional ByVal windowStyle As VbAppWinStyle = vbMinimizedFocus, _
Optional ByVal timeoutInSecs As Double = -1) As Long
Dim pid As Long ' PID (process ID) as returned by Shell().
Dim h As Long ' Process handle
Dim sts As Long ' WinAPI return value
Dim timeoutMs As Long ' WINAPI timeout value
Dim exitCode As Long
' Invoke the command (invariably asynchronously) and store the PID returned.
' Note that this invocation may raise an error.
pid = Shell(cmd, windowStyle)
' Translate the PIP into a process *handle* with the
' SYNCHRONIZE and PROCESS_QUERY_LIMITED_INFORMATION access rights,
' so we can wait for the process to terminate and query its exit code.
' &H100000 == SYNCHRONIZE, &H1000 == PROCESS_QUERY_LIMITED_INFORMATION
h = OpenProcess(&H100000 Or &H1000, 0, pid)
If h = 0 Then
Err.Raise vbObjectError + 1024, , _
"Failed to obtain process handle for process with ID " & pid & "."
End If
' Now wait for the process to terminate.
If timeoutInSecs = -1 Then
timeoutMs = &HFFFF ' INFINITE
Else
timeoutMs = timeoutInSecs * 1000
End If
sts = WaitForSingleObject(h, timeoutMs)
If sts <> 0 Then
Err.Raise vbObjectError + 1025, , _
"Waiting for process with ID " & pid & _
" to terminate timed out, or an unexpected error occurred."
End If
' Obtain the process's exit code.
sts = GetExitCodeProcess(h, exitCode) ' Return value is a BOOL: 1 for true, 0 for false
If sts <> 1 Then
Err.Raise vbObjectError + 1026, , _
"Failed to obtain exit code for process ID " & pid & "."
End If
CloseHandle h
' Return the exit code.
SyncShell = exitCode
End Function
' Example
Sub Main()
Dim cmd As String
Dim exitCode As Long
cmd = "Notepad"
' Synchronously invoke the command and wait
' at most 5 seconds for it to terminate.
exitCode = SyncShell(cmd, vbNormalFocus, 5)
MsgBox "'" & cmd & "' finished with exit code " & exitCode & ".", vbInformation
End Sub
Simpler and Compressed Code with examples:
first declare your path
Dim path: path = ThisWorkbook.Path & "\ProcessData.exe"
And then use any one line of following code you like
1) Shown + waited + exited
VBA.CreateObject("WScript.Shell").Run path,1, True
2) Hidden + waited + exited
VBA.CreateObject("WScript.Shell").Run path,0, True
3) Shown + No waited
VBA.CreateObject("WScript.Shell").Run path,1, False
4) Hidden + No waited
VBA.CreateObject("WScript.Shell").Run path,0, False
I was looking for a simple solution too and finally ended up to make these two functions, so maybe for future enthusiast readers :)
1.) prog must be running, reads tasklist from dos, output status to
file, read file in vba
2.) start prog and wait till prog is closed with a wscript shell .exec waitonrun
3.) ask for confirmation to delete tmp file
Modify program name and path variables and run in one go.
Sub dosWOR_caller()
Dim pwatch As String, ppath As String, pfull As String
pwatch = "vlc.exe" 'process to watch, or process.exe (do NOT use on cmd.exe itself...)
ppath = "C:\Program Files\VideoLAN\VLC" 'path to the program, or ThisWorkbook.Path
pfull = ppath & "\" & pwatch 'extra quotes in cmd line
Dim fout As String 'tmp file for r/w status in 1)
fout = Environ("userprofile") & "\Desktop\dosWaitOnRun_log.txt"
Dim status As Boolean, t As Double
status = False
'1) wait until done
t = Timer
If Not status Then Debug.Print "run prog first for this one! then close it to stop dosWORrun ": Shell (pfull)
status = dosWORrun(pwatch, fout)
If status Then Debug.Print "elapsed time: "; Format(Timer - t, "#.00s")
'2) wait while running
t = Timer
Debug.Print "now running the prog and waiting you close it..."
status = dosWORexec(pfull)
If status = True Then Debug.Print "elapsed time: "; Format(Timer - t, "#.00s")
'3) or if you need user action
With CreateObject("wScript.Shell")
.Run "cmd.exe /c title=.:The end:. & set /p""=Just press [enter] to delete tmp file"" & del " & fout & " & set/p""=and again to quit ;)""", 1, True
End With
End Sub
Function dosWORrun(pwatch As String, fout As String) As Boolean
'redirect sdtout to file, then read status and loop
Dim i As Long, scatch() As String
dosWORrun = False
If pwatch = "cmd.exe" Then Exit Function
With CreateObject("wScript.Shell")
Do
i = i + 1
.Run "cmd /c >""" & fout & """ (tasklist |find """ & pwatch & """ >nul && echo.""still running""|| echo.""done"")", 0, True
scatch = fReadb(fout)
Debug.Print i; scatch(0)
Loop Until scatch(0) = """done"""
End With
dosWORrun = True
End Function
Function dosWORexec(pwatch As String) As Boolean
'the trick: with .exec method, use .stdout.readall of the WshlExec object to force vba to wait too!
Dim scatch() As String, y As Object
dosWORexec = False
With CreateObject("wScript.Shell")
Set y = .exec("cmd.exe /k """ & pwatch & """ & exit")
scatch = Split(y.stdout.readall, vbNewLine)
Debug.Print y.status
Set y = Nothing
End With
dosWORexec = True
End Function
Function fReadb(txtfile As String) As String()
'fast read
Dim ff As Long, data As String
'~~. Open as txt File and read it in one go into memory
ff = FreeFile
Open txtfile For Binary As #ff
data = Space$(LOF(1))
Get #ff, , data
Close #ff
'~~> Store content in array
fReadb = Split(data, vbCrLf)
'~~ skip last crlf
If UBound(fReadb) <> -1 Then ReDim Preserve fReadb(0 To UBound(fReadb) - 1)
End Function
I incorporated this into a routine, and it has worked fine (but not used very often) for several years - for which, many thanks !
But now I find it throws up an error :-
Run-time error '-2147024894 (80070002)':
Method 'Run' of object 'IWshSheB' failed
on the line -
ErrorCode = wsh.Run(myCommand, windowStyle, WaitOnReturn)
Very strange !
5 hours later !
I THINK the reason it fails is that dear MicroSoft ("dear" meaning expensive) has changed something radical - "Shell" USED to be "Shell to DOS", but has that been changed >=?
The "Command" that I want the Shell to run is simply DIR
In full, it is "DIR C:\Folder\ /S >myFIle.txt"
. . . . . . . . . . . . . . . . . . . . . .
An hour after that-
Yup !
I have "solved" it by using this Code, which works just fine :-
Sub ShellAndWait(PathFile As String, _
Optional Wait As Boolean = True, _
Optional Hidden As Boolean = True)
' Hidden = 0; Shown = 1
Dim Hash As Integer, myBat As String, Shown As Integer
Shown = 0
If Hidden Then Shown = 1
If Hidden <> 0 Then Hidden = 1
Hash = FreeFile
myBat = "C:\Users\Public\myBat.bat"
Open myBat For Output As #Hash
Print #Hash, PathFile
Close #Hash
With CreateObject("WScript.Shell")
.Run myBat, Shown, Wait
End With
End Sub
I would come at this by using the Timer function. Figure out roughly how long you'd like the macro to pause while the .exe does its thing, and then change the '10' in the commented line to whatever time (in seconds) that you'd like.
Strt = Timer
Shell (ThisWorkbook.Path & "\ProcessData.exe")
Do While Timer < Strt + 10 'This line loops the code for 10 seconds
Loop
UserForm2.Hide
'Additional lines to set formatting
This should do the trick, let me know if not.
Cheers, Ben.
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 6 years ago.
Improve this question
i created an Application build in MS Access 2010, this create Jobs Orders, I am using split database which let me keep the tables in the server and the Front end program in the Work Station. Now, the problem is i have 6 laptops with the same application, but when the go out to the field the Laptops disconnect from network. I NEED A WAY TO SYNC TABLES WITH THE JOBS DONE when laptops come back to the office and connect to the network again.
I am Syncing pressing a button that copy files to server, delete tables locally and then copy back from server the records, but i want to find a way to Sync automatic when laptops find the network.
'*************IN THIS PART AM SENDING UPDATING SERVER AND SENDING NEW RECORDS ************
Dim x As Integer
Dim i As Integer
Dim strSQL As String
x = MsgBox("Are you Sure you want to Send to Server?????", vbOKCancel, "Are you sure?")
If x = vbOK Then
Dim intX, intY As Integer
Dim intW As Integer
Dim db As Database
Dim LSQL, SOurce, DestinaTion, fILE As String
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
SOurce = "O:\fieldticket\"
'DestinaTion = "\\rvfile03\Departments\Water\Common\FieldTickets\"
DestinaTion = "\\rwmain01\gis\FieldTicket\"
fILE = Dir$(SOurce & "*.one")
' Do While Len(fILE) > 0 And FSO.FileExists(DestinaTion & fILE) = True
Do While Len(fILE) > 0
If FSO.FileExists(fILE & DestinaTion) = False Then
FileCopy SOurce & fILE, DestinaTion & fILE
End If
fILE = Dir$()
Loop
fILE = Dir$(SOurce & "*.pdf")
Do While Len(fILE) > 0
If FSO.FileExists(fILE & DestinaTion) = False Then
FileCopy SOurce & fILE, DestinaTion & fILE
End If
fILE = Dir$()
Loop
Set db = CurrentDb()
' REINIT PROGRESS BAR
ProgressBarB.WIDTH = 0
Me.Repaint
' FILL IN OUR SQL QUERIES COLLECTION
Define_SQL_Queries
DoCmd.SetWarnings False
Me.Refresh
Me.Repaint
DoCmd.SetWarnings False
Me.Refresh
With CurrentDb
' ******* COUNT HOW MANY NEW RECORD ARE TRANSFERING **************************************************
intX = DCount("*", "RECORDS IN JobsOrder NOT IN JobsOrder1")
' ********** UPDATE JOBSORDER TABLE AND COUNT HOW MANY RECORDS ARE UPDATED ******************************
LSQL = "UPDATE_Jobsorder1_SERVER_WITH_Jobsorder"
db.Execute LSQL
' **************** GIVE A MESSAGE OF HOW MANY RECORDS ARE UPDATED AND TRANSFERED **********************
MsgBox CStr(db.RecordsAffected) & " RECORDS UPDATED " & intX & " NEW RECORDS WILL BE ADDED AND "
'************ new progress bar code using for command *************
Me.ProgressBarA.Visible = True
Me.ProgressBarB.Visible = True
For i = 1 To colSQL.Count
strSQL = colSQL(i)
Debug.Print "Executing : " & strSQL
Call .QueryDefs(strSQL).Execute
ProgressBarB.WIDTH = (ProgressBarA.WIDTH / colSQL.Count) * i
Me.Repaint
Next i
Call Me.Requery
DoCmd.SetWarnings True
End With
' MsgBox ("TRANSFER AND UPDATE HAS BEEN FINISHED!!!")
Me.ProgressBarA.Visible = False
Me.ProgressBarB.Visible = False
' Exit Sub
ElseIf x = vbCancel Then
Exit Sub
End If
'*******NOW I AM SENDING BACK FROM SERVER TO HANDHELD ************************
Dim y As Integer
Dim ii As Integer
Dim strSQL1, SOurce1, DestinaTion1, fIL1E As String
Beep
'x = MsgBox("Are you Sure you want to UPDATE HANDHELD?????", vbOKCancel, "Are you sure?")
'If y = vbOK Then
'If PASSWORD = "222222" Then
Dim intX1, intY1 As Integer
Dim intW1 As Integer
DoCmd.SetWarnings False
ProgressBarB.WIDTH = 0
Me.Repaint
'SOurce = "\\rvfile03\Departments\Water\Common\FieldTickets\"
'DestinaTion = "c:\mapping\"
'fILE = Dir$(SOurce & "*.one")
'Do While Len(fILE) > 0
' If Dir$(fILE) & "" = "" Then
' FileCopy SOurce & fILE, DestinaTion & fILE
' End If
' fILE = Dir$()
'Loop
' FILL IN OUR SQL QUERIES COLLECTION
Define_SQL_Queries1
DoCmd.SetWarnings False
Me.Refresh
With CurrentDb
intX1 = DCount("*", "RECORD IN Jobsorder1 not Finished")
' MsgBox (intX1 & " RECORDS WILL BE ADDED")
Me.ProgressBarA.Visible = True
Me.ProgressBarB.Visible = True
For ii = 1 To colSQL1.Count
strSQL1 = colSQL1(ii)
Debug.Print "Executing : " & strSQL1
Call .QueryDefs(strSQL1).Execute
ProgressBarB.WIDTH = (ProgressBarA.WIDTH / colSQL1.Count) * ii
Me.Repaint
Next ii
Call Me.Requery
DoCmd.SetWarnings True
End With
MsgBox ("HANDHELD UPDATE COMPLETED!!!"), vbInformation
ProgressBarA.Visible = False
ProgressBarB.Visible = False
Exit Sub
'ElseIf y = vbCancel Then
' Exit Sub
'End If
MsgBox (intX1 & " RECORDS ADDED TO HANDHELD")
'******** FINISHING THE HANADHEL UPDATING *******************
You'll need to write some code to check connectivity (On Error Resume next when connecting to the back end tables and check for an Error) and then connect to another local table if offline. Then once back in the office that code can then connect as normal and then you can upload your Jobs. Bottom line is that it'll take some VBA to do this. I can't give you a solution in code but this is the gist of it.
If you know how to code in VBA then you can really just check for a Network Folder that will be there if you're on the network. If it's not there, then you can assume you're offline. Then you will need to write more code to deal with local tables rather than linked tables.
Dim fso As FileSystemObject
Set fso = New FileSystemObject
If fso.FolderExists("[Path to Network Folder]") Then
' I'm online
Else
' I'm offline
End If
Have an assignment to do - it's to extract data from Lotus Notes DB including documents and their attachments. The purpose of this is to put it and store on the Sharepoint as a library.
So far I have managed to create a view and export the data for it to structure in Excel.
Also, I have looked up some Agents examples for extracting the attachments. With implementation of the below script, I managed to export the attachments:
Dim sDir As String
Dim s As NotesSession
Dim w As NotesUIWorkspace
Dim db As NotesDatabase
Dim dc As NotesDocumentCollection
Dim doc As NotesDocument
Sub Initialize
Set s = New NotesSession
Set w = New NotesUIWorkspace
Set db = s.CurrentDatabase
Set dc = db.UnprocessedDocuments
Set doc = dc.GetFirstDocument
Dim rtItem As NotesRichTextItem
Dim RTNames List As String
Dim DOCNames List As String
Dim itemCount As Integer
Dim sDefaultFolder As String
Dim x As Integer
Dim vtDir As Variant
Dim iCount As Integer
Dim j As Integer
Dim lngExportedCount As Long
Dim attachmentObject As Variant
x = MsgBox("This action will extract all attachments From the " & CStr(dc.Count) & _
" document(s) you have selected, And place them into the folder of your choice." & _
Chr(10) & Chr(10) & "Would you like To continue?", 32 + 4, "Export Attachments")
If x <> 6 Then Exit Sub
sDefaultFolder = s.GetEnvironmentString("LPP_ExportAttachments_DefaultFolder")
If sDefaultFolder = "" Then sDefaultFolder = "F:"
vtDir = w.SaveFileDialog( False, "Export attachments To which folder?", "All files|*.*", sDefaultFolder, "Choose Folder and Click Save")
If IsEmpty(vtDir) Then Exit Sub
sDir = StrLeftBack(vtDir(0), "\")
Call s.SetEnvironmentVar("LPP_ExportAttachments_DefaultFolder", sDir)
While Not (doc Is Nothing)
iCount = 0
itemCount = 0
lngExportedCount = 0
Erase RTNames
Erase DocNames
'Scan all items in document
ForAll i In doc.Items
If i.Type = RICHTEXT Then
Set rtItem = doc.GetfirstItem(i.Name)
If Not IsEmpty(rtItem.EmbeddedObjects) Then
RTNames(itemCount) = CStr(i.Name)
itemCount = itemCount +1
End If
End If
End ForAll
For j = 0 To itemCount-1
Set rtItem = Nothing
Set rtItem = doc.GetfirstItem(RTNames(j))
ForAll Obj In rtItem.EmbeddedObjects
If ( Obj.Type = EMBED_ATTACHMENT ) Then
Call ExportAttachment(Obj)
Call doc.Save( False, True )
'creates conflict doc if conflict exists
End If
End ForAll
Next
'Scan all items in document
ForAll i In doc.Items
If i.Type = ATTACHMENT Then
DOCNames(lngExportedCount) = i.Values(0)
lngExportedCount = lngExportedCount + 1
End If
End ForAll
For j% = 0 To lngExportedCount-1
Set attachmentObject = Nothing
Set attachmentObject = doc.GetAttachment(DOCNames(j%))
Call ExportAttachment(attachmentObject)
Call doc.Save( False, True )
'creates conflict doc if conflict exists
Next
Set doc = dc.GetNextDocument(doc)
Wend
MsgBox "Export Complete.", 16, "Finished"
End Sub
Sub ExportAttachment(o As Variant)
Dim sAttachmentName As String
Dim sNum As String
Dim sTemp As String
sAttachmentName = sDir & "\" & o.Source
While Not (Dir$(sAttachmentName, 0) = "")
sNum = Right(StrLeftBack(sAttachmentName, "."), 2)
If IsNumeric(sNum) Then
sTemp = StrLeftBack(sAttachmentName, ".")
sTemp = Left(sTemp, Len(sTemp) - 2)
sAttachmentName = sTemp & Format$(CInt(sNum) + 1, "##00") & _
"." & StrRightBack(sAttachmentName, ".")
Else
sAttachmentName = StrLeftBack(sAttachmentName, ".") & _
"01." & StrRightBack(sAttachmentName, ".")
End If
Wend
Print "Exporting " & sAttachmentName
'Save the file
Call o.ExtractFile( sAttachmentName )
End Sub
So the issue I do have right now is that these attachments are being saved to the same folder, which means that I would manually have to put them into right folders of library (several thousands). Could anyone help on how should I change the above code to have the attachments saved to separate folder for each document from DB?
Also for some reason that I cant find out below line is causing error pop up with "Object Variable not set":
sAttachmentName = sDir & "\" & o.Source
Would anyone know why it causes failure and stops the whole process?
You need to use the MkDir statement to create directory and extract attachments in the folder. Probably write something like:
MkDir sDir
You need to write code that create a new directory for each document (make sure you check if the directory exists, and preferably you make sure each directory has a unique name).
I wrote a tool like that, that exports all the fields of a document into XML, as well as attachments and embedded images. It can be set to separate each document into it's own directory.
You can read more about it ate the link below, perhaps you can get some ideas from the description. I use the UniversalID of teh document to get a unique folder name.
http://www.texasswede.com/websites/texasswede.nsf/Page/Notes%20XML%20Exporter
I have some code to build a basic report in access but, when I try to loop through all the reports with my variable rpt it skips the loop section, because nothing is assigned to the object. Any Ideas? What I need to get rpt to find the report with the caption qryDummy. Thanks in advance! :-)
Dim rptReport As Access.Report
Dim strCaption As String
Dim rpt As Report
CurrentDb.QueryDefs("qryDummy").SQL = strSQL
' Open dummy query to invoke NewObjectAutoReport command on it
' Put the report created to design view to make properties editable
With DoCmd
.OpenQuery "qryDummy", acViewNormal
.RunCommand acCmdNewObjectAutoReport
.Close acQuery, "qryDummy"
.RunCommand acCmdDesignView
End With
' Get reference to just created report
' !!!!!!!!!! This is the Section Giving me problems will !!!!!!!!!!!!!!
' !!!!!!!!!! not loop through all the reports. !!!!!!!!!!!!!!!!!!!!!!!!!
For Each rpt In Reports
If rpt.Caption = "qryDummy" Then Set rptReport = rpt
Next
With rptReport
' Create title control
With CreateReportControl(.Name, acLabel, _
acPageHeader, , ReportTitle, 0, 0)
.FontBold = True
.FontSize = 12
.SizeToFit
End With
' Create timestamp on footer
CreateReportControl .Name, acLabel, _
acPageFooter, , Now(), 0, 0
' Create page numbering on footer
With CreateReportControl(.Name, acTextBox, _
acPageFooter, , "='Page ' & [Page] & ' of ' & [Pages]", _
.Width - 1000, 0)
.SizeToFit
End With
' Detach the report from dummy query
.RecordSource = strSQL
' Set the report caption to autogenerated unique string
strCaption = GetUniqueReportName
If strCaption <> "" Then .Caption = strCaption
End With
DoCmd.RunCommand acCmdPrintPreview
Set rptReport = Nothing
EDIT:
Ok So I guess my problem will use this snippet of code as the report is left open when the VBA runs:
For Each rpt In Reports
If rpt.Caption = "qryDummy" Then Set rptReport = rpt
Next
The only problem I have is it is not assigning rptReport = rpt I get the error: rpt = nothing, which results in rpt.caption = "Object variable or with block variable not set". So it is like the open report is not being seen?
FYI Solved the Problem need to change rpt.caption to rpt.Name Thanks for the help!
Dim rpt As Report
For Each rpt In Reports
Debug.Print rpt.Name
Next
will only iterate through Reports that are currently open. To iterate through all reports you need to do
Dim rpt As Object
For Each rpt In Application.CurrentProject.AllReports
Debug.Print rpt.Name
Next