PDA

View Full Version : [SOLVED] Auto add code to [ThisWorkbook] while running macro from different location



wolf.stalker
09-24-2008, 04:38 AM
let me see if i can "explain" what I am trying to do before posting the code. I thought I had this figured out...but opps :bug: ....i was wrong.

One of my procedures takes all the worksheets in my workbook, and turns each sheet into it's own workbook. the code i have does this part nicely.

With the help of a fellow user :friends: (GTO), I was able to solve how to procect my vba project through a macro using sendkeys.

now i am trying to tie the two together. i would like for my macro that turns worksheets into workbooks to also add the code that protects vbaprojects in the "ThisWorkbook" object as it will need to run on a workbook open feature. How might I go about doing this?


here is part of the code for building workbooks from worksheets


For Each wkSheet In CurWkbook.Worksheets
If wkSheet.Index < 5 Then
'do nothing
Else
shtcnt(1) = (6)
Application.StatusBar = shtcnt(1) & "/" & shtcnt(2) & _
" " & wkSheet.Name ' so we can see whats going on in status bar
wkSheetName = Trim(wkSheet.Name) 'get name of worksheet
wkSheetName = wkSheetName & " " & dtimestamp 'add date stamp to worksheet name
Workbooks.Add ' auto build a new workbook
ActiveWorkbook.SaveAs _
Filename:=xpathname & wkSheetName & ".xls", _
FileFormat:=xlNormal, Password:="", _
WriteResPassword:="", CreateBackup:=False, _
ReadOnlyRecommended:=False 'how we save new workbook with name and stuff
Set newWkbook = ActiveWorkbook
Application.DisplayAlerts = False
newWkbook.Worksheets("sheet1").Delete ' remove sheet1
On Error Resume Next
newWkbook.Worksheets(wkSheet.Name).Delete
On Error GoTo 0
Application.DisplayAlerts = True
CurWkbook.Worksheets(wkSheet.Name).Copy before:=newWkbook.Sheets(1)
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
Next wkSheet


Here is code for using send keys to lock vbaproject


Private Sub workbook_open()
With Application
.VBE.mainwindow.Visible = True
.VBE.CommandBars("Menu Bar").Controls("Tools").Controls("VBAProject Properties...").Execute
.SendKeys "^{TAB}"
.SendKeys "{ }"
.SendKeys "{TAB}" & "123"
.SendKeys "{TAB}" & "123"
.SendKeys "{TAB}"
.SendKeys "{ENTER}"
.VBE.mainwindow.Visible = False
End With
End Sub



and if it's not to much trouble, is there a way to check to see if vbaproject is protected before workbook_open ? i have been testing it and i keep getting promted for password which means i think i might be stuck there too. i can always live with the user getting prompted for password i guess when they open up workbook :-D

Norie
09-24-2008, 04:50 AM
I know this doesn't actually deal with your question but there is another way to create a new workbook for each worksheet.


For Each ws In ThisWorkbook.Worksheets
ws.Copy
ActiveWorkbook.SaveAs Filename:=xpathname & ws.Name & ".xls"
Next ws

wolf.stalker
09-24-2008, 05:23 AM
I know this doesn't actually deal with your question but there is another way to create a new workbook for each worksheet.


For Each ws In ThisWorkbook.Worksheets
ws.Copy
ActiveWorkbook.SaveAs Filename:=xpathname & ws.Name & ".xls"
Next ws


hmm, good point. i didn't think of that. actually i got that snip-it of code awhile back and it worked so i ran with it. didn't think to slim it down :-)

GTO
09-24-2008, 11:57 PM
Presuming (1) that you don't have an armful of sheets in the 'parent' wb, and that (2) you don't mind if all the code from the 'parent' wb gets 'copied' to the resultant wb's, you could do this a bit backwards:

This would save a copy of the 'parent' workbook for ea sheet, deleting all but the desired sheet in ea resultant wb. This way you wouldn't have to worry whether the user had the 'Trust access to Visual Basic Project' box ticked.


Option Explicit
Sub ReplicateFile()
Dim wksWorksheet As Worksheet, _
wkbWorkbook_New As Workbook, _
strFullName As String
Dim n_wksWorksheet As Worksheet
For Each wksWorksheet In ThisWorkbook.Worksheets
If Not wksWorksheet.Index < 5 Then
'Note: I wasn't sure what "shtcnt(1)" referred to, so absent is status
' bar references.
'Create a string to name the new wb as. Adjust "Format(Time, ..." as
' needed to your date stamp.
strFullName = ThisWorkbook.Path & "\" & Trim(wksWorksheet.Name) _
& "_" & Format(Time, "HhMm") & ".xls"
' SaveAs a copy of this workbook w/o loading it.
ThisWorkbook.SaveCopyAs strFullName
' Set to the new copy, but w/o the exposure of setting to 'active'
Set wkbWorkbook_New = Workbooks.Open(strFullName)
' Inner loop. Now we loop thru ea sheet in the copy of this workbook
' and if its not the sheet we want, we delete it.
For Each n_wksWorksheet In wkbWorkbook_New.Worksheets
If Not n_wksWorksheet.Name = wksWorksheet.Name Then
Application.DisplayAlerts = False
n_wksWorksheet.Delete
Application.DisplayAlerts = False
End If
Next n_wksWorksheet
'Now we're down to the one sheet we wanted in the new book, so save
' and close.
wkbWorkbook_New.Close True
' We're done w/this wb object, so explicitly release.
Set wkbWorkbook_New = Nothing
End If
' Back to outer loop...
Next wksWorksheet
End Sub