I created a nice macro for CATIA V5, that make some geometrical parameters increase in a loop, and save the file for each case.
Unfortunately, there are some combinations that won't work and create errors in catia itself.
Until know I used On error Resume Next.
But I would prefere that if there is an error, it saves it as the previous, errorless, file
here is a part of my code :
For i = 1 To 10
strParam2.Value = Val(i) * 1
part1.Update
On Error Resume Next
folderpath3 = folderpath2 & "\" & "file" & i
MkDir folderpath3
name = folderpath3 & "\" & "file" & i
partDocument1.ExportData name, "CATPart"
If someone has an idea, I would be grateful!
matthieu
You should save a last known correct value if the part can be updated and then use this value if you have an error on Update. You should initialize lastCorrectValue to a value which will always work. I don't know what type do you use, so I just initialized it to an Integer with the value of 5.
Dim lastCorrectValue as Integer
lastCorrectValue = 5
For i = 1 To 10
strParam2.Value = Val(i) * 1
On Error Resume Next
part1.Update
If Err = 0 Then GoTo Continue
strParam2.Value = lastCorrectValue
part1.Update
Continue:
lastCorrectValue = strParam2.Value
folderpath3 = folderpath2 & "\" & "file" & i
MkDir folderpath3
name = folderpath3 & "\" & "file" & i
partDocument1.ExportData name, "CATPart"
Next i
Related
I'm struggling to figure out what I need to do in order to run this code. I've based almost the entire thing off of this question:
MS Access VBA download attachment Mkdir path not exist
In which we have similar objectives, except mine is to send all fields from a table to two new folders based off of two fields "engine" and "testtype" rather than "year" and "month" as in the question posted above^.
I'm very new to VBA programming (basically started two weeks ago), and am open to any suggestions. Basically, I set the Dim for Record 1 as a string so that the field value could be read and not have an error pop up. But, I'm still using the code from the question above at the end of the script, and I'm not sure if I should keep it in, given my objective. The question above has multiple attachments in one field, whereas I just have multiple fields with strings in their records.
I'm getting the error message at the "While Not Record1.EOF" line.
Please advise if possible!
Sub Eng_Test()
Dim database As DAO.database
Dim table As DAO.Recordset
Dim PONum As String
Dim folder As String
Dim Record1 As String
Set database = CurrentDb
Dim PKey As String
Dim P2Key As String
Set table = database.OpenRecordset("tblFieldLogNOAUTO#")
folder = "C:\users"
If Len(Dir(folder, vbDirectory)) = 0 Then
MkDir folder
End If
folder = folder & "\ndemos"
If Len(Dir(folder, vbDirectory)) = 0 Then
MkDir folder
End If
folder = folder & "\ONEDRIVE"
If Len(Dir(folder, vbDirectory)) = 0 Then
MkDir folder
End If
folder = folder & "\Documents"
If Len(Dir(folder, vbDirectory)) = 0 Then
MkDir folder
End If
With table
Do Until .EOF
Record1 = table.Fields("TimeDateTeam").Value
'Record2 = table.Fields("frmDate").Value
'Record3 = table.Fields("Location").Value
'Record4 = table.Fields("Engine").Value
'Record5 = table.Fields("TestType").Value
'Record6 = table.Fields("Data Locator").Value
'Record7 = table.Fields("Calibration File").Value
'Record8 = table.Fields("Engine Serial").Value
'Record9 = table.Fields("VIN Number").Value
'Record10 = table.Fields("Moe Number").Value
'Record11 = table.Fields("Name/Team").Value
'Records = Record1 & Record2 & Record3 & Record4 & Record5 & Record6 & Record7 & Record8 & Record9 & Record10 & Record11
PKey = table.Fields("Engine").Value
If Len(Dir(folder & "\" & PKey, vbDirectory)) = 0 Then
MkDir folder & "\" & PKey
End If
P2Key = table.Fields("TestType").Value
If Len(Dir(folder & "\" & PKey & "\" & P2Key, vbDirectory)) = 0 Then
MkDir folder & "\" & PKey & "\" & P2Key
End If
Eng_TestFolder = folder & "\" & PKey & "\" & P2Key
While Not Record1.EOF
Record1.Fields("FileData").SaveToFile (Eng_TestFolder)
Record1.MoveNext
Wend
.MoveNext
Loop
End With
End Sub
I've receive the above error for the following code:
Dim location_results As String
location_results = Worksheets("merging").Range("B1").Text 'absorbing the initial computation results folder
file_results = Dir$(location_results & "\" & "*" & NBDID & "*" & ".*") 'checks if there is a file with NBDID in the "location results folder
If (Len(file_results) > 0) Then
Worksheets("list").Range("D" & i).Value = file_results
Else
MsgBox (NBDID & " result not found")
End If
'problem todoB:
lineD:
Dim shortlocation As String
shortlocation = ThisWorkbook.Path & "\megaresults\" & file_results
On Error GoTo lineD
'Workbooks(shortlocation).Open
Set InputFile = Workbooks.Open(FileName:=shortlocation)
'Set InputFile = Workbooks.Open(location_results & file_results)
Set OutputFile = Workbooks.Open(location_merger & file_merger)
On Error GoTo 0
The error is raised on the line:
Set InputFile = Workbooks.Open(location_results & file_results)
and on the line:
Set InputFile = Workbooks.Open(FileName:=shortlocation)
Now googling that error, nearly everyone has an issue that the file they are trying to open is not in the parents-workbook folder, or that they did not preappend their path to the file specification.
I have done that however, and the path is validated, both manually by me checking whether the file is in the folder, as well as with:
If (Len(file_results) > 0) Then
Worksheets("list").Range("D" & i).Value = file_results
Else
MsgBox (NBDID & " result not found")
End If
, the file exists, and the total path, including file name and extention is 222 characters long. It also contains spaces.
But I can't find any reason for it to return as an error. On top of that, the on error goto lineD does not function, it still pops up with a message that does not allow continuing of the code.
Could someone point out my mistake to me, or give me a solution that would work?
Kind regards.
Interesting problem here. This line of code works through multiple iterations until it reaches a point where it throws an Run-time error 91 at me: "Object Variable or With block variable not set". This is occurring in a function designed to find a deal number. The entire program is an end of day email generation program that sends attachments to various different counter-parties. The error occurs on the ** line. For additional color, temp deal is not empty when execution is attempted. There doesn't appear to be any extraneous trailing or leading spaces either. Thanks in advance!
Function getPDFs(cFirm As Variant, iFirm As Variant, row_counter As Variant, reportsByFirm As Worksheet, trMaster As Worksheet, trSeparate As Variant, trName As Variant, reportDate As Variant) As String
dealCol = 1
Dim locationArray() As String
Dim DealArray() As String
cDes = "_vs._NY"
iDes = "_vs._IC"
filePath = "X:\Office\Confirm Drop File\"
dealNum = reportsByFirm.Cells(row_counter, dealCol)
FileType = ".pdf"
If InStr(1, dealNum, "-") > 0 Then
DealArray() = Split(dealNum, "-")
tempDeal = DealArray(LBound(DealArray))
Else
tempDeal = dealNum
End If
'Finds deal location in spread sheet for further detail to obtain file path
**trLocation = trMaster.Columns(2).Find(What:=tempDeal).Address
locationArray() = Split(trLocation, "$")
trRow = locationArray(UBound(locationArray))
'Formats client names for 20 characters and removes punctuation (".") in order to stay within convention of file naming
cFirmFormatted = Trim(Left(cFirm, 20))
iFirmFormatted = Trim(Left(iFirm, 20))
'Finds clearing method
clMethod = trMaster.Cells(trRow, 6).Value
Select Case clmethod
Case "Clport"
'Prevents naming convention issues with punctuations in the name
If InStr(1, cFirmFormatted, ".") > 0 Then
cFirmFormatted = Replace(cFirmFormatted, ".", "")
End If
getPDFs = filePath & cFirmFormatted & "\" & reportDate & "_" & dealNum & "_" & cFirmFormatted & cDes & FileType
Case "ICE"
If InStr(1, iFirmFormatted, ".") > 0 Then
iFirmFormatted = Replace(iFirmFormatted, ".", "")
End If
getPDFs = filePath & iFirmFormatted & "\" & reportDate & "_" & dealNum & "_" & iFirmFormatted & iDes & FileType
End Select
End Function
Your code assumes that trLocation is always found, if it isn't found then you will receive an error because you don't have a range to return the .Address property for.
Try testing the result first:
Dim testLocation As Excel.Range
Set testLocation = trMaster.Columns(2).Find(tempDeal)
If Not testLocation Is Nothing Then
trLocation = testLocation.Address
'// Rest of code here...
Else
MsgBox "Cannot find """ & tempDeal & """!"
Exit Function
End If
I'm trying to build an structure like this below.
where I have a loop and sometimes one of the loop steps can return error but I want to skip it and continue loop till the end.
But if any of the loops execution had error I want to know it printing in a cell something like "Missing loads: ( 1 ,20 ,36)" Where this number are unique values that one of my variables on the loop receive.
So I think every time one of my loop executions return error I need to build a list of this variable value and at the end of the loop process use this list to return this error msg.
UPDATE:
For the below I want to know the list of any eventual "sProdId" value that was in the SQL query wen it fail to execute by ANY error. Usually it try to insert #Value in a numeric SQL field.
Sub SavetoSQL()
Dim conn As New ADODB.Connection
Dim iRowNo As Integer
Dim Ddate
Ddate = Range("refdate")
Dim RngRefdate As Date
RngRefdate = DateSerial(Year(Ddate), Month(Ddate), Day(Ddate))
With Sheets("Hist Prods temp")
'Open a connection to SQL Server
conn.Open "Provider=SQLOLEDB;Data Source=XXXXX;Initial Catalog=XXXXXX;User Id=XXXX;Password=XXXXXXX;"
'Skip the header row
iRowNo = 2
'Loop until empty cell in sRefDate
Do Until .Cells(iRowNo, 1) = ""
sRefDate = .Cells(iRowNo, 1)
sProdId = .Cells(iRowNo, 2)
sPrice = .Cells(iRowNo, 3)
sValue = .Cells(iRowNo, 4)
sDV01 = .Cells(iRowNo, 5)
sDelta1 = .Cells(iRowNo, 6)
sDeltaPct = .Cells(iRowNo, 7)
sGamma = .Cells(iRowNo, 8)
sVega = .Cells(iRowNo, 9)
sTheta = .Cells(iRowNo, 10)
sDelta2 = .Cells(iRowNo, 11)
sIVol = .Cells(iRowNo, 12)
'Generate and execute sql statement to import the excel rows to SQL Server table
conn.Execute "INSERT INTO [dbo].[Prices] ([Date],[Id_Product],[Price],[Value],[DV01],[Delta1$],[Delta%],[Gamma$],[Vega$],[Theta$],[Delta2$],[Ivol],[Last_Update]) values ('" & sRefDate & "', '" & sProdId & "'," & sPrice & "," & sValue & "," & sDV01 & "," & sDelta1 & "," & sDeltaPct & "," & sGamma & "," & sVega & "," & sTheta & "," & sDelta2 & "," & sIVol & ",GETDATE())"
iRowNo = iRowNo + 1
Loop
conn.Close
Set conn = Nothing
End With
End Sub
Well you are a bit confused about Error Handling in VBA, have a look into Chip's website on proper Error Handling in VBA.
Your code should be something like,
Sub MyMacro()
On Error GoTo Errhandler
Dim errLog As String
Do Until
' My loop code
'Save variable X value in a list of error values.
Loop
ExitErrHandler:
If Len(errLog) > 0 Then
Range("M2") = "Missing loads: (" & Left(errLog, Len(errLog) - 2) & ")"
End If
Exit Sub
Errhandler:
'Make a Note of the Error Number and substitute it with 1234
If Err.Number = 1234 Then
' If an error occurs, display a message in a cell with all X values on the list.
errLog = errLog & yourUniqueValue & ", "
Resume Next
Else
MsgBox "Another Error occurred." & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description
Resume ExitErrHandler
End If
End Sub
Your code makes no sense because you are turning off error handling (On Error GoTo 0) before you ever get to the loop code that would throw the error.
Here is one way to do it. I have my error handler inside the loop. It appends the x value to a string. Because x = x + 1 is in the error handler you don't have to worry about x not incrementing when you get an error. If you only care about certain Err.Number values, then change the if statement in my error handler. At the end of the code I print the error message to cell A1 of Sheet2 if and only if the error message string has at least one value. Otherwise I reset that output cell. On Error GoTo -1 is important to reset the error handler.
Sub MyMacro()
Dim x As Integer
Dim errMsg As String
Dim outWs As Worksheet
Set outWs = ThisWorkbook.Worksheets("Sheet1")
errMsg = ""
On Error GoTo CurrRecFail
x = 1
Do Until x = 15
' My loop code
CurrRecFail:
If Err.Number > 0 Then
errMsg = errMsg & x & ", "
End If
On Error GoTo -1
x = x + 1
Loop
If Len(errMsg) > 0 Then
outWs.Cells(1, 1).Value = "Missing Loads: " & Left(errMsg, Len(errMsg) - 2)
Else
outWs.Cells(1, 1).Value = ""
End If
End Sub
The code above will jump to the next loop iteration when it hits an error. If you wish instead to proceed through the rest of the lines in the current loop iteration, change On Error GoTo CurrRecFail to On Error Resume Next and delete the line CurrRecFail: which is now a meaningless label.
I have the following code, this code was written in VB6 but i can not open the form or check any references.
Private Sub PopulatePrinterCombo(cmbDestination As ComboBox)
Dim objPrinter As Printer 'a printer in the Printers collection object
'Add the printers to the combo box
For Each objPrinter In printers
cmbPrinter.AddItem objPrinter.DeviceName
Next
'Set current selection to the default printer
cmbDestination.Text = Printer.DeviceName
End Sub
I am currently copying the code onto Excel VBA macro, the problem is the Dim objPrinter As Printer code, i keep getting an error message saying "USER DEFINED TYPE NOT DEFINED", do i need a reference to add on VBA to be able to get the option of declaring a variable as a "Printer" or something?
My second question is that i do not fully understand the "Printers" in the line For Each objPrinter In printers, what is "Printers"? can someone please explain that to me.
Thank you
PART 2
I am now trying to print files, i have the following as my code:
'Initialize values
intDraftsPrinted = 0
If objDraftPaths.Count > 1 Then
Else
intSelectedDraftCount = CountSelectedDrafts
End If
'prompt user to make sure
intMsgBoxResponse = MsgBox("You selected " & intSelectedDraftCount & " part numbers. After removing duplicates" & vbNewLine & "there were " & objDraftPaths.Count & " unique draft files found." & vbNewLine & "Do you want to print these files?", vbYesNo, "TD Printer")
If intMsgBoxResponse <> vbYes Then
intSelectedDraftCount = 0 'So the following for loop will not entered
Else
intSelectedDraftCount = objDraftPaths.Count
End If
For i = 1 To intSelectedDraftCount
booSuccess = False
'open the draft file
Set objDraftDocument = OpenSolidEdgeDraft(objDraftPaths.Item(i))
If objDraftDocument Is Nothing Then
'could not open file
MsgBox "Could not open the following draft file:" & vbNewLine & _
objDraftPaths.Item(i), vbExclamation, "Solid Edge Error"
Else
'Print the draft file
For Each objSheet In objDraftDocument.Sheets
strSheetSize = DetermineSheetSize(objSheet)
If strSheetSize <> "" Then
'Determine orientation
If InStr(1, strSheetSize, "90") <> 0 Then
'Print as landscape
intOrientation = vbPRORLandscape
Else
'Print as portrait
intOrientation = vbPRORPortrait
End If
'Specify Sheet Size
Select Case Left(strSheetSize, 1)
Case "A"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSLetter
Case "B"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPS11x17
Case "C"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSCSheet
Case "D"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSDSheet
Case "E"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSESheet
Case Else
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSLetter
End Select
'Enable error handling
On Error Resume Next
'Activate the current sheet
objSheet.Activate
If Err Then
'Could not activate sheet
MsgBox "An error occurred while attempting to print: " & vbNewLine & objDraftPaths.Item(i) & vbNewLine & "The error was:" & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbExclamation, "Solid Edge Error"
Err.Clear
Else
'Print to the printer specified by the combo box
objDraftDocument.PrintOut cmbPrinter.Text, 1, intOrientation, intPaperSize, , , , igPrintSelected
If Err Then
'Could not print document
MsgBox "An error occurred while attempting to print: " & vbNewLine & objDraftPaths.Item(i) & vbNewLine & "The error was:" & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbExclamation, "Solid Edge Error"
Err.Clear
Else
booSuccess = True
End If
End If
'Disable error handling
On Error GoTo 0
End If
Next
'Close the file
objDraftDocument.Close False
intDraftsPrinted = intDraftsPrinted + 1
End If
Next i
'Dereference objects
Set objSheet = Nothing
Set objDraftDocument = Nothing
'Set objDraftPaths = Nothing
PrintSelectedDrafts = intDraftsPrinted
Now the problem comes when i hits the line that says: intOrientation = vbPRORLandscape
in excel VBA, it does not recognize "vbPRORLandscape" as well as the next line "vbPRORPortrait". Is there a way to fix that?
Also, i have a feeling that VBRUN.PrinterObjectConstants.vbPRPSLetter and the rest of those lines might not work out as well. It works in VB6 though.
Thank you
It appears the Printers Collection is available in the MS Access VBA environment but I do not believe it is intrinsic to the Excel VBA environment.
I use the WshNetwork object of Windows Script Host to list the available printers. I use the subroutine below to populate a ComboBox with the list of printers that are connected to the system. In order for this code to work you will need to add the "Windows Script Host Object Model" reference to your VBA project. (Menu: Tools > References [Select from list])
I added the (j) loop to alphabetize the list.
Sub populatePrintersList()
Dim nwo As New WshNetwork
Dim i As Integer
Dim j As Integer
Dim bAdd As Boolean
bAdd = True
cmbPrinter.Clear
For i = 0 To (nwo.EnumPrinterConnections.Count / 2) - 1
For j = 0 To cmbPrinter.ListCount - 1
If nwo.EnumPrinterConnections(i * 2 + 1) < cmbPrinter.List(j) Then
cmbPrinter.AddItem nwo.EnumPrinterConnections(i * 2 + 1), j
bAdd = False
Exit For
End If
Next j
If bAdd Then cmbPrinter.AddItem nwo.EnumPrinterConnections(i * 2 + 1): bAdd = True
Next i
cmbPrinter.ListIndex = 0
End Sub
Part 2:
MSDN contains reference material for the Worksheet.PrintOut method: Worksheet.PrintOut
In depth documentation for the methods and properties of the Worksheet.PageSetup object can also be found on MSDN: Worksheet.PageSetup
I suggest using these resources to find a plethora of answers.