The problem seems to be simple, but all solutions that I found doesn't worked.
I would like to know how to open Chrome automatically, I tried the code below and several other solutions, but when Chrome is completely closed and I try to open, it shows the window, but it does not open any website.
Private Sub Command1_Click()
Shell "C:\Program Files\Google\Chrome\Application\chrome.exe -url https://www.google.com/"
End Sub
This doesn't have anything to do with VB6, of course, it's about Chrome command line switches. Chrome command line switches start with two dashes. So this should work:
Shell "C:\Program Files\Google\Chrome\Application\chrome.exe --url https://www.google.com/"
(Program Files (x86) if you're running 64 bit Windows, naturally)
But you don't need to specify the switch for the url, this also works:
Shell "C:\Program Files\Google\Chrome\Application\chrome.exe https://www.google.com/"
EDIT:
It would actually appear to be that there isn't an 'url' switch for Chrome, so it is proper to simply place the url on the command line on it's own, as in my second shell command above.
You should ensure where Chrome.exe is installed. 32 or 64 bit?
You have to check before to run it.
For example, I have a 64-bit computer and Chrome.exe is 32 bit version installed on:
C:\Program Files (x86)\Google\Chrome\Application
The code below check for both 32/64 bit version:
open a new VBP project, on Form1:
add a CommandButton, Name: cmdOpenChrome
add a TextBox, Name: txtUrl
copy the below code:
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Sub OpenChrome(ByVal pURL As String)
Dim sChromePath As String
Dim sTmp As String
Dim sProgramFiles As String
Dim bNotFound As Boolean
'
' check for 32/64 bit version
'
sProgramFiles = Environ("ProgramFiles")
sChromePath = sProgramFiles & "\Google\Chrome\Application\chrome.exe"
If Dir$(sChromePath) = vbNullString Then
' if not found, search for 32bit version
sProgramFiles = Environ("ProgramFiles(x86)")
If sProgramFiles > vbNullString Then
sChromePath = sProgramFiles & "\Google\Chrome\Application\chrome.exe"
If Dir$(sChromePath) = vbNullString Then
bNotFound = True
End If
Else
bNotFound = True
End If
End If
If bNotFound = True Then
MsgBox "Chrome.exe not found"
Exit Sub
End If
ShellExecute 0, "open", sChromePath, pURL, vbNullString, 1
End Sub
Private Sub cmdOpenChrome_Click()
OpenChrome txtUrl.Text
End Sub
The sample below use many different browsers:
http://nuke.vbcorner.net/Projects/VB60/VB60variousprojects/tabid/79/language/en-US/Default.aspx#OpenURLwithAnyBrowser
Related
I am trying to 'shell osk.exe' from within my VB-6 application on a Windows 10-32 or Windows 10-64 bit machine.
In the past we have simply used :
Private Sub Command1_Click()
Dim strTemp As String
Dim fso1 As New FileSystemObject
strTemp = fso1.GetSpecialFolder(SystemFolder) & "\osk.exe"
Dim lngReturn As Long
Let lngReturn = ShellExecute(Me.hwnd, "Open", strTemp, vbNullString, "C:\", SW_SHOWNORMAL)
lblReturn.Caption = CStr(lngReturn)
end sub
We have also used the simpler 'shell' command as well; neither work.
And in the past this worked fine. We could also open NotePad, msPaint and some other utilities from within our program. We use an industrial touchscreen PC and for convenience we placed some buttons on our 'settings' page to quickly access these type of helper programs. I do not want to wait on the program, our code has it's own 'touchscreen keyboard'. The users will only use the Windows OSK when they want to perform some work outside of our main application.
For Windows XP all of these programs would open fine. Now for Windows 10, only the OSK.exe program will not start. Looking at the return code, the error returned is a '2'- File Not Found (I assume). But looking in the c:\windows\system32 folder the file 'osk.exe' is there along with mspaint.exe and notepad.exe .
Is there some Windows setting that is hiding the real osk.exe from my program?
Thanks for any suggestions.
On my 64-bit Windows 10, your code behaves as you said. It looks like on 64-bit windows you have to disable WOW 64 redirection:
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_SHOWNORMAL = 1
Private Declare Function Wow64EnableWow64FsRedirection Lib "kernel32.dll" (ByVal Enable As Boolean) As Boolean '// ****Add this****
Private Sub Command1_Click()
Dim fso1 As New FileSystemObject
Dim strTemp As String
strTemp = fso1.GetSpecialFolder(SystemFolder) & "\osk.exe"
Dim lngReturn As Long
Wow64EnableWow64FsRedirection False '// ****Add this****
Let lngReturn = ShellExecute(Me.hwnd, "open", strTemp, vbNullString, "C:\", SW_SHOWNORMAL)
Wow64EnableWow64FsRedirection True '// ****Add this****
lblReturn.Caption = CStr(lngReturn)
End Sub
This code works like a charm on Windows 10 64-bit. Also tested on Windows 10 32-bit...works there as well.
I have the following sub:
Public Sub ShellApp(URL As String)
Dim vResult As Long
vResult = ShellExecute(0, "open", URL, vbNullString, vbNullString, vbMinimizedFocus)
End If
End Sub
This is on a layer that cannot be changed due to several functionality needed on that sub.
Now, on our Main() sub for example, we check a list of added plugins saved in a text file beside the EXE, and call the above Sub in for loop with the path of the plugins to run them. So if I have 3 plugins as below in the text file:
C:\App1.EXE
C:\App2.EXE
C:\Users\AhmadMusa\AppData\Roaming\App3.exe
First two apps will run fine on all PCs (Static path), but third app will not work on any PC except mine which is not ok... Note that App3 always installed on AppData on any PC, so how to dynamically access it to run the app from any PC without adjustments on the sub.
What will be the path placed in the text file for third app so it can work on all PCs?
I tried (AppData\Roaming\App3.exe) but it does not work... I found on a thread (http://www.vbforums.com/showthread.php?529776-RESOLVED-Open-a-folder-in-AppData) that I can call something like (shell:AppData\Roaming\App3.exe) it did not work to run the App3.exe, but if I call (shell:AppData\Roaming) it will open the Roaming folder very well. But cannot run the EXE.
Any ideas ?
Thanks.
I believe that there is no way to solve the problem without altering the original procedure "ShellApp".
in case you change your mind, i think this post may come in help (with some tweekings)
Public Sub ShellApp(URL As String)
Dim vResult As Long
'vResult = ShellExecute(0, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus)
vResult = ShellExecute(0, vbNullString, "cmd.exe", "/k """"" & URL & """""", vbNullString, vbNormalFocus)
End Sub
Private Sub Command1_Click()
ShellApp "%appdata%\PROGRAME.exe"
End Sub
this because only "cmd.exe" and ofcourse batch scripts are able to expend variables that are enclosed with percent character "%"
To close the console as soon as it starts change the parameter "/k" to "/c",
sub test()
dim tmp as string
tmp = environ("AppData ") & "\calc.exe"
call ShellExecute(..., tmp, ...)
end sub
fill the other arguments (...) the way you see it right
You need to expand the Environment variable (this is what the %...% does):
Debug.Print Environ("APPDATA") ' will print the expanded %appdata%
So, in your text file you should put:
%APPDATA%\App3.exe
How to expand the path? You can loop over the environment variables provided by the VB Environ function and do a string replace by yourself (the VB way) or you can profit from the ExpandEnvironmentStrings function (the Win32 API way).
Below a snippet using this second option:
Private Declare Function ExpandEnvironmentStrings Lib "kernel32.dll" _
Alias "ExpandEnvironmentStringsA" ( _
ByVal lpSrc As String, _
ByVal lpDst As String, _
ByVal nSize As Long) As Long
Public Function ExpandEnvironString(ByVal URL As String) As String
Dim buf As String, bufSize As Long
bufSize = ExpandEnvironmentStrings(URL, ByVal 0&, 0&)
buf = String(bufSize + 1, vbNullChar)
bufSize = ExpandEnvironmentStrings(URL, buf, Len(buf))
ExpandEnvironString = Left$(buf, InStr(1, buf, vbNullChar) - 1)
End Function
Before you call ShellApp(URL As String) you should expand the path:
URL = ExpandEnvironString(URL)
ShellExecute will receive the expanded path: C:\Users\AhmadMusa\AppData\Roaming\App3.exe
This is a non-breaking change, because if your initial default setting will be later changed to a custom fixed path, the ExpandEnvironmentStrings function will simply ignore it.
Example:
ExpandEnvironString("C:\App1.EXE ") will return C:\App1.EXE
More info:
you can get all your environment variables with following procedure:
Private Sub EnvironmentEntries()
Dim Entry As String, i As Long
i = 1
Do
Entry = Environ(i)
i = i + 1
If Entry = "" Then Exit Do
Debug.Print Entry
Loop
End Sub
... and check some additional info here:
Why are there directories called Local, LocalLow, and Roaming under \Users\?
Until recently this VB6 code worked on my windows 7 64 bit machine
Shell "c:\My App\Helpers\Helper.exe"
The error message this now throws is
Invalid procedure call or argument (Error 5)
Since it stopped working I have found that moving the directory Helpers to the desktop fixes the issue.
So also does getting rid of the space in the path by renaming the
My App
folder as
MyApp
So also does inserting opening and closing quotes as in :
Shell """c:\My App\Helpers\Helper.exe"""
Meanwhile if the Helpers folder is on the desktop I can insert a space into the path by renaming the folder 'Hel pers' and it still works without the extra quotes.
So these all work:
Shell """c:\My App\Helpers\Helper.exe"""
Shell "c:\Users\UserA\Desktop\Helpers\Helper.exe"
Shell "c:\Users\UserA\Desktop\Hel pers\Helper.exe"
while the original no longer works though it did for years
Shell "c:\My App\Helpers\Helper.exe"
What could be the cause of this, and is there a way to restore the behaviour to the way it was before?
The Shell() function dated from much simpler times, it is ambiguous today. The command can also mean "start the c:\My program and pass it the App\Helpers.Helper.exe command line argument".
Why it triggers on your machine is impossible to tell from a distance, especially when you obfuscate the real name of the program. An infamous example is having a file or directory named Program in the root directory. Now c:\Program Files\Etcetera no longer works.
Using the double-quotes is the correct approach.
Have a look at the ShellExecute() API instead of Shell()
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpszOp As String, _
ByVal lpszFile As String, ByVal lpszParams As String, _
ByVal LpszDir As String, ByVal FsShowCmd As Long) _
As Long
For more info : example on microsoft.com
[EDIT]
A small example with only the parts that you (probably) need:
'1 Form with:
' 1 Command button: Name="Command1"
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As String, ByVal lpszFile As String, ByVal lpszParams As String, ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long
Private Const SW_SHOWNORMAL = 1
Private Sub Command1_Click()
Dim strPath As String
Dim strExe As String
Dim lngReturn As Long
strExe = "TestProg.exe"
strPath = "C:\Program Files (x86)\ShellTest"
lngReturn = ShellExecute(0, "Open", strExe, vbNullString, strPath, SW_SHOWNORMAL)
Caption = CStr(Now) & " : " & CStr(lngReturn)
End Sub
When you click on the command button it will execute TextProg.exe from the ShellTest directory
In the caption of the form it will show the return value of the ShellExecute command
I need some code that will add the admin rights icon to command buttons and display the prompt when such buttons are clicked. How can I do this in VB6? Some actions require admin rights because they replace files and stuff where Windows Vista/7 don't allow the program normal access to the files.
Here's a VB6 example of ShellExecuteEx that will allow you to optionally execute any process with admin permissions. You can drop this into a module or class.
Option Explicit
Private Const SEE_MASK_DEFAULT = &H0
Public Enum EShellShowConstants
essSW_HIDE = 0
essSW_SHOWNORMAL = 1
essSW_SHOWMINIMIZED = 2
essSW_MAXIMIZE = 3
essSW_SHOWMAXIMIZED = 3
essSW_SHOWNOACTIVATE = 4
essSW_SHOW = 5
essSW_MINIMIZE = 6
essSW_SHOWMINNOACTIVE = 7
essSW_SHOWNA = 8
essSW_RESTORE = 9
essSW_SHOWDEFAULT = 10
End Enum
Private Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long 'Optional
lpClass As String 'Optional
hkeyClass As Long 'Optional
dwHotKey As Long 'Optional
hIcon As Long 'Optional
hProcess As Long 'Optional
End Type
Private Declare Function ShellExecuteEx Lib "shell32.dll" Alias "ShellExecuteExA" (lpSEI As SHELLEXECUTEINFO) As Long
Public Function ExecuteProcess(ByVal FilePath As String, ByVal hWndOwner As Long, ShellShowType As EShellShowConstants, Optional EXEParameters As String = "", Optional LaunchElevated As Boolean = False) As Boolean
Dim SEI As SHELLEXECUTEINFO
On Error GoTo Err
'Fill the SEI structure
With SEI
.cbSize = Len(SEI) ' Bytes of the structure
.fMask = SEE_MASK_DEFAULT ' Check MSDN for more info on Mask
.lpFile = FilePath ' Program Path
.nShow = ShellShowType ' How the program will be displayed
.lpDirectory = PathGetFolder(FilePath)
.lpParameters = EXEParameters ' Each parameter must be separated by space. If the lpFile member specifies a document file, lpParameters should be NULL.
.hwnd = hWndOwner ' Owner window handle
' Determine launch type (would recommend checking for Vista or greater here also)
If LaunchElevated = True Then ' And m_OpSys.IsVistaOrGreater = True
.lpVerb = "runas"
Else
.lpVerb = "Open"
End If
End With
ExecuteProcess = ShellExecuteEx(SEI) ' Execute the program, return success or failure
Exit Function
Err:
' TODO: Log Error
ExecuteProcess = False
End Function
Private Function PathGetFolder(psPath As String) As String
On Error Resume Next
Dim lPos As Long
lPos = InStrRev(psPath, "\")
PathGetFolder = Left$(psPath, lPos - 1)
End Function
Code examples can really run on, but here is a trivial one showing the "second instance of me" approach.
The program has a startup static module with a few public functions including an "elevated operation" handler, and a Form with just one CommandButton on it:
Module1.bas
Option Explicit
Private Const BCM_SETSHIELD As Long = &H160C&
Private Declare Sub InitCommonControls Lib "comctl32" ()
Private Declare Function IsUserAnAdmin Lib "shell32" () As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long
Private Declare Function ShellExecute Lib "shell32" _
Alias "ShellExecuteA" ( _
ByVal hWnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As VbAppWinStyle) As Long
Private mblnIsElevated As Boolean
Public Function IsElevated() As Boolean
IsElevated = mblnIsElevated
End Function
Public Sub OperationRequiringElevation(ByRef Params As Variant)
MsgBox "Insert logic here for: " & vbNewLine _
& Join(Params, vbNewLine)
End Sub
Public Sub RequestOperation( _
ByVal hWnd As Long, _
ByVal Focus As VbAppWinStyle, _
ByRef Params As Variant)
ShellExecute hWnd, "runas", App.EXEName & ".exe", _
Join(Params, " "), CurDir$(), Focus
End Sub
Public Sub SetShield(ByVal hWnd As Long)
SendMessage hWnd, BCM_SETSHIELD, 0&, 1&
End Sub
Private Sub Main()
If Len(Command$()) > 0 Then
'Assume we've been run elevated to execute an operation
'specified as a set of space-delimited strings.
OperationRequiringElevation Split(Command$(), " ")
Else
mblnIsElevated = IsUserAnAdmin()
InitCommonControls
Form1.Show
End If
End Sub
Form1.frm
Option Explicit
Private Sub Command1_Click()
Dim Params As Variant
Params = Array("ReplaceFile", "abc", "123")
If IsElevated() Then
OperationRequiringElevation Params
Else
RequestOperation hWnd, vbHide, Params
End If
End Sub
Private Sub Form_Load()
If Not IsElevated() Then
SetShield Command1.hWnd
End If
End Sub
The application has a simple "asInvoker" manifest selecting the Common Controls 6.0 assembly.
First, take the code that runs when someone clicks the button, and put it in a separate exe. Change your button-click code to launch the exe using ShellExecute. Second, build external manifests for each new exe and have it specify requireAdministrator. Third, send your buttons the BCM_SETSHIELD message (you will probably have to look up the numerical value of the message ID) to make the shield appear on them.
Move all of the code that requires elevation into external processes.
Send your buttons the BCM_SETSHIELD message to add the shield icon.
Embed manifests into those processes, telling Windows that they require elevation. See below.
In order to force Vista and higher to run a VB6 exe as administrator in UAC, you must embed a manifest xml as a resource inside of it. Steps follow;
Create the manifest file. Name it "YourProgram.exe.manifest" it should contain the following. The important line is the "requestedExecutionLevel". Change the attributes in to match your exe.
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
version="1.0.0.0"
processorArchitecture="X86"
name="YourProgram"
type="win32"
>
<description>application description</description>
<trustInfo xmlns="urn:schemas-microsoft-com:asm.v2">
<security
<requestedPrivileges>
<requestedExecutionLevel level="requireAdministrator" uiAccess="false"/>
</requestedPrivileges>
</security>
</trustInfo>
</assembly>
Create a file named "YourProgram.exe.manifest.rc". It should contain the following.
#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1
#define RT_MANIFEST 24 CREATEPROCESS_MANIFEST_RESOURCE_ID
RT_MANIFEST "YourProgram.exe.manifest"
Compile your resource using rc.exe. It is located by default in C:\Program Files\Microsoft Visual Studio\COMMON\MSDev98\Bin. This will create a file called YourProgram.exe.manifest.RES. The syntax is;
rc /r YourProgram.exe.manifest.rc
Add the .RES file to your project. Do this using the Resource Editor Add-In in VB6. The icon on the toolbar looks like green blocks. If you do not have the icon, make sure it is enabled in the addin manager. If it is not in the addin manager, you need to regsvr32 on C:\Program Files\Microsoft Visual Studio\VB98\Wizards\Resedit.dll. Once you've got the resource editor open, click open and select your .RES file.
Compile your project.
To double check that the manifest was embedded properly, you can use a tool called InspectExe. In explorer, go to the properties of the exe, and if the manifest was embedded you should have a manifest tab (.Net assemblies will also have this manifest tab).
Try running your program on Vista or later. If UAC is indeed enabled, it should come up with the prompt right away.
I periodically break binary compatibility and need to recompile an entire vb6 application composed of several dozen ActiveX DLLs and OCXs in total. I've written a script to automate this process, but I have encountered a problem.
When an OCX is recompiled with project compatibility its version is incremented, and projects referencing the OCX will not recompile until their reference is updated to the new version. This is checked automatically when the project is opened normally, and the user is prompted to update the reference, but I need to do it in a script.
How do I do it?
We are doing similar things, i.e. manipulating the references to the used OCXs directly in VB6 .vbp files, in our VB6 Project References Update Tool (download here). Generally it is used to update the references when the used ActiveX change their version numbers, CLSIDs, etc.
The tools is open-source so everyone who is interested in this problem can borrow our VB code snippets to implement tasks like these.
Our tool is written in Visual Basic 6 and uses tlbinf32.dll (the TypeLib Information DLL) that allows you to programmatically extract information from type libraries.
My project, maintained over a decade, consists of a hierarchy of two dozen ActiveX DLLs and a half dozen controls. Compiled with a script system as well.
I don't recommend doing what you are doing.
What we do is as follows
Make our changes including additions
and test in the IDE.
We compile from the bottom of the
hierarchy to the top
we copy the newly complied files to
a revision directory for example
601,then 602 etc etc
we create the setup.exe
when the setup is finalized we copy
over the revision directory into our
compatibility director. Note we
never point to the compiled binary
in the project directory. Always to
a compability directory that has all
the DLLs.
The reason this works is that if you look at the IDL source using the OLE View tool you will find that any referenced control or dlls is added to the interface via a #include. If you point to the binary in your project directory then the include is picked up from the registry which can lead to a lot of strangness and compatibility.
However if the referenced DLL is present in the directory that binary exists while being used for binary compatibility, VB6 will use that instead of whatever in the registry.
Now there is one problem that you will get on an infrequent basis. Consider this heirarchy
MyUtilityDLL
MyObjectDLL
MyUIDLL
MyEXE
If you ADD a property or method to a class in MyUtilityDLL MyUIDLL may not compile giving a binary incompatibility error if you are lucky or a strange error like [inref]. In any case the solution is to compile MyUtilityDLL and then immediately copy MyUtilityDLL into the compatibility directory. Then the rest of the automated compile will work fine.
You may want to include this step in the automated build.
Note that in many cases the projects will work fine in the IDE. To if you are now aware of this you could be pulling your hair out.
I guess you would have to edit the project files (.vbp), Form files (.frm) and the control files (.ctl) that reference the DLLs and OCXs and increment the typelib version number.
You would find latest typelib version number for the control / DLL in the registry.
This could be a pain depending on how many files you have.
A hack would be to open main project with VB6 using your script and send keys to confirm the Update References and then save the project.
Good Luck
Self-answer: I have written some vb6 code to do the upgrade programmatically. It is not extensively tested, there are probably a few bugs here and there for corner cases, but I did use it successfully.
Option Explicit
Const HKEY_LOCAL_MACHINE As Long = &H80000002
Const KEY_ENUMERATE_SUB_KEYS As Long = 8
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'''Returns the expected major version of a GUID if it exists, and otherwise returns the highest registered major version.
Public Function GetOcxMajorVersion(ByVal guid As String, Optional ByVal expected_version As Long) As Long
Const BUFFER_SIZE As Long = 255
Dim reg_key As Long
Dim ret As Long
Dim enum_index As Long
Dim max_version As Long: max_version = -1
ret = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\TypeLib\{" & guid & "}", 0, KEY_ENUMERATE_SUB_KEYS, reg_key)
If ret <> 0 Then Err.Raise ret, , "Failed to open registry key."
Do
'Store next subkey name in buffer
Dim buffer As String: buffer = Space(BUFFER_SIZE)
Dim cur_buffer_size As Long: cur_buffer_size = BUFFER_SIZE
ret = RegEnumKeyEx(reg_key, enum_index, buffer, cur_buffer_size, ByVal 0&, vbNullString, ByVal 0&, ByVal 0&)
If ret <> 0 Then Exit Do
buffer = Left(buffer, cur_buffer_size)
'Keep most likely version
buffer = Split(buffer, ".")(0)
If Not buffer Like "*[!0-9A-B]*" And Len(buffer) < 4 Then
Dim v As Long: v = CLng("&H" & buffer) 'convert from hex
If v = expected_version Then
max_version = v
Exit Do
ElseIf max_version < v Then
max_version = v
End If
End If
enum_index = enum_index + 1
Loop
RegCloseKey reg_key
If max_version = -1 Then Err.Raise -1, , "Failed to enumerate any viable subkeys."
GetOcxMajorVersion = max_version
End Function
Public Function RemoveFilename(ByVal path As String) As String
Dim folders() As String: folders = Split(Replace(path, "/", "\"), "\")
RemoveFilename = Left(path, Len(path) - Len(folders(UBound(folders))))
End Function
'''Changes any invalid OCX references to newer registered version
Public Sub UpdateFileOCXReferences(ByVal path As String)
Dim file_data As String
Dim changes_made As Boolean
'Read
Dim fn As Long: fn = FreeFile
Open path For Input As fn
While Not EOF(fn)
Dim line As String
Line Input #fn, line
'check for ocx reference line
If LCase(line) Like "object*=*{*-*-*-*-*}[#]*#.#*[#]#*;*.ocx*" Then
'get guid
Dim guid_start As Long: guid_start = InStr(line, "{") + 1
Dim guid_end As Long: guid_end = InStr(line, "}")
Dim guid As String: guid = Mid(line, guid_start, guid_end - guid_start)
'get reference major version
Dim version_start As Long: version_start = InStr(line, "#") + 1
Dim version_end As Long: version_end = InStr(version_start + 1, line, ".")
Dim version_text As String: version_text = Mid(line, version_start, version_end - version_start)
'play it safe
If Len(guid) <> 32 + 4 Then Err.Raise -1, , "GUID has unexpected length."
If Len(version_text) > 4 Then Err.Raise -1, , "Major version is larger than expected."
If guid Like "*[!0-9A-F-]*" Then Err.Raise -1, , "GUID has unexpected characters."
If version_text Like "*[!0-9]*" Then Err.Raise -1, , "Major version isn't an integer."
'get registry major version
Dim ref_version As Long: ref_version = CLng(version_text)
Dim reg_version As Long: reg_version = GetOcxMajorVersion(guid, ref_version)
'change line if necessary
If reg_version < ref_version Then
Err.Raise -1, , "Registered version precedes referenced version."
ElseIf reg_version > ref_version Then
line = Left(line, version_start - 1) & CStr(reg_version) & Mid(line, version_end)
changes_made = True
End If
End If
file_data = file_data & line & vbNewLine
Wend
Close fn
'Write
If changes_made Then
Kill path
Open path For Binary As fn
Put fn, , file_data
Close fn
End If
End Sub
'''Changes any invalid in included files to newer registered version
Public Sub UpdateSubFileOCXReferences(ByVal path As String)
Dim folder As String: folder = RemoveFilename(path)
Dim fn As Long: fn = FreeFile
Open path For Input As fn
While Not EOF(fn)
Dim line As String
Line Input #fn, line
If LCase(line) Like "form=*.frm" _
Or LCase(line) Like "usercontrol=*.ctl" Then
Dim file As String: file = folder & Mid(line, InStr(line, "=") + 1)
If Dir(file) <> "" Then
UpdateFileOCXReferences file
End If
End If
Wend
Close fn
End Sub