PDA

View Full Version : Combining two VBA processes



shyatt8
03-23-2009, 10:09 AM
I am a novice in VBA, and I've found some excellent macros on this site. I need to use two in one work book though. I think I need to merge the two codes into one, otherwise I get an ambiguous name error on the second one. (highlighted in red) This is to force user to enable macros, and then have the workbook expire after 30 days.

Option Explicit

Private Sub Workbook_Open()
Dim StartTime#, CurrentTime#

'*****************************************
'SET YOUR OWN TRIAL PERIOD BELOW
'Integers (1, 2, 3,...etc) = number of days use
'1/24 = 1Hr, 1/48 = 30Mins, 1/144 = 10Mins use

Const TrialPeriod# = 1 / 144 '< 30 days trial

'set your own obscure path and file-name
Const ObscurePath$ = "C:\"
Const ObscureFile$ = "TestFileLog.Log"
'*****************************************

If Dir(ObscurePath & ObscureFile) = Empty Then
StartTime = Format(Now, "#0.#########0")
Open ObscurePath & ObscureFile For Output As #1
Print #1, StartTime
Else
Open ObscurePath & ObscureFile For Input As #1
Input #1, StartTime
CurrentTime = Format(Now, "#0.#########0")
If CurrentTime < StartTime + TrialPeriod Then
Close #1
Exit Sub
Else
If [A1] <> "Expired" Then
MsgBox "Sorry, your trial period has expired - your data" & vbLf & _
"will now be extracted and saved for you..." & vbLf & _
"" & vbLf & _
"This workbook will then be made unusable."
Close #1
SaveShtsAsBook
[A1] = "Expired"
ActiveWorkbook.Save
Application.Quit
ElseIf [A1] = "Expired" Then
Close #1
Application.Quit
End If
End If
End If
Close #1
End Sub

Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
'//N.B. to remove all the cell formulas,
'//uncomment the 4 lines of code below...
'With Cells
'.Copy
'.PasteSpecial Paste:=xlPasteValues
'End With
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Open MyFilePath & "\READ ME.log" For Output As #1
Print #1, "Thank you for trying out this product."
Print #1, "If it meets your requirements, visit"
Print #1, "removed link to purchase"
Print #1, "the full (unrestricted) version..."
Close #1
End Sub
Option Explicit

Private Sub Workbook_Open()

With Application
'disable the ESC key
.EnableCancelKey = xlDisabled
.ScreenUpdating = False

Call UnhideSheets

.ScreenUpdating = True
're-enable ESC key
.EnableCancelKey = xlInterrupt
End With

End Sub
'
Private Sub UnhideSheets()
'
Dim Sheet As Object
'
For Each Sheet In Sheets
If Not Sheet.Name = "Prompt" Then
Sheet.Visible = xlSheetVisible
End If
Next
'
Sheets("Prompt").Visible = xlSheetVeryHidden
'
Application.Goto Worksheets(1).[A1], True '< Optional
'
Set Sheet = Nothing
ActiveWorkbook.Saved = True

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
With Application
.EnableCancelKey = xlDisabled
.ScreenUpdating = False

Call HideSheets

.ScreenUpdating = True
.EnableCancelKey = xlInterrupt
End With
End Sub

Private Sub HideSheets()
'
Dim Sheet As Object '< Includes worksheets and chartsheets
'
With Sheets("Prompt")
'
'the hiding of the sheets constitutes a change that generates
'an automatic "Save?" prompt, so IF the book has already
'been saved prior to this point, the next line and the lines
'relating to .[A100] below bypass the "Save?" dialog...
If ThisWorkbook.Saved = True Then .[A100] = "Saved"
'
.Visible = xlSheetVisible
'
For Each Sheet In Sheets
If Not Sheet.Name = "Prompt" Then
Sheet.Visible = xlSheetVeryHidden
End If
Next
'
If .[A100] = "Saved" Then
.[A100].ClearContents
ThisWorkbook.Save
End If
'
Set Sheet = Nothing
End With
'
End Sub

JKwan
03-23-2009, 10:17 AM
Well, the easiest thing to do:
1 - rename both SUBs to say SUB STEP1 and SUB STEP2
2 - now with a new SUB


Private Sub Workbook_Open()
STEP1
STEP2
End Sub

shyatt8
03-23-2009, 10:34 AM
Thanks JKwan, but I'm a very very novice user to the point of not really getting how processes are named. Are you saying I need to just delete the first End Sub, and the Second Private Sup Workbook_Open()

Or, do I need to add Private Sub STEP1 and Private Sub STEP2 in as well?

If you could tell me exactly what I need to change, that would be great.

Thanks

JKwan
03-23-2009, 10:36 AM
Just change both Workbook_Open to STEP1 and 2
then add a new one like in my first post - EXACTLY