create shortcut but not for active workbook

[pswanie]

i got the following code to save a copy of the workbook. I tried to add a
"create shortcut" but it makes the shortcut for the activeworkbook and not
the copy of the workbook...

########################***###########################

ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

ActiveSheet.Protect Password:=""



Dim bErr As Boolean
On Error Resume Next
MkDir "c:\maykent"
MkDir "C:\maykent\stocksheet"
bErr = (Err.Number <> 0)
On Error GoTo 0
If bErr Then
If Dir("C:\maykent\stocksheet\LAST WEEK stocksheet.xls") <> "" Then




ThisWorkbook.SaveCopyAs "C:\maykent\stocksheet\LAST WEEK stocksheet.xls"


CreateShortCut thisworkbook
###########################***########################

&

##########################***#########################

Sub CreateShortCut(bk As Workbook)
Dim oWSH As Object
Dim oShortcut As Object
Dim sPathDeskTop As String


Set oWSH = CreateObject("WScript.Shell")
sPathDeskTop = oWSH.SpecialFolders("Desktop")


Set oShortcut = oWSH.CreateShortCut(sPathDeskTop & "\" & _
bk.Name & ".lnk")
With oShortcut
.TargetPath = bk.FullName
.Save
End With
Set oWSH = Nothing


End Sub

#######################***############################

 

[Jim Thomlinson]

Not too sure exactly what it is that you want. Your active workbook never
changes by doing a savecopyas. Can you post the code that did not work for
you with a bit more of an expanation.

 

[pswanie]

the people that use the computers from time to time delete any and everything
from the desktop. thus what i need is that once a week when the code runs.

1. check and if neede recreate folder
2.. it save and over right a copy (got that)
3. recreate short cut (need that)

but when i use the undermentiond part i get a short cut that points to the
wrong file...

the macro gets run from StockSheet.xls
and save a copy as Previous Week StockSheet.xls
in folder c:\maykent\stocksheets

 

[Jim Thomlinson]

Forgive me I am nursing a cold at the moment so I might be missing something
here... Have you tried creating the shortcut just prior to the savecopyas...

CreateShortCut thisworkbook

ThisWorkbook.SaveCopyAs "C:\maykent\stocksheet\LAST WEEK stocksheet.xls"

 

[pswanie]

Thanx...!

i got a button in

maykent stocksheet.xls and it does the code below.

if i use the code as it is, it creates a shortcut to

maykent stocksheet.xls and not to
Previous week stocksheet.xls

the rest of the code works perfect to email and clear the selected sheets

************************************************************

Public Sub CopyIt()

Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "This will e-MAIL and CLEAR the entire stock sheet" & _
vbNewLine & " ENSURE TO SELECT CAREFULLY" '
Define message.
Style = vbOKCancel ' Define buttons.
Title = "Maykent t/a KFC" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic
' context.
' Display message.
Response = MsgBox(Msg, Style, Title)
If Response = vbOKCancel Then ' User chose Yes.



Sheets("Sheet1").Select
Range("E17").Select


Dim Msg2, Style2, Title2, Help2, Ctxt2, Response2, MyString2
Msg2 = "Ensure to select 'yes'…" & _
vbNewLine & "On the next security warning" ' Define message.
Style2 = vbExclamation ' Define buttons.
Title2 = "Maykent t/a KFC" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt2 = 1000 ' Define topic
' context.
' Display message.
Response2 = MsgBox(Msg2, Style2, Title2)


Dim bErr As Boolean
On Error Resume Next
MkDir "c:\maykent"
MkDir "C:\maykent\stocksheet"
bErr = (Err.Number <> 0)
On Error GoTo 0
If bErr Then
If Dir("C:\maykent\stocksheet\LAST WEEK stocksheet.xls") <> "" Then

'CreateShortCut ThisWorkbook

ThisWorkbook.SaveCopyAs "C:\maykent\stocksheet\LAST WEEK stocksheet.xls"

Application.ScreenUpdating = False


Sheets("products").PrintOut Copies:=1, Collate:=True

Sheets("products").Protect Password:=""



'Working in 2000-2007
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object

Set wb1 = ActiveWorkbook

If Val(Application.Version) >= 12 Then
If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no
VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro
again.", vbInformation
Exit Sub
End If
End If

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Make a copy of the file/Open it/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
TempFileName = "" & wb1.Name & " " & Format(Now, "dd-mmmm-yyyy ")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) -
InStrRev(wb1.Name, ".", , 1)))