saveing files with VBA

[Guest looseLISPSsinkSHIPS]

Hi,

 

We have this current VBA program to help us with AutoCAD via the use of a template excel sheet.

 

The setup we have created works well; however occasionally we have two drawings per folder, which often results in, two templates excel sheets of the same name, one overwriting the other.

 

In a nut shell dose anybody know how I can set the active drawing name in a variable that our program uses to check for, then if not present that it creates a copy of out template and then saves it as the active drawings file name which was set as the variable

 

This would allow our program to locate the associated excel sheet by name then save it by the unique drawing name and prevent existing excel files being overwritten if in the same folder.

 

Thanks-

 

;===CODE STARTS HERE===

 

Option Explicit

 

Private Objexcel As Excel.Application

Private ObjWorkbook As Workbook

 

Private Sub Frame1_Click()

 

End Sub

 

Private Sub Frame2_Click()

 

End Sub

 

Private Sub UserForm_Initialize()

Dim ObjRange As Range, ObjCell

Dim sFolder As String, sDefSheet As String

Dim iRow_counter As Integer

 

iRow_counter = 0

 

'Check if acad drawing is saved…

sFolder = fGetDefinitionSheetPath(AcadApplication.ActiveDocument.FullName)

If sFolder "" Then

' sDefSheet = "C:\ICT\AutoCAD_2009\Customisations\20090409\20090409.xls"

sDefSheet = sFolder & "\" & DEF_SHEET

 

'Check for precence of Excel-definitionsheet…

If Not fExistsDefinitionSheet(sDefSheet) Then

'Copy the standard definitionsheet…

Call fCopyDefinitionSheet(sDefSheet)

End If

 

'Opening of Excel...

Set Objexcel = CreateObject("Excel.Application")

Objexcel.Visible = False

 

Set ObjWorkbook = Objexcel.Workbooks.Open(sDefSheet)

 

Set ObjRange = ObjWorkbook.Names("Artikelinhoud").RefersToRange

 

For Each ObjCell In ObjRange

'Vullen van ComboBox met: Inhoudarticle , stored_count

ComboBox1.AddItem ObjCell.Value

'In Column "2" het aantal elementen (stored_count) plaatsen:

ComboBox1.Column(1, iRow_counter) = ObjWorkbook.Worksheets(3).Cells(ObjCell.Row, 3) + 1

 

iRow_counter = iRow_counter + 1

Next

 

'input of general information...

TextBox1 = ObjWorkbook.Worksheets(1).Cells(1, 1)

TextBox2 = ObjWorkbook.Worksheets(1).Cells(2, 1)

TextBox3 = ObjWorkbook.Worksheets(1).Cells(3, 1)

TextBox5 = ObjWorkbook.Worksheets(1).Cells(2, 2)

TextBox7 = ObjWorkbook.Worksheets(1).Cells(2, 3)

 

ObjWorkbook.Worksheets(3).Cells(31, 3).Value = "0"

 

'Set the focus to Textbox1 and highlight the text...

UserForm1.TextBox1.SetFocus

UserForm1.TextBox1.SelStart = 0

UserForm1.TextBox1.SelLength = Len(UserForm1.TextBox1.Text)

Else

Call MsgBox("Sla eerst uw tekening op in de projectmap, daarna kunt u kaders toevoegen!", vbExclamation + vbOKOnly, Me.Caption)

Unload UserForm1

End If

End Sub

 

Private Sub UserForm_Terminate()

 

'Imitate as it already saved...

ObjWorkbook.Saved = True

 

'Clear memory and close excel…

ObjWorkbook.Close

 

Objexcel.Quit

Set ObjWorkbook = Nothing

Set Objexcel = Nothing

End Sub

 

Private Sub CheckBox1_Click()

CommandButton3.Visible = CheckBox1

 

'Vrijgeven van de in te vullen velden...

Frame2.Enabled = CheckBox1

ComboBox1.Enabled = CheckBox1

'TextBox6.Enabled = CheckBox1

Label6.Enabled = CheckBox1

Label7.Enabled = CheckBox1

 

If CheckBox1 Then

'ComboBox recives first value…

ComboBox1.ListIndex = 0

 

'Calls consecutive cloumn from Combobox1…

If ComboBox1.ListIndex >= 0 Then TextBox6 = ComboBox1.Column(1)

Else

ComboBox1 = ""

TextBox6 = ""

Label8.Visible = CheckBox1

End If

End Sub

 

Private Sub ComboBox1_Change()

If ComboBox1.ListIndex >= 0 Then

TextBox6 = ComboBox1.Column(1)

Label8.Visible = True

End If

End Sub

 

Private Sub CommandButton1_Click()

Dim ObjWorksheet As Worksheet

Dim ObjRange As Range

 

UserForm1.Hide

 

Set ObjWorksheet = ObjWorkbook.Worksheets(1)

ObjWorksheet.Cells(1, 1).Value = TextBox1.Text

ObjWorksheet.Cells(2, 1).Value = TextBox2.Text

ObjWorksheet.Cells(3, 1).Value = TextBox3.Text

ObjWorksheet.Cells(2, 2).Value = TextBox5.Text

ObjWorksheet.Cells(2, 3).Value = TextBox7.Text

 

Objexcel.DisplayAlerts = False

ObjWorkbook.Save

 

Set ObjWorksheet = Nothing

 

Unload UserForm1

End Sub

 

Private Sub CommandButton2_Click()

Unload UserForm1

End Sub

 

Private Sub CommandButton3_Click()

Dim objBlock As AcadBlock

Dim objBlockRef As AcadBlockReference

Dim InsertionPnt As Variant

Dim Atts As Variant

Dim i As Integer

Dim ObjWorksheet As Worksheet

Dim ObjRange As Range

Dim intNewRow As Integer

Dim strNewCell As String

Dim ftw As String

 

UserForm1.Hide

 

Set ObjWorksheet = ObjWorkbook.Worksheets(1)

ObjWorksheet.Cells(1, 1).Value = TextBox1.Text

ObjWorksheet.Cells(2, 1).Value = TextBox2.Text

ObjWorksheet.Cells(3, 1).Value = TextBox3.Text

 

Set ObjWorksheet = ObjWorkbook.Worksheets(2)

ObjWorksheet.Cells(26, 1).Value = ComboBox1.Text

 

Set ObjWorksheet = ObjWorkbook.Worksheets(4)

Set ObjRange = ObjWorksheet.UsedRange

intNewRow = ObjRange.SpecialCells(xlCellTypeLastCell).Row + 1

strNewCell = "A" & intNewRow

ObjWorksheet.UsedRange.Cells(intNewRow).Value = ComboBox1

 

Objexcel.DisplayAlerts = False

ObjWorkbook.Save

 

Set ObjWorksheet = Nothing

 

InsertionPnt = ThisDrawing.Utility.GetPoint(, "Selecteer het startpunt:")

Set objBlockRef = ThisDrawing.ModelSpace.InsertBlock(InsertionPnt, "C:\ICT\AutoCAD_2009\Customisations\20090409\template.dwg", 1, 1, 1, 0)

 

'Sets template scale...

ftw = ObjWorkbook.Worksheets(2).Cells(32, 3).Text

objBlockRef.XScaleFactor = ftw

objBlockRef.YScaleFactor = ftw

objBlockRef.ZScaleFactor = ftw

 

If objBlockRef.HasAttributes Then

Atts = objBlockRef.GetAttributes

For i = LBound(Atts) To UBound(Atts)

Select Case (Atts(i).TagString)

Case "Onderdeel" ''the name of your attribute

Atts(i).TextString = ComboBox1.Text

Case "BLZnr"

Atts(i).TextString = ObjWorkbook.Worksheets(2).Cells(54, 12)

Case "PROJECTNR."

Atts(i).TextString = ObjWorkbook.Worksheets(1).Cells(1, 1)

Case "TEKENAAR"

Atts(i).TextString = ObjWorkbook.Worksheets(1).Cells(2, 1)

Case "DATUM"

Atts(i).TextString = ObjWorkbook.Worksheets(1).Cells(2, 2)

Case "VERD."

Atts(i).TextString = ObjWorkbook.Worksheets(1).Cells(2, 3)

Case "PROJECT"

Atts(i).TextString = ObjWorkbook.Worksheets(1).Cells(3, 1)

Case "STATUS"

Atts(i).TextString = ObjWorkbook.Worksheets(1).Cells(4, 1)

End Select

objBlockRef.Update

Next

End If

 

Unload UserForm1

End Sub

 

;===END OF CODE===

[Lee Mac]

As Marco pointed out in your other thread - please use

 [/ code] tags to post your code.
 
See here
 
http://www.cadtutor.net/forum/showthread.php?t=9184