VB6.0回调函数求助

[CCC的]

'public.bas
Option Explicit

Public hPort As Long
Public clock_id As Long
Public started As Boolean
Public callback1 As Long
Public callback2 As Long
Public callback3 As Long
Public serialnum As String
Public mydevid As Integer
Public myip As String
Public myclockid As Integer
Public myclock As Integer
Public myport As Integer
Public mystate As String
Public myrecords As String

Public Sub FunOnDeviceLogin(ByVal Dev_id As Integer, ByVal serial As Long, ByVal ip As Long, ByVal port As Integer, ByRef Heartbeat As Integer)

   '回调函数1
  Dim hasDevice As Boolean
  Dim i As Integer
  
  hasDevice = False
  If serialnum = SysAllocString(serial) Then
        hasDevice = True
        mydevid = Dev_id
        myip = SysAllocString(ip)
        myport = port
 End If
  
  If hasDevice = False Then
        myclockid = Dev_id
        serialnum = SysAllocString(serial)
        myip = SysAllocString(ip)
        myport = port
        mystate = "登录"
  End If
  
  Heartbeat = 2
End Sub

Public Sub FunOnRefreshDeviceStateBySerial(ByVal Dev_id As Integer, ByVal serial As Long, ByVal state As Integer, ByVal RecordCount As Integer)
   '回调函数2
   Dim a As String
   If serialnum = SysAllocString(serial) Then
        If state = 0 Then
           mystate = "状态：脱机"
        Else
           mystate = "状态：联机"
        End If
   End If
End Sub

Public Sub FunOnRecieveBatchRecordBySerialStr(ByVal Dev_id As Integer, ByVal serial As Long, ByVal index As Integer, ByVal RecordCount As Integer, ByVal Records As Long, ByRef bReturnOK As Boolean)
    '回调函数3    
     myrecords = SysAllocString(Records)    
    bReturnOK = True
End Sub

'delphi中的声明
'procedure SetUpLoadProcStr(vOnDeviceLogin:FunOnDeviceLogin; vOnRefreshDeviceState: FunOnRefreshDeviceStateBySerial; vOnRecieveBatchRecord: FunOnRecieveBatchRecordBySerialStr);  stdcall;

Public Declare Sub SetUpLoadProcStr Lib "EastRiver.Dll" (ByVal FunOnDeviceLogin As Long, ByVal FunOnRefreshDeviceStateBySerial As Long, ByVal FunOnRecieveBatchRecordBySerialStr As Long)

'delphi中的声明
'function StartUpLoad(vListenPort:Integer):boolean; stdcall;   external 'EastRiver.dll';
Public Declare Function StartUpLoad Lib "EastRiver.Dll" (ByVal port As Long) As Boolean

Declare Function SysAllocString Lib "oleaut32.dll" (ByVal pOlechar As Long) As String

调用

Function GetFuncPtr(ByVal Ptr As Long) As Long
  GetFuncPtr = Ptr
End Function

Private Sub Command4_Click()
  Dim iPort As Integer
  
  callback1 = GetFuncPtr(AddressOf FunOnDeviceLogin)
  callback2 = GetFuncPtr(AddressOf FunOnRefreshDeviceStateBySerial)
  callback3 = GetFuncPtr(AddressOf FunOnRecieveBatchRecordBySerialStr)
  
  iPort = CInt(Text1.Text)
  started = StartUpLoad(iPort)
  If started Then
    Command5.Enabled = 1
    Command4.Enabled = 0 
   Call SetUpLoadProcStr(VarPtr(callback1), VarPtr(callback2), VarPtr(callback3))
  End If
End Sub

[CCC的]

[lyserver]

通过窗口消息实现加内存映射代替吧

[CCC的]

delphi部分声明

TSerialType: array[0..16] of char;
FunOnRefreshDeviceStateBySerial = procedure(Dev_id: integer;Serial:TSerialType; State: integer; RecordCount: integer); stdcall;
  FunOnDeviceLogin=procedure(Dev_id:integer;Serial:TSerialType;ip:PChar;port:integer;
                   var Heartbeat:integer);  stdcall;
  FunOnRecieveBatchRecordBySerialStr=procedure(Dev_id: integer;Serial:TSerialType;RecoredIndex:integer;RecordCount:integer;Records: Pchar;var bReturnOK:boolean);stdcall;

procedure TServerManager.NotifyOnDeviceLogin(Dev_id: integer; Serial,
  ip: string; port: integer; var Heartbeat: integer);
var
 chSerial:TSerialType;
 chIP:array [0..16] of char;
begin
  fillchar(chSerial,sizeof(chSerial),0);
  fillchar(chIP,sizeof(chIP),0);
  Move(PChar(serial)[0],chserial[0],length(serial));
  Move(PChar(IP)[0], chIP[0],length(ip));
  try
    if Assigned(FOnDeviceLogin) then
    begin
      //ShowMessage('logo');
      FOnDeviceLogin(Dev_id,chSerial,chip,port,Heartbeat);  //
      //ShowMessage('logo echo');
    end;
  except
    on e:exception do
    begin
       WriteErr('通知登录异常'+e.Message);
    end;
  end;
end;

procedure TServerManager.NotifyOnRefreshDeviceStateBySerial(
  Dev_id: integer; Serial: string; State, RecordCount: integer);
var
 chSerial:TSerialType;
 lrecordcount:integer;
begin
   try
      FillChar(chSerial,sizeof(chSerial),0);
      Move(PChar(Serial)[0],chSerial[0],sizeof(chSerial));
      if Assigned(FOnRefreshDeviceState) then
      begin
          FOnRefreshDeviceState(Dev_id,chSerial,State,RecordCount);
      end;
   except
     on e:exception do
     begin
       WriteErr('状态更新异常:'+e.Message);
     end;
   end;
end;

procedure TServerManager.NotifyOnRecieveBatchRecordBySerial(
  Dev_id: integer; Serial: string;RecoredIndex:integer; RecordCount: integer;
  Records: DeviceDataArray; var bReturnOK: boolean);                                     //newnew
var
  chSerial:TSerialType;
  RecordsStr:array [0..2048] of Char;
  i:Integer;
  tempstr:string;
begin
  try
    FillChar(chSerial,sizeof(chSerial),0);
    Move(PChar(serial)[0],chSerial[0],sizeof(chSerial));
    if assigned(FOnRecieveBatchRecord) then
    begin
      //ShowMessage(IntToStr(sizeof(DeviceData)));

      FOnRecieveBatchRecord(Dev_id,chSerial,RecoredIndex,RecordCount,Records,bReturnOK);   //
//      bReturnOK := true;
    end;

    if assigned(FOnRecieveBatchRecordStr) then
    begin
      RecordsStr:='';
      //把  Records 传成  RecordsStr
      for i:=0 to 15 do
      begin
        if string(Records[i].cardno) <> '' then
          tempstr:=tempstr+
                  string(Records[i].cardno)+','+
                  string(Records[i].emp_no)+','+
                  inttostr(Records[i].dev_id)+','+
                  inttostr(Records[i].consume)+','+
                  inttostr(Records[i].blanace)+','+
                  inttostr(Records[i].times)+','+
                  string(Records[i].card_time)+';';
          StrPCopy(RecordsStr,tempstr);
      end;

      FOnRecieveBatchRecordStr(Dev_id,chSerial,RecoredIndex,RecordCount,RecordsStr,bReturnOK);   //
//      bReturnOK := true;
    end;
  except
    on e:exception do
    begin
        WriteErr('通知数据接收异常:'+e.Message);
    end;
  end;
end;

日志
通知登录异常External exception C000001E
状态更新异常:Access violation at address 00405037 in module 'demo7.exe'. Write of address 01BC3F43
通知数据接收异常:Access violation at address 00405038 in module 'demo7.exe'. Read of address 0000403C
状态更新异常:Access violation at address 00405037 in module 'demo7.exe'. Write of address 01BC3F43
状态更新异常:Access violation at address 00405037 in module 'demo7.exe'. Write of address 01BC3F43

[CCC的]

对VB不熟，希望VB大神相助

[CCC的]

这么复杂？可以提供一个示例吗？顶顶更健康

[专注VB编程开发20年]

把VB代码压到DELPHIE中执行，这样是挺累的，不如在VB中执行，执行完了再调用一下DELPHI的某个通知信息的DLL中的API