I've done VBA applications and stand alone VB6 but that was a long time ago and not much with databases. I want to make a CAD software work with Excel by automating the process of taking a drawing template, saving it to a directory, and placing the next successive number back in Excel to create a list. The list would determine the next number to be used. So, I think it's a matter of query a worksheet/cell to have a starting place and build from there. Below is an example of code that already works with Access, but it also contains code from the (Autodesk Inventor) CAD VBA. I think it is routine for someone with experience. May we should dial with the data exchange only and I'll work out the other. Perhaps someone has done something like this before. Thanks.

Jon Holler





Option Explicit

Private Sub getNextPN_bak()
Dim oFileLocations As FileLocations
Dim rs As ADODB.Recordset
Dim CN As ADODB.Connection
Dim sql As String
Dim CP As String
Dim len1 As Integer
Dim c As Integer

Dim JobNo As Long
Dim BN As Integer
Dim BN1 As String
Dim BN2 As String
Dim PN As String ' Part No
Dim CH As String
Dim cs As Integer

' Open database connection
Set CN = New ADODB.Connection
CN.Provider = "Microsoft.Jet.OLEDB.4.0"
CN.Open "\\deepblue\EngineeringBOM\data\EngineeringBOM_dat a.mdb"

Set oFileLocations = ThisApplication.FileLocations

' CP = "C:\Projects\36550-36599\99999 Workspace" ' Test Data
CP = oFileLocations.Workspace
Debug.Print CP

' JobNo = Int(Mid(CP, 25, 5))
' Needs more intelligence... We do not always want to start at the 25th position.
' Instead, we need to write code to find the last "\" position and add one for the
' first variable of the Mid statement.

len1 = Len(CP) ' Length of workspace string
Debug.Print len1

For c = len1 To 1 Step -1 ' Evaluate string characters backwards
CH = Mid(CP, c, 1) ' Character
Debug.Print CH
If CH = "\" Then
cs = c + 1 ' determine starting character after '\'
Debug.Print CH & "!"
Go to proceed1
End If
Next c

proceed1:
JobNo = Int(Mid(CP, cs, 5))
Debug.Print JobNo

sql = "SELECT tblBubbleNumbers.NextBubbleNumber FROM tblBubbleNumbers WHERE (((tblBubbleNumbers.JobNo) =" & JobNo & "));"
Debug.Print sql

' Open Recordset
Set rs = New ADODB.Recordset

rs.Open Source:=sql, _
ActiveConnection:=CN, _
CursorType:=adOpenStatic, _
LockType:=adLockOptimistic, _
Options:=adCmdText

rs.MoveFirst

BN = rs!NextBubbleNumber
Debug.Print BN

txtNextBubbleNumber.Value = Str(BN)

rs!NextBubbleNumber = BN + 1
rs.Update

' Close recordset
rs.Close
Set rs = Nothing

' Create Part Number
BN1 = Str(BN)
BN1 = Right(BN1, (Len(BN1) - 1)) ' Remove first character, for some reason the string conversion adds a space at the beginning

Debug.Print BN1
Debug.Print Len(BN1)
If Len(BN1) = 1 Then
BN2 = "000" & BN1
End If
If Len(BN1) = 2 Then
BN2 = "00" & BN1
End If
If Len(BN1) = 3 Then
BN2 = "0" & BN1
End If
If Len(BN1) = 4 Then
BN2 = BN1
End If
Debug.Print BN2

PN = Mid(Str(JobNo), 2) & "-" & BN2
Debug.Print PN

' Append New Part Number to Database

sql = "SELECT * FROM tblPartsListing WHERE PartNo = '" & PN & "'"
Debug.Print sql

Set rs = New ADODB.Recordset

rs.Open Source:=sql, _
ActiveConnection:=CN, _
CursorType:=adOpenDynamic, _
LockType:=adLockOptimistic, _
Options:=adCmdText

' rs.MoveLast

If (rs.EOF Or rs.BOF) Then
rs.AddNew
rs!PartNo = UCase(PN)

rs.Update
rs.Close
Else
MsgBox "A part with the number " & PN & " already exists in the database: ", vbInformation + vbOKOnly, "Error"
End If

' Close Database Connection
CN.Close
Set CN = Nothing

' Get Workgroup path
Dim CPX As String
Dim len2 As Long

Dim JobPath As String
Dim chx As String
Dim chx2 As Integer
Dim csx As Integer

CPX = oFileLocations.FileLocationsFile
Debug.Print CPX

len2 = Len(CPX) ' Length of FileLocationsFile
Debug.Print len2

For c = len2 To 1 Step -1 ' Evaluate string characters backwards
chx = Mid(CPX, c, 1) ' Character
Debug.Print CH
If chx = "\" Then
csx = c + 1 ' determine starting character after '\'
chx2 = chx2 + 1

If chx = "\" And chx2 >= 2 Then
Debug.Print chx & "!"
Go to proceed2
End If
End If
Next c

proceed2:
JobPath = Left(CPX, (csx - 1)) & "Parts\"
Debug.Print JobPath

' Save Part to disk
' Dim oPartDoc As Inventor.Document - Duplicate Issue!
Set oPartDoc = ThisApplication.ActiveDocument
If oPartDoc.FullFileName = "" Then
Call oPartDoc.SaveAs(JobPath & PN & ".ipt", False)

End If

End Sub