vb把字符串传入Fortran的DLL

晒sunstar · 发表于 2017-2-9 18:41:01

我想把字符串（如“文件名”）通过vb6.0传入Fortran的动态链接库，程序可以顺利结束，但是传入的字符串没有正确地截断？
vb代码：

[Visual Basic] 纯文本查看 复制代码

01Private 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)
02 
03 
04Private Sub Command1_Click()
05    Dim char As String
06    char = "c:/desktop/aaa.txt"
07    Text1.Text = char
08    Call char_1(char)
09End Sub
10 
11Private Sub Command2_Click()
12    End
13End Sub

Fortran代码：

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

001subroutine char_1( pfilename )
002!DEC$ ATTRIBUTES stdcall,DLLEXPORT::char_1
003!DEC$ ATTRIBUTES ALIAS:"char_1"::char_1
004!DEC$ ATTRIBUTES reference :: pfilename
005 
006use String_Functions
007 
008character(len=512)::pfilename
009character(len=512)::filename
010integer::ii
011ii=Clen(pfilename)
012filename=Ctrim(pfilename)
013open(unit=18,file="result_20170207",status='replace',action='write')
014write(18,*)"This is dll"
015write(18,*)filename(1:ii)
016write(18,*)"the third line"
017close(18)
018 
019end subroutine
020 
021 
022MODULE String_Functions ! by David Frank [email]dave_frank@hotmail.com[/email]
023IMPLICIT NONE ! [url]http://home.earthlink.net/~dave_gemini/strings.f90[/url]
024 
025! Copy (generic) char array to string or string to char array
026! Clen returns same as LEN unless last non-blank char = null
027! Clen_trim returns same as LEN_TRIM " "
028! Ctrim returns same as TRIM " "
029! Count_Items in string that are blank or comma separated
030! Reduce_Blanks in string to 1 blank between items, last char not blank
031! Replace_Text in all occurances in string with replacement string
032! Spack pack string's chars == extract string's chars
033! Tally occurances in string of text arg
034! Translate text arg via indexed code table
035! Upper/Lower case the text arg
036 
037INTERFACE Copy ! generic
038MODULE PROCEDURE copy_a2s, copy_s2a
039END INTERFACE Copy
040 
041CONTAINS
042! ------------------------
043PURE FUNCTION Copy_a2s(a) RESULT (s) ! copy char array to string
044CHARACTER,INTENT(IN) :: a(:)
045CHARACTER(SIZE(a)) :: s
046INTEGER :: i
047DO i = 1,SIZE(a)
048s(i:i) = a(i)
049END DO
050END FUNCTION Copy_a2s
051 
052! ------------------------
053PURE FUNCTION Copy_s2a(s) RESULT (a) ! copy s(1:Clen(s)) to char array
054CHARACTER(*),INTENT(IN) :: s
055CHARACTER :: a(LEN(s))
056INTEGER :: i
057DO i = 1,LEN(s)
058a(i) = s(i:i)
059END DO
060END FUNCTION Copy_s2a
061 
062! ------------------------
063PURE INTEGER FUNCTION Clen(s) ! returns same result as LEN unless:
064CHARACTER(*),INTENT(IN) :: s ! last non-blank char is null
065INTEGER :: i
066Clen = LEN(s)
067i = LEN_TRIM(s)
068IF (s(i:i) == CHAR(0)) Clen = i-1 ! len of C string
069END FUNCTION Clen
070 
071! ------------------------
072PURE INTEGER FUNCTION Clen_trim(s) ! returns same result as LEN_TRIM unless:
073CHARACTER(*),INTENT(IN) :: s ! last char non-blank is null, if true:
074INTEGER :: i ! then len of C string is returned, note:
075! Ctrim is only user of this function
076i = LEN_TRIM(s) ; Clen_trim = i
077IF (s(i:i) == CHAR(0)) Clen_trim = Clen(s) ! len of C string
078END FUNCTION Clen_trim
079 
080! ----------------
081FUNCTION Ctrim(s1) RESULT(s2) ! returns same result as TRIM unless:
082CHARACTER(*),INTENT(IN) :: s1 ! last non-blank char is null in which
083CHARACTER(Clen_trim(s1)) :: s2 ! case trailing blanks prior to null
084s2 = s1 ! are output
085END FUNCTION Ctrim
086 
087! --------------------
088INTEGER FUNCTION Count_Items(s1) ! in string or C string that are blank or comma separated
089CHARACTER(*) :: s1
090CHARACTER(Clen(s1)) :: s
091INTEGER :: i, k
092 
093s = s1 ! remove possible last char null
094k = 0 ; IF (s /= ' ') k = 1 ! string has at least 1 item
095DO i = 1,LEN_TRIM(s)-1
096IF (s(i:i) /= ' '.AND.s(i:i) /= ',' &
097.AND.s(i+1:i+1) == ' '.OR.s(i+1:i+1) == ',') k = k+1
098END DO
099Count_Items = k
100END FUNCTION Count_Items
101 
102! --------------------
103FUNCTION Reduce_Blanks(s) RESULT (outs)
104CHARACTER(*) :: s
105CHARACTER(LEN_TRIM(s)) :: outs
106INTEGER :: i, k, n
107 
108n = 0 ; k = LEN_TRIM(s) ! k=index last non-blank (may be null)
109DO i = 1,k-1 ! dont process last char yet
110n = n+1 ; outs(n:n) = s(i:i)
111IF (s(i:i+1) == ' ') n = n-1 ! backup/discard consecutive output blank
112END DO
113n = n+1 ; outs(n:n) = s(k:k) ! last non-blank char output (may be null)
114IF (n < k) outs(n+1:) = ' ' ! pad trailing blanks
115END FUNCTION Reduce_Blanks
116 
117! ------------------
118FUNCTION Replace_Text (s,text,rep) RESULT(outs)
119CHARACTER(*) :: s,text,rep
120CHARACTER(LEN(s)+100) :: outs ! provide outs with extra 100 char len
121INTEGER :: i, nt, nr
122 
123outs = s ; nt = LEN_TRIM(text) ; nr = LEN_TRIM(rep)
124DO
125i = INDEX(outs,text(:nt)) ; IF (i == 0) EXIT
126outs = outs(:i-1) // rep(:nr) // outs(i+nt:)
127END DO
128END FUNCTION Replace_Text
129 
130! ---------------------------------
131FUNCTION Spack (s,ex) RESULT (outs)
132CHARACTER(*) :: s,ex
133CHARACTER(LEN(s)) :: outs
134CHARACTER :: aex(LEN(ex)) ! array of ex chars to extract
135INTEGER :: i, n
136 
137n = 0 ; aex = Copy(ex)
138DO i = 1,LEN(s)
139IF (.NOT.ANY(s(i:i) == aex)) CYCLE ! dont pack char
140n = n+1 ; outs(n:n) = s(i:i)
141END DO
142outs(n+1:) = ' ' ! pad with trailing blanks
143END FUNCTION Spack
144 
145! --------------------
146INTEGER FUNCTION Tally (s,text)
147CHARACTER(*) :: s, text
148INTEGER :: i, nt
149 
150Tally = 0 ; nt = LEN_TRIM(text)
151DO i = 1,LEN(s)-nt+1
152IF (s(i:i+nt-1) == text(:nt)) Tally = Tally+1
153END DO
154END FUNCTION Tally
155 
156! ---------------------------------
157FUNCTION Translate(s1,codes) RESULT (s2)
158CHARACTER(*) :: s1, codes(2)
159CHARACTER(LEN(s1)) :: s2
160CHARACTER :: ch
161INTEGER :: i, j
162 
163DO i = 1,LEN(s1)
164ch = s1(i:i)
165j = INDEX(codes(1),ch) ; IF (j > 0) ch = codes(2)(j:j)
166s2(i:i) = ch
167END DO
168END FUNCTION Translate
169 
170! ---------------------------------
171FUNCTION Upper(s1) RESULT (s2)
172CHARACTER(*) :: s1
173CHARACTER(LEN(s1)) :: s2
174CHARACTER :: ch
175INTEGER,PARAMETER :: DUC = ICHAR('A') - ICHAR('a')
176INTEGER :: i
177 
178DO i = 1,LEN(s1)
179ch = s1(i:i)
180IF (ch >= 'a'.AND.ch <= 'z') ch = CHAR(ICHAR(ch)+DUC)
181s2(i:i) = ch
182END DO
183END FUNCTION Upper
184 
185! ---------------------------------
186FUNCTION Lower(s1) RESULT (s2)
187CHARACTER(*) :: s1
188CHARACTER(LEN(s1)) :: s2
189CHARACTER :: ch
190INTEGER,PARAMETER :: DUC = ICHAR('A') - ICHAR('a')
191INTEGER :: i
192 
193DO i = 1,LEN(s1)
194ch = s1(i:i)
195IF (ch >= 'A'.AND.ch <= 'Z') ch = CHAR(ICHAR(ch)-DUC)
196s2(i:i) = ch
197END DO
198END FUNCTION Lower
199 
200END MODULE String_Functions

运行后，输出的结果如下：

关于一些回复请看：http://stackoverflow.com/questio ... r-and-read-sentence
我用的“String_Functions”就是根据其中的方法做的，但是似乎不行？
另外弱弱地问一句：在vb里，怎么调试dll呢？（我看网上的方法要加入dll的工程，但是我的dll是ivf下的工程，加不进来啊）..

fcode · 发表于 2017-2-9 21:57:53

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

晒sunstar · 发表于 2017-2-10 19:10:37

根据您的方法，我成功地传入了字符串，代码如下（但是点“结束”按钮却死机了）：vb6.0代码：

[Visual Basic] 纯文本查看 复制代码

01Private Declare Sub char_2 Lib "D:\try_vb\char_2_ISOCBind\Dll1\Dll1\Debug\Dll1.dll" (ByVal char As String)
02 
03Private Sub Command1_Click()
04    Dim char As String
05    char = "c:/desktop/aaa.txt"
06    Text1.Text = char
07    Call char_2(char)
08End Sub
09 
10Private Sub Command2_Click()
11    End
12End Sub

Fortran的DLL代码：

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

01subroutine char_2( pfilename )
02!DEC$ ATTRIBUTES stdcall,DLLEXPORT::char_2
03!DEC$ ATTRIBUTES ALIAS:"char_2"::char_2
04!DEC$ ATTRIBUTES reference :: pfilename
05 
06use,intrinsic::ISO_C_Binding
07  character(len=512)::pfilename
08  character(len=512)::filename
09  integer::ii
10  ii=index(pfilename,c_null_char)
11  pfilename(ii:)=""
12  filename=trim(pfilename)
13  open(unit=18,file="result_20170207",status='replace',action='write')
14    write(18,*)"This is dll"
15    write(18,*)trim(filename)
16    write(18,*)"the third line"
17  close(18)
18end subroutine

vb的界面如图1。

运行结果：①“result_20170207”正确显示，如图2；②错误的界面如图3和图4

晒sunstar · 发表于 2017-2-10 19:15:19

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

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

01subroutine char_1( pfilename )
02!DEC$ ATTRIBUTES stdcall,DLLEXPORT::char_1
03!DEC$ ATTRIBUTES ALIAS:"char_1"::char_1
04!DEC$ ATTRIBUTES reference :: pfilename
05 
06use String_Functions
07 
08  character(len=512)::pfilename
09  character(len=512)::filename
10  integer::ii
11  ii=Clen(pfilename)
12  filename=Ctrim(pfilename)
13  open(unit=18,file="result_20170207",status='replace',action='write')
14    write(18,*)"This is dll"
15    !write(18,*)filename(1:ii)
16    write(18,*)trim(filename)
17    write(18,*)"the third line"
18  close(18)
19 
20end subroutine

②module：

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

01MODULE String_Functions  ! by David Frank  [email]dave_frank@hotmail.com[/email]
02IMPLICIT NONE            ! [url]http://home.earthlink.net/~dave_gemini/strings.f90[/url]
03 
04! Copy (generic) char array to string or string to char array
05! Clen           returns same as LEN      unless last non-blank char = null
06! Clen_trim      returns same as LEN_TRIM    "              "
07! Ctrim          returns same as TRIM        "              "
08! Count_Items    in string that are blank or comma separated
09! Reduce_Blanks  in string to 1 blank between items, last char not blank
10! Replace_Text   in all occurances in string with replacement string
11! Spack          pack string's chars == extract string's chars
12! Tally          occurances in string of text arg
13! Translate      text arg via indexed code table
14! Upper/Lower    case the text arg
15 
16 
17CONTAINS
18 
19! ------------------------
20PURE INTEGER FUNCTION Clen(s)      ! returns same result as LEN unless:
21CHARACTER(*),INTENT(IN) :: s       ! last non-blank char is null
22INTEGER :: i
23Clen = LEN(s)
24i = LEN_TRIM(s)
25IF (s(i:i) == CHAR(0)) Clen = i-1  ! len of C string
26END FUNCTION Clen
27 
28!
29PURE INTEGER FUNCTION Clen_trim(s) ! returns same result as LEN_TRIM unless:
30CHARACTER(*),INTENT(IN) :: s       ! last char non-blank is null, if true:
31INTEGER :: i                       ! then len of C string is returned, note:
32                                   ! Ctrim is only user of this function
33i = INDEX(s, CHAR(0))
34IF ( i == 0 ) i = LEN_TRIM(s)
35Clen_trim = i
36 
37END FUNCTION Clen_trim
38 
39! ----------------
40FUNCTION Ctrim(s1)  RESULT(s2)     ! returns same result as TRIM unless:
41CHARACTER(*),INTENT(IN)  :: s1     ! last non-blank char is null in which
42CHARACTER(Clen_trim(s1)) :: s2     ! case trailing blanks prior to null
43s2 = s1                            ! are output
44END FUNCTION Ctrim
45 
46 
47END MODULE String_Functions

fcode · 发表于 2017-2-10 20:18:26

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

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

改为

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

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

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

美女勋章

热心勋章

星光勋章

新人勋章

贡献勋章

管理勋章

帅哥勋章

爱心勋章

规矩勋章

元老勋章

水王勋章