I created an application in Access 2016 32 Bit, which in several update queries, log the user, by capturing it from Windows. We are now migrating to Windows 10 64 bit, and the code is not compatible. This is the code I have:
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal IpBuffer As
String, nSize As Long) As Long
Function fOSUserName() As String
'Returns the network login name'
Dim IngLen As Long, IngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
IngLen = 255
IngX = apiGetUserName(strUserName, IngLen)
If (IngX > 0) Then
fOSUserName = Left$(strUserName, IngLen - 1)
Else
fOSUserName = vbNullString
End If
End Function
Can someone give me a hand for a similar solution that works in 64 bit?
Thank you.
You need to migrate the API calls to make it compatible to 64-bit. Read Migrate Windows API-Calls in VBA to 64-bit
The correct syntax is:
Declare PtrSafe Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Also see Convert Windows API call to 64-bit in Excel VBA.
Related
I need to build a tool that can Encrypt databases on server.
So far I have found this info (but that's not enough).
It's possible to check if database encrypted (works only locally) using NSFDbIsLocallyEncrypted.
Make a replica W32_NSFDbCreateAndCopy and set Encryption while creating replica (that will be applied on replica).
There is an undocumented Notes C API call that sets encryption flag for compact, but I could not make that work.
STATUS far PASCAL NSFDbLocalSecInfoSet(DBHANDLE hDB, WORD Option, BYTE EncryptStrength, char far *Username);
I have also read it is possible (for older ODS version) to change 'icon note' or to use DBINFO3 for newer ODS version (I could not make it work as well)
Does anybody know how to solve this task?
p.s. I have been told that HCL will come with proper solution in future (but not sure when).
Here is working code. I could not figure out, what to set as EncrytionStrength to remove local encryption using this code.
%REM
Agent encrypt
Created Dec 22, 2019 by Ulrich Krause/singultus
Description: Comments for Agent
%END REM
Option Public
Option Declare
Public Const W32_LIB = {nnotes.dll}
Declare Function W32_NSFDbCompactExtended Lib W32_LIB Alias {NSFDbCompactExtended} (ByVal Pathname As String, Options As Long, retStats As Long) As Integer
Declare Function W32_NSFDbLocalSecInfoSet Lib W32_LIB Alias {NSFDbLocalSecInfoSet} (ByVal hDb As Long, ByVal wOptions As Integer, ByVal EncryptStrength As Integer, ByVal Username As String) As Integer
Declare Function W32_NSFDbIsLocallyEncrypted Lib W32_LIB Alias {NSFDbIsLocallyEncrypted} ( ByVal hDB As Long, V As Integer) As Integer
Declare Sub W32_OSLoadString Lib W32_LIB Alias {OSLoadString} (ByVal null1 As Long, ByVal sError As Integer, ByVal errstr As String, ByVal lenstr As Integer)
Declare Function W32_NSFDbOpen Lib W32_LIB Alias {NSFDbOpen}(ByVal dbName As String, hDb As Long) As Integer
Declare Function W32_NSFDbClose Lib W32_LIB Alias {NSFDbClose} (ByVal hDb As Long) As Integer
Sub Initialize
Dim hDb As Long
Dim rc As Integer
Dim sDb As String
Dim retStats As Long
sDb = "serv01/singultus!!crash.nsf"
rc = W32_NSFDbOpen(sDb, hDb)
If rc = 0 Then
rc = W32_NSFDbLocalSecInfoSet(hDb, 0,1, "")
msgbox GetError(rc)
If rc = 0 Then
rc = W32_NSFDbCompactExtended (sDb, 0, retStats)
End if
rc = W32_NSFDbClose(hDb)
End If
End Sub
Function GetError (errnum As Integer) As String
Dim s As String*256
If IsDefined("WINDOWS") Then
W32_OSLoadString 0, errnum And &h03FFFFFFF, s, 256
Else
'TUX_OSLoadString 0, errnum And &h03FFFFFFF, s, 256
End If
getError = StrLeft(s, Chr(0))
End Function
You should look into the BCC solution DominoProtect or Ulrich Krause had other solution, Having database encryption on the server is a requirement for many compliance situations.
I have 64 bit windows 10 with MS Office 64 bit.
I am trying to get the VBA for Powerpoint to load and execute a function in a self-written 64 bit windows DLL.
To prevent export name mangling I have used extern C:
extern "C" {
__declspec(dllexport) long jaadd(long a, long b)
{
return a + b;
}
}
This simple function can be called by a C++ module with no problems:
hinstDLL = LoadLibrary(L"D:\\Visual Studio 2017\\Projects\\PopUpDLL\\x64\\Debug\\PopUpDLL.dll");
if (hinstDLL != NULL)
{
jaadd = (AddFunc)GetProcAddress(hinstDLL, "jaadd");
if (jaadd != NULL) {
result = jaadd(13, 40);
}
fFreeDLL = FreeLibrary(hinstDLL);
}
The problem arises when trying to call the DLL from VBA in Powerpoint. GetProcAddress always returns zero and so does FreeLibrary
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As LongLong
Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private hLib As Long
Sub LLib()
hLib = LoadLibrary("D:\\Visual Studio 2017\\Projects\\PopUpDLL\\x64\\Debug\\PopUpDLL.dll")
MsgBox hLib
Dim pprocaddress As Long
pprocaddress = GetProcAddress(hLib, "jaadd") ***** always returns 0
MsgBox pprocaddress
xx = FreeLibrary(hLib) ***** always returns 0
MsgBox xx
End Sub
Any help gratefully received.
Did you every try
Private Declare PtrSafe Function jaadd Lib "......\x64\Debug\PopUpDLL.dll"
Alias "_jaadd#8" (ByVal arg1 As Long, ByVal arg2 as Long) As Long
Note the Alias mangling "algorithm": _ + your original name + # + sum of argument bytes.
You have two VBA Longs, or two C# ints, 4 + 4 = 8.
You can also dispense with the twin \ thing here in VBA-land.
See also https://learn.microsoft.com/en-us/office/client-developer/excel/how-to-access-dlls-in-excel
Lastly, make sure you use a 32-bit DLL for 32-bit VBA, and a 64-bit DLL for 64-bit VBA.
So many websites in their DECLARE statements have the handle for LoadLibrary and return of GetProcAddress as Long instead of LongPtr.
Problem is that the information is stale - the code was never updated to reflect the post-Excel 2009 state of VBA.
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 working on a program in Visual Basic 2008, I am required to have different types of sounds with varying volumes. Hence My.Computer.Audio.Play is not a valid option.
I decided to use mciSendString instead and found the following code
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
ByVal uReturnLength As Integer, ByVal hwndCallback As Integer) As Integer
mciSendString("close myWAV", Nothing, 0, 0)
Dim fileName1 As String =
mciSendString("open " & fileName1 & " type mpegvideo alias myWAV", Nothing, 0, 0)
mciSendString("play myWAV", Nothing, 0, 0)
'min Volume is 1, max Volume is 1000
Dim Volume As Integer = (SFXVolume * 100)
mciSendString("setaudio myWAV volume to " & Volume, Nothing, 0, 0)
Now this code I have tested and is working perfectly when filename1 = "C://Correct.wav"
However when I use
filename1 = My.Application.Info.DirectoryPath & "\Correct.wav"
I get no sound play whatsoever.
Could anyone please help me correct my code so that this works.
Thank you in advance.
If your DirectoryPath has spaces then mciSendString won't be able to recognize the command accurately, you need to surround the path with quotes:
mciSendString(
String.Format("open ""{0}"" type mpegvideo alias myWAV", fileName1), Nothing, 0, 0)
Be sure to check returned status as well, as Hans suggests.
Also, since you don't know whether DirectoryPath has a trailing backslash or not, the accurate way to produce full path from directory and name is:
fileName1 = System.IO.Path.Combine(My.Application.Info.DirectoryPath, "Correct.wav")
Use Private Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal lpPathName As String) As Long then SetCurrentDirectory filepath before opening file for play. That is working for me.
You need to use the DLL Call GetShortPathName in order to pass file paths to WINMM.DLL.
lpszLongPath is your full path string, and the short pathname will be passed to lpszShortPath.
cchbuffer should really be set to 200 or so, though in most cases, the returned string will be much shorter. You should use a VB padded string.
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
I have just used the mciSendString calls in a batch midi-file reading programme, opening 3642 midi files and returning copyright, title and play duration strings actually quite quickly!
Best Regards
David R Leach
) I am trying to send a short text from a VB app to Delphi app.. here is the
VB Code: Sender Program "Sender"
Public Class SendData
Const WM_COPYDATA = &H4A
Public Structure CopyDataStruct
Public dwData As Integer
Public cbData As Integer
Public lpData As String
End Structure
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As _
CopyDataStruct) As Long
Private Sub SendData(ByVal cds)
Dim iHwnd As Long
Dim SS As String = "Test String less than 30 Char"
Dim cds As CopyDataStruct
cds.dwData = 0
cds.cbData = Len(SS)
cds.lpData = SS
iHwnd = FindWindow(0&, "Receive")
SendMessage(iHwnd, &H4A, Me.Handle, cds)
End Sub
here is the Delphi Code: Receiver program "Receive"
procedure TForm1.HandleCopyDataString(copyDataStruct: PCopyDataStruct);
var
s : string;
begin
s := PChar(CopyDataStruct.lpData);
cdMemo.Lines.Add(Format('Received data "%s" at %s',[s, TimeToStr(Now)]));
end;
procedure TForm1.WMCopyData(var Msg: TWMCopyData) ;
var
s : string;
sText: array[0..255] of Char;
copyDataType : TCopyDataType;
begin
copyDataType := TCopyDataType(Msg.CopyDataStruct.dwData);
s := PChar(Msg.CopyDataStruct.dwData);
Form1.cdMemo.Lines.Add(Format('Data from: %d',[msg.From]));
HandleCopyDataString(Msg.CopyDataStruct);
case Msg.CopyDataStruct.dwData of 0: //we are being sent a string
begin
StrLCopy(sText, Msg.CopyDataStruct.lpData, Msg.CopyDataStruct.cbData);
Form1.Label1.Caption := sText;
end;
end;
end;
What am I doing wrong here? It is possible to send strings from VB to Delphi programs using WM_COPYDATA command, and SendMessage function?
please help me :-)
F
There are a few things wrong with your Delphi code.
The dwData field holds an integer, but you type-cast it to PChar, a pointer, and then assign it to your string. That's not the field where you stored your string data. That's lpData.
The string you pass is not null-terminated. The OS only promises to copy exactly as many bytes as you specify in the cbData field. That's not necessarily a problem, but you need to be aware of it when you read the string later. To assign s to hold the string copied from the other process, use SetString like this:
SetString(s, PAnsiChar(Msg.CopyDataStruct.lpData), Msg.CopyDataStruct.cbData);
You haven't shown what TCopyDataType is, but if it's anything other than an integer or integer-subrange type, you're using it wrong. The dwData field is already a DWord, so you can use it wherever a numeric value is expected.
You're calling StrLCopy wrong. The third parameter should be the size of the destination buffer, not the source. It's meant to prevent buffer overflows by not copying more characters than will fit in the destination. The function expects to be able to detect the size of the source buffer by finding the terminating null character (but we already established that that won't be available). You could fix it like this:
StrLCopy(sText, Msg.CopyDataStruct.lpData,
Min(Length(sText), Msg.CopyDataStruct.cbData));
(Min is in the Math unit.)