I am trying to add a value to 3 locations in the registry:
HKEY_CURRENT_USER\Software\Intel\Indeo
HKEY_LOCAL_MACHINE\SOFTWARE\Intel\Indeo
HKEY_USERS\S-1-5-21-669792009-2657969199-152103076-1000\Software\Intel\Indeo
This is the string I need to add to each registry path:
"Options"="360611321911"
For some reason I am unable to test this code just to see if it adds the value:
CreateObject("WScript.Shell").RegWrite "HKEY_USERS\S-1-5-21-669792009-2657969199-152103076-1000\Software\Intel\Indeo", "C:\Program Files\FastTuner\Clean.exe"
You can add these two functions to your project to work with values in the Registry:
' Write Reg:
' Write to the Windows Registry
' RegType should be 'REG_SZ' for string, 'REG_DWORD' for an integer,
' 'REG_BINARY' for a binary or boolean, and 'REG_EXPAND_SZ' for an expandable string
Function WriteReg(RegPath, Value, RegType)
Dim Key
Dim objRegistry
Set objRegistry = CreateObject("Wscript.shell")
Key = objRegistry.RegWrite(RegPath, Value, RegType)
WriteReg = Key
End Function
' Read Reg:
' Read from the Windows Registry
Function ReadReg(RegPath)
Dim Key
Dim objRegistry
Set objRegistry = CreateObject("Wscript.shell")
Key = objRegistry.RegRead(RegPath)
ReadReg = Key
End Function
Related
I have a macro which opens a PowerPoint file stored on the workbook and then modifies it using the below code
Set PApp = CreateObject("PowerPoint.Application")
PApp.Visible = True
Pth = ThisWorkbook.Path
ErrorPopUp = True
Dim TsyTemplate As Object
Set TsyTemplate = ThisWorkbook.Sheets("Report Templates").OLEObjects(“Report 1”)
TsyTemplate.Copy
Sheets("Version Control").Paste
Set TsyTemplate = ThisWorkbook.Sheets("Book 1").OLEObjects(1)
TsyTemplate.Verb Verb:=xlOpen
Set TsyTemplate = Nothing
Set PPres = PApp.ActivePresentation
This works fine however I want to add some code which then converts the open PowerPoint file into a PDF file. I would prefer it to just convert it without saving it somewhere but I don't believe this is possible so I am using he below code to save it as a PDF FILE
PDFName = ActiveWorkbook.Path & "/test.pdf"
PPres.ExportAsFixedFormat Path:=PDFName, FixedFormatType:=ppFixedFormatTypePDF, RangeType:=ppPrintSelection
This isn't working though as I get the error message "type mismatch"
Does anyone have any suggestions as to what I am doing wrong.
Thanks
Full code:
Global PApp As Object
Global PPres As Object
Global PPTFileName As String
Global ppFixedFormatTypePDF As Long
Global ppPrintSelection As Long
Sub Test_Printing_To_PDF()
Set PApp = CreateObject("PowerPoint.Application")
PApp.Visible = True
Pth = ThisWorkbook.Path
ErrorPopUp = True
Dim TsyTemplate As Object
Set TsyTemplate = ThisWorkbook.Sheets("Report Templates").OLEObjects("Report 1")
TsyTemplate.Copy
Sheets("Version Control").Paste
Set TsyTemplate = ThisWorkbook.Sheets("Version Control").OLEObjects(1)
TsyTemplate.Verb Verb:=xlOpen
Set TsyTemplate = Nothing
Set PPres = PApp.ActivePresentation
PPres.Slides(1).Shapes("Presentation_Title").TextFrame.TextRange.Text = "Test printing code"
ppFixedFormatTypePDF = 2
ppPrintSelection = 2
PDFName = ActiveWorkbook.Path & "/test.pdf"
PPres.ExportAsFixedFormat Path:=PDFName, FixedFormatType:=ppFixedFormatTypePDF, RangeType:=ppPrintSelection
End Sub
I removed some of your Excel code so that I could try this here; since it seems to have nothing to do with the PDF export from PPT, shouldn't make any difference. New (working) code below with comments:
Option Explicit
Global PApp As Object
Global PPres As Object
Global PPTFileName As String
Global ppFixedFormatTypePDF As Long
Global ppPrintSelection As Long
Const ppSaveAsPDF As Long = 32
Sub Test_Printing_To_PDF()
' Always include Option Explicit and DIM all variables
Dim Pth As String
Dim ErrorPopUp As Boolean
Dim PDFName As String
Set PApp = CreateObject("PowerPoint.Application")
PApp.Visible = True
Pth = ThisWorkbook.Path
ErrorPopUp = True
' Just invoking PowerPoint doesn't necessarily create a presentation.
' You need to add one (or open an existing one)
Set PPres = PApp.presentations.Add
' And creating a new presentation doesn't necessarily add slides so:
PPres.slides.Add 1, 1
' Unless you've opened a presentation that happens to have a shape named
' Presentation_Title on the first slide, this will fail:
'PPres.slides(1).Shapes("Presentation_Title").TextFrame.TextRange.Text = "Test printing code"
' So I've changed it to this:
PPres.slides(1).Shapes(1).TextFrame.TextRange.Text = "Test printing code"
' / isn't a valid character:
'PDFName = ActiveWorkbook.Path & "/test.pdf"
' so I changed it to this:
PDFName = ActiveWorkbook.Path & "\test.pdf"
' And there are all sorts of reports all over the net about
' the Export routine being buggy. Substitute this and it works:
PPres.SaveAs PDFName, ppSaveAsPDF
End Sub
This is the issue I am facing.
Normally the user's machine is set-up with a user graphic signature file recorded under the C:\Users\User name\Signature folder as a safe and secure place for using it in some Excel processes. But not all users’ signature files could be used as the folder path is not always correctly reported by the below code. I have some users with a machine set-up with two differents profiles under the C:\Users\ folder due to profile rebuilt - causing headache when looking at the location for the specific graphic file Excel is using. I attached sample of the code used to search for the correct folder.
So, could you provide me with information on what settings must be set, what changes in the code must be done, to ensure a reliable access to the graphic file however the user's profile is set-up on the machine?
------------------
Main Module
ChDrive "C"
strPictureFilePath = MyDocs()
strPictureFileName = "MySignature.jpg"
ActiveSheet.Shapes.AddPicture Filename:=(strPictureFilePath & strPictureFileName), linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=162, Top:=445, Width:=170, Height:=35
------------------
Sub Module
Option Explicit
' Declare for call to mpr.dll.
Declare Function WNetGetUser Lib "mpr.dll" _
Alias "WNetGetUserA" (ByVal lpName As String, _
ByVal lpUserName As String, lpnLength As Long) As Long
Const NoError = 0 'The Function call was successful
Function GetUserName()
' Buffer size for the return string.
Const lpnLength As Integer = 255
' Get return buffer space.
Dim status As Integer
' For getting user information.
Dim lpName, lpUserName As String
' Assign the buffer size constant to lpUserName.
lpUserName = Space$(lpnLength + 1)
' Get the log-on name of the person using product.
status = WNetGetUser(lpName, lpUserName, lpnLength)
' See whether error occurred.
If status = NoError Then
' This line removes the null character. Strings in C are null-
' terminated. Strings in Visual Basic are not null-terminated.
' The null character must be removed from the C strings to be used
' cleanly in Visual Basic.
lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
Else
' An error occurred.
MsgBox "Unable to get the name."
End
End If
GetUserName = lpUserName
End Function
'--------------------------------------------------------------------------
Function MyDocs() As String
Dim strStart As String
Dim strEnd As String
Dim strUser As String
strUser = GetUserName()
strStart = "C:\Users\"
strEnd = "\Signature\"
MyDocs = strStart & strUser & strEnd
End Function
'--------------------------------------------------------------------------
You can get it with Environ()
Function MyDocs() As String
Dim strStart As String
Dim strEnd As String
strStart = Environ("USERPROFILE")
strEnd = "\Signature\"
MyDocs = strStart & strEnd
End Function
Ok, so we need to create a GPO that allows our users to only use specific programs.
GPO Location:
User Configuration
Policies
Administrative Templates [...]
System
Run only specified Windows applications
Then setting the GPO to enabled and clicking on List of allowed applications --> Show...
I have created an excel spreadsheet containing the names of all the programs and their associated executable files with other pertinent information so that we can easily organize, add, delete, etc. the executable files that we need to allow our users access to.
This spreadsheet then dumps all the executable files into a text file.
Here is an example of what the text file looks like:
Acrobat.exe
chrome.exe
calc.exe
.
.
.
There are a lot of entries and these are likely subject to change. What I am trying to do is create a script that will take that text file and populate the GPO automatically. I don't care if we have to open the window and then run it, it does not need to run from the task scheduler (although that would be amazing if someone has that code ready). We just need it to populate this ridiculous amount of executable filenames into the fields.
Here is code I found (VBScript) that when run, should populate the fields automatically, however I cannot get it to run in the Group Policy Management Editor (it runs in the windows explorer window instead and ends up searching for some of the files)
' Open the text file, located in the same path as the script
Set objFSO = CreateObject("Scripting.FileSystemObject")
strPath = Mid(Wscript.ScriptFullName, 1, InStrRev(Wscript.ScriptFullName, wscript.ScriptName) -1)
Set objFile = objFSO.OpenTextFile(strPath & "appList.txt")
' Activate the "Show Contents" window with the "List of allowed applications".
' Note the window must be opened already and we should have selected where in
' the list we want to enter the data before running the script
set WshShell = WScript.CreateObject("WScript.Shell")
WScript.Sleep 1000
WshShell.AppActivate "Show Contents"
' Read the file line by line
Do While objFile.AtEndOfStream <> True
' Each line contains one EXE name
exeName = objFile.ReadLine
' Escape forbidden chars { } [ ] ( ) + ^ % ~
exeName = Replace(exeName, "[", "{[}")
exeName = Replace(exeName, "]", "{]}")
exeName = Replace(exeName, "(", "{(}")
exeName = Replace(exeName, ")", "{)}")
exeName = Replace(exeName, "+", "{+}")
exeName = Replace(exeName, "^", "{^}")
exeName = Replace(exeName, "%", "{%}")
exeName = Replace(exeName, "~", "{~}")
' Send the EXE name to the window
WScript.Sleep 100
WshShell.SendKeys exeName
' Move to the next one
WshShell.SendKeys "{TAB}"
Loop
objFile.Close
from: http://blogs.msdn.com/b/alejacma/archive/2011/03/24/how-to-update-quot-run-only-specified-windows-applications-quot-gpo-programmatically-vbscript.aspx
"C:\Windows\System32\GroupPolicy\User\Registry.pol"
Is where my policies are stored. It's a semi text file. Try writing to that file.
Ok, so I tried it many different ways. If anyone is looking for an answer to do this, this is the way I've figured it out and the way I've decided to proceed. I will post all relevant code below.
In Excel, the format of my table is as follows:
(With obviously WAY more entries)
Here is the VBA code I used to turn the data from this file into the proper format for the registry key:
VBA - In Excel
Public Sub ExportToTextFile(FName As String, _
Sep As String, SelectionOnly As Boolean, _
AppendData As Boolean)
Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile
StartRow = 2
If SelectionOnly = True Then
With Selection
StartCol = .Cells(2).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(2).Column
End With
Else
With ActiveSheet.UsedRange
StartCol = .Cells(2).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(2).Column
End With
End If
If AppendData = True Then
Open FName For Append Access Write As #FNum
Else
Open FName For Output Access Write As #FNum
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & Chr(34) & CellValue & ".exe" & Chr(34) & "=" & Chr(34) & CellValue & ".exe" & Chr(34) & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine; ""
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum
End Sub
Sub PipeExport()
Dim FileName As Variant
Dim Sep As String
FileName = Application.GetSaveAsFilename(InitialFileName:="appList", filefilter:="Text (*.txt),*.txt")
If FileName = False Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Sep = "|"
If Sep = vbNullString Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Debug.Print "FileName: " & FileName, "Extension: " & Sep
ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), _
SelectionOnly:=False, AppendData:=False
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
PipeExport
End Sub
The file that is created is appList.txt and its format is the same format as the registry key:
"Acrobat.exe"="Acrobat.exe"
"AcroRd32.exe"="AcroRd32.exe"
Now in your GPO, add a unique program name to the allowed applications list (say test1234.exe) and in your registry editor, go to Edit > Find test1234.exe.
Export that registry key under File > Export. Remove the test1234.exe line and paste in your text file. Then reimport that file and you're done!
I have the following values in my registry
key:
HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\Accepted Documents\
values:
* -> application/msword
** -> application/vnd.ms-excel
*** -> application/vnd.ms-powerpoint
and so on
I'd like to know how to read all of them
with Wscript.Shell, RegRead I can only read one value, but I don't know the values in advance...
Well, I got it
I had to use wmi, like this:
option explicit
const HKLM = &H80000002
dim keyPath
keyPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\Accepted Documents"
dim reg
dim valueNames, types
dim value
dim i
set reg = getObject( "Winmgmts:root\default:StdRegProv" )
if reg.enumValues( HKLM, keyPath, valueNames, types ) = 0 then
if isArray( valueNames ) then
for i = 0 to UBound( valueNames )
reg.getStringValue HKLM, keyPath, valueNames(i), value
msgBox( valueNames(i) & "=" & value )
next
end if
end if
saludos
sas
Following the howto Extending the Active Directory Schema To Track Custom Info I'm able to setup a single-value schema attribute that is easily changeable via a context menu in ADUC. Multi-value schema attributes get considerably more complicated. Say (for the sake of argument) my value is "Projects" and each user may be a list as many projects as necessary.
Following is a sad little script that will set Project to a single value:
Dim oproject
Dim oUser1
Dim temp1
Set oproject = Wscript.Arguments
Set oUser1 = GetObject(oproject(0))
temp1 = InputBox("Project: " & oUser1.project & vbCRLF & vbCRLF & "Project")
if temp1 <> "" then oUser1.Put "project",temp1
oUser1.SetInfo
Set oUser1 = Nothing
Set oproject = Nothing
Set temp1 = Nothing
WScript.Quit
How can I modify this to allow, assign, and modify multiple values?
I gave up on an elegant UI and just went with the semicolon delimited list. Here's the code if anyone cares:
Dim objProject
Dim objUser
Dim temp1, title, message, default
Dim projects
title = "Projects"
Set objProject = Wscript.Arguments
Set objUser = GetObject(objProject(0))
'Find our current projects
projects = objUser.projects
If Not isArray(projects) Then
projects = Array(projects)
End If
'Setup our message box
message = "Semicolon-delimited list of Projects"
default = arrayToStr(projects)
temp1 = InputBox(message, title, default)
'catch cancels
if IsEmpty(temp1) Then
WScript.Quit
End If
' update our data
projects = strToArray(temp1)
objUser.Put "projects",projects
objUser.SetInfo
'Clean up and quit
Set projects = Nothing
Set objUser = Nothing
Set objProject = Nothing
Set temp1 = Nothing
Set title = Nothing
Set message = Nothing
Set default = Nothing
WScript.Quit
'Functions
Function strToArray(s)
Dim a
Dim token
' discard blank entries
For Each token in split(s, ";")
token = trim(token)
If token <> "" Then
If isEmpty(a) Then
a = token
Else
a = a & ";" & token
End If
End If
Next
' return array
strToArray = split(a, ";")
End Function
Function arrayToStr(a)
Dim s
Dim token
For Each token in a
If isEmpty(s) Then
s = token
Else
s = s & ";" & token
End If
Next
' return string
arrayToStr = s
End Function