I am currently facing an issue when trying to set a public variable through an VBscript in an Custom Action.
Its regarding the Property "MYDOMAIN".
No matter what I am doing, the value is always 0.
Even setting an ";" after (example) Session.Property("MYDOMAIN")="1" does not solve the issue.
When the VBScript is executed locally the value can be retrieved (at least in the variable).
Please find my script below:
'~~~ Query My Domain
Option Explicit
'On Error Resume Next
Dim objWMISvc : Set objWMISvc = GetObject( "winmgmts:\\.\root\cimv2" )
Dim colItems : Set colItems = objWMISvc.ExecQuery( "Select * from Win32_ComputerSystem" )
Dim objSysInfo : Set objSysInfo = CreateObject("ADSystemInfo")
Dim objComp : Set objComp = GetObject("LDAP://" & objSysInfo.ComputerName)
Dim objCompDN : objCompDN = objComp.distinguishedName
Dim objItem
Dim strComputerDomain
Dim Session
For Each objItem in colItems
strComputerDomain = objItem.Domain
' If objItem.PartOfDomain Then
' WScript.Echo "Computer Domain: " & strComputerDomain
' Wscript.Echo "Computername: " & strComputerName
' End If
Next
If strComputerDomain = "DOMAIN1.loc" Then
Session.Property("MYDOMAIN")="1"
elseif strComputerDomain = "DOMAIN2.loc" Then
call CheckIRL(objCompDN,"(?:Division-)(8[0-9]\d{1,2}|982)-")
elseif strComputerDomain = "DOMAIN3.loc" Then
Session.Property("MYDOMAIN")="3"
Else
if strComputerDomain = "" then
Session.Property("MYDOMAIN")="0"
End if
End if
Sub CheckIRL(strReturnValue, strPattern)
Dim objRegEx : set objRegex = new RegExp
objRegex.pattern = strPattern
objRegex.global = true
If objRegex.Test( strReturnValue ) Then
Session.Property("MYDOMAIN") = "6"
Else
Session.Property("MYDOMAIN") = "7"
End If
End Sub
Sub CheckSLO(strReturnValue, strPattern)
Dim objRegEx : set objRegex = new RegExp
objRegex.pattern = strPattern
objRegex.global = true
If objRegex.Test( strReturnValue ) Then
Session.Property("MYDOMAIN") = "4"
Else
Session.Property("MYDOMAIN") = "5"
End If
End Sub
To be honest: I am out of ideas...
A friend inserted the script into an InstallShield project and the Property could be resolved. Any idea is appreciated :)
I would recommend you trying to debug your VBS action code by inserting a message box (MsgBox function) in each of your IF block of your VBS code. This is just to make sure your VBS code do indeed set the related property to a value different than 0 before it exits.
Just use a MsgBox statement like this:
MsgBox Session.Property("MYDOMAIN")
to display the property value.
Then if the VBS do indeed set the property to a value different than 0 before exiting, in this case we will need more details about the exact execution sequence when the property is reverted back to 0.
I will give this a try and will come back to you once checked.
In the meantime I created a second msi file to do the config...not the best solution but it seems to work :)
Related
I should start out with this is my first attempt at a vba user form.
I Have some simple code to fill a user form (pulling from Inventor Custom iProperties) the problem I am running into and made a false assumption (that if the property didn't exist it would be ignored) so now I get an error. oProSet1 & oProSet2 work perfectly (Those iProperties will always have a value) oProSet3 Throws an error, I am guessing because the "Setup Time" property doesn't exist & Isn't required (in this case). The code asterisks is my attempt and fail to use an if statement.
Private Sub CommandButton2_Click()
' Get the active document.
Dim oDoc As Document
Set oDoc = ThisApplication.ActiveDocument
' Get the custom property set.
Dim oPropSet As PropertySet
Set oPropSet = oDoc.PropertySets.Item( _
"Inventor User Defined Properties")
Dim oPropSet1 As Property
Set oPropSet1 = oPropSet("Operation 1 Work Center 1")
' Set the value of the property.
TextBox1.Value = oPropSet1.Value
Dim oPropSet2 As Property
Set oPropSet2 = oPropSet("Operation 1 Machine Code 1")
' Set the value of the property.
TextBox2.Value = oPropSet2.Value
*Dim oPropSet3 As Property
Set oPropSet3 = oPropSet("Operation 1 Setup Time 1")
If oPropSet3("Operation 1 Setup Time 1") Is Nothing Then
' Set the value of the property.
oPropSet3.Value = ""
Else TextBox3.Value = oPropSet3.Value*
I would try like this:
Dim oPropSet3 As Property
On Error Resume Next 'ignore error if missing
Set oPropSet3 = oPropSet("Operation 1 Setup Time 1")
On Error Goto 0 'stop ignoring errors
If oPropSet3 Is Nothing Then
Debug.Print "Property not found"
Else
Debug.Print oPropSet3.Value
End If
I'm trying to access from Outlook VBA, either a variable or content control ID that I've created in a word Macro.
Basically I am trying to get set a text field equal to a string variable and load this variable to a message box in outlook.
From outlook, I have the code that creates a word object, and opens the active document, but I'm confused as to accessing the variables. I've tried making the variable in word VBA a public variable with no luck.
Current code to access the variable from outlook:
Set oWordApp = CreateObject("Word.Application")
Set oWordDoc = oWordApp.Documents.Open("C:\Owner\Desktop\Job.docx")
oWordApp.Visible = True
MsgBox(oWordApp.testtest)
Having a look at the ContentControl help file you can pull back the text from the content control using its Tag property.
Sub Test()
Dim oWordApp As Object
Dim oWordDoc As Object
Dim oContent As Variant
Dim oCC As Variant
Set oWordApp = CreateObject("Word.Application")
Set oWordDoc = oWordApp.Documents.Open("S:\DB_Development_DBC\Test\MyNewDoc.docm")
oWordApp.Visible = True
Set oContent = oWordDoc.SelectContentControlsByTag("MyCalendarTag")
If oContent.Count <> 0 Then
For Each oCC In oContent
MsgBox oCC.PlaceholderText & vbCr & oCC.Range.Text
Next oCC
End If
End Sub
The code above displayed Click here to enter a date. as the PlaceHolderText value and 01/01/2007 as the Range.Text value. So no need to add separate functions; just reference the content control directly.
https://msdn.microsoft.com/en-us/library/office/gg605189(v=office.14).aspx
https://msdn.microsoft.com/en-us/vba/word-vba/articles/working-with-content-controls
Edit
As an example of returning value from multiple controls in one function:
Public Sub Example()
Dim MySevenTags As Variant
Dim x As Long
MySevenTags = Array("Tag1", "Tag2", "Tag3", "Tag4", "Tag5", "Tag6", "Tag7")
For x = LBound(MySevenTags) To UBound(MySevenTags)
MsgBox ReturnFromWordContent(CStr(MySevenTags(x))), vbOKOnly
Next x
End Sub
Public Function ReturnFromWordContent(TagID As String) As Variant
Dim oWordApp As Object
Dim oWordDoc As Object
Dim oContent As Variant
Dim oCC As Variant
Set oWordApp = CreateObject("Word.Application")
Set oWordDoc = oWordApp.Documents.Open("S:\DB_Development_DBC\Test\MyNewDoc.docm")
oWordApp.Visible = True
Set oContent = oWordDoc.SelectContentControlsByTag(TagID)
'I've made this next bit up.
'No idea how to get the type of control, or how to return the values.
Select Case oContent.Type
Case "calendar"
ReturnFromWordContent = oContent.Range.Date
Case "textbox"
ReturnFromWordContent = oContent.Range.Text
Case Else
'Return some default value such as Null which
'won't work in this case as it's returning to a messagebox
'but you get the picture.
End Select
' If oContent.Count <> 0 Then
' For Each oCC In oContent
' MsgBox oCC.PlaceholderText & vbCr & oCC.Range.Text
' Next oCC
' End If
End Function
"I've tried making the variable in word VBA a public variable with no luck."
Declare your macro "testtest" as a function with the return value of your variable.
Public Function testtest() As String
dim myVariabel as String
myVariable = "test"
' return value
testtest = myVariable
End Function
Best regards
I'm mapping to the company's sharepoint drive using VBA. The intention is to save local file to sharepoint, and delete local file and unmapped the drive after success.
On my machine(Windows 10 64bits), the code works perfectly fine, successfully mapped the drive, created folder and file, successfully uploaded to sharepoint and unmap the drive.
However, when I run the same excel workbook that contains the same code on my colleague's computer(Window 7), it failed. There's no error being shown, except that it keeps on loading and loading until Excel Not Responsive. I tried manually mapping the drive, it success.
I tried to debug and found out that the code stops (keeps on loading) at MsgBox "Hello" but could not figure out what's missing.
Both are using Excel 2016
Any help and suggestions are appreciated. let me know if more info is needed. Thanks in advance.
This is my vba code
Sub imgClicked()
Dim fileName As String
Dim SharePointLib As String
Dim MyPath As String
Dim folderPath As String
Dim objNet As Object
Dim copyPath As String
Dim copyFilePath As String
folderPath = Application.ThisWorkbook.path
MyPath = Application.ThisWorkbook.FullName
Dim objFSO As Object
Dim strMappedDriveLetter As String
Dim strPath As String
Dim spPath As String
strPath = "https://company.com/sites/test/test 123/" 'example path
spPath = AvailableDriveLetter + ":\test.xlsm" 'example path
copyPath = folderPath + "\copyPath\"
'Add reference if missing
Call AddReference
Set objFSO = CreateObject("Scripting.FileSystemObject")
With objFSO
strMappedDriveLetter = IsAlreadyMapped(.GetParentFolderName(strPath))
If Not Len(strMappedDriveLetter) > 0 Then
strMappedDriveLetter = AvailableDriveLetter
If Not MapDrive(strMappedDriveLetter, .GetParentFolderName(strPath)) Then
MsgBox "Failed to map SharePoint directory", vbInformation, "Drive Mapping Failure"
Exit Sub
End If
End If
' Check file/folder path If statement here
End With
Set objFSO = Nothing
End Sub
Code for getting available drive
' Returns the available drive letter starting from Z
Public Function AvailableDriveLetter() As String
' Returns the last available (unmapped) drive letter, working backwards from Z:
Dim objFSO As Object
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = Asc("Z") To Asc("A") Step -1
Select Case objFSO.DriveExists(Chr(i))
Case True
Case False
Select Case Chr(i)
Case "C", "D" ' Not actually necessary - .DriveExists should return True anyway...
Case Else
AvailableDriveLetter = Chr(i)
Exit For
End Select
End Select
Next i
Set objFSO = Nothing
MsgBox "This is the next available drive: " + AvailableDriveLetter ' returns Z drive
MsgBox "Hello" ' After this msgBox, starts loading until Not Responsive
End Function
Function to Map drive
Public Function MapDrive(strDriveLetter As String, strDrivePath As String) As Boolean
Dim objNetwork As Object
If Len(IsAlreadyMapped(strDrivePath)) > 0 Then Exit Function
Set objNetwork = CreateObject("WScript.Network")
objNetwork.MapNetworkDrive strDriveLetter & ":", strDrivePath, False
MapDrive = True
MsgBox "Successfully Created the Drive!"
Set objNetwork = Nothing
End Function
Code for MappedDrive
Public Function GetMappedDrives() As Variant
' Returns a 2-D array of (1) drive letters and (2) network paths of all mapped drives on the users machine
Dim objFSO As Object
Dim objDrive As Object
Dim arrMappedDrives() As Variant
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim arrMappedDrives(1 To 2, 1 To 1)
For i = Asc("A") To Asc("Z")
If objFSO.DriveExists(Chr(i)) Then
Set objDrive = objFSO.GetDrive(Chr(i))
If Not IsEmpty(arrMappedDrives(1, UBound(arrMappedDrives, 2))) Then
ReDim Preserve arrMappedDrives(1 To 2, 1 To UBound(arrMappedDrives, 2) + 1)
End If
arrMappedDrives(1, UBound(arrMappedDrives, 2)) = Chr(i) ' Could also use objDrive.DriveLetter...
arrMappedDrives(2, UBound(arrMappedDrives, 2)) = objDrive.ShareName
End If
Next i
GetMappedDrives = arrMappedDrives
Set objDrive = Nothing
Set objFSO = Nothing
End Function
Public Function IsAlreadyMapped(strPath As String) As String
' Tests if a given network path is already mapped on the users machine
' (Returns corresponding drive letter or ZLS if not found)
Dim strMappedDrives() As Variant
Dim i As Long
strMappedDrives = GetMappedDrives
For i = LBound(strMappedDrives, 2) To UBound(strMappedDrives, 2)
If LCase(strMappedDrives(2, i)) Like LCase(strPath) Then
IsAlreadyMapped = strMappedDrives(1, i)
Exit For
End If
Next i
Set objNetwork = Nothing
End Function
Add Reference
Sub AddReference()
'Macro purpose: To add a reference to the project using the GUID for the
'reference library
Dim strGUID As String, theRef As Variant, i As Long
'Update the GUID you need below.
strGUID = "{420B2830-E718-11CF-893D-00A0C9054228}"
'Set to continue in case of error
On Error Resume Next
'Remove any missing references
For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.Item(i)
If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
Next i
'Clear any errors so that error trapping for GUID additions can be evaluated
Err.Clear
'Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:=strGUID, Major:=1, Minor:=0
'If an error was encountered, inform the user
Select Case Err.Number
Case Is = 32813
'Reference already in use. No action necessary
Case Is = vbNullString
'Reference added without issue
Case Else
'An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
& "add or remove a reference in this file" & vbNewLine & "Please check the " _
& "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
Procedure imgClicked is calling function AvailableDriveLetter multiple times. Remember that the function has to execute each time you refer to it.
I ran imgClicked (assuming that's the procedure you start with) and I was told, twice, "Next available letter = Z" and "Hello" and then it crashed Excel (perhaps getting stuck in a loop of creating FileSystem objects to look for an available drive letter?)
Try assigning AvailableDriveLetter to a variable (string) at the beginning of the procedure and referring to the variable each time you need the value, and see if you still have the issue.
(Remember to save before execution -- I get frustrated when troubleshooting "application hanging" issues because I keep forgetting to save my changes and then lose them on the crash!)
If this doesn't work, add a breakpoint (F9) on the End Function line after your "Hello" box and see if the code stops there. (I have trouble believing the MsgBox or End Function are the culprit.) If not, which procedure runs after that?
One more thing whether the issue is resolved or not:
Add Option Explicit at the very beginning of your module and then Compile the project and fix your missing variable declaration(s).
This is recommended whenever troubleshooting an issue as a means to eliminate variable declaration issues as a possible cause.
I'm brand spanking new to VBA. But I've programmed a bit in SAS, just a bit in Assembler (mainframe and PC), Word Perfect (macros), a bit in Java, HTML, other stuff. What I do is, when I have a problem and I think I can program it, I look for code on the internet and adjust it to fit my needs. I have read a little bit of VBA programming. What I'm trying to do is make a macro to save a bunch of Outlook e-mail messages with PDFMAKER. I've come up with the below, so far. When I step the program, pmkr2 gets assigned type "ObjectPDFMaker" and stng gets assigned type "ISettings". So far, so good. Then I try to set stng and can't do it. I get the error "Method or data member not found." If I get rid of Set it highlights .ISettings and I get the same error. I go into F2 and the AdobePDFMakerforOffice library is there, and the class ISettings is there, but I can't seem to set stng. I'm wa-a-a-ay frustrated. Please help.
Sub ConvertToPDFWithLinks()
Dim pmkr2 As Object
Set pmkr2 = Application.COMAddIns.Item(6).Object ' Assign object reference.
Dim pdfname As String
pdfname = "C:\stuff\stuff\tester.pdf"
Dim stng As AdobePDFMakerForOffice.ISettings
Set stng = AdobePDFMakerForOffice.ISettings
stng.AddBookmarks = True
stng.AddLinks = True
stng.AddTags = True
stng.ConvertAllPages = True
stng.CreateFootnoteLinks = True
stng.CreateXrefLinks = True
stng.OutputPDFFileName = pdfname
stng.PromptForPDFFilename = False
stng.ShouldShowProgressDialog = True
stng.ViewPDFFile = False
pmkr.GetCurrentConversionSettings stng
pmkr2.CreatePDFEx stng, 0
Set pmkr2 = Nothing ' Discontinue association.
End Sub
I updated your code a little. See if this has any affect:
Sub ConvertToPDFWithLinks()
Dim pmkr2 As AdobePDFMakerForOffice.PDFMaker
'Set pmkr2 = Application.COMAddIns.Item(6).Object ' Assign object reference.
Set pmkr2 = Nothing
For Each a In Application.COMAddIns
If InStr(UCase(a.Description), "PDFMAKER") > 0 Then
Set pmkr2 = a.Object
Exit For
End If
Next
If pmkr2 Is Nothing Then
MsgBox "Cannot Find PDFMaker add-in", vbOKOnly, ""
Exit Sub
End If
Dim pdfname As String
pdfname = "C:\stuff\stuff\tester.pdf"
Dim stng As AdobePDFMakerForOffice.ISettings
pmkr2.GetCurrentConversionSettings stng
stng.AddBookmarks = True
stng.AddLinks = True
stng.AddTags = True
stng.ConvertAllPages = True
stng.CreateFootnoteLinks = True
stng.CreateXrefLinks = True
stng.OutputPDFFileName = pdfname
stng.PromptForPDFFilename = False
stng.ShouldShowProgressDialog = True
stng.ViewPDFFile = False
pmkr2.CreatePDFEx stng, 0
Set pmkr2 = Nothing ' Discontinue association.
End Sub
The main changes were in how the addin is obtained and in how stng is created.
I'm trying to pull text from a bunch of XML files into Word. I'm working from a list of files and have found that some of them don't actually exist in the folder. So, I'm using this function to check whether the files actually exist before opening them. But I'm still getting error 52 (Bad file name or number).
This is the function:
Function FileThere(FileName As String) As Boolean
FileThere = (Dir(FileName) > "")
End Function
And this is the code I'm calling it from:
Sub PullContent()
Dim docList As Document
Dim docCombinedFile As Document
Dim objFileListTable As Table
Dim objRow As Row
Dim strContent As String
Dim strFileCode As String
'Code # for the current file. (Pulled in temporarily, output to the Word doc.)
Dim strFilename As String
'Name of XML file. Created based on strFileCode
Set docCombinedFile = Documents.Add
'The new doc which will list all warnings
Dim strXml As String
'String variable that holds the entire content of the data module
Dim strInvalidCodes
'String listing any invalid file codes. Displayed at the end.
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Documents.Open FileName:="C:\Users\kelly.keck\Documents\Triton MTS\IETMs - Test\IETMList.docx"
Set docList = Documents("IETMList.docx")
Set objFileListTable = docList.Tables(1)
For Each objRow In objFileListTable.Rows
strFileCode = objRow.Cells(4).Range.Text
strFileCode = Left(strFileCode, Len(strFileCode) - 2)
strFilename = strFileCode & ".xml"
strPath = "C:\Applications\xml\"
If FileThere(strPath & strFileCode) = True Then
'MsgBox (strPath & strFilename)
strXml = FSO.OpenTextFile(strPath & strFilename).ReadAll
Else
strInvalidCodes = strInvalidCodes & vbCr & strFileCode
End If
Next
MsgBox ("The following filenames were invalid: " & vbCr & strInvalidCodes)
End Sub
Getting this error seems to defeat the purpose of having a function to check if a file exists, but I'm not sure what's wrong with the function.
A bit late to the party, but this hasn't had an accepted answer yet.
I generally use this method to test if a file exists, and your code uses FileSystemObject already so could use that reference.
Public Function FileExists(ByVal FileName As String) As Boolean
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileExists = oFSO.FileExists(FileName)
End Function
I believe that you need to be sure that FileThere is actually returning the Boolean value you intend. It would be more reliable if you checked the Len property (the number of characters) or checked whether it actually returns the empty string.
The following is more verbose than absolutely necessary in order to make the logic clear. If you were to use Len, instead, then you'd check Len(Dir(FileName)) > 0
Function FileThere(FileName as String) as Boolean
Dim bFileExists as Boolean
If Dir(FileName) = "" Then
bFileExists = False
Else
bFileExists = True
End If
FileThere = bFileExists
End Function