-
aa.jpg (31.66 KB, 下载次数: 245)
结果图片
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 dave_frank@hotmail.com
IMPLICIT NONE ! http://home.earthlink.net/~dave_gemini/strings.f90
! 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
aa.jpg (31.66 KB, 下载次数: 245)
结果图片
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
vb界面.png (8.35 KB, 下载次数: 249)
图1
图2.png (2.18 KB, 下载次数: 227)
图2
Image 001.png (65.28 KB, 下载次数: 218)
Image 002.png (31.5 KB, 下载次数: 234)
图4
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 dave_frank@hotmail.com
IMPLICIT NONE ! http://home.earthlink.net/~dave_gemini/strings.f90
! 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
| 欢迎光临 Fortran Coder (http://bbs.fcode.cn/) | Powered by Discuz! X3.2 |
