Hi Jeff
Thanks for the reply.
Yes in ther point 3D type each of the array points has a string
Useful in some cases if you need to add some quick and dirty informations in this geometric case.
But in real engineering world often types have a string - usually all
A example
a anchor plate has a length a height a thickness a number of studs - so far so good just numbers
stupidly such studs have a TYPE "Nelson headed stud"
a serial number "Plate 4711" and so on.
Its usually a good idea to keep those information together - otherwise you have to take care of some data structures. To keep them consolidated is "fun"
Its unhandy in most cases.
So back to string parameters
To ease your live i grabbed a few string routines together to move VBA strings in byte arrays as unicode or ansi and back.
I append it to the vba part
Yesterday i tested ho to deal with singles or real values.
So a VBA single is a FORTRANreal.
length is 8 bytes as i could see by dependancywalker.
I do not like this decorations cause
after i wrote and copiled the fortran code i have to look by dependany walker how the mangled decorations looks like...
Imagine you have a few hundred subroutines ...
Back to topic:
I guess fortran uses 8 bytes for the string
so i asume
1. th 4 bytes are for the length and
2. th 4 for the pointer of the first char - if web information is valid
FORTRAN CODE :
function testme() ! CRASHES VBA
!GCC$ attributes dllexport, stdcall :: testme
character c
character testme
c="Hello World"
testme=c
end
function testi(i,j)
! interface a vba integer by value
!GCC$ attributes dllexport, stdcall :: testi
integer, value :: i
integer, value :: j
integer testi
testi = j+i
end
function testr(a,b)
! interface a vba single by value
!GCC$ attributes dllexport, stdcall :: testr
real, value :: a
real, value :: b
real testr
testr = 3.1415+b
end
VBA code
''Jeff
'Declare Function testme Lib "C:\Users\Jeffrey\Workspace\example\vb2dll\fortran-library.dll" Alias "testme@0" () As Integer
'Declare Function testi Lib "C:\Users\Jeffrey\Workspace\example\vb2dll\fortran-library.dll" Alias "testi@8" (ByVal i As Integer, ByVal j As Integer) As Integer
'Thomas
Declare Function testme Lib "M:\DEVEL\FORTRAN\orion.math.iastate.edu\burkardt\f_src\geometry\fortran-library.dll" Alias "testme@0" () As Integer
Declare Function testi Lib "M:\DEVEL\FORTRAN\orion.math.iastate.edu\burkardt\f_src\geometry\fortran-library.dll" Alias "testi@8" (ByVal i As Integer, ByVal j As Integer) As Integer
Declare Function testr Lib "M:\DEVEL\FORTRAN\orion.math.iastate.edu\burkardt\f_src\geometry\fortran-library.dll" Alias "testr@8" (ByVal a As Single, ByVal b As Single) As Single
'WIN API FUNCTIONS FOR CHARACTER CONVERSATIONS SPEEDTESTS AND MEM FUNCS
'CodePage
Private Const CP_ACP = 0 'ANSI
Private Const CP_MACCP = 2 'Mac
Private Const CP_OEMCP = 1 'OEM
Private Const CP_UTF7 = 65000
Private Const CP_UTF8 = 65001
'dwFlags
Private Const WC_NO_BEST_FIT_CHARS = &H400
Private Const WC_COMPOSITECHECK = &H200
Private Const WC_DISCARDNS = &H10
Private Const WC_SEPCHARS = &H20 'Default
Private Const WC_DEFAULTCHAR = &H40
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
'The WideCharToMultiByte function maps a wide-character string to a new character string. 'The function is faster when both lpDefaultChar and lpUsedDefaultChar are NULL.
Sub fortran()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim a As Single
Dim b As Single
' k = testme() 'kills excel 
Debug.Print k
i = 1
j = 2
a = 1
b = 2
Debug.Print testi(i, j) 'should return 2 - wrom dll calling conventoin error or crash
Debug.Print testr(a, b) 'should return 5.1415
End Sub
'helper functions for string parameters.....
Public Sub unicode_string_to_bytearray()
Dim b() As Byte
Dim s As String
s = "Whatever"
b = s 'Assign Unicode string to bytes.'
s = ""
s = b 'Works in reverse, too!'
Debug.Print s
For i = 0 To UBound(b)
Debug.Print b(i)
Next
End Sub
Public Function Byte_Array_To_String(bytArray() As Byte) As String
Dim s As String
Dim i As Long
s = StrConv(bytArray, vbUnicode)
i = InStr(s, Chr(0))
If i > 0 Then s = Left(s, i - 1)
Byte_Array_To_String = s
End Function
Sub string_to_bytearray_2()
Dim s As String
Dim l As Long
Dim b() As Byte
s = "Good morning vietnam!"
l = Len(s)
b = StrConv(s, vbFromUnicode)
Debug.Print l, UBound(b)
Debug.Print Byte_Array_To_String(b())
End Sub
Private Function ByteArrayToString(Bytes() As Byte) As String
Dim iUnicode As Long, i As Long, j As Long
On Error Resume Next
i = UBound(Bytes)
If (i < 1) Then
'ANSI, just convert to unicode and return
ByteArrayToString = StrConv(Bytes, vbUnicode)
Exit Function
End If
i = i + 1
'Examine the first two bytes
CopyMemory iUnicode, Bytes(0), 2
If iUnicode = Bytes(0) Then 'Unicode
'Account for terminating null
If (i Mod 2) Then i = i - 1
'Set up a buffer to recieve the string
ByteArrayToString = String$(i / 2, 0)
'Copy to string
CopyMemory ByVal StrPtr(ByteArrayToString), Bytes(0), i
Else 'ANSI
ByteArrayToString = StrConv(Bytes, vbUnicode)
End If
End Function
Private Function StringToByteArray(strInput As String, Optional bReturnAsUnicode As Boolean = True, Optional bAddNullTerminator As Boolean = False) As Byte()
Dim lRet As Long
Dim bytBuffer() As Byte
Dim lLenB As Long
Dim method As Long
method = 2
If bReturnAsUnicode Then
'Number of bytes
lLenB = LenB(strInput)
'Resize buffer, do we want terminating null?
If bAddNullTerminator Then
ReDim bytBuffer(lLenB)
Else
ReDim bytBuffer(lLenB - 1)
End If
'Copy characters from string to byte array
CopyMemory bytBuffer(0), ByVal StrPtr(strInput), lLenB
Else
If method = 1 Then
'METHOD ONE
'Get rid of embedded nulls
strRet = StrConv(strInput, vbFromUnicode)
lLenB = LenB(strRet)
If bAddNullTerminator Then
ReDim bytBuffer(lLenB)
Else
ReDim bytBuffer(lLenB - 1)
End If
CopyMemory bytBuffer(0), ByVal StrPtr(strInput), lLenB
Else
'METHOD TWO
'Num of characters
lLenB = Len(strInput)
If bAddNullTerminator Then
ReDim bytBuffer(lLenB)
Else
ReDim bytBuffer(lLenB - 1)
End If
lRet = WideCharToMultiByte(CP_ACP, 0&, ByVal StrPtr(strInput), -1, ByVal VarPtr(bytBuffer(0)), lLenB, 0&, 0&)
End If
End If
StringToByteArray = bytBuffer
End Function
Private Sub s2b()
Dim bAnsi() As Byte
Dim bUni() As Byte
Dim str As String
Dim i As Long
str = "Convert"
bAnsi = StringToByteArray(str, False)
bUni = StringToByteArray(str)
For i = 0 To UBound(bAnsi)
Debug.Print "=" & bAnsi(i)
Next
Debug.Print "------------------------------"
For i = 0 To UBound(bUni)
Debug.Print "=" & bUni(i)
Next
Debug.Print "ANSI= " & ByteArrayToString(bAnsi)
Debug.Print "UNICODE= " & ByteArrayToString(bUni)
'Using StrConv to convert a Unicode character array directly
'will cause the resultant string to have extra embedded nulls
'reason, StrConv does not know the difference between Unicode and ANSI
Debug.Print "Result= " & StrConv(bUni, vbUnicode)
End Sub
Sub Test()
Dim X As Long, T As Long, m As String
Const sTESTc As String = "1234567890"
T = GetTickCount
For X = 1 To 100000
Method1 sTESTc
Next
m = "It took Method1" + str$((GetTickCount - T) / 1000) + " secs. to run 10000 times." & vbCrLf
T = GetTickCount
For X = 1 To 100000
Method2 sTESTc
Next
m = m & "It took Method2" + str$((GetTickCount - T) / 1000) + " secs. to run 10000 times." & vbCrLf
T = GetTickCount
For X = 1 To 100000
Method3 sTESTc
Next
MsgBox m & "It took Method3" + str$((GetTickCount - T) / 1000) + " secs. to run 10000 times."
End Sub
Sub Method1(sVal As String)
Dim lIndx As Long
Dim byMyArray() As Byte
byMyArray = VBA.StrConv(sVal, vbFromUnicode)
For lIndx = 0 To UBound(byMyArray)
byMyArray(lIndx) = CByte(VBA.Chr$(byMyArray(lIndx)))
Next lIndx
End Sub
Sub Method2(sVal As String) 'fastest of those three methods
Dim lIndx As Long
Dim byMyArray() As Byte
Dim lLen As Long
lLen = VBA.Len(sVal)
ReDim byMyArray(1 To lLen) As Byte
For lIndx = 1 To lLen
byMyArray(lIndx) = CByte(VBA.Mid$(sVal, lIndx, 1))
Next lIndx
End Sub
Private Sub Method3(sVal As String)
Dim s As Byte, Cnt As Long, Length As Long, byMyArray() As Byte
Length = Len(sVal)
ReDim byMyArray(1 To Length)
For Cnt = 0 To Length - 1
s = CByte(Mid$(sVal, Cnt + 1, 1))
CopyMemory ByVal VarPtr(byMyArray(1)) + Cnt, ByVal VarPtr(s), LenB(s)
Next Cnt
End Sub
Have a nice day
Thomas
