[Fortran] 纯文本查看 复制代码

Private Declare Sub char_1 Lib "D:\try_vb\char_1\char_1_dll\char_1_dll\Debug\char_1_dll.dll" (ByVal char As String)


Private Sub Command1_Click()
    Dim char As String
    char = "c:/desktop/aaa.txt"
    Text1.Text = char
    Call char_1(char)
End Sub

Private Sub Command2_Click()
    End
End Sub

改为

[Fortran] 纯文本查看 复制代码

subroutine char_1( pfilename )
!DEC$ ATTRIBUTES stdcall,DLLEXPORT::char_1
!DEC$ ATTRIBUTES ALIAS:"char_1"::char_1
!DEC$ ATTRIBUTES reference :: pfilename

use String_Functions

character(len=512)::pfilename
character(len=512)::filename
integer::ii
ii=Clen(pfilename)
filename=Ctrim(pfilename)
open(unit=18,file="result_20170207",status='replace',action='write')
write(18,*)"This is dll"
write(18,*)filename(1:ii)
write(18,*)"the third line"
close(18)

end subroutine


MODULE String_Functions ! by David Frank [email]dave_frank@hotmail.com[/email]
IMPLICIT NONE ! [url]http://home.earthlink.net/~dave_gemini/strings.f90[/url]

! Copy (generic) char array to string or string to char array
! Clen returns same as LEN unless last non-blank char = null
! Clen_trim returns same as LEN_TRIM " "
! Ctrim returns same as TRIM " "
! Count_Items in string that are blank or comma separated
! Reduce_Blanks in string to 1 blank between items, last char not blank
! Replace_Text in all occurances in string with replacement string
! Spack pack string's chars == extract string's chars
! Tally occurances in string of text arg
! Translate text arg via indexed code table
! Upper/Lower case the text arg

INTERFACE Copy ! generic
MODULE PROCEDURE copy_a2s, copy_s2a
END INTERFACE Copy

CONTAINS
! ------------------------
PURE FUNCTION Copy_a2s(a) RESULT (s) ! copy char array to string
CHARACTER,INTENT(IN) :: a(:)
CHARACTER(SIZE(a)) :: s
INTEGER :: i
DO i = 1,SIZE(a)
s(i:i) = a(i)
END DO
END FUNCTION Copy_a2s

! ------------------------
PURE FUNCTION Copy_s2a(s) RESULT (a) ! copy s(1:Clen(s)) to char array
CHARACTER(*),INTENT(IN) :: s
CHARACTER :: a(LEN(s))
INTEGER :: i
DO i = 1,LEN(s)
a(i) = s(i:i)
END DO
END FUNCTION Copy_s2a

! ------------------------
PURE INTEGER FUNCTION Clen(s) ! returns same result as LEN unless:
CHARACTER(*),INTENT(IN) :: s ! last non-blank char is null
INTEGER :: i
Clen = LEN(s)
i = LEN_TRIM(s)
IF (s(i:i) == CHAR(0)) Clen = i-1 ! len of C string
END FUNCTION Clen

! ------------------------
PURE INTEGER FUNCTION Clen_trim(s) ! returns same result as LEN_TRIM unless:
CHARACTER(*),INTENT(IN) :: s ! last char non-blank is null, if true:
INTEGER :: i ! then len of C string is returned, note:
! Ctrim is only user of this function
i = LEN_TRIM(s) ; Clen_trim = i
IF (s(i:i) == CHAR(0)) Clen_trim = Clen(s) ! len of C string
END FUNCTION Clen_trim

! ----------------
FUNCTION Ctrim(s1) RESULT(s2) ! returns same result as TRIM unless:
CHARACTER(*),INTENT(IN) :: s1 ! last non-blank char is null in which
CHARACTER(Clen_trim(s1)) :: s2 ! case trailing blanks prior to null
s2 = s1 ! are output
END FUNCTION Ctrim

! --------------------
INTEGER FUNCTION Count_Items(s1) ! in string or C string that are blank or comma separated
CHARACTER(*) :: s1
CHARACTER(Clen(s1)) :: s
INTEGER :: i, k

s = s1 ! remove possible last char null
k = 0 ; IF (s /= ' ') k = 1 ! string has at least 1 item
DO i = 1,LEN_TRIM(s)-1
IF (s(i:i) /= ' '.AND.s(i:i) /= ',' &
.AND.s(i+1:i+1) == ' '.OR.s(i+1:i+1) == ',') k = k+1
END DO
Count_Items = k
END FUNCTION Count_Items

! --------------------
FUNCTION Reduce_Blanks(s) RESULT (outs)
CHARACTER(*) :: s
CHARACTER(LEN_TRIM(s)) :: outs
INTEGER :: i, k, n

n = 0 ; k = LEN_TRIM(s) ! k=index last non-blank (may be null)
DO i = 1,k-1 ! dont process last char yet
n = n+1 ; outs(n:n) = s(i:i)
IF (s(i:i+1) == ' ') n = n-1 ! backup/discard consecutive output blank
END DO
n = n+1 ; outs(n:n) = s(k:k) ! last non-blank char output (may be null)
IF (n < k) outs(n+1:) = ' ' ! pad trailing blanks
END FUNCTION Reduce_Blanks

! ------------------
FUNCTION Replace_Text (s,text,rep) RESULT(outs)
CHARACTER(*) :: s,text,rep
CHARACTER(LEN(s)+100) :: outs ! provide outs with extra 100 char len
INTEGER :: i, nt, nr

outs = s ; nt = LEN_TRIM(text) ; nr = LEN_TRIM(rep)
DO
i = INDEX(outs,text(:nt)) ; IF (i == 0) EXIT
outs = outs(:i-1) // rep(:nr) // outs(i+nt:)
END DO
END FUNCTION Replace_Text

! ---------------------------------
FUNCTION Spack (s,ex) RESULT (outs)
CHARACTER(*) :: s,ex
CHARACTER(LEN(s)) :: outs
CHARACTER :: aex(LEN(ex)) ! array of ex chars to extract
INTEGER :: i, n

n = 0 ; aex = Copy(ex)
DO i = 1,LEN(s)
IF (.NOT.ANY(s(i:i) == aex)) CYCLE ! dont pack char
n = n+1 ; outs(n:n) = s(i:i)
END DO
outs(n+1:) = ' ' ! pad with trailing blanks
END FUNCTION Spack

! --------------------
INTEGER FUNCTION Tally (s,text)
CHARACTER(*) :: s, text
INTEGER :: i, nt

Tally = 0 ; nt = LEN_TRIM(text)
DO i = 1,LEN(s)-nt+1
IF (s(i:i+nt-1) == text(:nt)) Tally = Tally+1
END DO
END FUNCTION Tally

! ---------------------------------
FUNCTION Translate(s1,codes) RESULT (s2)
CHARACTER(*) :: s1, codes(2)
CHARACTER(LEN(s1)) :: s2
CHARACTER :: ch
INTEGER :: i, j

DO i = 1,LEN(s1)
ch = s1(i:i)
j = INDEX(codes(1),ch) ; IF (j > 0) ch = codes(2)(j:j)
s2(i:i) = ch
END DO
END FUNCTION Translate

! ---------------------------------
FUNCTION Upper(s1) RESULT (s2)
CHARACTER(*) :: s1
CHARACTER(LEN(s1)) :: s2
CHARACTER :: ch
INTEGER,PARAMETER :: DUC = ICHAR('A') - ICHAR('a')
INTEGER :: i

DO i = 1,LEN(s1)
ch = s1(i:i)
IF (ch >= 'a'.AND.ch <= 'z') ch = CHAR(ICHAR(ch)+DUC)
s2(i:i) = ch
END DO
END FUNCTION Upper

! ---------------------------------
FUNCTION Lower(s1) RESULT (s2)
CHARACTER(*) :: s1
CHARACTER(LEN(s1)) :: s2
CHARACTER :: ch
INTEGER,PARAMETER :: DUC = ICHAR('A') - ICHAR('a')
INTEGER :: i

DO i = 1,LEN(s1)
ch = s1(i:i)
IF (ch >= 'A'.AND.ch <= 'Z') ch = CHAR(ICHAR(ch)-DUC)
s2(i:i) = ch
END DO
END FUNCTION Lower

END MODULE String_Functions

对了，发在stackoverflow上的问题也得到了一个回复（他把module模块修改了下），试过也是可以的，也一并贴在这了。
Fortran的代码：
①主程序：

[Fortran] 纯文本查看 复制代码

subroutine char_2( pfilename )
!DEC$ ATTRIBUTES stdcall,DLLEXPORT::char_2
!DEC$ ATTRIBUTES ALIAS:"char_2"::char_2
!DEC$ ATTRIBUTES reference :: pfilename

②module：

[Fortran] 纯文本查看 复制代码

subroutine char_2( pfilename )
!DEC$ ATTRIBUTES DLLEXPORT::char_2
!DEC$ ATTRIBUTES ALIAS:"char_2"::char_2

ii=Clen(pfilename)
改为
use , intrinsic :: ISO_C_Binding
ii = index( pfilename , c_null_char )
pfilename( ii: ) = ""
删掉整个String_Functions 模块，没用