How can make a FreeBASIC DLL find its own filename and path?
I've tried this so far: (ran it with rundll32 filename,DllMain)
Code:
#include "windows.bi"
Extern "Windows-MS"
Sub DllMain() Export
dim This as String
This = dir(command$(0))
MessageBox( null, "Hello World", This, MB_OK )
End Sub
End Extern
. . . but it doesn't work.
When I compile it as an EXE though, it works fine.
Any suggestions? Thanks!
I tried to adapt the approach of this C++ snippet to FreeBASIC. At first glance, it seems to work. But: Snippet provided "as is", without warranty of any kind. Use at your own risk.
#include "windows.bi"
Const GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT = &H2
Const GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS = &H4
Extern "Windows-MS"
Function getMyPath() As String
' See https://stackoverflow.com/a/6924332/
Dim path As ZString * 255
Dim hm As HMODULE = NULL
If GetModuleHandleEx( _
GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS Or _
GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT, _
Cast(LPCSTR, #getMyPath), _
#hm _
) Then
GetModuleFileName( hm, path, SizeOf( path ) )
End If
Return path
End Function
Sub DllMain() Export
dim dllPath as String
dllPath = getMyPath()
MessageBox( null, dllPath, "Hello World", MB_OK )
End Sub
End Extern
Related
I have been keep getting error for "type mismatch" between VBA <-> DLL
the DLL code was coded with VS C++
#include "pch.h"
#include <Windows.h>
#include <iostream>
_declspec(dllexport) double _stdcall ArraySum(double *arr) {
std::cout << " Called me" << arr[0] << std::endl;
return 1.1;}
and VBA code to call
Private Declare Function testDLL _
Lib "...\Release\VBATest.dll" Alias "ArraySum"(ByRef Arr As Double) As Double
Sub Main
MyTest
End Sub
Sub MyTest
Dim MyX() As Double
Dim mySize As Integer
mySize = 10
ReDim MyX(mySize)
For i = 0 To mySize
MyX(i) =(i+1)
Debug.Print "Index = " & i & " arr = " & MyX(i)
Next
Dim MyResult As Double
MyResult = testDLL(MyX(0))
End Sub
the dll can be found, used kernel32 tested it
The debug for this process is hard because the VBA is provided by third-party, not Excel
can anyone take a look to see if I am making any stupid mistake?
BR
I'm using VBA in MS Access, and one of the subs takes a file path in a network, checks if the file exists or not, and write the result of a query on it.
The problem is that when I try to run the code, it gives me error 52 (Bad file name or number). But if I open the network path in windows explorer first, for example, after that the error doesn't happen anymore. Any ideas on what the problem might be?
Here is some of the code I'm running:
fpath = "\\networkpath\file.txt"
DeleteFile fpath
Sub DeleteFile(ByVal FileToDelete As String)
FileExists(FileToDelete) Then
SetAttr FileToDelete, vbNormal
FileToDelete
End If
End Sub
Function FileExists(ByVal FileToTest As String) As Boolean
FileExists = (Dir(FileToTest) <> "") 'this is where the error happens
End Function
Does the UNC path you use contain any non-Ascii characters, like accents? What is the exact path?
None of the file functions in VBA work well with Unicode anyway.
You could try to use the FileSystemObject to achieve the same a bit more reliably than the build-in VBA functions:
Public Function FileExists(filePath as string) as Boolean
Dim o As Object
Set o = CreateObject("Scripting.FileSystemObject")
FileExists = o.FileExists(filePath)
End Function
An alternative using the Win32 API tha works in 32 and 64 bit environments:
Private Const INVALID_FILE_ATTRIBUTES As Long = -1
#If VBA7 Then ' Win API Declarations for 32 and 64 bit versions of Office 2010 and later
Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesW" (ByVal lpFileName As LongPtr) As Long
#Else ' WIN API Declarations for Office 2007
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long
#End If
Public Function FileExists(fname As Variant) As Boolean
If IsNull(fname) Or IsEmpty(fname) Then Exit Function
' Make sure that we can take care of paths longer than 260 characters
If Left$(fname, 2) = "\\" Then
FileExists = GetFileAttributes(StrPtr("\\?\UNC" & Mid$(fname, 2))) <> INVALID_FILE_ATTRIBUTES
Else
FileExists = GetFileAttributes(StrPtr("\\?\" & fname)) <> INVALID_FILE_ATTRIBUTES
End If
End Function
I am unable to create a minimal working example of a native dll in combination with VBA
There are three Problems:
I can not resolve error 453 (can't find dll entry point)
I do not know how to marshall variac
VBA (ExCel)
Option Explicit
Public Declare Sub KERNEL32_SLEEP _
Lib "kernel32" _
Alias "Sleep" (ByVal dwMilliseconds As Long)
Public Declare Sub CALLADAPTER_SIMPLE _
Lib "D:\Stackoverflow\Release\CallAdapter.dll" _
Alias "simple" ()
Public Declare Function CALLADAPTER_ADD _
Lib "D:\Stackoverflow\Release\CallAdapter.dll" _
Alias "add" (ByVal A As Integer, ByVal B As Integer) As Integer
Public Declare Sub CALLADAPTER_PRINT _
Lib "D:\Stackoverflow\Release\CallAdapter.dll" _
Alias "print" (ByVal FormatSpecifier As String)
Sub TEST_KERNEL32_SLEEP()
Call KERNEL32_SLEEP(2000) 'works
End Sub
Sub TEST_CALLADAPTER_SIMPLE()
Call CALLADAPTER_SIMPLE 'error 453 can't find dll entry point
End Sub
Sub TEST_CALLADAPTER_ADD()
Dim A, B, C As Integer
A = 30
B = 12
C = CALLADAPTER_ADD(A, B) 'error 453 can't find dll entry point
MsgBox "A + B = " & C
End Sub
Sub TEST_CALLADAPTER_PRINT()
Call CALLADAPTER_PRINT("Hello World") 'error 453 can't find dll entry point
End Sub
Sub TEST_CALLADAPTER_PRINTF()
'I do not know how to marshall variadic
End Sub
Ansi C ( Visual Studio 2010 )
// Header
#ifdef CALLADAPTER_EXPORTS
#define CALLADAPTER_API __declspec(dllexport)
#else
#define CALLADAPTER_API __declspec(dllimport)
#endif
CALLADAPTER_API void _stdcall simple( void );
CALLADAPTER_API int _stdcall add( int a, int b );
CALLADAPTER_API void _stdcall print( const char * msg );
CALLADAPTER_API int _stdcall printf( const char * format, ... );
// code
#include "CallAdapter.h"
#include <stdio.h>
#include <stdarg.h>
CALLADAPTER_API void _stdcall simple( void )
{
printf("simple was called\n");
}
CALLADAPTER_API int _stdcall add( int a, int b )
{
return a + b;
}
CALLADAPTER_API void _stdcall print( const char * msg )
{
printf( "%s", msg );
}
CALLADAPTER_API int _stdcall printf( const char * format, ... )
{
int ret;
va_list args;
va_start( args, format );
ret = vprintf( format, args );
va_end( args );
return ret;
}
Edit #1: I completely reworked the examples to better illustrate my problems.
Edit #2: Progress with variadic.
There is a very useful site on the web.
I made some progress but i stll can not compule the call...
VBA
Option Explicit
Public Declare Function CallAdapter_sprintf _
Lib "D:\Stackoverflow\Release\CallAdapter.dll" _
Alias "sprintf" (ByRef DST As String, ByRef FORMAT As String, ParamArray args()) As Integer
Sub TEST_CALLADAPTER_sprintf()
Dim DESTINATION, FORMAT As String
Dim OTHER() As Variant
Dim C As Integer
FORMAT = "%s"
OTHER = Array("Hello World")
DESTINATION = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
C = CallAdapter_sprintf(DESTINATION, FORMAT, OTHER)
MsgBox "RET " & C & " -> " & DESTINATION
End Sub
Ansi C
CALLADAPTER_API int _stdcall sprintf( char * dest, const char * format, ... )
{
int ret;
va_list args;
va_start( args, format );
ret = vsprintf( dest, format, args );
va_end( args );
return ret;
}
varocarbas gave a good hint.
I used Dependency Walker to get the correct names.
This solves half of my problem, i still dont know how to marshall variadic
Public Declare Sub CALLADAPTER_SIMPLE _
Lib "D:\Stackoverflow\Release\CallAdapter.dll" _
Alias "_simple#0" ()
Public Declare Function CALLADAPTER_ADD _
Lib "D:\Stackoverflow\Release\CallAdapter.dll" _
Alias "_add#8" (ByVal A As Integer, ByVal B As Integer) As Integer
Public Declare Sub CALLADAPTER_PRINT _
Lib "D:\Stackoverflow\Release\CallAdapter.dll" _
Alias "_print#4" (ByVal FormatSpecifier As String)
Only the ADD example is a good example since stdout does not seem to exist.
I have a text file on my website that contains only the string "1.15" (for the version of the application I am writing). Upon initialization of the user form, I would like to read that file from its URL and have the string "1.15" returned so that I can check it against the application's version (stored as a const string).
Here is the format I'd like to have...
Const version As String = "1.14"
Const currentVersionURL As String = "http://mywebsite.com/currentversion.txt"
Sub UserForm_Initialize()
If version <> GetCurrentVersionNumber() Then
MsgBox "Please update the application."
End If
End Sub
Function GetCurrentVersionNumber() As String
' What do I put here? :(
End Function
I am aware of the Workbooks.OpenText method, but I don't want to write the string into a workbook. I have tried using the ADODB.LoadFromFile and WinHttp.WinHttpRequest.Open methods, but both are unable to read the file.
Any suggestions for what to fill GetCurrentVersionNumber() with would be greatly appreciated. :)
While it doesn't directly answer your question, a simpler approach would be to make it an XML file instead of a text file. There are more built-in tools to easily open an XML file from a URL. The secondary advantage is that it also makes it more flexible, so you can more easily add new data elements to the XML file later on.
For instance, if you made a http://mywebsite.com/currentversion.xml file that looked like this:
<?xml version="1.0" encoding="utf-8" ?>
<AppData>
<Version>1.14</Version>
</AppData>
Then, in VB.NET you could easily read it like this:
Function GetCurrentVersionNumber() As String
Dim doc As New XmlDocument()
doc.Load("http://mywebsite.com/currentversion.xml")
Return doc.SelectSingleNode("/AppData/Version").InnerText
End Function
Or, in VBA, you could read it like this:
Function GetCurrentVersionNumber() As String
Dim doc As MSXML2.DOMDocument?? ' Where ?? is the version number, such as 30 or 60
Set doc = New MSXML2.DOMDocument??
doc.async = False
doc.Load("http://mywebsite.com/currentversion.xml")
GetCurrentVersionNumber = doc.SelectSingleNode("/AppData/Version").Text
End Function
You will need to add a reference to the Microsoft XML, v?.? library, though.
Try this (UNTESTED)
Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
Const currentVersionURL As String = "http://mywebsite.com/currentversion.txt"
Const version As String = "1.14"
Dim Ret As Long
Sub UserForm_Initialize()
If version <> GetCurrentVersionNumber() Then
MsgBox "Please update the application."
End If
End Sub
Function GetCurrentVersionNumber() As String
Dim strPath As String
'~~> Destination for the file
strPath = TempPath & "currentversion.txt"
'~~> Download the file
Ret = URLDownloadToFile(0, currentVersionURL, strPath, 0, 0)
'~~> If downloaded
If Ret = 0 Then
Dim MyData As String, strData() As String
Open "C:\MyFile.Txt" For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
GetCurrentVersionNumber = MyData
Else
MsgBox "Unable to download the file"
GetCurrentVersionNumber = ""
End If
End Function
'~~> Get Users Temp Path
Function TempPath() As String
TempPath = String$(MAX_PATH, Chr$(0))
GetTempPath MAX_PATH, TempPath
TempPath = Replace(TempPath, Chr$(0), "")
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.