Trying to add the latest revision number to my drawing number
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
I'm trying to add the latest revision number from my revision table to the end of my drawing number. Right now it is set to pull in from a manually entered field in an excel file. Here is what I have
Public Sub UpdateTitleBlock()
'On Error Resume Next
Dim titleB, boxesB, textB As textBox
Dim bRet As Boolean
Dim PDFAddIn As TranslatorAddIn
Set PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
If drawingB Is Nothing Then
Set drawingB = ThisApplication.ActiveDocument
End If
Dim sheetsB As Sheets
Set sheetsB = drawingB.Sheets
Dim sheetB As sheet
Dim PromptProp() As Variant
Dim rev As String
Dim jNum As String
Dim dScale As Double
Dim draw As String
Dim shtSizeDesc As String
Dim iPos As Long
Dim sheetName As String
Const numSize As Integer = 2 'Numer of digits in sheet number at end of drawing number
Const revNote As String = "<REV>"
Const drawNum As String = "<DRAWING NO>"
Const jobNum As String = "<JOB NO>"
Const shtNumber As String = "<SHEET NO>"
Const shtTotal As String = "<SHEET NO TOTAL>"
Const shtScale As String = "<PLOT SCALE>"
Const oldDwgTB As String = "<AUTHOR>"
Const shtSize As String = "<DWG SIZE>"
xlArray PromptProp
drawingB.Update
'Call Update_TitleBlock
For Each sheetB In sheetsB 'rotates through each sheet
sheetB.Activate
sheetB.Update
Dim oDrgViews As DrawingViews
Set oDrgViews = sheetB.DrawingViews
Dim oDrgView As DrawingView
For Each oDrgView In oDrgViews 'rotates through each view making sure they are up to date.
If oDrgView.IsRasterView() = True Then
Debug.Print oDrgView.IsRasterView() & "is raster."
End If
oDrgView.IsRasterView() = False
Next
Set titleB = sheetB.TitleBlock
Set boxesB = titleB.Definition.Sketch.TextBoxes
For Each textB In boxesB
If textB.Text = oldDwgTB Then
Call UpdateTB 'Check for old Title Block
Exit For
End If
If textB.Text = shtSize Then
shtSizeDesc = sheetB.Size
If shtSizeDesc = 9988 Then
Call titleB.SetPromptResultText(textB, "B")
ElseIf shtSizeDesc = 9990 Then
Call titleB.SetPromptResultText(textB, "D")
ElseIf shtSizeDesc = 9989 Then
Call titleB.SetPromptResultText(textB, "C")
ElseIf shtSizeDesc = 9987 Then
Call titleB.SetPromptResultText(textB, "A")
ElseIf shtSizeDesc = 9991 Then
Call titleB.SetPromptResultText(textB, "E")
Else
Call titleB.SetPromptResultText(textB, "-")
End If
End If
Next
If UBound(PromptProp) > 1 Then
Dim i As Long, j As Boolean
For i = LBound(PromptProp) To UBound(PromptProp) 'Enter items from Excel into drawing border.
If Not IsEmpty(PromptProp(i, 2)) Then
For Each textB In boxesB
If textB.Text = PromptProp(i, 1) Then
Call titleB.SetPromptResultText(textB, PromptProp(i, 2))
End If
If textB.Text = jobNum Then
jNum = titleB.GetResultText(textB)
End If
Next
End If
Next
For Each textB In boxesB
If textB.Text = revNote Then
rev = titleB.GetResultText(textB)
End If
Next
For Each textB In boxesB
If textB.Text = drawNum Then 'Checks for drawing number sheet and revision
iPos = InStrRev(sheetB.Name, ":")
sheetName = Right(sheetB.Name, Len(sheetB.Name) - iPos)
If CInt(sheetName) < 10 Then 'add zero if sheet num less than 10 to keep 2 digit code
sheetName = "0" & sheetName
End If
draw = titleB.GetResultText(textB)
If Len(draw) < 4 Then 'If drawing is small than 3(01a) then use filename
draw = drawingB.FullFileName
draw = Right(draw, Len(draw) - InStrRev(drawingB.FullFileName, "\"))
End If
'Debug.Print Len(draw)
draw = Left(draw, InStrRev(draw, "-"))
'*NO LONGER NEEDED If (Len(jNum) > 1) And (Len(draw) > 1) Then 'Adds Job number to begining of drawing number
'Name now updated by file name draw = Right(draw, Len(draw) - InStr(draw, "-") + 1)
' 'Debug.Print Mid(draw, 2, 1) & IsNumeric(Mid(draw, 2, 1))
' If IsNumeric(Mid(draw, 2, 1)) = True Then
' draw = Right(draw, Len(draw) - InStr(2, draw, "-") + 1)
' End If
' draw = jNum & draw
' End If
'Debug.Print draw
draw = draw & sheetName & rev
Call titleB.SetPromptResultText(textB, draw)
ElseIf textB.Text = shtNumber Then
iPos = InStrRev(sheetB.Name, ":")
sheetName = Right(sheetB.Name, Len(sheetB.Name) - iPos)
Call titleB.SetPromptResultText(textB, sheetName)
ElseIf textB.Text = shtTotal Then
Call titleB.SetPromptResultText(textB, sheetsB.Count)
ElseIf textB.Text = shtScale Then
'If titleB.GetResultText(textB) = "" Then
Call titleB.SetPromptResultText(textB, sheetB.DrawingViews.Item(1).ScaleString)
'End If
End If
Next
Else
For Each textB In boxesB
If textB.Text = revNote Then
rev = titleB.GetResultText(textB)
End If
Next
End If
Next
drawingB.Save2
Dim oContext As TranslationContext
Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = kFileBrowseIOMechanism
' Create a NameValueMap object
Dim oOptions As NameValueMap
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
' Create a DataMedium object
Dim oDataMedium As DataMedium
Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
'If PDFAddIn.HasSaveCopyAsOptions(oDataMedium, oContext, oOptions) Then
If PDFAddIn.HasSaveCopyAsOptions(drawingB, oContext, oOptions) Then
oOptions.Value("All_Color_AS_Black") = 0
oOptions.Value("Remove_Line_Weights") = 0
oOptions.Value("Vector_Resolution") = 400
oOptions.Value("Sheet_Range") = Inventor.PrintRangeEnum.kPrintAllSheets
'oOptions.Value("Custom_Begin_Sheet") = 2 'oOptions.Value("Custom_End_Sheet") = 4
End If
oDataMedium.filename = SaveNameRev(drawingB, "01", rev, ".pdf")
If IsFileOpen(oDataMedium.filename) = False Then
Call PDFAddIn.SaveCopyAs(drawingB, oContext, oOptions, oDataMedium)
Else
MsgBox "File OPEN, please close " & oDataMedium.filename & " and run again."
End If
Call WriteSheetMetalDXF(drawingB, rev)
Set drawingB = Nothing
Set titleB = Nothing
Set boxesB = Nothing
'Call isOpen
End Sub
