I have this code:
Sub ChangeImportedBOQCodeName(importedName As String)
ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).Name = "BOQ_" & importedName
End Sub
That is called from
Private Sub cmdOK_Click()
Dim TargetName As String
TargetName = cbxSheets.Text
Set TargetSheet = TargetWB.Sheets(TargetName)
TargetSheet.Copy After:=SourceWB.Sheets(SourceSheet.Index)
ChangeImportedBOQCodeName ActiveSheet.CodeName
' Close the User Form
Unload Me
' Inform User on Successful BOQ Import
MsgBox "The selected BOQ was successfully imported to the Analysis", vbInformation, "Import Successful"
' Ask User to generate codes automatically
Dim msgTxt As String
msgTxt = "Generate codes in the imported BOQ, automatically ?" & vbNewLine & vbNewLine & _
"(The proccess may take a while depending on the System specs and BOQ layout and size)"
If MsgBox(msgTxt, vbYesNo, "Auto Code BOQ") = vbYes Then
CheckImportedBOQ ActiveSheet
Else
MsgBox "Auto code genrate was aborted", vbInformation, "Aborted"
End If
End Sub
But I am getting this error:
Run-time error '-2147417848 (80010108)' Automation error The object
invoked has disconnected from its client
And excel exits abruptly.
Problem is that this error never occurred before and the code was working very fine.
I also tried commenting ChangeImportedBOQCodeName ActiveSheet.CodeName this line and the code works.
In your Sub ChangeImportedBOQCodeName you are passing ActiveSheet.CodeName, so all you need to do is change:
ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).Name = "BOQ_" & importedName
To:
ActiveWorkbook.VBProject.VBComponents(importedName).Name = "BOQ_" & importedName
Related
I am making a Macro in VBA (Excel 2016 32bit + Windows 10 Pro) that fires when Workbook.NewSheet event occurs.
This Macro must rename Sheet.CodeName property of every new sheet.
The problem is that when I run my Macro in breaking mode, step by step, it works perfectly.
But it can’t rename Sheet.CodeName property after VB Editor (VBE) is closed. Simply Sheet.CodeName property is empty, so Macro doesn’t know what sheet must have to renamed. If I open VBE and, doing nothing, close it again, Macro runs rightly.
And next, this Macro works correctly with Workbook.Open and Workbook.SheetChange events. Only Workbook.NewSheet event gives a trouble.
Give me a suggest, please, if you know, how I can improve parameter transmit from Excel to my Macro behind closed VBE.
Hi!
Thank You for want to helping me!
The code is very easy.
The goal is - get properly value of sh_CodeName property in message window
when VBE is closed.
Current code:
Private Sub Workbook_NewSheet(ByVal sh As Object)
NewSheet sh
End Sub
Option Explicit
Sub NewSheet(ByVal sh As Object)
Dim sh_CodeName As String, sh_Name As String, i As Integer
sh_CodeName = sh.CodeName: sh_Name = sh.Name
MsgBox "Code Name - " & sh_CodeName & vbCrLf & "Name - " & sh_Name, vbOKOnly, "MESSAGE FROM WorkBook.NewSheet"
End Sub
It seems that sh.codename is not available after adding a new sheet as long as one has not accessed the VBA project. Maybe someone else hase more on this.
This code works for me but has the disadvantage that you need to trust access to the VBA project object model.
Sub NewSheet(ByVal Sh As Object)
Dim sh_CodeName As String, sh_Name As String, i As Integer
sh_CodeName = ActiveWorkbook.VBProject.VBComponents(Sh.Name).Properties("_Codename")
sh_Name = Sh.Name
MsgBox "Code Name - " & sh_CodeName & vbCrLf & "Name - " & sh_Name, vbOKOnly, "MESSAGE FROM WorkBook.NewSheet"
End Sub
Even this simple macro will not give a codename when run with closed VBE
Sub TestAddIt()
Dim sh As Worksheet
Set sh = ActiveWorkbook.Worksheets.Add
MsgBox sh.Name & " - " & sh.CodeName
End Sub
PS: Another workaround could be to open the VBE and close it again but you still need access to the VBA project
Sub TestAddIt()
Dim Sh As Worksheet
Set Sh = ActiveWorkbook.Worksheets.Add
With Application.VBE.MainWindow
.WindowState = 1
.Visible = True
.Visible = False
End With
MsgBox Sh.Name & " - " & Sh.CodeName
End Sub
Update: This also worked for me.
Sub TestAddIt()
Dim Sh As Worksheet
Set Sh = ActiveWorkbook.Worksheets.Add
' Recompile the project
Application.VBE.CommandBars.FindControl(ID:=578).Execute
MsgBox Sh.Name & " - " & Sh.CodeName
End Sub
You help me with this statement.
sh_CodeName = ActiveWorkbook.VBProject.VBComponents(Sh.Name).Properties("_Codename")
I modified it slightly (Sh.CodeName instead of Sh.Name). And added a delay.
Sub Check_NewSheet(ByVal sh As Object)
Dim sh_CodeName As String, sh_Name As String, i As Integer
On Error Resume Next
sh_CodeName = ThisWorkbook.VBProject.VBComponents(sh.CodeName).Properties("_Codename")
If Err.number > 0 Then
i = 0
Do While sh_CodeName = ""
sh_CodeName = ThisWorkbook.VBProject.VBComponents(sh.CodeName).Properties("_Codename")
DoEvents
i = i + 1
Loop
End If
sh_Name = sh.Name
MsgBox "Code Name - " & sh_CodeName & vbCrLf & "Name - " & sh_Name & vbCrLf & _
"Attempts - " & i, vbOKOnly, "MESSAGE FROM WorkBook.NewSheet"
End Sub
It works pretty good now. It is quite well as an interim solution.
But I still interested to find out an explanation what is wrong in the Excel to Macro communication.
So, if you will find one, please, share it with me.
First time post but a long time user! Firstly I wanted to say thank you to every for all the code feedback you guys put on posts. It's helped me develop my VBA code more than you can imagine!
Ok so the question:
Background:
I'm developing a VBA focused addin for myself and colleagues to use. Part of this is include functions that you would except in Excel but aren't there. Some of these were quite easy to do (ie invert filters) but some are proving more difficult. This is one of those examples.
Issue:
The following code is meant to loop through the users selection of sheets, apply a user defined password or remove the existing one. Part of the function is to capture passwords that can't be removed (ie becuase the user entered an incorrect password). It works great for the first error occurrence but throughs up the runtime error (1004) for the second and repeating ones after. I don't much much experience with runtime errors handling (try to avoid errors!) but I can't get this to work. Any ideas /help to stop the runtime error popping up would be great.
Code:
Dim SHT As Worksheet, Password As String, SHT_Names(0 To 30) As String
'PREP
'DISABLE APPLICATION FUNCTIONS
Call Quicker_VBA(False)
Application.EnableEvents = False
'USER PASSWORD OPTION
Password = InputBox("Please enter a password (leave blank for no password)", "Password")
'USER INFORMATION MESSAGES SETUP
MSG_Protect = "Added to-"
Protect_check = MSG_Protect
MSG_Unprotect = "Removed from-"
Unprotect_check = MSG_Unprotect
MSG_unable = "Unable to remove protection from-"
Unable_check = MSG_unable
'ID SHEETS SELECTED
For Each SHT In ActiveWindow.SelectedSheets
a = a + 1
SHT.Activate
SHT_Names(a) = SHT.name
Next
'MAIN
HomeSHT = ActiveSheet.name
'PROTECT SHEETS SELECTED BY USER
For b = 1 To a
Sheets(SHT_Names(b)).Select
Set SHT = ActiveSheet
'ENABLE OR REMOVE PROTECTION FROM SELECTED SHEET
If SHT.ProtectContents Then
On Error GoTo Password_FAIL
Application.DisplayAlerts = False
SHT.Unprotect Password
On Error GoTo 0
MSG_Unprotect = MSG_Unprotect & vbNewLine & Chr(149) & " " & SHT.name
Else:
'ENABLE FILTER CHECK
FilterOn = False
If ActiveSheet.AutoFilterMode Then FilterOn = True
'PROTECT SHEET
SHT.Protect Password, AllowFiltering:=FilterOn
'UPDATE USER MESSAGE
MSG_Protect = MSG_Protect & vbNewLine & Chr(149) & " " & SHT.name & " - Users can: Select locked and unlocked cells"
If FilterOn = True Then MSG_Protect = MSG_Protect & " and use filters"
End If
200 Next
'INFORM USER
If Protect_check <> MSG_Protect Then msg = MSG_Protect & vbNewLine & "___________________" & vbNewLine
If Unprotect_check <> MSG_Unprotect Then msg = msg & MSG_Unprotect & vbNewLine & "___________________" & vbNewLine
If Unable_check <> MSG_unable Then msg = msg & MSG_unable
MsgBox msg, , "Protection summary"
'TIDY UP
Sheets(HomeSHT).Activate
'ENABLE APPLICATION FUNCTIONS
Call Quicker_VBA(True)
Exit Sub
Password_FAIL:
MSG_unable = MSG_unable & vbNewLine & Chr(149) & " " & SHT.name
Application.EnableEvents = False
GoTo 200
End Sub
At a quick glance, it seems that the problem is in the way you're handling your errors. You use the line On Error GoTo Password_FAIL to jump down to the error handler. The error handler logs some information and then jumps up to label '200'. I can't tell if the formatting is off, but it looks like the label for '200' points to Next, indicating that the loop should continue with the next sheet.
So, where's the problem? You never actually reset the original error. Three lines below On Error GoTo Password_FAIL you explicitly call On Error GoTo 0 to reset the error handler, but that line will never actually be reached in an error. The program will jump to the error handler, and then from there jump up to the loop iterator. Using the GoTo statement for control flow can easily lead to these types of issues, which is why most developers recommend against it.
I'll post some sample code below to show a different (potentially better) way to handle code exceptions. In the sample below, the code simply loops through all of the worksheets in the workbook and toggles the protection. I didn't include much of your logging, or the constraint that only the selected sheets be toggled. I wanted to focus on the error handling instead. Besides, from reading you code, it seems that you can manage more of the peripheral details. Send a message if there's still some confusion
Sub ToggleProtectionAllSheets()
Dim sht As Worksheet
Dim password As String
On Error Resume Next
password = InputBox("Please enter a password (leave blank for no password)", "Password")
For Each sht In ActiveWorkbook.Worksheets
If sht.ProtectContents Then
sht.Unprotect password
If Err.Number <> 0 Then
Err.Clear
MsgBox "Something did not work according to plan unprotecting the sheet"
End If
Else
sht.Protect password
If Err.Number <> 0 Then
Err.Clear
MsgBox "Something went wrong with protection"
End If
End If
Next sht
End Sub
Here's the basic problem: I am writing an Excel macro and I would like to use the worksheet code names to try to eliminate any errors down the road. I can use the code name for Sheet1 and it works fine, but when I try to use the other codes, like Sheet3 or Sheet7 the editor doesn't recognize them and if I run the macro Excel kicks up an error telling me that my "variable is not defined".
For example:
Option Explicit
Sub Test()
Dim SheetObject As Worksheet
Dim SheetObject2 As Worksheet
Set SheetObject = Sheet1
Set SheetObject2 = Sheet3
MsgBox (SheetObject.Name)
MsgBox (SheetObject2.Name)
End Sub
If I comment out any code referring to SheetObject2 the macro runs correctly. If I put them in I get the errors. I definitely have a Sheet3, and the code name is definitely Sheet3. I've looked around Google all day and can't seem to come up with any solutions, any help would be great.
Thanks in advance,
Jesse
My last employer collected data and created national statistics. Much of that data came in the form of Excel workbooks so I have had a lot of relevant experience.
If you are running your own macro and if this is a one-off exercise then tests like this may be adequate:
Debug.Assert WbookTgt.WsheetTgt.Range("A1").Value = "Date"
Many languages have an Assert statement as a development aid; this is the VBA version. If the assertion is not true, the macro will stop with this statement highlighted.
If this approach is not adequate, you should consider developing parameterised macros that perform checking and updating tasks. I have looked through some of my old macros but most would not be intelligible to someone new to VBA. I have extracted code to create two macros which I hope will give you some ideas.
Macro 1 - OpenWorkbook
Organisations that regularly supply data often use names like: "Xxxxx 1409.xlsx" and "Xxxxx 1410.xlsx" for the September and October versions of their data. You could, for example, update the macro each month for the latest name or you could change the filename to a standard value. Either of these possibilities would be a nuisance and I would be particularly opposed to the second idea because I like to archive all the workbooks I have processed.
OpenWorkbook() uses the Dir statement to search a folder for a file that matches a template such as “Xxxxx*.xls*”. If a single file matches this template, the macro opens the workbook and returns a reference to it.
Macro 2 – CheckWorksheets
You may have noticed that some VBA routines have a fixed number of parameters while others have a variable number of parameters. For example, the following are all valid calls of CheckWorksheets:
If CheckWorksheets(WbookTgt, WbookThis, “Name1”) then
If CheckWorksheets(WbookTgt, WbookThis, “Name1”, “Name2”) then
If CheckWorksheets(WbookTgt, WbookThis, “Name1”, “Name2”, “Name3”) then
CheckWorksheets has three parameters. The first two are workbook references. The third is ParamArray SheetName() As Variant. Any parameter after the first two is placed in array SheetName which can be as large as necessary. Here all the trailing parameters are strings but they could be of any type.
I can use OpenWorkbook to open this month’s version of the source file and then use CheckWorksheets to confirm all the worksheets required by my macro are present.
Worksheet Errors”
These two macros require a worksheet Errors be present in a specified workbook. If the macros detect an error, they add a detailed error message to this worksheet. I have found this a convenient technique for capturing the details of any errors.
Macros Demo1 and Demo2
I have included two macros that demonstrate the use of these macros with workbooks on my system. If you amend Demo1 and Demo2 to operate on some of your workbooks, you should get an idea of what OpenWorkbook and CheckWorksheets can do for you.
Come back with questions as necessary but the more you can decipher OpenWorkbook and CheckWorksheets yourself, the faster you will develop your own skills
Option Explicit
Sub Demo1()
Dim Path As String
Dim WbookThis As Workbook
Dim WbookTgt As Workbook
' Application.ThisWorkbook identifies the workbook containing this macro.
Set WbookThis = Application.ThisWorkbook
' I find it convenient to place my target workbooks in the folder
' holding the workbook containing the macro(s).
Path = WbookThis.Path
Set WbookTgt = OpenWorkbook(Path, "Combined*.xls*", WbookThis)
If WbookTgt Is Nothing Then
' Detailed error message already recorded in "Errors"
Call MsgBox("Wokbook failed checks", vbOKOnly)
Else
With WbookTgt
Debug.Print .Path & "\" & .Name & " opened."
.Close SaveChanges:=False
End With
End If
End Sub
Sub Demo2()
Dim Path As String
Dim WbookThis As Workbook
Dim WbookTgt As Workbook
' Application.ThisWorkbook identifies the workbook containing this macro.
Set WbookThis = Application.ThisWorkbook
' I find it convenient to place my target workbooks in the folder
' holding the workbook containing the macro(s).
Path = WbookThis.Path
Set WbookTgt = OpenWorkbook(Path, "Combined 2.04.xls*", WbookThis)
If WbookTgt Is Nothing Then
' Detailed error message already recorded in "Errors"
Call MsgBox("Wokbook failed checks", vbOKOnly)
Exit Sub
End If
With WbookTgt
If Not CheckWorksheets(WbookTgt, WbookThis, "Critical Path", "Dyn Dims") Then
Call MsgBox("Wokbook failed checks", vbOKOnly)
.Close SaveChanges:=False
Exit Sub
End If
Debug.Print .Path & "\" & .Name & " contains worksheets Critical and Dym Dims"
.Close SaveChanges:=False
End With
End Sub
Function CheckWorksheets(ByRef WbookTgt As Workbook, ByRef WbookError As Workbook, _
ParamArray SheetName() As Variant) As Boolean
' * Return True if WbookTgt contains every specified worksheet.
' * WbookTgt is the workbook to be checked
' * WbookError identifies the workbook containing worksheet "Error" to which any
' error message will be added.
' * SheetName() is an array of worksheet names.
Dim ErrorMsg As String
Dim FoundError As Boolean
Dim FoundSheet() As Boolean
Dim FoundSheetsCount As Long
Dim InxName As Long
Dim InxWsheet As Long
Dim NotFoundSheetsCount As Long
Dim RowErrorNext As Long
Dim SheetNamesFound As String
' Size FoundSheet to match SheetName. Array elements initialised to False
ReDim FoundSheet(LBound(SheetName) To UBound(SheetName))
FoundSheetsCount = 0
NotFoundSheetsCount = 0
With WbookTgt
For InxName = LBound(SheetName) To UBound(SheetName)
NotFoundSheetsCount = NotFoundSheetsCount + 1 ' Assume not found until found
For InxWsheet = 1 To .Worksheets.Count
If SheetName(InxName) = .Worksheets(InxWsheet).Name Then
FoundSheet(InxName) = True
FoundSheetsCount = FoundSheetsCount + 1
NotFoundSheetsCount = NotFoundSheetsCount - 1
Exit For
End If
Next
Next
End With
If NotFoundSheetsCount = 0 Then
CheckWorksheets = True
Exit Function
End If
SheetNamesFound = ""
ErrorMsg = WbookTgt.Path & "\" & WbookTgt.Name & " does not contain "
If NotFoundSheetsCount = 1 Then
ErrorMsg = ErrorMsg & "this expected worksheet:"
Else
ErrorMsg = ErrorMsg & "these expected worksheets:"
End If
For InxName = LBound(SheetName) To UBound(SheetName)
If Not FoundSheet(InxName) Then
ErrorMsg = ErrorMsg & vbLf & " " & SheetName(InxName)
Else
SheetNamesFound = SheetNamesFound & vbLf & " " & SheetName(InxName)
End If
Next
If FoundSheetsCount = 0 Then
' No need to add list of found sheet names
Else
ErrorMsg = ErrorMsg & vbLf & "but does contain "
If FoundSheetsCount = 1 Then
ErrorMsg = ErrorMsg & "this expected worksheet:"
Else
ErrorMsg = ErrorMsg & "these expected worksheets:"
End If
ErrorMsg = ErrorMsg & SheetNamesFound
End If
With WbookError
With .Worksheets("Errors")
RowErrorNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
With .Cells(RowErrorNext, "A")
.Value = Now()
.VerticalAlignment = xlTop
End With
.Cells(RowErrorNext, "B").Value = ErrorMsg
End With
End With
CheckWorksheets = False
End Function
Function OpenWorkbook(ByVal Path As String, ByVal FileTemplate As String, _
ByRef WbookError As Workbook) As Workbook
' * If Path & FileTemplate identifies a single workbook, open it and return
' it as an object. If Path & FileTemplate does not represent a single
' workbook, report the problem in worksheet Errors and return Nothing.
' * WbookError identifies the workbook containing worksheet "Error".
' * Path must be the name of the folder in which the required workbook is located
' * FileTemplate can either be a specific filename or can contain wild cards
' providing only one file matches the template.
' * WbookError identifies the workbook containing worksheet "Error" to which any
' error message will be added.
Dim ErrorMsg As String
Dim FileNameCrnt As String
Dim FileNameMatch As String
Dim RowErrorNext As Long
FileNameMatch = Dir$(Path & "\" & FileTemplate, vbNormal)
If FileNameMatch = "" Then
' No matches found
ErrorMsg = "Template " & Path & "\" & FileTemplate & " does not match any file"
Else
' At least one match.
' If only one match, its name is in FileNameMatch
Do While True
FileNameCrnt = Dir$
If FileNameCrnt = "" Then
' No more matches
Exit Do
End If
' A second or subsequent match has been found.
If FileNameMatch <> "" Then
' This is the second match.
' Initialise error message and report name of first match
ErrorMsg = "Template " & Path & "\" & FileTemplate & " matches more than one file:" & _
vbLf & " " & FileNameMatch
FileNameMatch = "" ' No single match
End If
' Add name of current match to error message
ErrorMsg = ErrorMsg & vbLf & " " & FileNameCrnt
Loop
End If
If FileNameMatch = "" Then
' No single match found.
' ErrorMsg contains an appropriate error message
With WbookError
With .Worksheets("Errors")
RowErrorNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
With .Cells(RowErrorNext, "A")
.Value = Now()
.VerticalAlignment = xlTop
End With
.Cells(RowErrorNext, "B").Value = ErrorMsg
Set OpenWorkbook = Nothing
End With
End With
Else
' Single match found
Set OpenWorkbook = Workbooks.Open(Path & "\" & FileNameMatch)
End If
End Function
Response to extra question
VBA has nothing quite as convenient as VB's Try but it does have some error handling under programmer control.
If you use a command such as:
Worksheets("Sheet2").Delete
the user will be asked to confirm the deletion. To avoid this, use:
Application.DisplayAlerts = False
Worksheets("Sheet2").Delete
Application.DisplayAlerts = True
I have seen code with Application.DisplayAlerts = False at the start of a macro which means no alert will be displayed for the user's attention even if the pogrammer was not expecting it. By bracketing the Delete, I ensure only the alert I was expecting is suppressed.
Consider:
Sub OpenFile()
Dim InputFileNum As Long
InputFileNum = FreeFile
Open "Dummy.txt" For Input As InputFileNum
Debug.Print "File successfully opened"
Close InputFileNum
End Sub
The file "Dummy.txt" does not exist so the macro will stop on the Open statement.
You will sometimes see code like this:
Sub OpenFile()
Dim InputFileNum As Long
On Error GoTo ErrorCode
InputFileNum = FreeFile
Open "Dummy.txt" For Input As InputFileNum
Call MsgBox("File successfully opened", vbOKOnly)
Close InputFileNum
Exit Sub
ErrorCode:
Debug.Print "Unexpected error: " & Err.Number & " " & Err.Description
End Sub
Here I have provided a general handler for any error condition that may occur. I do not approve although I accept that this is slightly better than having the non-technical user seeing the faulty statement highlighted. The trouble is any error will result in the same unhelpful error message.
I never include error handling during development. If an error occurs, I want the macro to stop on the faulty statement so I can consider how to avoid the error. Here I should check the file exists before attempting to open it. I prefer something like this:
Sub OpenFile()
Dim FileSysObj As Object
Dim InputFileNum As Long
On Error GoTo ErrorCode
Set FileSysObj = CreateObject("Scripting.FileSystemObject")
If Not FileSysObj.FileExists("Dummy.txt") Then
Call MsgBox("I am unable to find ""Dummy.txt"". List of helpful suggestions.", vbOKOnly)
Exit Sub
End If
InputFileNum = FreeFile
Open "Dummy.txt" For Input As InputFileNum
Call MsgBox("File successfully opened", vbOKOnly)
Close InputFileNum
Exit Sub
ErrorCode:
Debug.Print "Unexpected error: " & Err.Number & " " & Err.Description
End Sub
I have including checking code for the error I expect. If the file does not exist, I have displayed a message which I hope will help the user fix the problem for themselves.
Sometimes you cannot avoid an error. To test the code below, I created file Dummy.txt but set the "Read access denied" flag. There is no easy method (to my knowledge) for a VBA macro to test this flag. I have a general handler for unexpected errors but I switch it off for the Open statment so I can include specific code for open failures. I have removed the code that uses FileExists() to test if Dummy.txt exists because it is easier to include it with the other open file error tests.
Sub OpenFile()
Dim FileSysObj As Object
Dim InputFileNum As Long
On Error GoTo ErrorCode ' General handler for unexpected errors
InputFileNum = FreeFile
Err.Clear
On Error Resume Next ' Record error in Err object and continue
Open "Dummy.txt" For Input As InputFileNum
Select Case Err.Number
Case 0
' No error.
Case 53 ' File does not exist
Call MsgBox("I am unable to find ""Dummy.txt"". List of helpful suggestions.", vbOKOnly)
Exit Sub
Case 75 ' Path/File access error
Call MsgBox("It appears file ""Dummy.txt"" exists but I do not have permission to read it.", vbOKOnly)
Exit Sub
Case Else
Call MsgBox("My attempt to open ""Dummy.txt"" failed with an unexpected error condition" & vbLf & _
" " & Err.Number & " " & Err.Description, vbOKOnly)
Exit Sub
End Select
On Error GoTo ErrorCode ' Restore general handler for unexpected errors
Call MsgBox("File successfully opened", vbOKOnly)
Close InputFileNum
Exit Sub
ErrorCode:
Debug.Print "Unexpected error: " & Err.Number & " " & Err.Description
End Sub
Visit http://support.microsoft.com/kb/146864 for a long list of error codes and more information about error handling.
Hi im looking for a formulla to show User's full name who is opening excel file.it should show that logged in user name. I tried some VBA script and got succesfull but there is one problem that when i run script that time only it Generate pop up windows saying your user name. it should show user name in cell as a date formulla a"=TODAY()". i have this script please anybody help me to show full user name in cell.
Sub GetUserFullName()
Dim MyOBJ As Object
On Error Resume Next
Set MyOBJ = GetObject("WinMgmts:").instancesOf("Win32_NetworkLoginProfile")
If Err.Number <> 0 Then
MsgBox "WMI has not been installed, code will be terminated...", vbExclamation, "Windows Management Instrumentation"
Exit Sub
End If
For Each objItem In MyOBJ
MyMsg = MyMsg & "Welcome To IT Dept : " & vbCrLf & vbCrLf & objItem.FullName
Next
MsgBox MyMsg, vbInformation, "Swapnil (System Admin)"
End Sub
UPD:
Function GetUserFullName() As String
Dim MyOBJ As Object
Dim res As String
On Error Resume Next
Set MyOBJ = GetObject("WinMgmts:").instancesOf("Win32_NetworkLoginProfile")
If Err.Number <> 0 Then
GetUserFullName = "error"
Exit Function
End If
For Each objItem In MyOBJ
res = res & objItem.FullName
Next
GetUserFullName = res
End Function
you can use it in any cell like formula: =GetUserFullName()
I have my front end in excel and backend as access. I send these files to client everyday.i do not want others to see the database. Is there a way to integrate access in excel such that if i transfer only excel file, access file also gets transferred automatically and others do not get to know about my database??
database should remain in access only.
You can't email or FTP an Access file invisibly, but you could move your data to a SQL Server (or other) database that is reachable from the internet.
However that poses several issues:
1) security
2) odbc DSN
3) availability of the odbc driver on the client machine
You can embed the Access database as an object into your Excel file (Insert->Object->Create from file , select Display as icon) and ask the user to extract and remove it. However, this is a bit cumbersome for both sides if you do it manually.
If you want to automate the process, use the following code:
Private Const cStrSheetName As String = "Sheet1"
Private Const cStrObjName As String = "EmbeddedFile"
Sub EmbedFile()
Dim strFile As String
Dim ws As Worksheet
Set ws = Sheets(cStrSheetName)
strFile = Application.GetOpenFilename("Any file (*.*), *.*", 1, _
"Please select a file to embed")
If strFile = "False" Then Exit Sub
On Error Resume Next
ws.Shapes(cStrObjName).Delete
On Error GoTo ErrorHandler
ws.OLEObjects.Add(Filename:=strFile, Link:=False, _
DisplayAsIcon:=True, IconFileName:="", _
IconIndex:=0, IconLabel:=strFile).Select
Selection.Name = cStrObjName
MsgBox "File succesfully embedded!"
Exit Sub
ErrorHandler:
MsgBox "Could not embed file. Error: " & _
Err.Number & " - " & Err.Description
End Sub
Sub ExtractEmbeddedFile()
Dim ws As Worksheet
Set ws = Sheets(cStrSheetName)
On Error Resume Next
ws.OLEObjects(cStrObjName).Copy
If Err.Number Then
MsgBox "No file embedded!"
Exit Sub
End If
On Error GoTo ErrorHandler
CreateObject("Shell.Application").Namespace(ActiveWorkbook.Path) _
.Self.InvokeVerb "Paste"
If MsgBox("File succesfully extracted to " & ActiveWorkbook.Path _
& vbCrLf & vbCrLf & "Do you want to remove the embedded " & _
"file from the this workbook to reduce its size?", vbYesNo) _
= vbYes Then
ws.Shapes(cStrObjName).Delete
End If
Exit Sub
ErrorHandler:
MsgBox "Error extracting file: " & _
Err.Number & " - " & Err.Description
End Sub
This will give you two macros (EmbedFile and ExtractEmbeddedFile) that you can assign to a button in your worksheet.
Please note that you need to modify "Sheet1" in the first line to the name of the worksheet you want to store the embedded file.