) 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.)
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.
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Integer, ByVal lpBaseAddress As Integer, ByRef lpBuffer As Integer, ByVal nSize As Integer, ByRef lpNumberOfBytesWritten As Integer) As Integer '--- Should anyone of these be single instead?
Dim p = Process.GetProcessesByName("insert random process name here")
If p.Count > 0 Then
Dim ReadBuffer As Integer = 0 '--- Should this one be single instead?
ReadProcessMemory(p(0).Handle, &H400000, ReadBuffer, 4, 0)
Dim Result As Single = ReadBuffer
Msgbox(Result.ToString)
End If
I could be using integer in the wrong places and should probably use single but when I do I still don't get the correct values. For example, I've changed the ReadBuffer data type to Single. The error could also lie here: Declare Function ReadProcessMemory on one or several of the Integer's.
This is an example value I expect to get: 16.6317005 and the value I do get instead is: -9,808334E+08, or 1,1471E-25 or something else, all depending on where I change the integer data type to single. I never get the correct value and I've tried all combinations.
Or is it perhaps just a conversion issue?
So I guess my main question is - What's wrong with my code? How do I properly read Floating Point values in VB.NET?
I tried to use a C DLL function in VBA but when it is called, Excel crashes. In VBA the function is declared like this:
Public Declare Function HR8_CONNECT Lib "D:xxxxx.dll" _
(ByVal PortCom As Byte, ByVal Mode As Byte, ByVal Config As Byte, ByVal Dbg As Byte, ByVal context As String) As Byte
I have a problem with context parameter I think which is a pointer to an unsigned char. See next the header of C function
extern "C" __declspec(dllimport) UCHAR HR8_CONNECT(UCHAR, UCHAR, UCHAR, UCHAR, UCHAR*);
I tried a lot of variants for passing the pointer like byval string, byref byte, etc ... but Excel is crashing every time.
Did you try to create a variable for every parameters and after call C function?
I experiment more or less similar issue and that came from a parameter send by pointer who was not directly declared.
Dim paramPortCom As Byte;
Dim paramMode As Byte;
Dim paramConfig As Byte;
Dim paramDbg As Byte;
Dim paramContext As String;
Dim resultFn As Byte;
' Set value into each variable
paramPortCom := 123;
...
' Call C function
resultFn := HR8_CONNECT(paramPortCom, ...);
Objective: Print from string or rich text box to any printer desired, using the Win API functions specified.
Problem: Calling StartDocPrinter in VBA Access always returns 0.
Info: The code below runs through, without breaking. OpenPrinter appears to get a good handle. When StartDocPrinter is called, it returns 0.
Using the following code I have tried,
Saving different info to dDocInfo and per #David_Heffernan recommendation, declared DOCINFO properties as Long and set values to 0.
When .pDatatype = vbNullstring, GetLastError returns,
Error 124 (invalid level) when StartDocPrinter parameter Level = 1
Error 6 (invalid handle) when StarDocPrinter parameter Level = ByVal 1, though an apparent valid handle shows in hPrinter
When .pDatatype = "RAW", GetLastError returns 0 regardless.
When .pDatatype = 'vbNullString and either DOCINFO property is set to a string, GetLastError returns 0 regardless.
Changing the parameters of the WinAPI functions (ByRef DOCINFO)
Checking into access privilege issues. It appears, from other's code, that setting the last OpenPrinter parameter to 0 should set the requested access to the printer to be PRINTER_ACCESS_USE. Is it possible GetLastError is not returning access denial errors?
Converting multiple references' code from C++ to VBA, but converting or not including pointers is confusing. Am I not converting StartDocPrinter(printer, 1, (LPBYTE) &docInfo); correctly?
Code:
Declarations:
Type DOCINFO
pDocName As String
pOutputFile As String
pDatatype As String
End Type
Public Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, hPrinter As Long, ByVal pDefault As Long) As Long
Public Declare Function StartDocPrinter Lib "winspool.drv" Alias "StartDocPrinterA" (hPrinter As Long, Level As Long, dDocInfo As DOCINFO) As Long
Function:
Public Function printRawData(sPrinterName As String, lData As String) As Boolean
Dim bStatus As Boolean, hPrinter As Long, dDocInfo As DOCINFO, lJob As Long, nWritten As Integer
' Open a handle to the printer.
bStatus = OpenPrinter(sPrinterName, hPrinter, 0)
If bStatus Then
' Fill in the structure with info about this "document."
dDocInfo.pDocName = vbNullString
dDocInfo.pOutputFile = vbNullString
dDocInfo.pDatatype = "RAW"
' Inform the spooler the document is beginning.
lJob = StartDocPrinter(hPrinter, 1, dDocInfo) 'Returns 0 :(
Debug.Print hPrinter, sPrinterName, lJob, GetLastError()
If lJob > 0 Then
' Start a page.
bStatus = StartPagePrinter(hPrinter)
If bStatus Then
' Send the data to the printer.
bStatus = WritePrinter(hPrinter, lData, Len(lData), nWritten)
EndPagePrinter (hPrinter)
End If
' Inform the spooler that the document is ending.
EndDocPrinter (hPrinter)
End If
' Close the printer handle.
ClosePrinter (hPrinter)
End If
' Check to see if correct number of bytes were written.
If Not bStatus Or (nWritten <> Len(lData)) Then
printRawData = False
Else
printRawData = True
End If
End Function
References/Relevant Questions:
- http://support.microsoft.com/kb/154078 Basis document for this code. Edit: Found where ByVal was missed on a few declarations here.
- Send Raw Data to ZPL Printer using Visual Basic (MS Access 2000) This person seems to use nearly identical code effectively, so why can't I? The answer to this question is written in C++.
- http://www.cplusplus.com/forum/general/26184/ The code here is also written in C++ and I am unsure how to convert.
- http://codingdomain.com/visualbasic/win32api/datatypes/ Guidance I'm using on converting datatypes and pointers, which I don't fully understand.
- StartDocPrinter(hPrinter, 1, di) returns false Some code was provided here but no answer. This is where I got idea to give errors provided.
- excel bva code to send command to usb printer I tried this and do not have the required access privileges. I would still like to know how to use the above code correctly, even if this is what I would end up doing.
With #HansPassant's link to the MS KB, I discovered the error in my code. The declaration of the StartDocPrinter function was missing ByVal for the hPrinter and Level parameters.
Public Declare Function StartDocPrinter Lib "winspool.drv" Alias "StartDocPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, dDocInfo As DOCINFO) As Long
Your declaration for the DOCINFO structure does not look correct. It should be declared as:
Type DOCINFO
cbSize As Integer
lpszDocName As String
lpszOutput As String
lpszDatatype As String
fwType As Integer
End Type
The cbSize should be initialized to the size of the structure in bytes, and fwType should be set to 0.
While searching in the net i got few lines of code in VB for extracting an image from EMF File.
I tried to convert that into Delphi but doesnt work.
Help me in converting this code to delphi.
Public Function CallBack_ENumMetafile(ByVal hdc As Long, _
ByVal lpHtable As Long, _
ByVal lpMFR As Long, _
ByVal nObj As Long, _
ByVal lpClientData As Long) As Long
Dim PEnhEMR As EMR
Dim PEnhStrecthDiBits As EMRSTRETCHDIBITS
Dim tmpDc As Long
Dim hBitmap As Long
Dim lRet As Long
Dim BITMAPINFO As BITMAPINFO
Dim pBitsMem As Long
Dim pBitmapInfo As Long
Static RecordCount As Long
lRet = PlayEnhMetaFileRecord(hdc, ByVal lpHtable, ByVal lpMFR, ByVal nObj)
RecordCount = RecordCount + 1
CopyMemory PEnhEMR, ByVal lpMFR, Len(PEnhEMR)
Select Case PEnhEMR.iType
Case 1 'header
RecordCount = 1
Case EMR_STRETCHDIBITS
CopyMemory PEnhStrecthDiBits, ByVal lpMFR, Len(PEnhStrecthDiBits)
pBitmapInfo = lpMFR + PEnhStrecthDiBits.offBmiSrc
CopyMemory BITMAPINFO, ByVal pBitmapInfo, Len(BITMAPINFO)
pBitsMem = lpMFR + PEnhStrecthDiBits.offBitsSrc
tmpDc = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
hBitmap = CreateDIBitmap(tmpDc, _
BITMAPINFO.bmiHeader, _
CBM_INIT, _
ByVal pBitsMem, _
BITMAPINFO, _
DIB_RGB_COLORS)
lRet = DeleteDC(tmpDc)
End Select
CallBack_ENumMetafile = True
End Function
What you've posted is an instance of an EnumMetaFileProc callback function, so we'll start with the signature:
function Callback_EnumMetafile(
hdc: HDC;
lpHTable: PHandleTable;
lpMFR: PMetaRecord;
nObj: Integer;
lpClientData: LParam
): Integer; stdcall;
It begins by declaring a bunch of variables, but I'll skip that for now since I don't know which ones we'll really need, and VB has a more limited type system than Delphi. I'm going to declare them as we need them; you can move them all to the top of the function yourself.
Next comes a call to PlayEnhMetaFileRecord using most of the same parameters that were passed into the callback function. The function returns a Bool, but then the code ignores it, so let's not bother with lRet.
PlayEnhMetaFileRecord(hdc, lpHtable, lpMFR, nObj);
Next we initialize RecordCount. It's declared static, which means it retains its value from one call to the next. That looks a little dubious; it should probably be passed in as a pointer in the lpClientData parameter, but let's not veer too far from the original code for now. Delphi does static variables with typed constants, and they need to be modifiable, so we'll use the $J directive:
{$J+}
const
RecordCount: Integer = 0;
{$J}
Inc(RecordCount);
Next we mcopy some of the meta record into another variable:
var
PEnhEMR: TEMR;
CopyMemory(#PEnhEMR, lpMFR, SizeOf(PEnhEMR));
It looks a little strange to copy the TMetaRecord structure onto a TEMR structure since they aren't really similar, but again, I don't want to veer from the original code too much.
Next is a case statement on the iType field. The first case is when it's 1:
case PEnhEMR.iType of
1: RecordCount := 1;
The next case is that it's emr_StretchDIBits. It copies more of the meta record, and then assigns some other pointers to refer to subsections of the main data structure.
var
PEnhStretchDIBits: TEMRStretchDIBits;
BitmapInfo: TBitmapInfo;
pBitmapInfo: Pointer;
pBitsMem: Pointer;
emr_StretchDIBits: begin
CopyMemory(#PEnhStrecthDIBits, lpMFR, SizeOf(PEnhStrecthDIBits));
pBitmapInfo := Pointer(Cardinal(lpMFR) + PEnhStrecthDiBits.offBmiSrc);
CopyMemory(#BitmapInfo, pBitmapInfo, SizeOf(BitmapInfo));
pBitsMem := Pointer(Cardinal(lpMFR) + PEnhStrecthDiBits.offBitsSrc);
Then comes what seems to be the real meat of the function, where we create a display context and a bitmap to go with it using the DIBits extracted using the previous code.
var
tmpDc: HDC;
hBitmap: HBitmap;
tmpDc := CreateDC('DISPLAY', nil, nil, nil);
hBitmap := CreateDIBitmap(tmpDc, #BitmapInfo.bmiHeader, cbm_Init,
pBitsMem, #BitmapInfo, dib_RGB_Colors);
DeleteDC(tmpDc);
end; // emr_StretchDIBits
end; // case
Finally, we assign a return value to the callback function:
Result := 1;
So, there's your translation. Wrap it in a begin-end block, remove my commentary, and move all the variable declarations to the top, and you should have Delphi code that's equivalent to your VB code. However, all this code ultimately does is generate memory leaks. The hBitmap variable is local to the function, so the bitmap handle it holds is leaked as soon as this function returns. I assume the VB code works for you, though, so I guess you have some other plans for what to do with it.
If you're working with metafiles, have you considered using the TMetafile class in the Graphics unit? It might make your life easier.