gobouさん＞
目的をはずしていたらゴメンナサイ・・
CHOOSEFONT関数で選択した色はLONG型変数に入るそうなので私の場合は
変数 var shared RGBCOLOR as longと指定しておき
if CHOOSEFONT(FFONT,RGBCOLOR,-1,0) then
・・
後、印刷時フォント選択ダイアログで色を選択し、PRT1.SETFORECOLOR RGBCOLOR で
選択した色で印刷しています。
結果的に不都合なく使っていますが、使い方が違っていたらご指摘ください。
declare function SETWINDOWPOS lib "user32" alias "SetWindowPos" (byval HWND as long, byval HWNDINSERTAFTER as long, byval X as long, byval Y as long, byval CX as long, byval CY as long, byval UFLAGS as long) as long
var shared MAINFORM as object
var shared BUTTON1 as object
MAINFORM.ATTACH GETHWND
BUTTON1.ATTACH GETDLGITEM("BUTTON1")
declare sub MAINFORM_START edecl ()
sub MAINFORM_START()
'初期設定（フラグ）
FLG = 1
end sub
'コマンドボタンの処理
declare sub BUTTON1_ON edecl ()
sub BUTTON1_ON()
var RST as long
if FLG = 0 then
'「常に手前に表示」を解除
RST = SETWINDOWPOS(MAINFORM.GETHWND, HWND_NOTTOPMOST, 0, 0, 0,0, SWP_SHOWWINDOW or SWP_NOMOVE or SWP_NOSIZE)
FLG = 1
BUTTON1.SETWINDOWTEXT "「常に手前に表示」する"
MAINFORM.SETWINDOWTEXT "現在は「ノーマル」状態です"
else if FLG = 1 then
'「常に手前に表示」をセット
RST = SETWINDOWPOS(MAINFORM.GETHWND, HWND_TOPMOST, 0, 0, 0, 0, SWP_SHOWWINDOW or SWP_NOMOVE or SWP_NOSIZE)
FLG = 0
BUTTON1.SETWINDOWTEXT "「常に手前に表示を解除」する"
MAINFORM.SETWINDOWTEXT "現在は「常に手前に表示」状態です"
end if
end sub
sub MAINFORM_START()
TIMER1.SETINTERVAL 6000
TIMER1.ENABLE -1
FLG = 0
FORM_STATE
end sub
declare sub BUTTON1_ON edecl ()
sub BUTTON1_ON()
FLG = not(FLG)
FORM_STATE
end sub
sub FORM_STATE()
var RST as long
if FLG = 0 then
RST = SETWINDOWPOS(MAINFORM.GETHWND, HWND_NOTTOPMOST, 0, 0, 0,0, SWP_SHOWWINDOW or SWP_NOMOVE or SWP_NOSIZE)
BUTTON1.SETWINDOWTEXT "「常に手前に表示」する"
MAINFORM.SETWINDOWTEXT "現在は「ノーマル」状態です"
else
RST = SETWINDOWPOS(MAINFORM.GETHWND, HWND_TOPMOST, 0, 0, 0, 0, SWP_SHOWWINDOW or SWP_NOMOVE or SWP_NOSIZE)
BUTTON1.SETWINDOWTEXT "「常に手前に表示を解除」する"
MAINFORM.SETWINDOWTEXT "現在は「常に手前に表示」状態です"
end if
end sub
declare sub TIMER1_TIMER edecl ()
sub TIMER1_TIMER()
MAINFORM.SETFOREGROUNDWINDOW
end sub
(一部省略)で1分ごとにアクティブになりました。自己流のためひょっとしてとんでもないことをしているかも・・
var shared MAINFORM as object :MAINFORM.ATTACH GETDLGITEM("MAINFORM")
var shared TIMER1 as object :TIMER1.ATTACH GETDLGITEM("TIMER1")
var shared EDIT1 as object :EDIT1.ATTACH GETDLGITEM("EDIT1")
declare function SETWINDOWPOS lib "user32" alias "SetWindowPos" (byval HWND as long, byval HWNDINSERTAFTER as long, byval X as long, byval Y as long, byval CX as long, byval CY as long, byval UFLAGS as long) as long
declare sub MAINFORM_START edecl ()
sub MAINFORM_START()
TIMER1.SETINTERVAL 1000
TIMER1.ENABLE -1
end sub
declare sub TIMER1_TIMER edecl ()
sub TIMER1_TIMER()
beep
A= SETWINDOWPOS(MAINFORM.GETHWND, -1, 0, 0, 0, 0, &H43)
MAINFORM.SHOWWINDOW 0
MAINFORM.SETFOCUS
MAINFORM.SHOWWINDOW -1
EDIT1.SETFOCUS
A= SETWINDOWPOS(MAINFORM.GETHWND, -2, 0, 0, 0, 0, &H43)
end sub
declare function APIFINDWINDOW lib "user32" alias "FindWindowA" (byval LPCLASSNAME as string, byval LPWINDOWNAME as string) as long
var IE_HWND as long
IE_HWND = APIFINDWINDOW("IEFrame",byval 0)
tanakaさん＞
RES = API_SETFOREGROUNDWINDOW(MENO_HWND)でアクティブ後
F-Basic自身のメインフォームをアクティブにするんですね？
RES = API_SETFOREGROUNDWINDOW(MAINFORM.GETHWND)でアクティブになりませんか？
佐藤さん＞
RES = POSTMESSAGE&(IE_HWND,WM_COMMAND,&HA043,0)
一度コピーしたものをペーストしているようです。文字数の多いところで試すと時間が
かかりますし、
RES = POSTMESSAGE&(IE_HWND,WM_COMMAND,&HA042,0)の１行を抜くと選択解除にはなりま
せん。
RES = POSTMESSAGE&(IE_HWND,WM_LBUTTONDOWN,0,0)
RES = POSTMESSAGE&(IE_HWND,WM_LBUTTONUP,0,0)
のように、マウスをDOWNおよびUPの両方を送るといいようです。
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
var IE_HWND as long
IE_HWND = WINAPI_APIFINDWINDOW("IEFrame",byval 0)
if hex$(IE_HWND)<>"0" then
RET = WINAPI_POSTMESSAGE(IE_HWND,&H111,&HA044,0) 'すべて選択
RET = WINAPI_POSTMESSAGE(IE_HWND,&H111,&HA042,0) 'コピー
end if
exit sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
declare sub MainForm_Start edecl ()
sub MainForm_Start()
Button1.MoveWindow 100,50
Button1.SetWindowSize 80,25
Button1.SetFontName "ＭＳ 明朝"
Button1.SetFontSize 14
Button1.SetWindowText "abcde"
end sub
var shared text(30) as object
var shared edit(10) as object
for i = 1 to 30
text(i).attach getdlgitem("text"+trim$(str$(i)))
select case i
case 1 to 5
text(i).setfontsize 12
case 6 to 20
text(i).setfontsize 14
case else
text(i).setfontsize 20
end select
next i
for i = 1 to 10
edit(i).attach getdlgitem("edit"+trim$(str$(i)))
edit(i).setfontsize 14
next i
お世話になります。
end sub以降で下記の症状が発生します。end sub以降はどのような処理しているの
かもし、ご存知の方がおりましたら参考程度で教えて頂けませんでしょうか。
宜しくお願い致します。
症状
Win95では特にテスト_Onを起動後STOPまでは問題ありませんでしたが、end subを
実行しますと即終了するはずがメニューに設置してありますビットマップボタン
(BMPBUTTON)の部分が数秒間色抜け（白色）状態になります。その後、終了状態に
なります。
declare sub テスト_On edecl ()
sub テスト_ON()
・
・
STOP
end sub
if G_TESTON then テストで テストの代わりにstopまたendなどを設けてテストしました。
endは即終了されます。stopは即停止になります。stopを実行しますと数秒後になって停止状態になります。
詳しい事は解りませんが、イベントの停止する為のSystem内のdllが関係しているのかと思っていますが？
API見習い中のＴＯＫＯです・・
>例 declare function API_XYZ & lib "ABC" alias "XYZ" ( byval A$ , byval ・・・・ )
上記の場合
API_XYZと&の間に空白が入っていないとしてAPI_XYZ&は自由に変更することができます。
DLLの部分"ABC"および関数名"XYZ"は変数に置き換える人はいないでしょうが
#define Z$ "ABC"
#define W$ "XYZ"
declare function API_XYZ& lib Z$ alias W$ ( byval A$ , byval ・・・・ )でも動きます。
例えば下記のAPIをF-BASICで使いたい場合、
Public Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" _
(ByVal dwExStyle As Long, ByVal lpClassName As String, _
ByVal lpWindowName As String, ByVal dwStyle As Long, _
ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hWndParent As Long, _
ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
ＴＯＫＯさん
APIのDestroyWindowのご回答によりまして
作成後のビットマップボタンをプログラムで取り除く事ができました。
if (GETDLGITEM("Bmpbutton21"))<>0 then RET=winapi_DestroyWindow(GETDLGITEM("Bmpbutton21"))
お陰様で目的通りのものが出来ました。
心より厚くお礼を申しあげます。
本当にありがとうございました。
SUB SORT(TOTALCNT1&,ITI,ZYUN$)
SELECT CASE ZYUN$
CASE IS = "U"
for L& = TOTALCNT1& to 1 step -1
for J& = 1 to L& - 1
if SORTWORK1(J&, ITI) > SORTWORK1(J& + 1, ITI) then
for M = 1 to 6
swap SORTWORK1(J&, M), SORTWORK1(J& + 1, M)
next
endif
next
next
CASE IS = "D"
For L& = TOTALCNT1& to 1 step -1
for J& = 1 to L& - 1
if SORTWORK1(J&, ITI) < SORTWORK1(J& + 1, ITI) then
for M = 1 to SORTKOUMOKU
swap SORTWORK1(J&, M), SORTWORK1(J& + 1, M)
next
endif
next
next
END SELECT
ENDSUB
open "sort.txt" for output as #1
for j&=1 to 50000
nen$=right$( space$(3)+str$( SORTWORK1(J&, 2) ),3 )
kin&=1000000&-val( SORTWORK1(J&, 6) ) '金額は0〜999999(6桁)の場合
kin$=right$( space$(6)+str$( abs(kin$) ),6 )
print #1, nen$+kin$+right$( space$(5)+str$(j%),5 )
next j&
close #1
open "sort.out" for input as #1
while not eof(1)
line input #1, buf$
code&=val( right$( sortkey$(j&),5 ) )
for m=1 to 6
print SORTWORK1(code&, 6)
next m
wend
L$ = "テキストファイル(*.TXT)"
F$ = WINSAVEDLG("ファイルの保存","3DG.BAS",FL$,0)
if F$ <> chr$(&H1B) then
'実際はリネームする前にPATHを分解する必要があります。
'また既に同名のファイルがあった場合に削除する処理も必要と思われます
IF RIGHT$(UCASE$(F$),4)><".TXT" THEN NAME F$ AS F$+".TXT"
endif
L$ = "datファイル(*.dat)"
F$=WINSAVEDLG("新しい名前をつけて保存","main.dat",L$,0)
if F$<>chr$(&H1B) then
open F$ for create as #1
print #1
if right$(ucase$(F$),4)><".DAT" then name F$ as F$+".DAT"
再度、お世話になります。
webをタグにできるサンプルがありましたので一部手を加えました。
-------------------------------------------------------------------
Private Sub Command1_Click()
Dim ObjIE As Object
Dim myHTML As String
Dim iFileNo As Integer
Label1 = "なし"
Text1 = myHTML
If InStr(Text1, "FRAMESET") <> 0 Then Label1 = "あり"
End Sub
--------------------------------------------------------------------
ｖｂにつきましてはDim→Ver変換及びｖｂ、F-BASIC共通についての知識しかない初心者です。
上記のｖｂサンプルをF-BASICに置き換えれればと思っていますが可能でしょうか。
ご存知の方がおりましたらご指導して頂ければと思います。宜しくお願い致します。
WHILE 1
IF IEXECTIME>=INT(MILLITIME/1000) THEN
' ↑IEXECTIME=INT(MILLITIME/1000) では無いのを確認して下さい
'(60*5)秒に1回行う処理をここへ
IEXECTIME=IEXECTIME+(60*5)
ENDIF
WEND
-----
タイマーを使うのなら１秒に設定し…
NXTIME$="10:05:10"
'↑実際にはTIME$から5分後を作るルーチンが必要です
Private Sub Timer1_Timer()
IF NXTIME$>=TIME$ THEN
If hWndIE <> 0 Then Ret = PostMessage(hWndIE, &H111, &HA220, 0) 'IE更新
「むだい」さんのホームページにある「カレントフォルダの取得（ＡＰＩ）」を利用させて頂き下記のようなプログラムにしましたが、標記のようなエラーを発生してしまいます。
◆エラー発生してしまうプログラム（メイン部分のみ）
-------------------------------------------------
DT$=PATHNAME+"\ABC.dat"【←「PATHNAME」は「むだい」さんのサンプルのまま利用させて頂いています】
open DT$ for input as #1
input #1,XTZ$
close #1
-------------------------------------------------
◆実行時エラー発生表示内容→「○○.bas エラー[63]指定のファイルが見つかりません」
ＯＳはWindowsXP Home edition です。（他のＯＳは未確認です）
コンパイルした「exe」ファイルを直接起動した場合やディスクトップにショートカットを置いて、更にそのショートカットを「スタートボタン」にドロップして、ショートカットを作った場合はエラー発生しません。
もし、既に同じトラブルの解決方法が記載されているホームページなどありましたら、教えて頂ければ幸いです。
よろしくお願い致します。
スレッド型もいくつかの種類がありますのでその中で削除可能な掲示板があればご指導頂けると助かります
KENT WEBでスレッド型でCGI型（レンタルでは無いので自分でCGI設置が必要なもの）がありました
KENT WEBのスレッド型掲示板は投稿者自身の削除が可能なのですが、geocitiesがCGIに対応しておりません
CGI設置が可能な所を探してみます
尚、レンタル掲示板でスレッド型で削除が可能なのがあればすぐに設置出来ますのでご指導頂けると助かります
// File version info ===
1 VERSIONINFO
FILEVERSION 1,0,0,0
PRODUCTVERSION 1,0,0,0
FILEFLAGSMASK 0x3fL
FILEFLAGS 0x0L
FILEOS 0x40004L
FILETYPE 0x1L
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "041103a4"
BEGIN
VALUE "Comments", "\0"
VALUE "CompanyName", "\0"
VALUE "FileDescription", "\0"
VALUE "FileVersion", "1, 0, 0, 0\0"
VALUE "InternalName", "\0"
VALUE "LegalCopyright", "\0"
VALUE "OriginalFilename", "\0"
VALUE "ProductName", "\0"
VALUE "ProductVersion", "1, 0, 0, 0\0"
END
END
BLOCK "VarFileInfo"
BEGIN
VALUE "Translation", 0x411, 932
END
END
--------
Declare Sub Edit1_Change edecl ()
Sub Edit1_Change()
Ed1$ = GetDlgItemText("Edit1")
EPos = InStr(Ed1$, CrLf$)
If EPos <> 0 Then
Ed1$ = Mid$(Ed1$, 1, EPos - 1) & Mid$(Ed1$, EPos + 2)
Edit1.SetWindowText Ed1$
Edit2.SetFocus
End If
End Sub
諸先輩方教えてください
サンプルで
var PP as PRINTPARAM
var PRINTER as object
PRINTEROBJECT PRINTER
if PRINTER.PRINTDLG(PP) then
SETMOUSEPOINTER 2
PRINTER.STARTDOC "文書"
PRINTER.STARTPAGE
PRINTER.DRAWGRP
PRINTER.ENDPAGE
PRINTER.ENDDOC
PRINTER.CLOSEPRINTER
SETMOUSEPOINTER 0
endif
で印刷するとき行間を指定したいのですが・・・・
No544で投稿したひろです。
未だにODBCがよくわかりません
FBASICV63のサンプルでODBC.MAKを使ってMS-SQL-Serverに接続できません
'========================================================================
'= 接続／クエリ =
'========================================================================
' 入力：OBJ 結果を設定するコントロール（リストボックス）
' 入力：DATANAME$ データベース名
' 入力：SQL_COMMAND$ SQLコマンド
function EXEC_ODBC( OBJ as object, DATANAME$, SQL_COMMAND$ )
var HDBC as long ' DB HANDLE
var HSTMT as long ' SQL Statement HANDLE
var RCODE as integer ' 復帰コード
' 初期化
if SQL_SUCCESS<>SQLALLOCCONNECT( HENV, HDBC ) then goto *_ERR
if SQL_SUCCESS<>SQLCONNECT( HDBC, DATANAME$, SQL_NTS, "", SQL_NTS, "", SQLNTS ) then goto *_ERR ->ここで落ちる
if SQL_SUCCESS<>SQLALLOCSTMT( HDBC, HSTMT ) then goto *_ERR
' SQLコマンドの実行
if SQL_SUCCESS<>SQLEXECDIRECT( HSTMT, SQL_COMMAND$, SQL_NTS ) then goto *_ERR
現在の私の解決策は エディタでＩＭＥより使用する外字を配列文字変数にコピーして
その変数を表示する（symbol or ?）、配列の１番が jis &H7f21 に該当する。
data でソースプログラムに書き込むとか別ファイルで保存するとかしています。
ＡＰＩを使用するより、こんな馬鹿げた方法が簡単な気がします。
何かいい方法があったら教えてください。
226 open "tcz2013" for input as #2 'datdat10
227 ta!=0
228 while not eof(2)
229 ta!=ta!+1
230 input #2,DCO#(TA!),DHI(TA!),DNM!(TA!),DDA$(TA!),DNA$(TA!),DBL$(TA!),DNM$(TA!),DNO(TA!),DPR!(TA!),DPZ!(TA!),DCP(TA!),DPL(TA!)
231 'print DCO#(TA!),DHI(TA!),DNM!(TA!),DDA$(TA!),DNA$(TA!),DBL$(TA!),DNM$(TA!),DNO(TA!),DPR!(TA!),DPZ!(TA!),DCP(TA!),DPL(TA!)
232 'if DNM!(TA!)=81118 then 236 'テータの終わりを認識してくれるかどうか
235 wend
236 close #2
open "tcz2013" for input as #2 'datdat10
△open "tcz2013" for input as #3 'datdat10を二度開く(LINE INPUT用)
TA!=0
while not eof(2)
△line input #3, DTEST$
△if len(trim$(DTEST$))<12 then print "Over!",TA!:exit 'データの終わりをオーバー？
TA!=TA!+1
input #2,DCO#(TA!),DHI(TA!),DNM!(TA!),DDA$(TA!),DNA$(TA!),DBL$(TA!),DNM$(TA!),DNO(TA!),DPR!(TA!),DPZ!(TA!),DCP(TA!),DPL(TA!)
'print DCO#(TA!),DHI(TA!),DNM!(TA!),DDA$(TA!),DNA$(TA!),DBL$(TA!),DNM$(TA!),DNO(TA!),DPR!(TA!),DPZ!(TA!),DCP(TA!),DPL(TA!)
'if DNM!(TA!)=81118 then exit 'テータの終わりを認識してくれるかどうか
wend
close #2
△close #3
'**** FILE1の末尾にFILE2の内容(テキストデータ)を追加する。
var L1 as long '読み込んだ行数
var L2 as long '実際に追記した行数
var DTEST$
open "FILE1.TXT" for append as #2 'このファイルに追記する
open "FILE2.TXT" for input as #3 '読み込むデータ
L1=0
L2=0
while not eof(3)
L1=L1+1
if L1>=20000& then print "LoopBreak!":exit '***ＥＯＦが効かない？
line input #3, DTEST$
if not (len(trim$(DTEST$))<12) then '空行等でなければ出力
L2=L2+1
print #2,DTEST$
endif
wend
close #2
close #3
'**** F-BASICにより自動付加されたファイル末尾のＥＯＦコードを削除する。
DTEST$=space$(1) '読み込むバイト数の桁の領域確保
open "FILE1.TXT" for binio as #2 '対象(※追記したファイル)
if lof(2)<>0 then 'ファイルの内容が空でないこと
seek #2,-1,2 '***mode 2:ファイルの末尾から -n移動
fread #2,DTEST$ '確認のため一度読み込む
if DTEST$=chr$(&H1A) then 'EOFコードかどうか確認する
seek #2,-1,2 '再度、移動する(※EOFコードの位置)
truncate #2 '現在の位置からファイルの内容を切り捨てる
endif
endif
close #2
プロジェクトファイル(*.MAK)の役目はおおまかに、
・メニュー:プロジェクト(P) - 環境(E) のダイアログで設定する内容を記録する
・一つの実行可能形式ファイル(.EXE)を作るために必要なソースファイル等の一覧を記録
a. (一つまたは複数の)BASICソースプログラム(.BAS、.SUB)
b. リソースファイル(.RC)およびアイコンファイルやその他のファイル
c. 必要な追加ライブラリやオブジェクトファイル
・個々のファイルを再コンパイル(翻訳)して実行可能形式ファイルを再作成する
かどうかの判断材料にする
(作成例):Outlook Expressでの場合 (文字はANSI、JISコードで)
□From: "test name" <test@example.com>
□To: <sample@example.com>
□Subject: TestTitle
□MIME-Version: 1.0
□Content-Type: text/plain;
□ charset="iso-2022-jp"
□Content-Transfer-Encoding: 7bit
□X-Mailer: Microsoft Outlook Express 6.00.9999.9999
□X-MimeOLE: Produced By Microsoft MimeOLE V6.00.9999.9999
□
□TEST MAIL TEST MAIL
var CM$, R$
baud 0,9600
CM$="COM0:(S7N2N7NNN)"
open CM$ for output as #2 : open CM$ for input as #1
WAIT 100
print"!!送信始!!" : print#2,"D" ' コマンド送信
while eof(1) :print"*"; :wend ' 受信開始までループ
R$=input$(1,#1) :print:print"!!受信あり!!"
WAIT 100
if LOF(1)>0 then R$=R$ + input$(LOF(1),#1)
close
stop : end
1 var CM$, R$
2 baud 0,9600
3 CM$="COM0:(S7N2N7NNN)"
4 open CM$ for output as #2 : open CM$ for input as #1
5 WAIT 100
6 print"!!送信始!!" : print#2,"D" ' コマンド送信
7 while eof(1) :print"*"; :wend ' 受信開始までループ
8 R$=input$(1,#1) :print:print"!!受信あり!!"
9 wait 100
10 if LOF(1)>0 then R$=R$ + input$(LOF(1),#1)
11 close
12 stop : end
line input#1,R$(0) :print "!!Frame-1入力終"
line input#1,R$(1) :print "!!Frame-2入力終"
line input#1,R$(2) :print "!!Frame-3入力終"
line input#1,R$(3) :print "!!Frame-4入力終"
close
for I%=0 to 4 - 1
if len(R$(I%))=0 then R$(I%)=space$(14 - 1)
for J%=1 to len(R$(I%))
' もし、ヌルキャラクタがあれば空白に置き換え
if asc(mid$(R$(I%),J%,1))=&H0 then mid$(R$(I%),J%,1)=" "
next J%,I%
print "1):";R$(0) ;"<"
print "2):";R$(1) ;"<"
print "3):";R$(2) ;"<"
print "4):";R$(3) ;"<"
Type T_DCB
DCBlength As Long
BaudRate As Long
fBitFields As Long ' Bits
wReserved As Integer
XonLim As Integer
XoffLim As Integer
ByteSize As Byte
Parity As Byte
StopBits As Byte
XonChar As Byte
XoffChar As Byte
ErrorChar As Byte
EofChar As Byte
EvtChar As Byte
wReserved1 As Integer
end type
declare function CREATEFILE lib "kernel32" alias "CreateFileA" (byval LPFILENAME as string,
byval DESACC as long, byval SHAREMODE as long,
byref LPSECUATTR as any, byval CREDISPOS as long,
byval FLAGSATTR as long, byval HTEMPLFILE as long) as long
declare function CLOSEHANDLE lib "kernel32" alias "CloseHandle" (byval HOBJECT as long) as long
declare function GETCOMMSTATE lib "kernel32" alias "GetCommState" (byval NCID as long,
LPDCB as T_DCB) as long
declare function SETCOMMSTATE lib "kernel32" alias "SetCommState" (byval HCOMMDEV as long,
LPDCB as T_DCB) as long
declare function TEST1_CBIT(V as long,B as long) as long
function TEST1_CBIT(V as long,B as long) as long
var I as long,J as long
TEST1_CBIT=V
if B=0 then error 5:exit function
if B<0 then error 11:exit function '未実装
I=B :J=1
do while (I mod 2 = 0)
J=J * 2 : I=I \ 2
loop
TEST1_CBIT=(V and B) \ J
if ((V and B) mod J) <> 0 then error 21
end function
declare sub TEST1_GetState()
sub TEST1_GETSTATE()
var RES as long
var hfile as long
var DCB as T_DCB
var F as long
HFILE=INVALID_HANDLE_VALUE
HFILE = CREATEFILE("COM1", (GENERIC_READ or GENERIC_WRITE), 0, NULL, OPEN_EXISTING, 0, NULL)
if HFILE= INVALID_HANDLE_VALUE then print "Error:open失敗":exit sub
RES=GetCommState(hfile, DCB)
if RES=0 then
print "Error:GetCommState"
RES=CLOSEHANDLE(HFILE)
else
RES=CLOSEHANDLE(HFILE)
>※GW-BASICの",rs"オプションが気になりますが。
>(RS suppresses detection of RTS(Request To Send))
QuickBasicのマニュアルにも"RTSを抑制する"とありましたが、「抑制」とはどういう意味で使われているのでしょうね。いままでよくわからずに使っていました。
private declare function ADDR(byref A as long) as long
function ADDR(A as long) as long
'print "test=";hex$(varadr(A))
ADDR=A
end function
declare function _PBGETDCBNO alias "_$PbGetDCBNo@4" (byval FILENO as long) as long
declare function _PBGETDCB alias "_$PbGetDCB@4" (byval FBDCBNO as long) as long
declare function FB63_GETFILEHANDLE bdecl (byval FILENO as integer) as long
function FB63_GETFILEHANDLE (byval FILENO as integer) as long
var FBDCBNO as long, FBDCBDATA as long
FB63_GETFILEHANDLE= INVALID_HANDLE_VALUE
select case FILENO
case 1 to 255
FBDCBNO= -1
FBDCBNO= _PBGETDCBNO(clng(FILENO))
if FBDCBNO = -1 then error 57:exit function
FBDCBDATA=0
FBDCBDATA=_PBGETDCB(FBDCBNO)
if FBDCBDATA = 0 then error 60:exit function
FB63_GETFILEHANDLE=FBDCBDATA
FBDCBDATA=FBDCBDATA+&H108 'オフセット
FB63_GETFILEHANDLE=ADDR(byval FBDCBDATA)
case else
error 50
end select
end function
declare sub TEST2_SETSTATE(byval FILENO%)
sub TEST2_SETSTATE(byval FILENO%)
var RES as long
var DCB as T_DCB, HFILE as long
var F as long, M as long
HFILE= FB63_GETFILEHANDLE(FILENO%)
if HFILE=0 or HFILE=-1 then HFILE=INVALID_HANDLE_VALUE
if HFILE= INVALID_HANDLE_VALUE then print "Error:open":exit sub
RES=GetCommState(hfile, DCB) 'ポートの設定取得
if res=0 then
print "Error:GetCommState"
else
if DCB.DCBLENGTH<>len(T_DCB) then print "!!DCBlength(hex)=";DCB.DCBLENGTH
print "fBitFields(16進数)変更前=";hex$(DCB.FBITFIELDS)
'＊＊ここで設定を変更する＊＊
F=DCB.FBITFIELDS '＊bit毎設定必要
'----fRtsControl----
F=F and (not FRTSCONTROL) 'ビット消去
M=FRTSCONTROL :M=M and (M \ 2) '※下位ビットを残す
M=M * RTS_CONTROL_TOGGLE '設定値
F=F or M 'ビット設定
print "fRtsControl書換";RTS_CONTROL_TOGGLE ;" (RTS フロー制御:0..3)"
'--------
DCB.FBITFIELDS=F '設定
'＊＊＊＊
print "fBitFields(16進数)変更後=";hex$(DCB.FBITFIELDS)
'設定を強制更新する
RES=SetCommState(hfile, DCB)
if res=0 then
print "Error:SetCommState"
endif
endif
end sub
'－－－－－－－－
var CM$, R$(4-1)
baud 0,9600
CM$="COM0:(S7N2N7NNN)"
open CM$ for output as #2 : open CM$ for input as #1
TEST2_SETSTATE 2 '←ファイル番号のCOM設定を強制変更する
WAIT 100
if not eof(1) then print "!!受信バッファが空でない！"
print"!!送信始!!"
print#2,"D";chr$(13);
wait 50
while eof(1) :print"*"; :wend ' 受信開始までループ
print:print"!!受信始!!"
wait 5
while lof(1) < 14*4 :print"."; :wait 5 :wend ' 全フレーム受信までループ
print:print"!!受信終!!"
line input#1,R$(0) :print "!!Frame-1入力"
line input#1,R$(1) :print "!!Frame-2入力"
line input#1,R$(2) :print "!!Frame-3入力"
line input#1,R$(3) :print "!!Frame-4入力"
close
stop:end
declare sub TEST1_SETSTATE_NULLCHAR(FDSCRP$, byval SW%= 0)
sub TEST1_SETSTATE_NULLCHAR(FDSCRP$, byval SW%)
var RES as long, DCB as T_DCB
var HFILE as long
var F as long, M as long
var DEVNAME$
if SW%<0 then SW%=0
if SW%> 1 then SW%=1
select case ucase$(left$(FDSCRP$,5))
case "COM0:"
DEVNAME$="COM1"
case "COM1:"
DEVNAME$="COM2"
case "COM2:"
DEVNAME$="COM3"
case "COM3:"
DEVNAME$="COM4"
case "COM4:"
DEVNAME$="COM5"
case else
error 55 :exit sub
end select
HFILE=INVALID_HANDLE_VALUE
HFILE = CREATEFILE(DEVNAME$, (GENERIC_READ or GENERIC_WRITE), 0, NULL, OPEN_EXISTING, 0, NULL)
if HFILE= INVALID_HANDLE_VALUE then print "Error:open失敗":exit sub
RES=GetCommState(hfile, DCB)
if res=0 then
print "Error:GetCommState"
RES=CLOSEHANDLE(HFILE)
else
if DCB.DCBLENGTH<>len(T_DCB) then print "!!DCBlength(hex)=";DCB.DCBLENGTH
'＊＊ここで設定を変更する＊＊
F=DCB.FBITFIELDS '＊bit毎設定必要
'----fNull----
F=F and (not fnULL) 'ビット消去
M=fnULL
M=M * clng(SW%) '設定値
F=F or M 'ビット設定
if DCB.FBITFIELDS <> F then
print "fBitFields(16進数)変更前=";hex$(DCB.FBITFIELDS)
DCB.FBITFIELDS=F '設定
print "fBitFields(16進数)変更後=";hex$(DCB.FBITFIELDS)
'設定を更新する
RES=SetCommState(hfile, DCB)
if res=0 then
print "Error:SetCommState"
endif
endif
RES=CLOSEHANDLE(HFILE)
endif
end sub
原文はつぎのとおりです。
RTS_CONTROL_TOGGLE (0x03): トグルモード
Specifies that the RTS line will be high if bytes are available for transmission.
After all buffered bytes have been sent, the RTS line will be low.
declare sub TEST2_SETSTATE(byval FILENO%)
sub TEST2_SETSTATE(byval FILENO%)
var RES as long
var DCB as T_DCB, HFILE as long
var F as long, M as long
HFILE= FB63_GETFILEHANDLE(FILENO%)
if HFILE=0 or HFILE=-1 then HFILE=INVALID_HANDLE_VALUE
if HFILE= INVALID_HANDLE_VALUE then print "Error:open":exit sub
RES=GetCommState(hfile, DCB) 'ポートの設定取得
if res=0 then
print "Error:GetCommState"
else
if DCB.DCBLENGTH<>len(T_DCB) then print "!!DCBlength(hex)=";DCB.DCBLENGTH
print "fBitFields(16進数)変更前=";hex$(DCB.FBITFIELDS)
'＊＊ここで設定を変更する＊＊
F=DCB.FBITFIELDS '＊bit毎設定必要
'----fRtsControl----
F=F and (not FRTSCONTROL) 'ビット消去
M=FRTSCONTROL :M=M and (M \ 2) '※下位ビットを残す
M=M * RTS_CONTROL_TOGGLE '設定値
F=F or M 'ビット設定
print "fRtsControl書換";RTS_CONTROL_TOGGLE ;" (RTS フロー制御:0..3)"
'--------
DCB.FBITFIELDS=F '設定
'----fNull----
M=fnULL '設定値
F=F or M 'ビット設定
print "fNull書換";" (NULL BYTES 受信を破棄する)"
・「コマンド送信 〜 データ受信完了」の一連のサイクルを高速で繰り返してはならない。
資料( >611 )より、
Caution:
For exact measurement and good communication with PC, use “data request” signal
once per one second.
Data Conversion time:
Data Conversion time is based on conversion time of ADC included in DMM and is 2 or
3 times per one second.
[翻訳]
注意:正確な測定とPCとの良好な通信のためには、1秒に1度「データ要求」信号を使用する。
データ変換時間:データ変換時間は、DMM内蔵ADC(訳注:アナログ－デジタル変換)の変換時間を
基本として、1秒あたり2〜3回である。
[了]
declare function LTRIMCTRL bdecl (S as string) as string
function LTRIMCTRL$ (S$)
'機能：引数で指定された文字列の左側の制御コード等を取り除きます。
var I as long ,P as long ,N as long
LTRIMCTRL$=S$
N=len(S$)
if N=0 then exit function
P=0 :I=0
do
I=I+1
select case asc(mid$(S$,I,1))
case is < &H20
case &H7F,&HFF
case else
exit do
end select
P=P+1
loop while I < N
if P > 0 then LTRIMCTRL$=mid$(S$,P+1)
end function
var FRUN as long,FEND as long
var TT&(50), RR$(4-1, 50) as string * 13 'データ保管領域確保
var TIMER1 as object
var CM$, R$(4-1), CNT1&, CNT2&, I&
TIMER1.ATTACH GETDLGITEM("TIMER1")
TIMER1.SETINTERVAL 50 ' (10ms単位)
baud 0,9600
CM$="COM0:(S7N2N7NNN)"
open CM$ for output as #2 : open CM$ for input as #1
TEST2_SETSTATE 2 '←ファイル番号の対応COM設定を強制変更する
wait 100
if not eof(1) then R$(0)=input$(lof(1),#1):R$(0)="" '最初の(00h)を捨てる
while CHECKEVENT :CALLEVENT :wend
TIMER1.ENABLE -1 'タイマー通知開始
*LOOP1
'イベント発生して処理されるまで待つ(かつ変数FRUNでタイマーイベントを待つ)
while FRUN=0 :WAITEVENT :wend
if FEND then *ENDING '中止して終了する
CNT1&=CNT1&+1
print#2,"D";chr$(13);
TT&(CNT1&)=millitime ' 00:00:00からの通算時間の値(1ms単位)
if CHECKEVENT then CALLEVENT
wait 10 '受信データ作成待ち
while eof(1) and FEND=0 :CALLEVENT :wend ' 受信開始までループ
if FEND then *ENDING
if lof(1) < 14 and FEND=0 then wait 5 :CALLEVENT ' １行受信までもう少し待つ
if CHECKEVENT then CALLEVENT
if lof(1) < 14 then
print "!!データ受信エラー!!";lof(1)
R$(0)="":if lof(1) <> 0 then R$(0)=input$(lof(1),#1)
R$(1)="":R$(2)="":R$(3)=""
else
line input#1,R$(0) :if CHECKEVENT then CALLEVENT
line input#1,R$(1) :line input#1,R$(2) :line input#1,R$(3)
endif
RR$(0,CNT1&)=R$(0):RR$(1,CNT1&)=R$(1):RR$(2,CNT1&)=R$(2):RR$(3,CNT1&)=R$(3)
CNT2&=CNT2&+1
while CHECKEVENT :CALLEVENT :wend '未処理イベントの処理
FRUN=0 '次のタイマー通知へ
if CNT1& < 50 then *LOOP1 '繰り返し
*ENDING
if CHECKOBJECT(TIMER1) then TIMER1.ENABLE 0 'タイマー停止
if CHECKEVENT then CALLEVENT
if CHECKOBJECT(TIMER1) then TIMER1.DETACH 'オブジェクトと切り離し
close
'これはテスト：データ画面表示
for I&=1 to 50:print TT&(I&),RR$(0,I&);RR$(1,I&);RR$(2,I&);RR$(3,I&):next
return
'================================================================
' タイマーイベント プロシージャ
declare sub TIMER1_TIMER edecl ()
sub TIMER1_TIMER()
shared FRUN as long, FEND as long
shared TIMER1 as object
var RES as long
'print "Test:タイマー";time$
if FRUN then
TIMER1.ENABLE 0 'タイマー停止
FRUN=-1:FEND=-1 '終了
RES=MESSAGEBOX("TIMER1","処理時間があふれました！",0,0)
exit sub
end if
FRUN=-1 'タイマー通知があった
end sub
'================================================================
' メインフォーム が閉じられようとしている
declare sub MAINFORM_QUERYCLOSE edecl ( CANCEL%, byval MODE% )
sub MAINFORM_QUERYCLOSE( CANCEL%, byval MODE% )
shared FRUN as long, FEND as long
FRUN=-1
FEND=-1 '処理終了させる
end sub
OWARI =(millitime/1000.0)
do
NOW =(millitime/1000.0):if NOW < OWARI then NOW=NOW+86400
if NOW >= OWARI+KANKAKU then print date$,time$,millitime :OWARI=NOW
loop
KAISU%=KAISU%+1 :loop
'
stop:end
*KAKE: print date$,time$ :return
'
*JUSTTIME2:return
*JUSTTIME
OWARI=KANKAKU-(time mod KANKAKU)
if OWARI >= 2 then '差が2秒以上あるならば、
interval OWARI-1 '秒単位の割り込み。ただし１秒残す。
on interval gosub *JUSTTIME2
interval on
waiti '設定している割り込みが発生するまで停止します。
interval off
end if
OWARI=1000-(millitime mod 1000)
if OWARI >= 100 then
wait (OWARI \ 100)*10 '1/100秒単位：0.1秒粗く待つ
endif
OWARI=1000-(millitime mod 1000)
if MUGEN_NN then for MUGEN_CC=(MUGEN_NN / 1000)*(OWARI \ 10)*10 to 0 step -1:MUGEN_NN=MUGEN_NN:next
if KANKAKU-((millitime \ 1000) mod KANKAKU)>= 2 then print "Time Over!!"
OWARI=1000-(millitime mod 1000)
MUGEN_CC=0
do 'ループしてmillitimeを秒単位チェック待ち
MUGEN_CC=MUGEN_CC+1
NOW=(millitime \ 1000) mod KANKAKU
loop until NOW=0
return
'
*MUGENSENS2 :MUGEN_NN=MUGEN_CC :return
*MUGENSENS
interval 1
on interval gosub *MUGENSENS2
MUGEN_CC=0:MUGEN_NN=0
interval on
waiti '１回目発生待ち
for KAISU%=1 to 3
do '２回目以降でループ回数カウント
MUGEN_CC=MUGEN_CC+1
loop until MUGEN_NN
if MUGEN_NN < MUGEN_NN2 or MUGEN_NN2=0 then MUGEN_NN2=MUGEN_NN
MUGEN_NN=0:MUGEN_CC=0
next KAISU%
MUGEN_NN=MUGEN_NN2
interval off
return
end
if NOW >= OWARI+KANKAKU
この方法の場合、計測間隔の精度はいいのですが、時間的確度はだんだん正の方にずれて行ってしまいます。やはり、millitimeを基本に計測間隔±0.005秒とかの設定にした方がいいみたいです。ただし、この方法では一度ずれてしまうと、戻らなくなる可能性があります。
いかに無限ループでmillitimeを観測しようと、プリエンティブなマルチタスクOSなので、
どこかで実行権を剥奪されるので、タスク切り換え単位以下の精度を維持しつづけることは
できないので、計測時間範囲で平均値を維持するのがやっとのはずです。
まあ極論、OSをWindows Ver.3.1、F-BASIC for Windows (V3.1)にすればということですが。
CHK_TIME%=((time mod 60)+2) mod 60 'リミットをおよそ2秒後に設定
do while lof(1) < 90
if (time mod 60) = CHK_TIME% then print "＊＊受信エラー＊＊" :exit do
loop
if lof(1) < 90 then GPGGA$=input$(lof(1), #1) else GPGGA$=input$(90, #1)
if right$(GPGGA$,1)=chr$(13) then GPGGA$=left$(GPGGA$, len(GPGGA$) - 1)
ソフト・ハード両環境によるが、次の1行を順次変更することで精度を上げられるかもしれません。
→→ if OWARI>=30 and OWARI < 100 then wait (1+(OWARI \ 10)) :return
1. if OWARI>=30 and OWARI < 100 then wait (0+(OWARI \ 10)) :return
2. if OWARI>=30 and OWARI < 100 then wait (0+(OWARI \ 10))
3.コメントアウトしてプログラムから外す。
※2、3の変更案は、負荷がかかります。
*JUSTTIME2:return
*JUSTTIME
OWARI=millitime
if (OWARI mod 1000)>=900 and KANKAKU>=2 then
OWARI=1000-(OWARI mod 1000)
wait 1+(OWARI \ 10) 'ここは越えるようにする
endif
OWARI=KANKAKU-((millitime \ 1000) mod KANKAKU)
if OWARI >= 2 then '差が2秒以上あるならば、
interval OWARI-1 '秒単位の割り込み。ただし１秒残す。
on interval gosub *JUSTTIME2
interval on
waiti '設定している割り込みが発生するまで停止します。
interval off
end if
OWARI=1000-(millitime mod 1000)
if OWARI >= 100 then
wait (OWARI \ 100)*10 '1/100秒単位：0.1秒粗く待つ
endif
OWARI=1000-(millitime mod 1000)
if OWARI>= 100 then MUGEN_CC=-1:return '←TIME OVER!!
OWARI=millitime
if KANKAKU-((OWARI \ 1000) mod KANKAKU)>= 2 then
MUGEN_CC=-1 :return '←TIME OVER!!
OWARI=1000-(OWARI mod 1000)
else
OWARI=1000-(OWARI mod 1000)
endif
OWARI=1000-(millitime mod 1000)
MUGEN_CC=0
if OWARI >= 100 then return
if OWARI>=30 and OWARI < 100 then wait (1+(OWARI \ 10)) :return
if KANKAKU < 2 then
do 'ループしてmillitimeを秒未満チェック待ち
MUGEN_CC=MUGEN_CC+1
NOW=(millitime mod 1000)
loop until NOW<900
else
do 'ループしてmillitimeを秒単位チェック待ち
MUGEN_CC=MUGEN_CC+1
NOW=(millitime \ 1000) mod KANKAKU
loop until NOW=0
endif
return
KAISU%=KAISU%+1 :loop
'
stop:end
*KAKE: print date$,time$ :return
'
*JUSTTIME2:return
*JUSTTIME
OWARI=millitime
if (OWARI mod 1000)>=900 and KANKAKU>=2 then
OWARI=1000-(OWARI mod 1000)
wait 1+(OWARI \ 10) 'ここは越えるようにする
endif
OWARI=KANKAKU-((millitime \ 1000) mod KANKAKU)
if OWARI >= 2 then '差が2秒以上あるならば、
interval OWARI-1 '秒単位の割り込み。ただし１秒残す。
on interval gosub *JUSTTIME2
interval on
waiti '設定している割り込みが発生するまで停止します。
interval off
end if
OWARI=1000-(millitime mod 1000)
if OWARI >= 100 then
wait (OWARI \ 100)*10 '1/100秒単位：0.1秒粗く待つ
endif
OWARI=1000-(millitime mod 1000)
if OWARI>= 100 then MUGEN_CC=-1:return '←TIME OVER!!
OWARI=millitime
if KANKAKU-((OWARI \ 1000) mod KANKAKU)>= 2 then
MUGEN_CC=-1 :return '←TIME OVER!!
OWARI=1000-(OWARI mod 1000)
else
OWARI=1000-(OWARI mod 1000)
endif
OWARI=1000-(millitime mod 1000)
MUGEN_CC=0
if OWARI >= 100 then return
if OWARI>=30 and OWARI < 100 then wait (1+(OWARI \ 10)) :return
if KANKAKU < 2 then
do 'ループしてmillitimeを秒未満チェック待ち
MUGEN_CC=MUGEN_CC+1
NOW=(millitime mod 1000)
loop until NOW<900
else
do 'ループしてmillitimeを秒単位チェック待ち
MUGEN_CC=MUGEN_CC+1
NOW=(millitime \ 1000) mod KANKAKU
loop until NOW=0
endif
return
CHK_TIME%=((time mod 60)+2) mod 60 'リミットをおよそ2秒後に設定
do while lof(1) < 90
if (time mod 60) = CHK_TIME% then print "＊＊受信エラー＊＊" :exit do
loop
if lof(1) < 90 then GPGGA$=input$(lof(1), #1) else GPGGA$=input$(90, #1)
if right$(GPGGA$,1)=chr$(13) then GPGGA$=left$(GPGGA$, len(GPGGA$) - 1)
size as single 'フォントサイズ
bold as integer 'ボールド(太字)指定の有無
italic as integer 'イタリック(斜体)指定の有無
underline as integer 'アンダーライン(下線)指定の有無
strikeout as integer '消し線指定の有無
ffname as string * 32 'フォント名
end type
なお、このFONT構造体はF-BASIC専用です。Windows APIのFONT構造体等とは違いますので、
F-BASICの組込命令を使用せずにフォント選択ダイアログを呼び出したり、
Windows APIでフォント操作をする場合には適用できません。
