I would like to prevent users from opening a sepcific template (rte) file directly.
My thoughts are to check the file name that is opening if it is the specific template then close it after a dialog notifying the user to user proper procedures creating a project from said template.
I'm working in VB.net (visual basic not c) & Revit 2019 & 2022
Not sure if it's best to embed the code in the document or application.
I've played around with some code in the document but can't get the file to close.
Any ideas/feedback would be helpful.
Imports System
Imports System.IO
Imports Microsoft.VisualBasic
Imports Autodesk.Revit.UI
Imports Autodesk.Revit.DB
Imports Autodesk.Revit.UI.Selection
Imports System.Collections.Generic
Imports System.Linq
<Autodesk.Revit.Attributes.Transaction(Autodesk.Re vit.Attributes.TransactionMode.Manual)> _
<Autodesk.Revit.DB.Macros.AddInId("87A056AA-AEB8-4E72-8DCC-D03CA2C8141B")> _
Partial Public Class ThisDocument
Private Sub Module_Startup(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Startup
Dim curDoc As Document = Me.Application.ActiveUIDocument.Document
Dim DocName As String = curDoc.PathName
Dim CurAdmin As String = Environment.UserName
Dim RevComID As RevitCommandId = RevitCommandId.LookupCommandId("ID_FILE_CLOSE")
Dim uiDoc As UIDocument = Me.Application.ActiveUIDocument
If DocName = "NetworkTemplatePath\_Templates\Revit 2019.rte" Then
TaskDialog.Show("ACCESS ALERT", "DO NOT OPEN THIS TEMPLATE DIRECTLY" & vbCrLf & "Create a Temporary project from the template to access family content" & vbCrLf & _
vbCrLf & "Contact the BIM Manager if you require further assistance" & vbCrLf & vbCrLf & "This template file will now be closed")
End If
‘This is temporary..
‘Future code will be to close the template for designers only, allowing BIM Manager/Coordinator access to editing the template.
Dim CloseDoc As Boolean
CloseDoc = MsgBox("Close Template", vbYesNo)
If CloseDoc Then
uiDoc.SaveAndClose ‘<--- THIS IS NOT WORKING
End If
End Sub
Private Sub Module_Shutdown(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Shutdown
End Sub
End Class
Reading your question carefully, it appears to me that a better title for it would be Prevent document opening, since that is your ultimate goal. Why allow it to be opened at all in the first place? You can easily prevent the opening of a document by subscribing to the DocumentOpening event and cancelling that.
Related
I have been searching for a way to distribute macros to my tech illiterate office in the simplest way I can.
From my research, saving the Macros into a .xlam add-in would seem to be headed in the right direction.
Is it also possible to set up a custom ribbon tab in this manner?
Thus far I have failed to find any guides and our office security may also block certain avenues.
Edit:
Using W-Hit's excellent solution, and setting up the folder structure as indicated, it definitely helps make deploying an update much easier with the DeployAddIn subroutine.
I also found it useful to put the DeployAddIn and InstallAddin subroutines into a custom ribbon tab of their own!
I ran into a problem with the InstallAddin subroutine however: how to format the XML text in VBA without running into syntax errors.
I discovered that Each Element must have mso at the start e.g. <button> becomes <mso:button> and each "speech marked section" in a line must have ""double speech marks".
Perhaps the easiest way to use this install function is to save and edit the code into an active file, then open C:\Users[username]\AppData\Local\Microsoft\Office\Excel.officeUI in Notepad++. Then simply perform a find and replace to add in the extra quotation marks and paste it into the ribbonXML = "insert your text here" section of the code, ensuring it is encapsulated by the final speech marks to mark the entire section as a text string.
I might also look into adding extra functionality here... having an inputbox or userform that allows you to paste the code in at this point rather than have you enter the VBA editor to paste it in.
I currently do this, and it's a somewhat in depth process to setup, but runs smoothly once it is.
1st step is to create a folder structure with testing and production copies of your .xlam files that you are the admin for.
2nd, in the production folder, right click all .xlam files and set the attributes in the properties to Read-only. If you don't you'll never be able to update the addin if anyone else is in it.
3rd, when you make updates to the code in the testing file, just replace the production file with the updated file, and change to Read-only again. Users will only have to close all instances of excel and reopen to have the most up-to-date copy of the add-in.
Below is an admin add-in I use to move testing files to production.
Sub DeployAddIn()
'Author : Ken Puls (www.excelguru.ca)
'Macro Purpose: To deploy finished/updated add-in to a network
' location as a read only file
Dim strAddinDevelopmentPath As String
Dim strAddinPublicPath As String
Dim FSO As New FileSystemObject
'Set development path
ChDrive "R:"
ChDir "R:\addins\PROJECTS"
strAddinDevelopmentPath = Application.GetOpenFilename()
If strAddinDevelopmentPath = "False" Then
Exit Sub
ElseIf InStr(strAddinDevelopmentPath, "\PRODUCTION\") > 1 Then
If MsgBox("You've Selected a Production File To Replace a Production File. Would You Like To Continue Anyway?", vbYesNo) = vbNo Then
Exit Sub
End If
End If
'Get Desitination path
strAddinPublicPath = Replace(strAddinDevelopmentPath, "TESTING", "PRODUCTION")
'Create dir if it doesn't exist
On Error Resume Next
MkDir Left(strAddinPublicPath, InStrRev(strAddinPublicPath, "\") - 1)
On Error GoTo 0
'Turn off alert regarding overwriting existing files
Application.DisplayAlerts = False
'overwrite existing file
On Error Resume Next
SetAttr strAddinPublicPath, vbNormal
On Error GoTo 0
FSO.CopyFile strAddinDevelopmentPath, strAddinPublicPath, True
SetAttr strAddinPublicPath, vbReadOnly
'Resume alerts
Application.DisplayAlerts = True
End Sub
4th, I've also written a macro to change the custom ribbon. The below link, in addition Ron deBruin's site is useful. https://grishagin.com/vba/2017/01/11/automatic-excel-addin-installation.html
Code to automate addin install after you get the right text from the officeUI file
Sub InstallAddin()
'Adapted from https://grishagin.com/vba/2017/01/11/automatic-excel-addin-installation.html
Dim eai As Excel.AddIn
Dim alreadyinstalled As Boolean
Dim ribbonXML As String
'check if already installed
For Each eai In Application.AddIns
If eai.Name = "Main addin.xlam" Then
eai.Installed = False
Exit For
End If
Next
'add and install the addin
Set eai = Application.AddIns.Add("path to Main addin.xlam", False)
eai.Installed = True
'append quick access ribbon xml to add button
ClearCustRibbon
LoadNewRibbon
'have to close addin for it to load properly the first time
Workbooks("Main addin.xlam").Close
End Sub
Sub ClearCustRibbon()
'https://social.msdn.microsoft.com/Forums/vstudio/en-US/abddbdc1-7a24-4664-a6ff-170d787baa5b/qat-changes-lost-when-using-xml-to-modify-ribbon-excel-2016-2016?forum=exceldev
Dim hFile As Long
Dim ribbonXMLString As String
hFile = FreeFile
OfficeUIFilePath = Environ("USERPROFILE") & "\AppData\Local\Microsoft\Office\Excel.officeUI"
ribbonXMLString = "<mso:customUI xmlns:mso=""http://schemas.microsoft.com/office/2009/07/customui"">" & _
"<mso:ribbon>" & _
"<mso:qat>" & _
"<mso:sharedControls>" & _
"</mso:sharedControls>" & _
"</mso:qat>" & _
"</mso:ribbon>" & _
"</mso:customUI>"
Open OfficeUIFilePath For Output Access Write As hFile
Print #hFile, ribbonXMLString
Close hFile
End Sub
Sub LoadNewRibbon()
Dim hFile As Long
hFile = FreeFile
OfficeUIFilePath = Environ("USERPROFILE") & "\AppData\Local\Microsoft\Office\Excel.officeUI"
ribbonXML = "your ribbon text here"
Open OfficeUIFilePath For Output Access Write As hFile
Print #hFile, ribbonXML
Close hFile
End Sub
***IMPORTANT---- If you install the addin manually, make sure you select no when prompted if you want the file saved to the local machine. If you save it to the local machine, it creates a local copy, and will never update if you make changes to the network copy or need to fix an error.
There are more tips, but you'll mostly need to adapt them to fit how you operate. Hope that helps.
I am new to VBA and have to complete a task for my manager about saving sheet as a pdf into sharepoint (if firstly can be done) which creates a folder at the location with the same name as the saved PDF and saves the pdf there.
Now where it gets harder for me is at the location in sharepoint there are 3 folders, for USD, EUR and GBP and depending on a field in the excel (which will denote one of the 3 currencies) it will have to be saved at that location
(Sharepoint URL or mapped to network drive)\Quote\USD\new folder created with file name matching pdf\pdf file
(Sharepoint URL or mapped to network drive)\Quote\EUR\new folder created with file name matching pdf\pdf file
(Sharepoint URL or mapped to network drive)\Quote\GBP\new folder created with file name matching pdf\pdf file
Is it the sharepoint URL will work or is it only when mapped to the network drive (which I have with a filepath with my username which im guessing would stop working from anyone else but me)
I am using the below which saves to sharepoint but with me as User_1 I cant see how anyone else will be able to?
Sub test()
ChDir "C:\Users\user_1\company\Sales Team - Documents\Quotes"
With Sheets("Quote")
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:="C:\Users\user_1\company\Sales Team - Documents\Quotes\" & ActiveSheet.Range("B2").Value & " Quote.pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
end sub
It took me a while to figure out the above (which im sure is really simple) but i am still learning,
Can anyone help me with this?
Thanks
OK, I probably overshot the targer a bit...
This code only works with drives mapped to the normal Filesystem, if you want to use a network path you can read some more on the topic here: Cannot save file to Sharepoint Online using VBA (Permissions error)
Unfortunately I do not have a way to test code against a Sharepoint Server until I get back to work.
First of, you need to add the Microsoft Scripting Runtime to your project, described here: https://stackoverflow.com/a/3236348
You can call the publishQuoteToDirectory sub from anywhere inside your project. I would recommend a custom Ribbon in the Application that passes the activeSheet Object, but you could also just point a Makro to runExportExample and fill in some static parameters.
sheetToPublish: Expects a Worksheet Object, you can use ActiveSheet if you want
publishingPath: The "Quotes" Folder
currencyCell: The Cell which holds the Currency
fileName: If you want to override the Filename for some reason
The Select Case structure decides which currency the Worksheet Contains, it also accepts the signs of the currencies, can be extended with whatever you want.
quoteNamePathPart I was not exactly sure how you meant this in your main question, this gives you the option to use the Workbook or the Worksheet Name, choose whichever you want.
The FileSystemObject helps us with building a valid path, there are other methodes to create this but I prefer using it over them because it gives direct access to the Microsoft Filesystem.
BuildFullPath is a separate sub because it has to call itself recursively. The FSO can not create nested Folder in one Action. An alternative would be to use the Shell (described here: https://stackoverflow.com/a/4407468).
This is the whole Magic, if you have any Question regarding the code feel free to ask.
There are definitely other easier, faster, more secure ways to solve this. My knowledge with VBA is still limited and I don't know all the best practices, but the code should get the job done. (#all the other, feel free to criticize)
Code:
'all this sits in a standart module:
Option Explicit
Private Const StandartCurrencyCell As String = "B2"
Private Const StandartFileName As String = "Quote.pdf"
Public Sub runExportExample()
publishQuoteToDirectory _
sheetToPublish:=ActiveSheet, _
publishingPath:="C:\Users\User1\company\Sales Team - Documents\Quotes\", _
currencyCell:="B2", _
fileName:="SomeOtherFileName.pdf"
End Sub
Public Sub publishQuoteToDirectory(sheetToPublish As Worksheet, Optional publishingPath As String, Optional currencyCell As String, Optional fileName As String)
'Sanitize the input if necessary
If publishingPath = "" Then publishingPath = Environ$("USERPROFILE") & "\Quotes\"
If currencyCell = "" Then currencyCell = StandartCurrencyCell
If fileName = "" Then fileName = StandartFileName
Dim currencyPathPart As String
Select Case sheetToPublish.Range(currencyCell).Value2
Case "USD", "$"
currencyPathPart = "USD"
Case "EUR", "€"
currencyPathPart = "EUR"
Case "GBP", "£"
currencyPathPart = "GBP"
Case Else
currencyPathPart = "OtherCurrencies"
End Select
Dim quoteNamePathPart
With New FileSystemObject
'I'm a bit sceptic on the correctness of this, since your PDF is called "Quote" the FOlder Name would be "Quote" as well
'Comment out whatever you don't want
'I think this should be:
quoteNamePathPart = .GetBaseName(sheetToPublish.Parent.Name) 'this will use the Workbook Name (without Suffix)
'not:
'quoteNamePathPart = sheetToPublish.Name 'This will use the Name of the Sheet
'build the path and create folder, using the FSO takes care of missing Seperators etc.
publishingPath = .BuildPath(publishingPath, currencyPathPart)
publishingPath = .BuildPath(publishingPath, quoteNamePathPart)
BuildFullPath (publishingPath)
publishingPath = .BuildPath(publishingPath, fileName)
End With
On Error GoTo ExportFailed
sheetToPublish.ExportAsFixedFormat _
Type:=xlTypePDF, _
fileName:=publishingPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Exit Sub
ExportFailed:
MsgBox prompt:="The Export of the File: " & fileName & " failed" & vbCrLf & "The expected Output Path was: " & publishingPath, Title:="Export Failed"
End Sub
Sub BuildFullPath(ByVal FullPath)
'FSO can only create one Folder at a time, so I used a recursive function found here: https://stackoverflow.com/a/4407468
Dim fso As New FileSystemObject
If Not fso.FolderExists(FullPath) Then
BuildFullPath fso.GetParentFolderName(FullPath)
fso.CreateFolder FullPath
End If
End Sub
I've found how to add a reference programmatically with VBA,
This explains how to add object references programmatically using the name of the Library,
with the example "VBScript_RefExp_55".
My question is how do I find this reference name to use in this code for different object libraries?
Such as the PowerPoint Library for example?
I use this to get the info on my references :
Private Sub ListProjectReferencesList()
Dim i As Long
Dim VBProj As Object 'VBIDE.VBProject
Dim VBComp As Object 'VBIDE.VBComponent
Set VBProj = Application.VBE.ActiveVBProject
Dim strTmp As String
On Error Resume Next
For i = 1 To VBProj.References.Count
With VBProj.References.Item(i)
Debug.Print "Description: " & .Description & vbNewLine & _
"FullPath: " & .FullPath & vbNewLine & _
"Major.Minor: " & .Major & "." & .Minor & vbNewLine & _
"Name: " & .Name & vbNewLine & _
"GUID: " & .GUID & vbNewLine & _
"Type: " & .Type
Debug.Print "-------------------"
End With 'VBProj.References.Item(i)
Next i
End Sub
And generally, I prefer to add it with GUID rather than name.
But as pointed out by #Rory,
you should use Late Binding rather than adding References programmatically!
Why?
Because in order to add them programmatically, your users will have to go into :
Options of the Application (Excel, ...) from which it's launched
Trust Center
Trust Center Settings
Macro Settings tab
Tick Trust access to the VBA project object model check box
OK
OK
So you'd better finish your code with references, then :
Remove the references
Change all declarations using those librairies to Dim ??? As Object
Check if you have Option Explicit at the top of the module (add it if not)
Look for app-specific variables (Option Explicit should throw an message on them)
Test your code a lot
Export module to be used by others!
Is it possible to define a string variable in excel and then use that variable inside Access?
I have a program where in Excel a window pops up asking for where a file is located which will feed into an Access database - get processed - then shoot into Excel. The problem is that this is for a lot of different people and so each computer is going to have its own extension address of where the file is located, so it is necessary to have it be easy for users to identify where their file is located instead of hard-coding it into the VBA.
No matter what I try, I can't seem to figure out how to get the string variable to talk to the access database so it knows where to go look for the file.
I can't seem to find a solution for this. Anyone have any ideas?
Here is the code I have so far: This is what is inside the excel file----
'CommandButton1 is a button inside of a form window that pops up for the user to enter the address of the file
Public Sub CommandButton1_Click()
'both of these are public/global variables defined in a global macro
locationaddress = txbBrowse2.Value
LocationOfData = txbBrowse.Value
Dim appAccess As Object
Set appAccess = CreateObject("Access.Application")
'location of data is the location of the access file itself
location address is the string that I'm trying to feed into access
appAccess.OpenCurrentDatabase LocationOfData, exclusive:=False
appAccess.Application.Run "DoExcelImport"
End Sub
'Here is the code inside the access file, the idea is that it will modify the "Import-TEST" saved import. It will change where it pulls the excel sheet that contains a bunch of items that requires access to process.
Sub DoExcelImport()
DoCmd.SetWarnings False
Dim ies As ImportExportSpecification, i As Long, oldXML() As String, newXML As String
Set ies = CurrentProject.ImportExportSpecifications("Import-TEST")
oldXML = Split(ies.XML, vbCrLf, -1, vbBinaryCompare)
newXML = ""
For i = 0 To UBound(oldXML)
If i = 1 Then
' re-write the second line of the existing XML
newXML = newXML & _
"<ImportExportSpecification Path = """ & _
locationaddress & _
""" xmlns=""urn:www.microsoft.com/office/access/imexspec"">" & _
vbCrLf
Else
newXML = newXML & oldXML(i) & vbCrLf
End If
Next
ies.XML = newXML
ies.Execute
Set ies = Nothing
DoCmd.SetWarnings True
End Sub
Probably the easiest way might be using
SaveSettings(AppName As String, Section As String,Key As String, Setting As `String)
to store the string in the registry,
GetSettings((AppName As String, Section As String,Key As String)
to get it in Access, and
DeleteSetting (AppName as String)
to delete it.
Is probably a bit abusing the registry, but an easy way.
I am working on generating OFT files that will be e-mailed to customers who will then fill the To: and Subject: in and send them as e-mails to their clients.
My data comes from an Excel Workbook with one sheet containing static data (Books) and another information pasted in by the user (Pins). I've got a basic template that has placeholder text which gets replaced by the data in the aforementioned Excel sheets.
One important part of this is that I need the changed template to get saved to it's own file, so it can be stored for reference later. Originally I had the code below setup to open the template and call .SaveAs myFilename, olTemplate but that just made a broken 3KB file. You will notice I am copying the template to the actual destination file and operating on that instead.
My problem is that if I have the template item call .Display, everything is perfect. I see my image in the right place and all of the text is properly replaced. If I call .Save it saves out a copy of the original OFT template with no changes present.
Can anyone tell me what I'm doing wrong here? I've been searching here and google for hours trying to find some indication of what I'm missing. I'm trying to automate this thing as much as possible. Resaving the new OFT with Outlook's UI is a real time sink for a coworker and I'd like to eliminate that if possible. They're going to be generating dozens of these OFTs every day, so the work seems worth it in my opinion.
UPDATE
I have managed to get this to work but the solution feels like a half-answer. The code below has been updated with changes that properly save the OFT.
Here is my sub:
Sub OutlookTemplate(ByVal pins As Range, ByVal book As Range, ByVal ImageLocation As String)
Dim myolapp As Object
Dim myItem As Object
Set myolapp = CreateObject("Outlook.Application")
'myolapp.Session.Logon
For Each p In pins.Cells
If Not IsEmpty(p.Value) Then
Dim myFilename As String
myFilename = "c:\temp\" & Worksheets("PINS").Range("A2") & "-" & p.Value & ".oft"
FileCopy "c:\template.oft", myFilename
Set myItem = myolapp.CreateItemFromTemplate(myFilename)
myItem.Save <- Added immediate save after creation of myItem
myItem.Attachments.Add ImageLocation, olByValue, 0
myItem.HTMLBody = Replace(myItem.HTMLBody, "THEIMAGE", "<img src='cid:" & book.Cells(2).Value & "'" & "width='154'>")
myItem.HTMLBody = Replace(myItem.HTMLBody, "PINHERE", p.Value)
myItem.HTMLBody = Replace(myItem.HTMLBody, "THETITLE", book.Cells(1).Value)
myItem.HTMLBody = Replace(myItem.HTMLBody, "THESUBTITLE", book.Cells(3).Value)
myItem.HTMLBody = Replace(myItem.HTMLBody, "THEAUTHORS", book.Cells(4).Value)
myItem.HTMLBody = Replace(myItem.HTMLBody, "THEDESCRIPTION", book.Cells(5).Value)
' Leaving the next line off results in a broken image
' when .SaveAs is called
myItem.Display
' This saves all of the changes out to the file properly
' in combination with .Display
' Note: if I call myItem.SaveAs myFilename, olTemplate
' I get the 3KB broken OFT. Omitting ,olTemplate works
myItem.SaveAs myFilename
End If
Next
End Sub
The Save method doesn't propagate changes to the .oft file. It saves the Microsoft Outlook item to the current folder or, if this is a new item, to the Outlook default folder for the item type.
Try to open the existing .oft file without copying it anywhere. Then do the required changes and call the SaveAs method to save it as a template wherever you need.