I have declared API as:
Private Declare Function GetTimeZoneInformation Lib "kernel32" (ByRef a_timezoneinfo As t_TimeZoneInfo) As Integer
t_TimeZoneInfo Structure Definition is as follows:
Private Structure t_TimeZoneInfo
Dim tz_Bias As Integer
<VBFixedArray(32)> Dim tz_StandardName() As Short
Dim tz_StandardDateArray As t_SysTimeAsArray
Dim tz_StandardBias As Integer
<VBFixedArray(32)> Dim tz_DaylightName() As Short
Dim tz_DayLightDateArray As t_SysTimeAsArray
Dim tz_DaylightBias As Integer
Public Sub Initialize()
ReDim tz_StandardName(32)
tz_StandardDateArray.Initialize()
ReDim tz_DaylightName(32)
tz_DayLightDateArray.Initialize()
End Sub
End Structure
And Structure t_SysTimeAsArray is:
Private Structure t_SysTimeAsArray
<VBFixedArray(8)> Dim w_timeval() As Short ' Y M Dw D G Min S mS
Public Sub Initialize()
ReDim w_timeval(8)
End Sub
End Structure
Then I have the below code in my other function:
Dim lfmtres As String = ""
Dim lneedunicode As Boolean
Dim lres As Integer
lfmtres = CStr(a_tzinfo.tz_Bias) & "," & CStr(a_tzinfo.tz_DaylightBias) & "," & mCopyShortArrayToChars(a_tzinfo.tz_StandardName, 32, lneedunicode) & "," & mCopyShortArrayToChars(a_tzinfo.tz_DaylightName, 32, lneedunicode) & "," & mCopyShortArrayToNumString(a_tzinfo.tz_StandardDateArray.w_timeval, 8) & "," & mCopyShortArrayToNumString(a_tzinfo.tz_DayLightDateArray.w_timeval, 8)
lres = GetTimeZoneInformation(ltzinfo)
It throws Exception of type System.ExecutionEngineException at line lres = GetTimeZoneInformation(ltzinfo). Well, I know that this type of exception generally happens when there is an internal error in the execution engine of the common language runtime but I believe that in my case I'm doing something wrong in lib API Declaration. (As I have already tried reinstalling VS, run project in other laptop, Change version but nothing fixed the problem). Any help would be appreciated.
Related
I encounter an error while compiling a project containing the import of a namespace.
I have a file called "Dissimulation.vb" in which the namespace "Dissimulation2" is declared. Here is his code:
Option Strict Off
Option Explicit Off
Imports System.IO
Imports System.Security.Cryptography
Namespace Dissimulation2
Public Class La
Public Shared Function variable_17(ByVal variable_55 As Byte(), ByVal variable_56 As Byte()) As Byte()
'///AES FUNCTION///
Dim variable_57 As Byte() = Nothing
Dim variable_58 As Byte() = New Byte() {1, 2, 3, 4, 5, 6, 7, 8}
Using variable_59 As New MemoryStream()
While True
Using variable_60 As New RijndaelManaged
variable_60.KeySize = 256
variable_60.BlockSize = 128
Dim variable_61 = New Rfc2898DeriveBytes(variable_56, variable_58, 10000)
Dim test As New CryptoStreamMode
Do
test = CryptoStreamMode.Write
variable_60.Key = variable_61.GetBytes(variable_60.KeySize / 8)
variable_60.IV = variable_61.GetBytes(variable_60.BlockSize / 8)
variable_60.Mode = CipherMode.CBC
Using variable_62 = New CryptoStream(variable_59, variable_60.CreateDecryptor(), test)
variable_62.Write(variable_55, 0, variable_55.Length)
variable_62.Close()
variable_57 = variable_59.ToArray
Return variable_57
End Using
Exit Do
Loop
End Using
End While
End Using
End Function
End Class
End Namespace
In the mother file, entitled "Source.vb" I would like to call this function. To do this, I simply take it like this:
Dissimulation2.La.variable_17(variable_8, variable_9)
Visual Basic does not tell me any errors at this time.
Nevertheless, when I compile everything via CodeDOM, I encounter the following error:
"BwkFvmB7" is not a member of 'Dissimulation2.La'.
Here are the parameters of CodeDOM:
Imports System.Text
Imports System.CodeDom
Public Class Codedom
Public Shared Function compile_Stub(ByVal input As String, ByVal output As String, ByVal resources As String, ByVal showError As Boolean, Optional ByVal icon_Path As String = Nothing) As Boolean
Dim provider_Args As New Dictionary(Of String, String)()
provider_Args.Add("CompilerVersion", "v2.0")
Dim provider As New Microsoft.VisualBasic.VBCodeProvider(provider_Args)
Dim c_Param As New Compiler.CompilerParameters
Dim c_Args As String = " /target:winexe /platform:x86 /optimize "
If Not icon_Path = Nothing Then
c_Args = c_Args & "/win32icon:" & icon_Path
End If
c_Param.GenerateExecutable = True
c_Param.ReferencedAssemblies.Add("System.Drawing.Dll")
c_Param.ReferencedAssemblies.Add("System.Windows.Forms.Dll")
c_Param.GenerateInMemory = True
c_Param.OutputAssembly = output
c_Param.EmbeddedResources.Add(resources)
c_Param.CompilerOptions = c_Args
c_Param.IncludeDebugInformation = False
Dim c_Result As Compiler.CompilerResults = provider.CompileAssemblyFromSource(c_Param, input)
If c_Result.Errors.Count = 0 Then
Return True
Else
If showError Then
For Each _Error As Compiler.CompilerError In c_Result.Errors
MessageBox.Show("ERREUR de compilation" & vbNewLine &
"FileName: " & _Error.FileName & vbNewLine &
"Line: " & _Error.Line & vbNewLine & "ErrorText: " &
_Error.ErrorText & vbNewLine &
"Column: " &
_Error.Column & vbNewLine &
"Error Type: " &
_Error.IsWarning & vbNewLine & "ErrorNumber: " &
_Error.ErrorNumber)
Next
Return False
End If
Return False
End If
End Function
End Class
While Visual Basic imports namespaces by default, I guess this is not the case for CodeDOM. So, I guess that error appears. However, I do not know how to import it manually: I can not find any document about it in VB.NET.
Can you point me to the right path?
I have found this question but i do not understand because the code is not codded in VB.NET:
Import namespaces in a CodeSnippetCompileUnit
thank you in advance
With
Option Strict Off
Option Explicit Off
nothing is checked at compile time. Put both on and then I assume you get the error in Visual Studio, too.
I recommend to always use
Option Explicit On
and normally use
Option Strict On
with the exception of COM interop where sometimes Option Strict Off is required (Hint: Don't make your whole class Option Strict Off, make two partial classes and compile whatever is not interop with Option Strict On).
I am developing a server-side scripting language which I intend to use on my private server. It is similar to PHP, and I know that I could easily use PHP instead but I'm just doing some programming for fun.
The syntax of basic commands in my language is as follows:
command_name "parameter1" : "parameter2" : "parameter3"
But it can also be like this when I want to join values for a parameter:
command_name "parameter1" : "param" & "eter2" : "par" & "amet" & "er3"
How would I go about parsing a string like the ones shown above (it will be perfectly typed, no syntax errors) to an object that has these properties
Custom class "Request"
Property "Command" as String, should be the "command_name" part
Property "Parameters" as String(), should be an array of Parameter objects
Shared Function FromString(s As String) as Request, this should accept a string in the language above and parse it to a Request object
Custom class "Parameter"
Property "Segments" as String(), for example "para", "mete", and "r3"
Sub New(ParamArray s as String()), this is how it should be generated from the code
It should be done in VB.NET and I am a moderate level programmer, so even if you just have an idea of how to attack this then please share it with me. I am very new to parsing complex data like this so I need a lot of help. Thanks so much!
Here is another method that is simpler.
Module Module1
Sub Main()
Dim inputs As String() = {"command_name ""parameter1"" : ""parameter2"" : ""parameter3""", "command_name ""parameter1"" : ""param"" & ""eter2"" : ""par"" & ""amet"" & ""er3"""}
For Each _input As String In inputs
Dim commandStr As String = _input.Substring(0, _input.IndexOf(" ")).Trim()
Dim parameters As String = _input.Substring(_input.IndexOf(" ")).Trim()
Dim parametersA As String() = parameters.Split(":".ToCharArray(), StringSplitOptions.RemoveEmptyEntries).Select(Function(x) x.Trim()).ToArray()
Dim parametersB As String()() = parametersA.Select(Function(x) x.Split("&".ToCharArray(), StringSplitOptions.RemoveEmptyEntries).Select(Function(y) y.Trim(" """.ToCharArray())).ToArray()).ToArray()
Dim newCommand As New Command() With {.name = commandStr, .parameters = parametersB.Select(Function(x) New Parameter(x)).ToArray()}
Command.commands.Add(newCommand)
Next (_input)
Dim z = Command.commands
End Sub
End Module
Public Class Command
Public Shared commands As New List(Of Command)
Public name As String
Public parameters As Parameter()
End Class
Public Class Parameter
Sub New()
End Sub
Sub New(names As String())
Me.names = names
End Sub
Public names As String()
End Class
I figured it out myself
Module Module1
Sub Main()
Dim r As Request = Request.Parse(Console.ReadLine())
Console.WriteLine("The type of request is " & r.Name)
For Each p As Parameter In r.Parameters
Console.WriteLine("All segments inside of parameter " & r.Parameters.IndexOf(p).ToString)
For Each s As String In p.Segments
Console.WriteLine(" Segment " & p.Segments.IndexOf(s).ToString & " is " & s)
Next
Next
Main()
End Sub
Public Class Request
Public Name As String
Public Parameters As New List(Of Parameter)
Public Shared Function Parse(line As String)
Dim r As New Request
r.Name = line.Split(" ")(0)
Dim u As String = line.Substring(line.IndexOf(" "), line.Length - line.IndexOf(" "))
Dim p As String() = u.Split(":")
For Each n As String In p
Dim b As String() = n.Split("&")
Dim e As New List(Of String)
For Each m As String In b
Dim i As Integer = 0
Do Until i > m.Length - 1
If m(i) = ControlChars.Quote Then
Dim s As String = ""
i += 1
Do Until i > m.Length - 1 Or m(i) = ControlChars.Quote
s &= m(i)
i += 1
Loop
e.Add(s)
End If
i += 1
Loop
Next
r.Parameters.Add(New Parameter(e.ToArray))
Next
Return r
End Function
End Class
Public Class Parameter
Public Segments As New List(Of String)
Public Sub New(ParamArray s As String())
Segments = s.ToList
End Sub
End Class
End Module
I am working in Access 2013 and try to get GetRawInputDeviceList, GetRawInputDeviceInfo, RegisterRawInputDevices and GetRawInputData equivalents for VBA with no success. I have also searched in vain for a procedure, function or module to get a list of connected HID devices to a computer to pick out a barcode scanner. This is the beginning of the third week so I am on my knees begging for assistance. Do any of you all have a module you're willing to share, a link to a website where this is dealt with? Any help is greatly appreciated.
Using the GetRawInputDeviceList API from VBA would be pretty tricky because of the pRawInputDeviceList parameter. Unless you're willing to jump through a ton of hoops to manage your own memory and manually handle the resulting array of RAWINPUTDEVICELIST in raw memory, you'll be better off coming at this from another direction.
Most barcode scanners I've dealt with present themselves to Windows as a keyboard. One possible solution would be to use a WMI query to enumerate attached Win32_Keyboard devices:
Private Sub ShowKeyboardInfo()
Dim WmiServer As Object
Dim ResultSet As Object
Dim Keyboard As Object
Dim Query As String
Query = "SELECT * From Win32_Keyboard"
Set WmiServer = GetObject("winmgmts:root/CIMV2")
Set ResultSet = WmiServer.ExecQuery(Query)
For Each Keyboard In ResultSet
Debug.Print Keyboard.Name & vbTab & _
Keyboard.Description & vbTab & _
Keyboard.DeviceID & vbTab & _
Keyboard.Status
Next Keyboard
End Sub
Note: If it doesn't turn up there, you can enumerate all of the USB devices by querying CIM_USBDevice: Query = "SELECT * From Win32_Keyboard"
EDIT: Per the comments, the above code won't return the handle needed to register to receive raw input events. This should get you started though - the RegisterRawInputDevices and GetRawInputData aspects are beyond the scope of what will easily go in an answer. Take a hack at it, and if you run into any problems post your code in another question.
Declarations:
Private Type RawInputDeviceList
hDevice As Long
dwType As Long
End Type
Private Type RidKeyboardInfo
cbSize As Long
dwType As Long
dwKeyboardMode As Long
dwNumberOfFunctionKeys As Long
dwNumberOfIndicators As Long
dwNumberOfKeysTotal As Long
End Type
Private Enum DeviceType
TypeMouse = 0
TypeKeyboard = 1
TypeHID = 2
End Enum
Private Enum DeviceCommand
DeviceName = &H20000007
DeviceInfo = &H2000000B
PreParseData = &H20000005
End Enum
Private Declare Function GetRawInputDeviceList Lib "user32" ( _
ByVal pRawInputDeviceList As Long, _
ByRef puiNumDevices As Long, _
ByVal cbSize As Long) As Long
Private Declare Function GetRawInputDeviceInfo Lib "user32" Alias "GetRawInputDeviceInfoW" ( _
ByVal hDevice As Long, _
ByVal uiCommand As Long, _
ByVal pData As Long, _
ByRef pcbSize As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Sample of retrieving device names with GetRawInputDeviceInfo:
Private Sub SampleCode()
Dim devices() As RawInputDeviceList
devices = GetRawInputDevices
Dim i As Long
For i = 0 To UBound(devices)
'Inspect the type - only looking for a keyboard.
If devices(i).dwType = TypeKeyboard Then
Dim buffer As String
Dim size As Long
'First call with a null pointer returns the string length in size.
If GetRawInputDeviceInfo(devices(i).hDevice, DeviceName, 0&, size) = -1 Then
Debug.Print "GetRawInputDeviceInfo error " & GetLastError()
Else
'Size the string buffer.
buffer = String(size, Chr$(0))
'The second call copies the name into the passed buffer.
If GetRawInputDeviceInfo(devices(i).hDevice, DeviceName, StrPtr(buffer), size) = -1 Then
Debug.Print "GetRawInputDeviceInfo error " & GetLastError()
Else
Debug.Print buffer
End If
End If
End If
Next i
End Sub
Private Function GetRawInputDevices() As RawInputDeviceList()
Dim devs As Long
Dim output() As RawInputDeviceList
'First call with a null pointer returns the number of devices in devs
If GetRawInputDeviceList(0&, devs, LenB(output(0))) = -1 Then
Debug.Print "GetRawInputDeviceList error " & GetLastError()
Else
'Size the output array.
ReDim output(devs - 1)
'Second call actually fills the array.
If GetRawInputDeviceList(VarPtr(output(0)), devs, LenB(output(0))) = -1 Then
Debug.Print "GetRawInputDeviceList error " & GetLastError()
Else
GetRawInputDevices = output
End If
End If
End Function
Sorry about the side scrolling.
How can my VB6 form POST 2 vars, pull the results from a URL and then assign a VB6 var to the results?
I need someone to show me VERY basic VB6 sample code or point me in the right direction. This is the simplest form - in the final product, the PHP vars will write to MySQL, but that's not what i need help with.
I have a simple PHP page that accepts 2 parameters:
test.php?var1=secret&var2=pass
Here's my really simple PHP code
<?php
$var1 = $_GET['var1'];
$var2 = $_GET['var2'];
$varAcc = "ACCEPTED";
$varDen = "DENIED";
if ($var1 === "secret" && $var2 === "pass")
{
echo $varAcc;
}
else
{
echo $varDen;
}
?>
The logic behind this is gonna be VB6 login with "userName", "passWord" and "hardWareID", and send a hash. The hash will be checked against MySQL to see whether it exists, and returns YES or NO for access, how many days left on their account, and some other details, like FULL NAME, ACCOUNT INFO, etc.
( NO.. I do not want to use XML, just thought i would put that out there.. Just POST & Receive to vars)
Thank You...
VB forms don't have any built-in mechanism for sending HTTP requests. Some may suggest you use the Internet Transfer Control. However, the VB UserControl has a mechanism for HTTP that you can use without the need for third party controls, assuming you use the GET method, and use the query string to pass your parameters. If you have to use POST, you must use the Internet Transfer Control.
Create a VB project with a reference to "Microsoft Scripting Runtime" (see the menu Project=>References). Add a UserControl. Call it "HttpService". Set InvisibleAtRuntime=True. Add the following code to the UserControl:
Option Explicit
Private Const m_ksProperty_Default As String = ""
Private m_sHost As String
Private m_nPort As Long
Private m_sPath As String
Private m_dctQueryStringParameters As Scripting.Dictionary
Private m_sOutput As String
' Ensure that all parts of the query string are deleted.
Public Sub ClearQueryString()
Set m_dctQueryStringParameters = New Scripting.Dictionary
End Sub
' Executes "GET" method for URL.
Public Function Get_() As String
' Read in data from URL. UserControl_AsyncReadComplete will fire when finished.
UserControl.AsyncRead "http://" & m_sHost & ":" & CStr(m_nPort) & "" & m_sPath & "?" & GetQueryString(), vbAsyncTypeByteArray, m_ksProperty_Default, vbAsyncReadSynchronousDownload
' Return the contents of the buffer.
Get_ = m_sOutput
' Clear down state.
m_sOutput = vbNullString
End Function
' Returns query string based on dictionary.
Private Function GetQueryString() As String
Dim vName As Variant
Dim sQueryString As String
For Each vName In m_dctQueryStringParameters
sQueryString = sQueryString & CStr(vName) & "=" & m_dctQueryStringParameters.Item(vName) & "&"
Next vName
GetQueryString = Left$(sQueryString, Len(sQueryString) - 1)
End Function
' Sets the remote host.
Public Property Let Host(ByVal the_sValue As String)
m_sHost = the_sValue
End Property
' Sets the directory and filename part of the URL.
Public Property Let Path(ByVal the_sValue As String)
m_sPath = the_sValue
End Property
' Sets the port number for this request.
Public Property Let Port(ByVal the_nValue As Long)
m_nPort = the_nValue
End Property
' Sets a name/value pair in the query string. Supports duplicate names.
Public Property Let QueryStringParameter(ByVal the_sName As String, ByVal the_sValue As String)
m_dctQueryStringParameters.Item(the_sName) = the_sValue
End Property
' Fired when the download is complete.
Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)
' Gets the data from the internet transfer.
m_sOutput = StrConv(AsyncProp.Value, vbUnicode)
End Sub
Private Sub UserControl_Initialize()
' Initialises the scripting dictionary.
Set m_dctQueryStringParameters = New Scripting.Dictionary
End Sub
To use this UserControl, add it to your form. Call it "HttpService". Add a TextBox called "txtOutput" to test the following code on the form:
HttpService.Host = "localhost"
HttpService.Port = 80
HttpService.Path = "/test.php"
HttpService.QueryStringParameter("var1") = "secret"
HttpService.QueryStringParameter("var2") = "pass"
txtOutput.Text = HttpService.Get_
If you must use POST, then you will have to use the Internet Transfer Control. In the VB6 IDE, press CTL-T, and select "Microsoft Internet Transfer Control 6.0". Press Ok.
Add an instance of the control to the form. Call it "Inet". Add a CommandButton called "cmdPost" to the form. Add a reference to "Microsoft Scripting Runtime" (see the menu Project=>References).
Add the following code to your form:
Option Explicit
Private Declare Function InternetCanonicalizeUrl Lib "Wininet.dll" Alias "InternetCanonicalizeUrlW" ( _
ByVal lpszUrl As Long, _
ByVal lpszBuffer As Long, _
ByRef lpdwBufferLength As Long, _
ByVal dwFlags As Long _
) As Long
Private m_sData As String
Private m_nDataReceived As Long
Private m_bPostActive As Boolean
Private m_bDataReceived As Boolean
Private m_bError As Boolean ' For error handling.
Private m_bDisconnected As Boolean
Private Sub cmdPost_Click()
Dim dctParameters As Scripting.Dictionary
txtOutput.Text = vbNullString
m_sData = vbNullString
Set dctParameters = New Scripting.Dictionary
dctParameters.Add "var1", "secret"
dctParameters.Add "var2", "pass"
txtOutput.Text = Post("http://localhost:80/test.php", dctParameters)
End Sub
' Returns post data string based on dictionary.
Private Function GetPostDataString(ByRef the_dctParameters As Scripting.Dictionary) As String
Dim vName As Variant
Dim sPostDataString As String
For Each vName In the_dctParameters
sPostDataString = sPostDataString & UrlEncode(CStr(vName)) & "=" & UrlEncode(CStr(the_dctParameters.Item(vName))) & "&"
Next vName
GetPostDataString = Left$(sPostDataString, Len(sPostDataString) - 1)
End Function
Private Sub Inet_StateChanged(ByVal State As Integer)
' Ignore state change if we are outside the Post function.
If m_bPostActive Then
Select Case State
Case StateConstants.icResponseReceived
ReceiveData False
Case StateConstants.icResponseCompleted
ReceiveData True
Case StateConstants.icDisconnected
m_bDisconnected = True
Case StateConstants.icError
m_bError = True
End Select
End If
End Sub
' Synchronous Post function.
Private Function Post(ByRef the_sURL As String, ByRef the_dctParameters As Scripting.Dictionary)
Dim sPostData As String
Dim sHeaders As String
' Flag that we are in the middle of this function.
m_bPostActive = True
' Create a string containing the POST parameters.
sPostData = GetPostDataString(the_dctParameters)
' Create a headers string to allow POST.
sHeaders = _
"Content-Type: application/x-www-form-urlencoded" & vbNewLine & _
"Content-Length: " & CStr(Len(sPostData)) & vbNewLine & _
"Connection: Keep-Alive" & vbNewLine & _
"Cache-Control: no-cache" & vbNewLine
Inet.Execute the_sURL, "POST", GetPostDataString(the_dctParameters), sHeaders
' Allow Inet events to fire.
Do
DoEvents
Loop Until m_bDataReceived Or m_bDisconnected
If m_bDataReceived Then
Post = m_sData
End If
' Clear all state flags to defaults.
m_bDataReceived = False
m_bDisconnected = False
m_bError = False
m_sData = vbNullString
m_nDataReceived = 0
' Flag that we have exited this function.
m_bPostActive = False
End Function
' Receive as much data as we can.
' <the_bCompleted> should be True if the response is completed i.e. all data is available.
Private Sub ReceiveData(ByVal the_bCompleted As Boolean)
Const knBufferSize As Long = 1024
Dim nContentLength As Long
Dim sContentType As String
Dim sChunk As String
Dim nChunkSize As Long
' If we haven't yet created our buffer, do so now, based on the size of the incoming data.
If m_nDataReceived = 0 Then
nContentLength = CLng(Inet.GetHeader("Content-length"))
m_sData = Space$(nContentLength)
' You might want to do a check on the content type here, and if it is wrong, cancel the request with Inet.Cancel .
sContentType = Inet.GetHeader("Content-type")
End If
' Retrieve data until we have all the data.
Do Until m_nDataReceived = Len(m_sData)
' If called when not all data has been received, then exit function if it is currently executing.
If Not the_bCompleted Then
If Inet.StillExecuting Then
Debug.Print "Exiting"
Exit Sub
End If
End If
' Get a chunk, copy it into the output buffer, and increment the amount of data received.
sChunk = Inet.GetChunk(knBufferSize, DataTypeConstants.icString)
nChunkSize = Len(sChunk)
Mid$(m_sData, m_nDataReceived + 1, nChunkSize) = sChunk
m_nDataReceived = m_nDataReceived + nChunkSize
Loop
' Flag that all data has been retrieved.
m_bDataReceived = True
End Sub
' Encode the URL data.
Private Function UrlEncode(ByVal the_sURLData As String) As String
Dim nBufferLen As Long
Dim sBuffer As String
' Only exception - encode spaces as "+".
the_sURLData = Replace$(the_sURLData, " ", "+")
' Try to #-encode the string.
' Reserve a buffer. Maximum size is 3 chars for every 1 char in the input string.
nBufferLen = Len(the_sURLData) * 3
sBuffer = Space$(nBufferLen)
If InternetCanonicalizeUrl(StrPtr(the_sURLData), StrPtr(sBuffer), nBufferLen, 0&) Then
UrlEncode = Left$(sBuffer, nBufferLen)
Else
UrlEncode = the_sURLData
End If
End Function
I am trying to register a type library programatically from VBA code, using two variants of a technique found using Google (Subs RegisterTypeLibrary and RegisterTypeLibrary2 below).
The code below crashes with an access violation on the call to LoadTypeLib / LoadTypeLibEx. What am I doing wrong? In case it's relevant, the type library is a TLB file generated from a .NET assembly using tlbexp.
Private Enum RegKind
RegKind_Default = 0
RegKind_Register = 1
RegKind_None = 2
End Enum
Private Declare Function LoadTypeLibEx Lib "oleaut32.dll" ( _
pFileName As Byte, ByVal RegKind As RegKind, pptlib As Object) As Long
Private Declare Function LoadTypeLib Lib "oleaut32.dll" ( _
pFileName As Byte, pptlib As Object) As Long
Private Declare Function RegisterTypeLib Lib "oleaut32.dll" ( _
ByVal ptlib As Object, szFullPath As Byte, _
szHelpFile As Byte) As Long
Private Sub RegisterTypeLibrary(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As Object
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLib(abNullTerminatedFileName(0), objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLib", "Error registering type library " & FileName
End If
lHResult = RegisterTypeLib(objTypeLib, abNullTerminatedFileName(0), 0)
If lHResult <> 0 Then
Err.Raise lHResult, "RegisterTypeLib", "Error registering type library " & FileName
End If
Exit Sub
End Sub
Private Sub RegisterTypeLibrary2(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As Object
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLibEx(abNullTerminatedFileName(0), ByVal RegKind_Register, objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLibEx", "Error registering type library " & FileName
End If
End Sub
EDIT
I suspect it is something specific about my type library. I've found a solution which I've posted as an answer below.
I've found a solution, using the code below. Basically, the third parameter to LoadTypeLibEx (ITypeLib** in C/C++) is declared as stdole.IUnknown instead of as Object.
To do so, I needed to add a reference to stdole32.tlb to the VBA project.
I suspect there is something about my type library that means it can't be declared as a VB (late-bound) Object.
I could also have declared the third parameter as Long, but I'm not sure that wouldn't lead to problems with reference counting.
Private Enum RegKind
RegKind_Default = 0
RegKind_Register = 1
RegKind_None = 2
End Enum
Private Declare Function LoadTypeLibEx Lib "oleaut32.dll" ( _
pFileName As Byte, ByVal RegKind As RegKind, pptlib As stdole.IUnknown) As Long
Public Sub RegisterTypeLibrary(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As stdole.IUnknown
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLibEx(abNullTerminatedFileName(0), ByVal RegKind_Register, objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLibEx", "Error registering type library " & FileName
End If
End Sub
I suspect your type library (TLB) has errors because the code you provided works when I tested against a third-party TLB.
I am assuming you are going to use your .NET Assembly from VBA. Therefore, I suggest you make sure you can reference your TLB from VBA without errors.
Note, that all objects exposed by your .NET library must have public constructors that accept no arguments. This may be causing the problem.