[混编] vb把字符串传入Fortran的DLL

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

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

Private Declare Sub char_2 Lib "D:\try_vb\char_2_ISOCBind\Dll1\Dll1\Debug\Dll1.dll" (ByVal char As String)

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

Private Sub Command2_Click()
    End
End Sub

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

use,intrinsic::ISO_C_Binding
  character(len=512)::pfilename
  character(len=512)::filename
  integer::ii
  ii=index(pfilename,c_null_char)
  pfilename(ii:)=""
  filename=trim(pfilename)
  open(unit=18,file="result_20170207",status='replace',action='write')
    write(18,*)"This is dll"
    write(18,*)trim(filename)
    write(18,*)"the third line"
  close(18)
end subroutine

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,*)trim(filename)
    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


CONTAINS

! ------------------------
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 = INDEX(s, CHAR(0)) 
IF ( i == 0 ) i = LEN_TRIM(s)
Clen_trim = i

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


END MODULE String_Functions

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

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