Fortran Coder

查看: 5728|回复: 4
打印 上一主题 下一主题

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

[复制链接]

20

帖子

4

主题

0

精华

入门

F 币
97 元
贡献
48 点
跳转到指定楼层
楼主
发表于 2017-2-9 18:41:01 | 只看该作者 |只看大图 回帖奖励 |倒序浏览 |阅读模式
我想把字符串(如“文件名”)通过vb6.0传入Fortran的动态链接库,程序可以顺利结束,但是传入的字符串没有正确地截断?
vb代码:
[Visual Basic] 纯文本查看 复制代码
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代码:
[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



运行后,输出的结果如下:

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

aa.jpg (31.66 KB, 下载次数: 244)

结果图片

结果图片
分享到:  微信微信
收藏收藏 点赞点赞 点踩点踩

2015

帖子

12

主题

5

精华

论坛跑堂

臭石头雪球

F 币
1574 元
贡献
676 点

美女勋章热心勋章星光勋章新人勋章贡献勋章管理勋章帅哥勋章爱心勋章规矩勋章元老勋章水王勋章

沙发
发表于 2017-2-9 21:57:53 | 只看该作者
ii=Clen(pfilename)
改为
use , intrinsic :: ISO_C_Binding
ii = index( pfilename , c_null_char )
pfilename( ii: ) = ""
删掉整个String_Functions 模块,没用

20

帖子

4

主题

0

精华

入门

F 币
97 元
贡献
48 点
板凳
 楼主| 发表于 2017-2-10 19:10:37 | 只看该作者
根据您的方法,我成功地传入了字符串,代码如下(但是点“结束”按钮却死机了):vb6.0代码:
[Visual Basic] 纯文本查看 复制代码
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


Fortran的DLL代码:
[Fortran] 纯文本查看 复制代码
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


vb的界面如图1。

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


vb界面.png (8.35 KB, 下载次数: 249)

图1

图1

图2.png (2.18 KB, 下载次数: 226)

图2

图2

Image 001.png (65.28 KB, 下载次数: 218)

Image 001.png

Image 002.png (31.5 KB, 下载次数: 233)

图4

图4

20

帖子

4

主题

0

精华

入门

F 币
97 元
贡献
48 点
地板
 楼主| 发表于 2017-2-10 19:15:19 | 只看该作者
对了,发在stackoverflow上的问题也得到了一个回复(他把module模块修改了下),试过也是可以的,也一并贴在这了。
Fortran的代码:
①主程序:
[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,*)trim(filename)
    write(18,*)"the third line"
  close(18)

end subroutine


②module:
[Fortran] 纯文本查看 复制代码
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

2015

帖子

12

主题

5

精华

论坛跑堂

臭石头雪球

F 币
1574 元
贡献
676 点

美女勋章热心勋章星光勋章新人勋章贡献勋章管理勋章帅哥勋章爱心勋章规矩勋章元老勋章水王勋章

5#
发表于 2017-2-10 20:18:26 | 只看该作者
[Fortran] 纯文本查看 复制代码
subroutine char_2( pfilename )
!DEC$ ATTRIBUTES stdcall,DLLEXPORT::char_2
!DEC$ ATTRIBUTES ALIAS:"char_2"::char_2
!DEC$ ATTRIBUTES reference :: pfilename

改为
[Fortran] 纯文本查看 复制代码
subroutine char_2( pfilename )
!DEC$ ATTRIBUTES DLLEXPORT::char_2
!DEC$ ATTRIBUTES ALIAS:"char_2"::char_2


您需要登录后才可以回帖 登录 | 极速注册

本版积分规则

捐赠本站|Archiver|关于我们 About Us|小黑屋|Fcode ( 京ICP备18005632-2号 )

GMT+8, 2024-11-15 07:08

Powered by Tencent X3.4

© 2013-2024 Tencent

快速回复 返回顶部 返回列表