With Matt's permission:
Option Explicit
Private Const strDefaultPath = "S:\Jobs\2008\"
Private Const strDWTPath = "S:\Drafting\Templates\Drawing Templates\"
Public strNewDwgPath As String
Public strTB As String
Public intSDIMode As Integer
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdOK_Click()
If CreateJob.Value = True Then
If CheckFoldersExistance(strDefaultPath & txtFolderName.Text) = True Then
MsgBox "The project '" & TitleCase(txtFolderName.Text) & "' already exists! Please enter a different name!", vbCritical + vbOKOnly, AppTitle
frmMain.txtFolderName.Text = ""
MultiPage1.Value = 0
Exit Sub
End If
If txtFolderName <> "" Then
intSDIMode = ThisDrawing.GetVariable("SDI")
If intSDIMode = 1 Then
ThisDrawing.SetVariable "SDI", 0
CreateProject
CreateDrawings
ThisDrawing.SetVariable "SDI", intSDIMode
Else
CreateProject
CreateDrawings
End If
MsgBox "Project setup complete!", vbInformation + vbOKOnly, AppTitle
Unload Me
Else
MsgBox "You didn't enter a folder name. Please enter a valid folder name before continuing!", vbCritical + vbOKOnly, AppTitle
End If
ElseIf ExistJob.Value = True Then
If CheckFoldersExistance(strDefaultPath & txtExistFolder.Text) = False Then
MsgBox "The project '" & TitleCase(txtExistFolder.Text) & "' does not exist! Please enter a different name!", vbCritical + vbOKOnly, AppTitle
frmMain.txtExistFolder.Text = ""
MultiPage1.Value = 0
Exit Sub
End If
If txtExistFolder <> "" Then
intSDIMode = ThisDrawing.GetVariable("SDI")
If intSDIMode = 1 Then
ThisDrawing.SetVariable "SDI", 0
InsertProject
CreateDrawings
ThisDrawing.SetVariable "SDI", intSDIMode
Else
InsertProject
CreateDrawings
End If
MsgBox "Project setup complete!", vbInformation + vbOKOnly, AppTitle
Unload Me
Else
MsgBox "You didn't enter a folder name. Please enter a valid folder name before continuing!", vbCritical + vbOKOnly, AppTitle
End If
End If
End Sub
Private Sub CreateProject()
Dim strProjectPath As String
strProjectPath = strDefaultPath & TitleCase(txtFolderName.Text) & "\"
If chkFolder1.Value = True Then
CreateFolder strProjectPath & "Drawings" & "\"
strNewDwgPath = strProjectPath & "Drawings" & "\"
End If
If chkFolder2.Value = True Then CreateFolder strProjectPath & "Calculations" & "\"
If chkFolder3.Value = True Then CreateFolder strProjectPath & "Pictures" & "\"
If chkFolder4.Value = True Then CreateFolder strProjectPath & "Correspondence" & "\"
If chkFolder5.Value = True Then CreateFolder strProjectPath & "Email" & "\"
End Sub
Private Sub InsertProject()
Dim strProjectPath As String
strProjectPath = strDefaultPath & TitleCase(txtExistFolder.Text) & "\"
If chkFolder1.Value = True Then
CreateFolder strProjectPath & "Drawings" & "\"
strNewDwgPath = strProjectPath & "Drawings" & "\"
End If
If chkFolder2.Value = True Then CreateFolder strProjectPath & "Calculations" & "\"
If chkFolder3.Value = True Then CreateFolder strProjectPath & "Pictures" & "\"
If chkFolder4.Value = True Then CreateFolder strProjectPath & "Correspondence" & "\"
If chkFolder5.Value = True Then CreateFolder strProjectPath & "Email" & "\"
End Sub
Private Sub CreateDrawings()
Dim fso As FileSystemObject
Dim objUtil As Object
Dim varPnt As Variant
Dim dblX As Double
Dim dblAngle As Double
Dim objLayout As AcadLayout
dblAngle = CDbl(0 / 180 * (Atn(1) * 4))
Set objUtil = ThisDrawing.Utility
objUtil.CreateTypedArray varPnt, vbDouble, 0#, 0#, 0#
dblX = CDbl(1#)
Set fso = New FileSystemObject
fso.CopyFile strDWTPath & cboTB.Text & ".dwg", strNewDwgPath & cboTB.Text & ".dwg", True
strTB = cboTB.Text
If chkDwg1.Value = True Then
fso.CopyFile strDWTPath & "C-01.dwt", strNewDwgPath & "C-01.dwg", True
Application.Documents.Open strNewDwgPath & "C-01.dwg"
For Each objLayout In ThisDrawing.Layouts
If objLayout.Name <> "Model" Then
ThisDrawing.ActiveLayout = ThisDrawing.Layouts(objLayout.Name)
ThisDrawing.PaperSpace.AttachExternalReference strNewDwgPath & strTB & ".dwg", strTB, varPnt, dblX, dblX, dblX, dblAngle, True
End If
Next objLayout
Application.ActiveDocument.Close True
End If
If chkDwg2.Value = True Then
fso.CopyFile strDWTPath & "S-01.dwt", strNewDwgPath & "S-01.dwg", True
Application.Documents.Open strNewDwgPath & "S-01.dwg"
For Each objLayout In ThisDrawing.Layouts
If objLayout.Name <> "Model" Then
ThisDrawing.ActiveLayout = ThisDrawing.Layouts(objLayout.Name)
ThisDrawing.PaperSpace.AttachExternalReference strNewDwgPath & strTB & ".dwg", strTB, varPnt, dblX, dblX, dblX, dblAngle, True
End If
Next objLayout
Application.ActiveDocument.Close True
End If
If chkDwg3.Value = True Then
fso.CopyFile strDWTPath & "S-02.dwt", strNewDwgPath & "S-02.dwg", True
Application.Documents.Open strNewDwgPath & "S-02.dwg"
For Each objLayout In ThisDrawing.Layouts
If objLayout.Name <> "Model" Then
ThisDrawing.ActiveLayout = ThisDrawing.Layouts(objLayout.Name)
ThisDrawing.PaperSpace.AttachExternalReference strNewDwgPath & strTB & ".dwg", strTB, varPnt, dblX, dblX, dblX, dblAngle, True
End If
Next objLayout
Application.ActiveDocument.Close True
End If
If chkDwg4.Value = True Then
fso.CopyFile strDWTPath & "A-01.dwt", strNewDwgPath & "A-01.dwg", True
Application.Documents.Open strNewDwgPath & "A-01.dwg"
For Each objLayout In ThisDrawing.Layouts
If objLayout.Name <> "Model" Then
ThisDrawing.ActiveLayout = ThisDrawing.Layouts(objLayout.Name)
ThisDrawing.PaperSpace.AttachExternalReference strNewDwgPath & strTB & ".dwg", strTB, varPnt, dblX, dblX, dblX, dblAngle, True
End If
Next objLayout
Application.ActiveDocument.Close True
End If
Set fso = Nothing
End Sub
Private Function CreateFolder(sFolder As String) As String
Dim s As String
On Error GoTo ErrorHandler
s = GetPathOnly(sFolder)
If Dir(s, vbDirectory) = "" Then
s = CreateFolder(s)
MkDir s
End If
CreateFolder = sFolder
Exit Function
ErrorHandler:
Exit Function
End Function
Private Function GetPathOnly(sPath As String) As String
GetPathOnly = Left(sPath, InStrRev(sPath, "\", Len(sPath)) - 1)
End Function
Private Sub MultiPage1_Change()
End Sub
Private Sub UserForm_Initialize()
MultiPage1.Value = 0
With cboTB
.AddItem "X-TB-CASE"
.AddItem "X-TB-MI-Swaco"
.AddItem "X-TB-ToddBroussard"
.AddItem "X-TB-RogerMcChargue"
.ListIndex = 0
End With
End Sub
First text box = txtFolderName
Second text box = txtExistFolder
First OptionButton = CreateJob
Second OptionButton = ExistJob
(edit... updated text box names... forgot the 'txt's)