VB6: Writing to registry - vb6

I have to edit an old legacy VB6 application so that it can edit the registry to write the following:
reg add "HKCU\Software\Microsoft\Print\UnifiedPrintDialog" /v "PreferLegacyPrintDialog" /d 1 /t REG_DWORD /f
How can I emulate the above command in VB6?
I read a few posts using the registry = CreateObject("WScript.shell") methodology but it doesn't seem clear to me and I really don't want to mess around with the registry without knowing what I'm doing. Otherwise, could I just run the command through a ShellExecute or something similar?
Any assistance would be appreciated. Thanks!

For "proper" registry access/read/write in VB6, you would need to implement the appropriate Win32 API methods. Here's a wrapper class for that. But for your simple need, the WScript.Shell approach should it (from the Windows Scripting Host helpfile):
RegWrite supports strType as REG_SZ, REG_EXPAND_SZ, REG_DWORD, and
REG_BINARY. If another data type is passed as strType, RegWrite
returns E_INVALIDARG.
RegWrite automatically converts anyValue to a string when strType is
REG_SZ or REG_EXPAND_SZ. If strType is REG_DWORD, anyValue is
converted to an integer. If strType is REG_BINARY, anyValue must be an
integer.
Example
The following example writes a value and key entry into the
registry:
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.RegWrite "HKCU\ScriptEngine\Value", "Some string value"
WshShell.RegWrite "HKCU\ScriptEngine\Key\", 1 ,"REG_DWORD"

You can use the Windows API to accomplish what you need. Here's some general purpose code to read and write to the Registry:
Option Explicit
Private Sub Read_Click()
Text1.Text = ReadRegistry(HKEY_CURRENT_USER, "Software\Microsoft\Print\UnifiedPrintDialog", "PreferLegacyPrintDialog", ValDWord, "1")
End Sub
Private Sub Write_Click()
WriteRegistry HKEY_CURRENT_USER, "Software\Microsoft\Print\UnifiedPrintDialog", "PreferLegacyPrintDialog", ValDWord, Text1.Text
End Sub
In a Module place the following code:
Option Explicit
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const REG_SZ = 1
Public Const REG_DWORD = 4
Public Enum InTypes
ValNull = 0
ValString = 1
ValXString = 2
ValBinary = 3
ValDWord = 4
ValLink = 6
ValMultiString = 7
ValResList = 8
End Enum
Private Const ERROR_SUCCESS = 0&
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Function ReadRegistry(ByVal Group As Long, ByVal Section As String, ByVal Key As String, ByVal ValType As InTypes, Optional Default As Variant) As Variant
If ValType = ValString Then
ReadRegistry = ReadString(Group, Section, Key)
If ReadRegistry = "" Then ReadRegistry = Default
ElseIf ValType = ValDWord Then
ReadRegistry = ReadDword(Group, Section, Key)
If ReadRegistry = 0 Then ReadRegistry = Default
End If
End Function
Public Sub WriteRegistry(ByVal Group As Long, ByVal Section As String, ByVal Key As String, ByVal ValType As InTypes, ByVal Value As Variant)
If ValType = ValString Then
WriteString Group, Section, Key, CStr(Value)
ElseIf ValType = ValDWord Then
WriteDword Group, Section, Key, CLng(Value)
End If
End Sub
Private Function ReadString(hKey As Long, strPath As String, strValue As String) As String
Dim keyhand As Long
Dim lResult As Long
Dim strBuf As String
Dim lDataBufSize As Long
Dim intZeroPos As Integer
Dim lValueType As Long
Dim r As Long
r = RegOpenKey(hKey, strPath, keyhand)
lResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)
strBuf = String(lDataBufSize, " ")
lResult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
intZeroPos = InStr(strBuf, Chr$(0))
If intZeroPos > 0 Then
ReadString = Left$(strBuf, intZeroPos - 1)
Else
ReadString = strBuf
End If
End If
End Function
Private Sub WriteString(hKey As Long, strPath As String, strValue As String, strdata As String)
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(hKey, strPath, keyhand)
r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
r = RegCloseKey(keyhand)
End Sub
Private Function ReadDword(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String) As Long
Dim lResult As Long
Dim lValueType As Long
Dim lBuf As Long
Dim lDataBufSize As Long
Dim r As Long
Dim keyhand As Long
r = RegOpenKey(hKey, strPath, keyhand)
lDataBufSize = 4
lResult = RegQueryValueEx(keyhand, strValueName, 0&, lValueType, lBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
If lValueType = REG_DWORD Then ReadDword = lBuf
End If
r = RegCloseKey(keyhand)
End Function
Private Sub WriteDword(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String, ByVal lData As Long)
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(hKey, strPath, keyhand)
r = RegSetValueEx(keyhand, strValueName, 0&, REG_DWORD, lData, 4)
r = RegCloseKey(keyhand)
End Function

Related

base64 string to byte to image

I have a base64 string which was generated from an image using another application. Now on my application I want to convert the base64 string to byte and display it on a PictureBox.
I already found a sample application which takes a byte input and sets a PictureBox image. Unfortunately the sample application gets the byte array from an image and just translates it back. Here's the function it uses.
Public Function PictureFromByteStream(b() As Byte) As IPicture
Dim LowerBound As Long
Dim ByteCount As Long
Dim hMem As Long
Dim lpMem As Long
Dim IID_IPicture(15)
Dim istm As stdole.IUnknown
On Error GoTo Err_Init
If UBound(b, 1) < 0 Then
Exit Function
End If
LowerBound = LBound(b)
ByteCount = (UBound(b) - LowerBound) + 1
hMem = GlobalAlloc(&H2, ByteCount)
If hMem <> 0 Then
lpMem = GlobalLock(hMem)
If lpMem <> 0 Then
MoveMemory ByVal lpMem, b(LowerBound), ByteCount
Call GlobalUnlock(hMem)
If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then
If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
Call OleLoadPicture(ByVal ObjPtr(istm), ByteCount, 0, IID_IPicture(0), PictureFromByteStream)
End If
End If
End If
End If
Exit Function
Err_Init:
If Err.Number = 9 Then
'Uninitialized array
MsgBox "You must pass a non-empty byte array to this function!"
Else
MsgBox Err.Number & " - " & Err.Description
End If
End Function
Here's the function I found to convert a base64 string to a byte, it seems to be converting it but when I pass the byte data to the above function, no image appears.
Private Function DecodeBase64(ByVal strData As String) As Byte()
Dim objXML As MSXML2.DOMDocument
Dim objNode As MSXML2.IXMLDOMElement
' help from MSXML
Set objXML = New MSXML2.DOMDocument
Set objNode = objXML.createElement("b64")
objNode.dataType = "bin.base64"
objNode.Text = strData
DecodeBase64 = objNode.nodeTypedValue
' thanks, bye
Set objNode = Nothing
Set objXML = Nothing
End Function
And here's my code calling the functions.
Dim b() As Byte
b = DecodeBase64(Text1.Text)
Dim pic As StdPicture
Set pic = PictureFromByteStream(b)
Set Picture1.Picture = pic
Try this:
Option Explicit
Private Const CRYPT_STRING_BASE64 As Long = &H1&
Private Const STRING_IPICTURE_GUID As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Declare Function CryptStringToBinaryW Lib "Crypt32.dll" ( _
ByVal pszString As Long, _
ByVal cchString As Long, _
ByVal dwFlags As Long, _
ByVal pbBinary As Long, _
ByRef pcbBinary As Long, _
ByVal pdwSkip As Long, _
ByVal pdwFlags As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" ( _
ByRef hGlobal As Any, _
ByVal fDeleteOnResume As Long, _
ByRef ppstr As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32.dll" ( _
ByVal lpStream As IUnknown, _
ByVal lSize As Long, _
ByVal fRunMode As Long, _
ByRef riid As GUID, _
ByRef lplpObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpsz As Long, _
ByRef pclsid As GUID) As Long
Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public Function DecodeBase64(ByVal strData As String) As Byte()
Dim Buffer() As Byte
Dim dwBinaryBytes As Long
dwBinaryBytes = LenB(strData)
ReDim Buffer(dwBinaryBytes - 1) As Byte
If CryptStringToBinaryW(StrPtr(strData), LenB(strData), CRYPT_STRING_BASE64, _
VarPtr(Buffer(0)), dwBinaryBytes, 0, 0) Then
ReDim Preserve Buffer(dwBinaryBytes - 1) As Byte
DecodeBase64 = Buffer
End If
Erase Buffer
End Function
Public Function PictureFromByteStream(ByRef b() As Byte) As IPicture
On Error GoTo errorHandler
Dim istrm As IUnknown
Dim tGuid As GUID
If Not CreateStreamOnHGlobal(b(LBound(b)), False, istrm) Then
CLSIDFromString StrPtr(STRING_IPICTURE_GUID), tGuid
OleLoadPicture istrm, UBound(b) - LBound(b) + 1, False, tGuid, PictureFromByteStream
End If
Set istrm = Nothing
Exit Function
errorHandler:
Debug.Print "Error in converting to IPicture."
End Function

VB6 reading registry entry but no data returned

newly signed up desperate user here.
I left the programming business quite a while ago but now and then get asked to make some enhancements etc.
I want to use the registry to store some file locations so the user doesn't have to specify them all the time. I want to store them under HKEY_LOCAL_MACHINE because there are multiple users.
I have got the key created using RegCreateKeyEx, and a value has been entered into the key, with RegSetValueExString, so there is a key under HKEY_LOCAL_MACHINE called SUPPLIERFILE and it has the value "C:\Documents and Settings.." etc.
However when I use RegQueryValueExString it doesn't work: the lpValue string is empty, although the cbdata does contain the length of the string I was expecting to find there. The error retured is 234, ERROR_MORE_DATA.
I have tried using RegGetValue, because I thought maybe a non-null terminated string was the problem, but I haven't got RegGetValue in the api dll.
Any suggestions would be gratefully received, even along the lines of how to terminate a string with a null.
Thanks,
Steve
Your error indicates you have not initialized a large enough string buffer for the API function to use, but without your code, ??? I pulled the code below from a registry utility class I use. I think I have included all the API declarations, and constants used, as well as a method to translate returned errors to something helpful.
Public Enum RegRootKey
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_CONFIG = &H80000005
HKEY_CURRENT_USER = &H80000001
HKEY_DYN_DATA = &H80000006
HKEY_LOCAL_MACHINE = &H80000002
HKEY_PERFORMANCE_DATA = &H80000004
HKEY_USERS = &H80000003
End Enum
'the following declare is used to return windows error descriptions
Private Declare Function FormatMessage Lib "Kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
'key constants
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_SUCCESS = 0&
Private Const SYNCHRONIZE = &H100000
Private Const READ_CONTROL = &H20000
Private Const READ_WRITE = 2
Private Const READAPI = 0
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const STANDARD_RIGHTS_EXECUTE = (READ_CONTROL)
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Private Const KEY_NOTIFY = &H10
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_EVENT = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Private Const REG_OPTION_NON_VOLATILE = 0
Private Const REG_SZ = 1 ' Unicode nul terminated string
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_MULTI_SZ = 7 ' Multiple Unicode strings
Private Const REG_NONE = 0 ' No value type
Private Const KEY_WOW64_64KEY As Long = &H100& '32 bit app to access 64 bit hive
Private Const KEY_WOW64_32KEY As Long = &H200& '64 bit app to access 32 bit hive
'API declarations
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
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 RootKeyName Lib "advapi32.dll" Alias "RootKeyNameA" (ByVal lphKey As RegRootKey) As String
Public Function GetStringValue(ByVal hKeyRoot As RegRootKey, ByVal hKeySubKey As String, ByVal ValueName As String, Optional ByVal Default As String) As String
Dim strReturn As String
Dim strBuffer As String
Dim lngType As Long
Dim lngBufLen As Long
Dim lngRst As Long
Dim hKeyHandle As Long
On Error GoTo errGetStringValue
'just to avoid any errors in calling functions using a ubound to check the contents
strBuffer = String(255, vbNullChar)
lngBufLen = Len(strBuffer)
lngRst = RegOpenKeyEx(hKeyRoot, hKeySubKey, 0, KEY_READ Or KEY_WOW64_64KEY, hKeyHandle)
If hKeyHandle <> 0 Then
If StrComp(ValueName, "default", vbTextCompare) = 0 Then
lngRst = RegQueryValueEx(hKeyHandle, "", ByVal 0&, lngType, ByVal strBuffer, lngBufLen)
Else
lngRst = RegQueryValueEx(hKeyHandle, ValueName, ByVal 0&, lngType, ByVal strBuffer, lngBufLen)
End If
End If
If lngRst = 0 Then
If lngType = REG_SZ Then
If lngBufLen > 0 Then
strReturn = Left$(strBuffer, lngBufLen - 1)
Else
strReturn = Default
End If
Else
Err.Raise 1, App.EXEName, FormatClassError(1)
End If
ElseIf lngRst = 2 Then 'the key does not exists so return the default
strReturn = Default
Else 'if the return is non-zero there was an error
Err.Raise lngRst, App.EXEName, "There was an error reading the " & RootKeyName(hKeyRoot) & "\" & _
hKeySubKey & " registry key, " & LCase$(FormatClassError(lngRst))
End If
If hKeyHandle <> 0 Then
lngRst = RegCloseKey(hKeyHandle)
hKeyHandle = 0
End If
GetStringValue = strReturn
Exit Function
errGetStringValue:
If hKeyHandle <> 0 Then
lngRst = RegCloseKey(hKeyHandle)
hKeyHandle = 0
End If
Err.Raise Err.Number, Err.Source & ":GetStringValue", Err.Description
End Function
Private Function FormatClassError(ByVal ErrorNumber As Long) As String
Dim strReturn As String
Dim strBuffer As String
Dim lngBufLen As Long
Dim lngRst As Long
On Error Resume Next
'initialize the buffer to to API function
strBuffer = String(1024, vbNullChar)
lngBufLen = Len(strBuffer)
'make the call to the API function
lngRst = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, ByVal 0&, ErrorNumber, ByVal 0&, strBuffer, lngBufLen, ByVal 0&)
'if the return value is <> 0 then we have a valid message
If lngRst <> 0 Then
strReturn = Left$(strBuffer, lngRst)
Else
'make another call to the API function with the last dll error
lngRst = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, ByVal 0&, Err.LastDllError, ByVal 0&, strBuffer, lngBufLen, ByVal 0&)
If lngRst <> 0 Then
strReturn = Left$(strBuffer, lngRst)
Else
strReturn = "Unable to retrieve error description."
End If
End If
'return the result
FormatClassError = strReturn
End Function
Quick answer: try the GetRegStringValue$ code here
In case you (or others) want to know more
When you call that API, as with many windows APIs you are supposed to provide a buffer (string) to hold the registry value, and you are supposed to pass in the maximum size of your buffer.
MSDN explains
If the buffer specified by lpData parameter is not large enough to hold the data, the function returns ERROR_MORE_DATA and stores the required buffer size in the variable pointed to by lpcbData. In this case, the contents of the lpData buffer are undefined.
You need to allocate a buffer (probably fill your string with spaces) and pass in the size in lpData.
you should check first, if the Registry is really do exist or not. By error handling, we can check for the Registry key Entry.
Private Function RegOSInfo(RegPath As String, RegKey As String) As String
On Error GoTo ErrHandler
Dim osName As String
Dim Reg As Object
Set Reg = CreateObject("WScript.Shell")
RegOSInfo = Reg.RegRead(RegPath & "\" & RegKey)
ErrHandler:
RegOSInfo = "-555" 'custom Error Code, Registry key doesn't exist
End Function
you can handle the Custom error code according to your need.

Deleting a registry subkey in Visual Basic 6

I am working on an application that deletes registry subkeys, but I can't seem to find a solution for that problem... I know it is easier to do this with VB.NET but I want to know how to get this done using VB6
What I have tried...
DeleteRegKey HKEY_CURRENT_USER\Software\Test.
Take this for what it's worth. I haven't used this in a few years so it has not been tested on Windows 8, and I'm not at all sure about Windows 7 either. I pulled this from a utility class so hopefully I got all the declarations.
Private Const KEY_NOTIFY = &H10
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_EVENT = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Public Enum RegRootKey
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_CONFIG = &H80000005
HKEY_CURRENT_USER = &H80000001
HKEY_DYN_DATA = &H80000006
HKEY_LOCAL_MACHINE = &H80000002
HKEY_PERFORMANCE_DATA = &H80000004
HKEY_USERS = &H80000003
End Enum
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) 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, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Public Function DeleteRegKey(ByVal hKeyRoot As RegRootKey, ByVal hKeySubKey As String, ByVal KeyName As String) As Boolean
Dim lngRst As Long
Dim hKeyReturn As Long
Dim hKeyDisposition As Long
Dim strSubKeys() As String
Dim lngSubKeyCount As Long
Dim i As Long
On Error GoTo errDeleteRegKey
lngRst = RegOpenKeyEx(hKeyRoot, hKeySubKey, ByVal 0&, KEY_READ + KEY_WRITE, hKeyReturn)
If lngRst = 0 Then 'we can continue
' first need to find and delete sub keys
lngSubKeyCount = EnumSubKeys(hKeyRoot, hKeySubKey & "\" & KeyName, strSubKeys)
' recursively call this function to delete all sub keys
For i = 0 To lngSubKeyCount - 1
Call DeleteRegKey(hKeyRoot, hKeySubKey & "\" & KeyName, strSubKeys(i))
Next i
' finally down (up?) to the parent key
lngRst = RegDeleteKey(hKeyReturn, ByVal KeyName)
'close the handle
If hKeyReturn <> 0 Then
lngRst = RegCloseKey(hKeyReturn)
hKeyReturn = 0
End If
End If
If lngRst = 0 Then '0 = success
DeleteRegKey = True
Else
Err.Raise lngRst, App.EXEName, FormatClassError(lngRst)
End If
Exit Function
errDeleteRegKey:
'close the handle
If hKeyReturn <> 0 Then
lngRst = RegCloseKey(hKeyReturn)
hKeyReturn = 0
End If
Err.Raise Err.Number, Err.Source & ":DeleteRegKey", Err.Description
End Function
Add this function to a form, module, or class then
Call DeleteRegKey(HKEY_CURRENT_USER, "Software", "Test")
' or
DeleteRegKey HKEY_CURRENT_USER, "Software", "Test"
' or
Dim blnRst as Boolean
blnRst = DeleteRegKey(HKEY_CURRENT_USER, "Software", "Test")

Vb6 Opening a custom file with my program in a text box

Help I am making a word processor and have a custom file extension to save it with but when I save that file and use open with select my program's exe then open it, the program opens with blank text how would I get it to open my text from double click in windows explorer
Inside your code use the following (no way to make it pretty but it works fine, copy and paste)
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKey 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 RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_BADDB = 1&
Private Const ERROR_BADKEY = 2&
Private Const ERROR_CANTOPEN = 3&
Private Const ERROR_CANTREAD = 4&
Private Const ERROR_CANTWRITE = 5&
Private Const ERROR_OUTOFMEMORY = 6&
Private Const ERROR_INVALID_PARAMETER = 7&
Private Const ERROR_ACCESS_DENIED = 8&
Private Const KEY_QUERY_VALUE = &H1&
Private Const KEY_CREATE_SUB_KEY = &H4&
Private Const KEY_ENUMERATE_SUB_KEYS = &H8&
Private Const KEY_NOTIFY = &H10&
Private Const KEY_SET_VALUE = &H2&
Private Const MAX_PATH = 260&
Private Const REG_DWORD As Long = 4
Private Const REG_SZ = 1
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = READ_CONTROL
Private Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Private Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Private Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Sub MakeFileAssociation(Extension As String, PathToApplication As String, ApplicationName As String, Description As String, Optional FullIconPath As String)
Dim ret&
If Left(PathToApplication, 1) <> "\" Then PathToApplication = PathToApplication & "\"
'Create a Root entry called .XXX associated with application name
sKeyName = "." & Extension
sKeyValue = ApplicationName
ret& = WriteKey(HKEY_CLASSES_ROOT, sKeyName, "", sKeyValue)
'Set application key and file description
sKeyName = ApplicationName
sKeyValue = Description
ret& = WriteKey(HKEY_CLASSES_ROOT, sKeyName, "", sKeyValue)
'This sets the default icon for XXX_auto_file
If FullIconPath <> "" Then
sKeyName = ApplicationName & "\DefaultIcon"
sKeyValue = FullIconPath & ",0"
ret& = WriteKey(HKEY_CLASSES_ROOT, sKeyName, "", sKeyValue)
End If
'This sets the command line for XXX_auto_file
sKeyName = ApplicationName & "\shell\open\command"
sKeyValue = Chr(34) & PathToApplication & ApplicationName & ".exe" & Chr(34) & " %1"
ret& = WriteKey(HKEY_CLASSES_ROOT, sKeyName, "", sKeyValue)
End Sub
Public Sub DeleteFileAssociation(Extension As String)
Dim Application As String
Dim ret&
'check if filetype is registred
Application = ReadKey(HKEY_CLASSES_ROOT, "." & Extension, "", "")
If Application <> "" Then
'delete file extension
ret& = DeleteKey(HKEY_CLASSES_ROOT, "." & Extension)
'delete command lines
ret& = DeleteKey(HKEY_CLASSES_ROOT, Application)
End If
End Sub
Public Function CheckFileAssociation(ByVal Extension As String) As String
Extension = "." & Extension
'read in the program name associated with this filetype
CheckFileAssociation = ReadKey(HKEY_CLASSES_ROOT, Extension, "", "")
End Function
Public Function ReadKey(ByVal KeyName As String, ByVal SubKeyName As String, ByVal ValueName As String, ByVal DefaultValue As String) As String
Dim sBuffer As String
Dim lBufferSize As Long
Dim ret&
sBuffer = Space(255)
lBufferSize = Len(sBuffer)
ret& = RegOpenKey(KeyName, SubKeyName, 0, KEY_READ, lphKey&)
If ret& = ERROR_SUCCESS Then
ret& = RegQueryValue(lphKey&, ValueName, 0, REG_SZ, sBuffer, lBufferSize)
ret& = RegCloseKey(lphKey&)
Else
ret& = RegCloseKey(lphKey&)
End If
sBuffer = Trim(sBuffer)
If sBuffer <> "" Then
sBuffer = Left(sBuffer, Len(sBuffer) - 1)
Else
sBuffer = DefaultValue
End If
ReadKey = sBuffer
End Function
Public Function WriteKey(ByVal KeyName As String, ByVal SubKeyName As String, ByVal ValueName As String, ByVal KeyValue As String) As Long
Dim ret&
ret& = RegCreateKey&(KeyName, SubKeyName, lphKey&)
If ret& = ERROR_SUCCESS Then
ret& = RegSetValue&(lphKey&, ValueName, REG_SZ, KeyValue, 0&)
Else
ret& = RegCloseKey(lphKey&)
End If
WriteKey = ret&
End Function
Public Function DeleteKey(ByVal KeyName As String, ByVal SubKeyName As String) As Long
Dim ret&
ret& = RegOpenKey(KeyName, SubKeyName, 0, KEY_WRITE, lphKey&)
If ret& = ERROR_SUCCESS Then
ret& = RegDeleteKey(lphKey&, "") 'delete the key
ret& = RegCloseKey(lphKey&)
End If
DeleteKey = ret&
End Function
Then you can call them and provide the parameter and it will create it for you, delete it and check it. As for handing it via your application when you open the file using the extension, you need to make sure you have a command line parser and feed it with a %1 and use that file name to open the document within your program. That's it.
You can create a main() and set your program startup to use that instead of the usual form1 and inside that put:
Public Sub main()
'Store command line arguments in this array
Dim sArgs() As String
Dim iLoop As Integer
'Assuming that the arguments passed from
'command line will have space in between,
'you can also use comma or other things...
sArgs = Split(Command$, " ")
For iLoop = 0 To UBound(sArgs)
'this will print the command line
'arguments that are passed from the command line
Debug.Print sArgs(iLoop)
Next
End Sub
Depending on what arguments you are passing to the command of your program, you would replace the debug line with the path to the file you just opened with your program and do what you do with it in your application.

How can I stop Excel workbook flicker on automation open?

I'm using GetObject with a workbook path to either create a new or grab an existing Excel instance. If it's grabbing an existing user-created instance, the application window is visible; if the workbook path in question is closed, it will open and hide, but not before it flickers on the screen. Application.ScreenUpdating does not help with this.
I don't think I can use the Win32Api call LockWindowUpdate, because I don't know whether I'm getting or creating before the file is open. Is there some other VBA-friendly way (i.e. WinAPI) to freeze the screen long enough to get the object?
EDIT: Just to clarify, because the first answer suggests using the Application object... These are the steps to reproduce this behavior.
1. Open Excel--make sure you're only running one instance--save and close the default workbook. Excel window now visible but "empty"
2. Open Powerpoint or Word, insert a module, add the following code
Public Sub Open_SomeWorkbook()
Dim MyObj As Object
Set MyObj = GetObject("C:\temp\MyFlickerbook.xlsx")
'uncomment the next line to see the workbook again'
'MyObj.Parent.Windows(MyObj.Name).Visible = True'
'here's how you work with the application object... after the fact'
Debug.Print MyObj.Parent.Version
End Sub
Note the flicker as Excel opens the file in the existing instance, and then hides it... because it's automation
Note also, however, that there is no application object to work with, until the flickering is done. This is why I'm looking for some larger API method to "freeze" the screen.
Try,
Application.VBE.MainWindow.Visible = False
If that doesn't work try
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal ClassName As String, ByVal WindowName As String) As Long
Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hWndLock As Long) As Long
Sub EliminateScreenFlicker()
Dim VBEHwnd As Long
On Error GoTo ErrH:
Application.VBE.MainWindow.Visible = False
VBEHwnd = FindWindow("wndclass_desked_gsk", _
Application.VBE.MainWindow.Caption)
If VBEHwnd Then
LockWindowUpdate VBEHwnd
End If
'''''''''''''''''''''''''
' your code here
'''''''''''''''''''''''''
Application.VBE.MainWindow.Visible = False
ErrH:
LockWindowUpdate 0&
End Sub
Both found here Eliminating Screen Flicker During VBProject Code
Ok you didn't mention multiple instances... [1. Open Excel--make sure you're only running one instance] :)
How about something like this.....
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare PtrSafe Function ShowWindow Lib "user32" (ByVal lHwnd As Long, _
ByVal lCmdShow As Long) As Boolean
Public Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Sub GetWindowHandle()
Const SW_HIDE As Long = 0
Const SW_SHOW As Long = 5
Const SW_MINIMIZE As Long = 2
Const SW_MAXIMIZE As Long = 3
'Const C_WINDOW_CLASS = "XLMAIN"
Const C_WINDOW_CLASS = vbNullString
Const C_FILE_NAME = "Microsoft Excel - Flickerbook.xlsx"
'Const C_FILE_NAME = vbNullString
Dim xlHwnd As Long
xlHwnd = FindWindow(lpClassName:=C_WINDOW_CLASS, _
lpWindowName:=C_FILE_NAME)
'Debug.Print xlHwnd
if xlHwnd = 0 then
Dim MyObj As Object
Dim objExcel As Excel.Application
Set objExcel = GetObject(, "Excel.Application")
objExcel.ScreenUpdating = False
Set MyObj = GetObject("C:\temp\MyFlickerbook.xlsx")
'uncomment the next line to see the workbook again'
'MyObj.Parent.Windows(MyObj.Name).Visible = True
'here's how you work with the application object... after the fact'
Debug.Print MyObj.Parent.Version
MyObj.Close
objExcel.ScreenUpdating = True
else
'Either HIDE/SHOW or MINIMIZE/MAXIMISE
ShowWindow xlHwnd, SW_HIDE
Set MyObj = GetObject("C:\temp\MyFlickerbook.xlsx")
'manage MyObj
ShowWindow xlHwnd, SW_SHOW
'Or LockWindowUpdate then Unlock
LockWindowUpdate xlHwnd
Set MyObj = GetObject("C:\temp\MyFlickerbook.xlsx")
'manage MyObj
LockWindowUpdate 0
end if
' 'Get Window Name
' Dim strWindowTitle As String
' strWindowTitle = Space(260) ' We must allocate a buffer for the GetWindowText function
' Call GetWindowText(xlHwnd, strWindowTitle, 260)
' debug.print (strWindowTitle)
End Sub
I ended up basically ditching GetObject, because it wasn't granular enough, and wrote my own flickerless opener, with some inspiration from osknows and great code samples from here and here. Thought I would share it in case others found it useful. First the complete module
'looping through, parent and child (see also callbacks for lpEnumFunc)
Private Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, _
ByVal lParam As Long) As Long
Private Declare Function EnumChildWindows Lib "user32.dll" (ByVal hWndParent As Long, _
ByVal lpEnumFunc As Long, _
ByVal lParam As Long) As Long
'title of window
Private Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hWnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
'class of window object
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
'control window display
Private Declare Function ShowWindow Lib "user32" (ByVal lHwnd As Long, _
ByVal lCmdShow As Long) As Boolean
Private Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Public Enum swcShowWindowCmd
swcHide = 0
swcNormal = 1
swcMinimized = 2 'but activated
swcMaximized = 3
swcNormalNoActivate = 4
swcShow = 5
swcMinimize = 6 'activates next
swcMinimizeNoActivate = 7
swcShowNoActive = 8
swcRestore = 9
swcShowDefault = 10
swcForceMinimized = 11
End Enum
'get application object using accessibility
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, _
ByVal dwId As Long, _
ByRef riid As GUID, _
ByRef ppvObject As Object) _
As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, _
ByRef lpiid As GUID) As Long
'Const defined in winuser.h
Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0
'IDispath pointer to native object model
Private Const Guid_Excel As String = "{00020400-0000-0000-C000-000000000046}"
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
'class names to search by (Excel, in this example, is XLMAIN)
Private mstrAppClass As String
'title (a.k.a. pathless filename) to search for
Private mstrFindTitle As String
'resulting handle outputs - "default" app instance and child with object
Private mlngFirstHwnd As Long
Private mlngChildHwnd As Long
'------
'replacement GetObject
'------
Public Function GetExcelWbk(pstrFullName As String, _
Optional pbleShow As Boolean = False, _
Optional pbleWasOpenOutput As Boolean) As Object
Dim XLApp As Object
Dim xlWbk As Object
Dim strWbkNameOnly As String
Set XLApp = GetExcelAppForWbkPath(pstrFullName, pbleWasOpenOutput)
'other stuff can be done here if the app needs to be prepared for the load
If pbleWasOpenOutput = False Then
'load it, without flicker, if you plan to show it
If pbleShow = False Then
XLApp.ScreenUpdating = False
End If
Set xlWbk = XLApp.Workbooks.Open(pstrFullName)
Else
'get it by its (pathless, if saved) name
strWbkNameOnly = PathOrFileNm("FileNm", pstrFullName)
Set xlWbk = XLApp.Workbooks(strWbkNameOnly)
End If
Set GetExcelWbk = xlWbk
Set xlWbk = Nothing
Set XLApp = Nothing
End Function
Private Function GetExcelAppForWbkPath(pstrFullName As String, _
pbleWbkWasOpenOutput As Boolean, _
Optional pbleLoadAddIns As Boolean = True) As Object
Dim XLApp As Object
Dim bleAppRunning As Boolean
Dim lngHwnd As Long
'get a handle, and determine whether it's for a workbook or an app instance
lngHwnd = WbkOrFirstAppHandle(pstrFullName, pbleWbkWasOpenOutput)
'if a handle came back, at least one instance of Excel is running
'(this isnt' particularly useful; just check XLApp.Visible when you're done getting/opening;
'if it's a hidden instance, it wasn't running)
bleAppRunning = (lngHwnd > 0)
'get an app instance.
Set XLApp = GetAppForHwnd(lngHwnd, pbleWbkWasOpenOutput, pbleLoadAddIns)
Set GetExcelAppForWbkPath = XLApp
Set XLApp = Nothing
Exit Function
End Function
Private Function WbkOrFirstAppHandle(pstrFullName As String, _
pbleIsChildWindowOutput As Boolean) As Long
Dim retval As Long
'defaults
mstrAppClass = "XLMAIN"
mstrFindTitle = PathOrFileNm("FileNm", pstrFullName)
mlngFirstHwnd = 0
mlngChildHwnd = 0
'find
retval = EnumWindows(AddressOf EnumWindowsProc, 0)
If mlngChildHwnd > 0 Then
pbleIsChildWindowOutput = True
WbkOrFirstAppHandle = mlngChildHwnd
Else
WbkOrFirstAppHandle = mlngFirstHwnd
End If
'clear
mstrAppClass = ""
mstrFindTitle = ""
mlngFirstHwnd = 0
mlngChildHwnd = 0
End Function
Private Function GetAppForHwnd(plngHWnd As Long, _
pbleIsChild As Boolean, _
pbleLoadAddIns As Boolean) As Object
On Error GoTo HandleError
Dim XLApp As Object
Dim AI As Object
If plngHWnd > 0 Then
If pbleIsChild = True Then
'get the parent instance using accessibility
Set XLApp = GetExcelAppForHwnd(plngHWnd)
Else
'get the "default" instance
Set XLApp = GetObject(, "Excel.Application")
End If
Else
'no Excel running
Set XLApp = CreateObject("Excel.Application")
If pbleLoadAddIns = True Then
'explicitly reload add-ins (automation doesn't)
For Each AI In XLApp.AddIns
If AI.Installed Then
AI.Installed = False
AI.Installed = True
End If
Next AI
End If
End If
Set GetAppForHwnd = XLApp
Set AI = Nothing
Set XLApp = Nothing
Exit Function
End Function
'------
'API wrappers and utilities
'------
Public Function uWindowClass(ByVal hWnd As Long) As String
Dim strBuffer As String
Dim retval As Long
strBuffer = Space(256)
retval = GetClassName(hWnd, strBuffer, 255)
uWindowClass = Left(strBuffer, retval)
End Function
Public Function uWindowTitle(ByVal hWnd As Long) As String
Dim lngLen As Long
Dim strBuffer As String
Dim retval As Long
lngLen = GetWindowTextLength(hWnd) + 1
If lngLen > 1 Then
'title found - pad buffer
strBuffer = Space(lngLen)
'...get titlebar text
retval = GetWindowText(hWnd, strBuffer, lngLen)
uWindowTitle = Left(strBuffer, lngLen - 1)
End If
End Function
Public Sub uShowWindow(ByVal hWnd As Long, _
Optional pShowType As swcShowWindowCmd = swcRestore)
Dim retval As Long
retval = ShowWindow(hWnd, pShowType)
Select Case pShowType
Case swcMaximized, swcNormal, swcRestore, swcShow
BringWindowToTop hWnd
SetFocus hWnd
End Select
End Sub
Private Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Dim strThisClass As String
Dim strThisTitle As String
Dim retval As Long
Dim bleMatch As Boolean
'mlngWinCounter = mlngWinCounter + 1
'type of window is all you need for parent
strThisClass = uWindowClass(hWnd)
bleMatch = (strThisClass = mstrAppClass)
If bleMatch = True Then
strThisTitle = uWindowTitle(hWnd)
'Debug.Print "Window #"; mlngWinCounter; " : ";
'Debug.Print strThisTitle; "(" & strThisClass & ") " & hWnd
If mlngFirstHwnd = 0 Then mlngFirstHwnd = hWnd
'mlngChildWinCounter 0
retval = EnumChildWindows(hWnd, AddressOf EnumChildProc, 0)
If mlngChildHwnd > 0 Then
'If mbleFindAll = False And mlngChildHwnd > 0 Then
'stop EnumWindows by setting result to 0
EnumWindowsProc = 0
Else
EnumWindowsProc = 1
End If
Else
EnumWindowsProc = 1
End If
End Function
Private Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Dim strThisClass As String
Dim strThisTitle As String
Dim retval As Long
Dim bleMatch As Boolean
strThisClass = uWindowClass(hWnd)
strThisTitle = uWindowTitle(hWnd)
If Len(mstrFindTitle) > 0 Then
bleMatch = (strThisTitle = mstrFindTitle)
Else
bleMatch = True
End If
If bleMatch = True Then
mlngChildHwnd = hWnd
EnumChildProc = 0
Else
EnumChildProc = 1
End If
End Function
Public Function GetExcelAppForHwnd(pChildHwnd As Long) As Object
Dim o As Object
Dim g As GUID
Dim retval As Long
'for child objects only, e.g. must use a loaded workbook to get its parent Excel.Application
'make a valid GUID type
retval = IIDFromString(StrPtr(Guid_Excel), g)
'get
retval = AccessibleObjectFromWindow(pChildHwnd, OBJID_NATIVEOM, g, o)
If retval >= 0 Then
Set GetExcelAppForHwnd = o.Application
End If
End Function
Public Function PathOrFileNm(pstrPathOrFileNm As String, _
pstrFileNmWithPath As String)
On Error GoTo HandleError
Dim i As Integer
Dim j As Integer
Dim strChar As String
If Len(pstrFileNmWithPath) > 0 Then
i = InStrRev(pstrFileNmWithPath, "\")
If i = 0 Then
i = InStrRev(pstrFileNmWithPath, "/")
End If
If i > 0 Then
Select Case pstrPathOrFileNm
Case "Path"
PathOrFileNm = Left(pstrFileNmWithPath, i - 1)
Case "FileNm"
PathOrFileNm = Mid(pstrFileNmWithPath, i + 1)
End Select
ElseIf pstrPathOrFileNm = "FileNm" Then
PathOrFileNm = pstrFileNmWithPath
End If
End If
End Function
And then some sample/test code.
Public Sub Test_GetExcelWbk()
Dim MyXLApp As Object
Dim MyXLWbk As Object
Dim bleXLWasRunning As Boolean
Dim bleWasOpen As Boolean
Const TESTPATH As String = "C:\temp\MyFlickerbook.xlsx"
Const SHOWONLOAD As Boolean = False
Set MyXLWbk = GetExcelWbk(TESTPATH, SHOWONLOAD, bleWasOpen)
If Not (MyXLWbk Is Nothing) Then
Set MyXLApp = MyXLWbk.Parent
bleXLWasRunning = MyXLApp.Visible
If SHOWONLOAD = False Then
If MsgBox("Show " & TESTPATH & "?", vbOKCancel) = vbOK Then
MyXLApp.Visible = True
MyXLApp.Windows(MyXLWbk.Name).Visible = True
End If
End If
If bleWasOpen = False Then
If MsgBox("Close " & TESTPATH & "?", vbOKCancel) = vbOK Then
MyXLWbk.Close SaveChanges:=False
If bleXLWasRunning = False Then
MyXLApp.Quit
End If
End If
End If
End If
Set MyXLWbk = Nothing
Set MyXLApp = Nothing
End Sub
Hope someone else finds this useful.

Resources