Вот пример самой Лоции. В моей программе многие функции работают (тот же PartyObjAttribSet), но вот с импортом через api глухо
Очень приятно, что нашлись неравнодушные люди
Option Base 0
Private Type PtDateTime
Year As Integer
Month As Byte
Day As Byte
Hour As Byte
Min As Byte
Sec As Byte
MilSec As Long
End Type
Const cPtDateTimeSize As Integer = 11
Private Type PtValue
cDataType As Byte
szValueS(255) As Byte
dblValueN(7) As Byte
dtValueT(cPtDateTimeSize - 1) As Byte
End Type
Const cPtValueSize As Integer = 276
Private Type PtList
dwSize As Long
wType As Integer
wCnt As Integer
End Type
Const cPtListSize As Integer = 8
Private Type PtObjAttrib
piID(17) As Byte
piAttribID(17) As Byte
pvValue(cPtValueSize - 1) As Byte
cMultiType As Byte
cLinkMode As Byte
piGroupID(17) As Byte
szEditMask(255) As Byte
cEditType As Byte
szDescription(50) As Byte
szGroupDescr(50) As Byte
End Type
Const cPtObjAttribSize As Integer = 691
Private Type PtObject
piID(17) As Byte
piTypeID(17) As Byte
szDescription(50) As Byte
szTypeDesc(50) As Byte
szTypeMnemo(4) As Byte
cTypeClass As Byte
End Type
Const cPtObjectSize As Integer = 144
Private Type PtArgFind
wType As Integer
lpFindArg As Long
End Type
Private Declare Function PartyInit Lib "PartyAPI" (ByVal Wnd As Long) As Integer
Private Declare Function PartyUpdate Lib "PartyAPI" () As Integer
Private Declare Function PartyUIObjectOpen Lib "PartyAPI" (ByVal lpObjID As String, ByVal dwFlags As Long, ByVal Res1 As Long) As Integer
Private Declare Function PartyUIObjectSelect Lib "PartyAPI" (ByVal lpObjID As String, ByVal dwFlags As Long, ByVal Res1 As Long) As Integer
Private Declare Function PartyObjectGetEx Lib "PartyAPI" (lpFindArg As PtArgFind, lpList As Long) As Integer
Private Declare Function PartyObjAttribGet Lib "PartyAPI" (ByVal lpObjID As String, ByVal lpTLinkID As String, ByVal lpAttrID As String, lpList As Long) As Integer
Private Declare Function PartyObjAttribSet Lib "PartyAPI" (ByVal lpObjID As String, ByVal lpTLinkID As String, ByVal lpAttrID As String, lpValue As PtValue, ByVal lpID As String) As Integer
' WinAPI
Private Declare Function StrToArr Lib "Kernel32" Alias "lstrcpyA" (ByRef RetVal As Any, ByVal Str As String) As Long
Private Declare Function CopyStr Lib "Kernel32" Alias "lstrcpyA" (ByVal RetVal As String, Ptr As Any) As Long
Private Declare Function StrLen Lib "Kernel32" Alias "lstrlenA" (Ptr As Any) As Long
Private Declare Function StrPtr Lib "Kernel32" Alias "lstrcpyA" (RetVal As Byte, ByVal Ptr As String) As Long
Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Sub CopyMemoryPtr Lib "Kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Sub LocalFree Lib "Kernel32" (ByVal lPtr As Long)
' ñòðóêòóðû VB
Private Type vbObjAttrib
piID As String
piAttribID As String
pvValue As Variant
cMultiType As String
cLinkMode As String
piGroupID As String
szEditMask As String
cEditType As String
szDescription As String
szGroupDescr As String
End Type
Private Type vbObject
piID As String
piTypeID As String
szDescription As String
szTypeDesc As String
szTypeMnemo As String
cTypeClass As String
End Type
Sub PartyGetObjectAttrib()
Dim lpObjID As String
Dim dtValueT As PtDateTime
Dim lpAttrib() As vbObjAttrib, lpAttrib1 As vbObjAttrib
Dim lsStr As String
Dim lListPtr As Long, lPtr As Long
Dim lpList As PtList
Dim lpRow As PtObjAttrib
Dim ldblValue As Double
PartyInit (0)
lpObjID = Space(18)
rc = PartyUIObjectSelect(lpObjID, 0, 0)
Dim lpValID As String
Value.cDataType = Asc("S") ' String
Call StrToArr(Value.szValueS(0), "Значение атрибута" & vbNullChar)
' Value.cDataType = Asc("N") ' Double
' Call CopyMemory(Value.dblValueN(0), CDbl(123.45),
' Value.cDataType = Asc("T") ' DateTime
' dtValueT.Day = 21
' dtValueT.Month = 11
' dtValueT.Year = 2000
' Call CopyMemory(Value.dtValueT(0), dtValueT, 11)
lpValID = Space(18) '
rc = PartyObjAttribSet("43", "0", "-30", Value, lpValID)
rc = PartyUpdate()
End Sub
офис вылетает и все. Как у вас успехи?