Attribute VB_Name = "M_xlib" Option Explicit Const GXDUMP As String = " addr loc 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F ----+----+----+-" Type ST_STACK '*** Stack管理構造体 *** max_reg As Integer '最大登録数 sp As Integer 'スタック位置 reg() As String 'stack End Type Type ST_XFLIST max_flist As Integer flista() As Integer End Type '********1*********2*********3*********4*********5*********6*********7** '* 名称 : bcopy * '* 機能 : バイト単位のコピー * '* 引数 : IN : d() : コピー先領域 * '* s() : コピー元領域 * '* leng : コピーバイト数 * '* Optional dpos : コピー先の開始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* Optional spos : コピー元の開始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* OUT : d() : コピーされたデータ * '* 作成 : 2014/01/26 Akito Kobayashi * '* 更新 : * '*********************************************************************** Sub bcopy( _ ByRef d() As Byte _ , ByRef s() As Byte _ , ByVal leng As Integer _ , Optional ByVal dpos As Integer = 0 _ , Optional ByVal spos As Integer = 0 _ ) Dim i As Integer If dpos < 0 Then dpos = 0 If spos < 0 Then spos = 0 For i = 0 To leng - 1 d(i + dpos) = s(i + spos) Next End Sub '********1*********2*********3*********4*********5*********6*********7** '* 名称 : bset * '* 機能 : バイト単位のデータ設定 * '* IN : d() : コピー先領域 * '* val : 設定データ * '* leng : 設定バイト数 * '* Optional dpos : コピー先の開始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* OUT : d() : 設定されたデータ * '* 作成 : 2014/01/26 Akito Kobayashi * '* 更新 : 2019/07/22 Akito Kobayashi Add check dpos * '*********************************************************************** Sub bset( _ ByRef d() As Byte _ , ByRef val As Byte _ , ByVal leng As Integer _ , Optional ByVal dpos As Integer = 0 _ ) Dim i As Integer If dpos < 0 Then dpos = 0 For i = 0 To leng - 1 d(i + dpos) = val Next End Sub '********1*********2*********3*********4*********5*********6*********7** '* 名称 : Byte2Str * '* 機能 : String Byte列 * '* ". 1" <-- 1A 20 31 * '* 引数 : IN : dat() : 変換元領域 * '* pos : 変換元の開始位置 * '* leng : 変換バイト数 * '* Optional opt : オプション (default=1) * '* =&H1 : 非表示文字コードは、ピリオド * '* (".")にする * '* 作成 : 2014/01/26 Akito Kobayashi * '* 更新 : 2019/07/16 Akito Kobayashi Add opt=1 * '*********************************************************************** Function Byte2Str( _ ByRef dat() As Byte _ , ByVal pos As Integer _ , ByVal leng As Integer _ , Optional opt As Integer = 1 _ ) As String Dim c As String Dim w As String Dim i As Integer Dim opt1 As Integer Dim n As Byte opt1 = opt And &H1 w = "" For i = 0 To leng - 1 n = dat(i + pos) If opt1 <> 0 Then c = to_ank(n) Else c = Chr(n) End If w = w & c Next Byte2Str = w End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : Pack2Str * '* 機能 : 10進文字列 パック10進形式 * '* 123 <-- 12 3C * '* -123 <-- 12 3D * '* 引数 : IN : dat() : 変換元領域 * '* leng : 変換バイト数 * '* syo : 少数点以下の桁数 * '* OUT : なし * '* 返却 : 10進文字列 * '* 作成 : 2014/01/26 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function Pack2Str( _ ByRef dat() As Byte _ , ByVal leng As Integer _ , ByVal syo As Integer _ ) As String Dim w As String Dim c As String Dim ilen As Integer w = to_hex(dat, leng) ilen = Len(w) - 1 c = Right(w, 1) w = Left(w, ilen) If syo > 0 Then w = Left(w, ilen - syo) & "." & Mid(w, ilen - syo + 1) If c = "D" Then w = "-" & w Pack2Str = w End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : Zone2Str * '* 機能 : 10進文字列 ゾーン形式(Byte列) 小数点以下の桁数 * '* 123 <-- F1 F2 F3 or F1 F2 C3 2 * '* -123 <-- F1 F2 D3 * '* 引数 : IN : dat() : 変換元領域 * '* leng : 変換バイト数 * '* syo : 少数点以下の桁数 * '* OUT : なし * '* 返却 : 10進文字列 * '* 作成 : 2014/01/26 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function Zone2Str( _ ByRef dat() As Byte _ , ByVal leng As Integer _ , ByVal syo As Integer _ ) As String Dim w As String Dim i As Integer Dim s As Integer Dim x As Byte s = 0 For i = 0 To leng - 1 x = dat(i) If (x And &HF0) = &HD0 Then s = -1 dat(i) = (x And &HF) Or &H30 'ASCIIコード変換 Next w = Byte2Str(dat, 0, leng) If syo > 0 Then w = Left(w, leng - sy0) & "." & Mid(w, lemng - syo + 1) End If If s < 0 Then w = "-" & w Zone2Str = w End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : Byte2XStr * '* 機能 : String Byte列 * '* "1A2031" <-- 1A 20 31 * '* 引数 : IN : dat() : 変換元領域 * '* leng : 変換バイト数 * '* sign : 符号 * '* >=0 : 正 * '* < 0 : 負 * '* 返却 : 16進文字列 * '* 作成 : 2014/01/26 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function Byte2XStr( _ ByRef dat() As Byte _ , ByVal leng As Integer _ , ByVal sign As Integer _ ) As String Dim n As Long Dim i As Integer Dim s As Integer Dim x As Byte s = 0 If sign >= 0 Or leng = 4 Then x = dat(0) If (x And &H80) <> 0 Then s = -1 End If End If For i = 0 To leng - 1 x = dat(i) If s < 0 Then x = x Xor &HFF 'ビット反転 n = n * 256 + x Next If s < 0 Then n = -1 - n 'ビット反転のみでは、負にしたときに1多くなる Byte2XStr = CStr(n) End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : Str2Byte * '* 機能 : Byte列 String * '* 内部形式またはSJISコード <-- "ABC123" * '* 引数 : IN : temp() : 変換先領域 * '* lenby : 変換先バイト数 * '* >0 : 出力バイト数 * '* =0 : 数制限なしに出力する * '* <0 : 出力しない * '* dat : 変換元領域 * '* lenbyに満たない場合は、" "を変換する * '* leng : 変換元文字数 * '* Optional opt : 0/1=内部形式のまま/SJISコード * '* SJISのときは、ASCIIコード 倍角文字は * '* 2バイトになる * '* OUT : rec() : バイト列データ * '* 返却 : 変換先バイト数 * '* 作成 : 2014/01/24 Akito Kobayashi * '* 更新 : 2020/03/18 Akito Kobayashi Add opt * '*********************************************************************** Function Str2Byte( _ ByRef temp() As Byte _ , ByVal lenby As Integer _ , ByRef dat As String _ , ByVal leng As Integer _ , Optional ByVal opt As Integer = 0 _ ) As Integer Dim w As String Dim i As Integer Dim ii As Integer Dim j As Integer Dim k As Integer Dim kk As Integer Dim m As Integer Dim n As Long Dim rec(4) As Byte If opt = 1 Then ii = 0 For i = 1 To leng w = Mid(dat, i, 1) If w = "" Then w = " " n = Asc(w) If n < 0 Then n = n + 655356 m = Bin2Byte(rec, 4, n) For j = 0 To 3 If rec(j) <> 0 Then Exit For Next k = 4 - j If k > 0 Then If lenby > 0 And (ii + k) > lenby Then kk = lenby - ii Else kk = k End If If lenby >= 0 Then Call bcopy(temp, rec, kk, ii, j) ii = ii + kk If lenby > 0 And ii >= lenby Then Exit For End If Next Else w = Left(dat, leng) ii = LenB(w) If lenby >= 0 Then If lenby > 0 Then If ii > lenby Then ii = lenby End If For i = 1 To ii temp(i - 1) = AscB(MidB(w, i, 1)) Next End If End If Str2Byte = ii End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : Str2Bin * '* 機能 : Binary(Byte列) String * '* 00 00 04 01 <-- "1025 * '* FF FF FF FF <-- "-1" * '* 引数 : IN : rec() : 変換先領域 * '* lenby : 変換先バイト数 * '* dat : 変換元領域 * '* leng : 変換元文字数 * '* OUT : rec() : バイト列データ * '* 返却 : 変換先バイト数 * '* 作成 : 2014/01/24 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function Str2Bin( _ ByRef rec() As Byte _ , ByVal lenby As Integer _ , ByRef dat As String _ , ByVal leng As Integer _ ) As Integer Str2Bin = Bin2Byte(rec, lenby, atol(dat)) End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : Bin2Byte * '* 機能 : Binary(Byte列) 10進数 * '* 00 00 04 01 <-- 1025 * '* FF FF FF FF <-- -1 * '* 引数 : IN : rec() : 変換先領域 * '* lenby : 変換先バイト数 * '* nn : 変換元数 * '* OUT : rec() : バイト列データ * '* 返却 : 変換先バイト数 * '* 作成 : 2014/01/24 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function Bin2Byte( _ ByRef rec() As Byte _ , ByVal lenby As Integer _ , ByVal nn As Long _ ) As Integer Dim i As Integer Dim ii As Integer Dim n As Long n = nn And &H7FFFFFFF '正のビット列で処理する ii = lenby - 1 '下位バイトから処理する For i = 0 To lenby - 1 rec(ii) = n Mod 256 n = Int(n / 256) ii = ii - 1 Next If nn < 0 And lenby >= 4 Then rec(lenby - 4) = rec(lenby - 4) Or &H80 '負のときのビット補正 For i = 0 To lenby - 5 rec(i) = &HFF Next End If Bin2Byte = lenby End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : Bin2XStr * '* 機能 : 16進文字列 10進数 * '* "00000401" <-- 1025 * '* "FFFFFFFF" <-- -1 * '* 引数 : IN : nn : 10進数(バイナリ * '* ket : 出力バイト数 * '* OUT : なし * '* 返却 : 16進文字列 * '* 作成 : 2014/01/24 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function Bin2XStr( _ ByVal n As Long _ , ByVal ket As Integer _ ) As String Dim rec() As Byte Dim k As Integer If ket > 0 Then ReDim rec(ket) As Byte k = Bin2Byte(rec, ket, n) Bin2XStr = to_hex(rec, ket) Else Bin2XStr = "" End If End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : Str2Pack * '* 機能 : パック10進形式 10進文字列 * '* 12 3C <-- "123" * '* 12 3D <-- "-123" * '* 引数 : IN : rec() : 変換先領域 * '* lenby : 変換先バイト数 * '* dat : 変換元データ * '* leng : 変換文字数 * '* OUT : rec() : バイト列データ * '* 返却 : 出力バイト数 * '* 作成 : 2014/01/24 Akito Kobayashi * '* 更新 : 2014/02/18 Akito Kobayashi Mod use Str2PackOpt() * '*********************************************************************** Function Str2Pack( _ ByRef rec() As Byte _ , ByVal lenby As Integer _ , ByRef dat As String _ , ByVal leng As Integer _ , Optional opt As Integer = 1 _ ) As Integer Str2Pack = Str2PackOpt(rec, lenby, dat, leng, 0, -1) End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : Str2PackOpt * '* 機能 : パック10進形式 10進文字列 * '* 12 3C <-- 123 * '* 12 3D <-- -123 * '* 引数 : IN : rec() : 変換先領域 * '* lenby : 変換先バイト数 * '* dat : 変換元データ * '* leng : 変換文字数 * '* syo : 少数点以下の桁数 * '* Optional opt : 端数処理 0:四捨五入、1:切上げ、2:切捨て* '* OUT : rec() : バイト列データ * '* 返却 : 出力バイト数 * '* 作成 : 2014/02/18 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function Str2PackOpt( _ ByRef rec() As Byte _ , ByVal lenby As Integer _ , ByVal dat As String _ , ByVal leng0 As Integer _ , ByVal syo As Integer _ , Optional opt As Integer = 0 _ ) As Integer Dim x As Byte Dim sig As Byte Dim kur As Byte Dim i As Integer Dim ii As Integer Dim i0 As Integer Dim mode As Integer Dim leng As Integer Dim pos As Integer Dim dsyo As Integer Dim zero As Integer Dim fsyo As Integer Dim sket As Integer Dim ket As Integer Dim d As Long Dim c As String dat = Trim(dat) '符号判定と削除 sig = &HC c = Left(dat, 1) If c = "-" Then sig = &HD dat = Mid(dat, 2) ElseIf c = "+" Then dat = Mid(dat, 2) End If '初期値設定 leng = Len(dat) If leng > leng0 Then leng = leng0 fsyo = 0 sket = 0 ket = 0 kur = 0 zero = 0 Call bset(ret, 0, lenby - 1, 0) ret(lenby - 1) = sig '最下位バイトに符号をセットする If opt >= 0 Then 'syoの指定に合うように先頭からの文字数を求める pos = InStr(dat, ".") If pos > 0 Then dsyo = leng - pos If dsyo > 0 Then leng = leng - (dsyo - syo) dsyo = syo If syo < 0 Then leng = leng - 1 '少数点の分を引く End If Else If syo < 0 Then dsyo = syo leng = leng + syo Else dsyo = 0 sket = syo End If End If '端数処理 If leng >= 0 Then c = Mid(dat, leng + 1, 1) If c <> "" Then x = Asc(c) And &HF If opt = 0 Then If x >= 5 Then kur = 1 ElseIf opt = 1 Then If x > 0 Then kur = 1 End If End If End If 'PACK開始位置を求める If dsyo >= 0 Then ii = syo - dsyo + 1 Else ii = 1 - dsy0 End If mode = ii Mod 2 '上位と下位のどちらから始めるかを設定する ii = lenby - Int(ii / 2) - 1 'PACK開始位置設定 i0 = 0 '最上位の繰り上がり処理のため1余計に回す Else mode = 1 '最下位の4ビットを処理済みとする ii = lenby - 1 '最下位のバイト位置 i0 = 1 End If 'PACK処理 For i = leng To i0 Step -1 If i > 0 Then c = Mid(dat, i, 1) Else c = "0" End If If c = "." Then If fsyo = 0 Then sket = ket fsyo = 1 Else Str2PackOpt = -1 Exit Function End If ElseIf c >= "0" And c <= "9" Then If ii >= 0 Then x = Asc(c) And &HF If x > 0 Then zero = 0 '繰り上がり処理 x = x + kur If x >= 10 Then x = x - 10 kur = 1 Else kur = 0 End If 'PACK If mode = 0 Then '下位4ビットの処理 rec(ii) = x mode = 1 Else '上位4ビットの処理 rec(ii) = rec(ii) + x * 16 mode = 0 ii = ii - 1 End If ket = ket + 1 Else 'あふれ部分の値を求める If i > 0 Then d = atol(Left(dat, i)) Else d = 0 End If If d + kur > 0 Then 'Over Flow Call bset(rec, &H99, lenby - 1, 0) rec(lenby - 1) = &H90 Or sig zero = 0 End If Exit For End If Else Str2PackOpt = -1 Exit Function End If Next 'PACK値が0で負符号のときは正にする If sig = &HD And zero = 1 Then ii = lenby - 1 x = rec(ii) rec(ii) = x And &HF Or &HC End If Str2PackOpt = sket End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : Str2Zone * '* 機能 : ゾーン形式(Byte列) 10進文字列 * '* F1 F2 F3 <-- "123" * '* F1 F2 D3 <-- "-123" * '* 引数 : IN : rec() : 変換先領域 * '* lenby : 変換先バイト数 * '* dat : 変換元データ * '* leng : 変換文字数 * '* OUT : rec() : バイト列データ * '* 返却 : 出力バイト数 * '* 作成 : 2014/01/24 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function Str2Zone( _ ByRef rec() As Byte _ , ByVal lenby As Integer _ , ByRef dat As String _ , ByVal leng As Integer _ , Optional opt As Integer = 1 _ ) As Integer Dim c As String Dim i As Integer Dim ii As Integer Dim x As Byte ii = lenby - 1 For i = leng To 1 Step -1 c = Mid(dat, i, 1) If c = "-" Then rec(lenby - 1) = (rec(lenby - 1) And &HF) Or &HD0 ElseIf c = "" Or c = " " Or c = "+" Or c = "." Then Else If ii >= 0 Then rec(ii) = (Asc(c) And &HF) Or &HF0 ii = ii - 1 End If End If Next Str2Zone = lenby End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : to_hex * '* 機能 : String Byte列 * '* "1A2031" <-- 1A 20 31 * '* 引数 : IN : dat() : 変換元領域 * '* leng : 変換バイト数 * '* 返却 : 16進文字列 * '* 作成 : 2014/01/26 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function to_hex( _ ByRef dat() As Byte _ , ByVal leng As Integer _ ) As String Const hex As String = "0123456789ABCDEF" Dim i As Integer Dim n As Long Dim w As String w = "" For i = 0 To leng - 1 n = dat(i) w = w & Mid(hex, Int(n / 16) + 1, 1) & Mid(hex, (n Mod 16) + 1, 1) Next to_hex = w End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : to_ank * '* 機能 : 1Byteのコードを表示文字に変換する * '* 非表示文字コードのときは、ピリオド(".")にする * '* 引数 : IN : n : コード * '* 返却 : 表示文字 * '* 作成 : 2014/01/26 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function to_ank(ByVal n As Byte) As String Dim c As String If (n >= &H20 And n <= &H7E) Or (n >= &HA1 And n <= &HDF) Then c = Chr(n) Else c = "." End If to_ank = c End Function Sub bytexdump( _ ByRef msg As String _ , ByRef dat() As Byte _ , ByVal pos As Integer _ , ByVal leng As Integer _ ) Dim i As Integer Dim j As Integer Dim k As Integer Dim w As String Dim wc As String Dim n As Byte Dim rec(4) As Byte Call DEBUGOUT("*** " & msg & " ***") Call DEBUGOUT(GXDUMP) For j = 0 To leng - 1 Step 16 w = Bin2XStr(j, 4) & " " & LPad(CStr(loc), 6, "0") & " " k = j + 15 wc = "" For j = 1 To m If i >= leng Then w = w & " " Else n = dat(i + pos) w = w & Bin2XStr(n, 1) & " " wc = wc & to_ank(n) End If Next w = w & wc Call DEBUGOUT(w) Next w = Bin2XStr(leng, 4) & " " & LPad(CStr(leng), 6, "0") & " " w = w & "(DATA END)" Call DEBUGOUT(w) End Sub Sub BYTEXDUMPL( _ ByVal log_level As Integer _ , ByRef msg As String _ , ByRef dat() As Byte _ , ByVal pos As Integer _ , ByVal leng As Integer _ ) If is_dbgout(log_level) Then Call bytexdump(msg, dat, pos, leng) End If End Sub Sub strxdump(ByRef msg As String, ByRef dat As String, ByVal leng As Integer) Dim i As Integer Dim j As Integer Dim loc As Integer Dim m As Integer Dim mode As Integer Dim ilen As Integer Dim c As String Dim w As String Dim wc As String Dim n As Byte Dim rec(4) As Byte Dim moj(4) As Byte Call DEBUGOUT("*** " & msg & " ***") Call DEBUGOUT(GXDUMP) loc = 0 i = 0 mode = 1 Do While i < leng w = Bin2XStr(loc, 4) & " " & LPad(CStr(loc), 6, "0") & " " wc = "" ilen = 0 Do While ilen < 16 If i >= leng Then w = w & " " ilen = ilen + 1 Else If mode = 2 Then n = moj(1) w = w & Bin2XStr(n, 1) & " " loc = loc + 1 ilen = ilen + 1 c = " " mode = 1 Else i = i + 1 c = Mid(dat, i, 1) m = Str2Byte(moj, 0, c, Len(c), 1) For j = 1 To m If ilen >= 16 Then mode = 2 Exit For End If n = moj(j - 1) w = w & Bin2XStr(n, 1) & " " loc = loc + 1 ilen = ilen + 1 Next If m = 1 Then c = to_ank(n) End If wc = wc & c End If Loop w = w & wc Call DEBUGOUT(w) Loop w = Bin2XStr(loc, 4) & " " & LPad(CStr(loc), 6, "0") & " " w = w & "(DATA END)" Call DEBUGOUT(w) End Sub Sub STRXDUMPL( _ ByVal log_level As Integer _ , ByRef msg As String _ , ByRef dat As String _ , ByVal leng As Integer _ ) If is_dbgout(log_level) Then Call strxdump(msg, dat, leng) End If End Sub Function MaxLong(ByVal a As Long, ByVal b As Long) As Long If a > b Then MaxLong = a Else MaxLong = b End If End Function Function MaxInt(ByVal a As Integer, ByVal b As Integer) As Integer MaxInt = MaxLong(cng(a), CLng(b)) End Function Function MinLong(ByVal a As Long, ByVal b As Long) As Long If a < b Then MinLong = a Else MinLong = b End If End Function Function MinInt(ByVal a As Integer, ByVal b As Integer) As Integer MinInt = MinLong(CLng(a), CLng(b)) End Function '*1*********2*********3*********4********* *****6*********7** '機能 スタック構造体を初期化 '引数 IN : stack スタック構造体への参照 '* 'max_stack スタックの 'OUT: stack: スタック構造体のメ 'stack.max_reg = max_stack 'stack.sp = 0 'stack.reg (max_stack) 配列定義 '返却 : %3D0 正常 '=-2 max_stack <= 0 ''*作成 : 2014/12/01 Akito Kobayashi ''* 更新 '* '* '* '* 'i Function stack_init( _ ByRef stack As ST_STACK _ , ByVal max_stack As Integer _ ) As Integer Dim ret As Integer ret = 0 ' If stack Is Nothig Then ret = ret - 1 If max_stack <= 0 Then ret = ret - 2 If ret = 0 Then stack.max_reg = max_stack stack.sp = 0 ReDim stack.reg(max_stack) End If stack_init = ret End Function '******* *********3******************5*********6*********** '* 機能 'スタック構造体 '* 引数 'GIN:stack」 スタック構造体への参照 'OUT stack スタック構造体のメンバ 'stack.max_reg = 0 'stack.sp% 3# 'ReDim stack.reg(0) '2020/01/27 Akito Kobayashi '米 '作成 '更新 Sub stack_free(ByRef stack As ST_STACK) stack.max_reg = 0 stack.sp = 0 ReDim stack.reg(0) End Sub '*****************2*********3******************5*********6*********** '* 機能 スタックに積む '* 引数 IN : stack スタック構造体への参照 'val 'スタックに積む値への 'OUT: stack スタック構造体のメ 'stack.sp stack.sp + 1 'stack.reg (stack.sp) val '* 返却 1:30正常 '-2 スタックオーバ '* 作成 :2014/12/01 AkitoKobayashi '更新 Function PushStack( _ ByRef stack As ST_STACK _ , ByRef val As String _ ) As Integer Dim ret As Integer ret = 0 ' If stack Is Nothing Then ' ret = -1 ' ElseIf stack.sp > stack.max_reg Then If stack.sp >= stack.max_reg Then ret = -2 Else stack.reg(stack.sp) = val stack.sp = stack.sp + 1 End If PushStack = ret End Function '**************************3****** *********5****** *********7** '* 機能 スタックをのぞく、または、スタックから取り出す '引数 : IN : stack : スタック構造体への参照 'val 'スタックの値への 'isPeek Peekフラグ '=30スタックから取り出す '!=0 スタックをのぞく 'OUT: stack: スタック構造体のメ 'スタックから取り出すと、 'stack.sp = stack.sp + 1 '返却 0正常 '=-2 スタックは空 '* 作成 : 2014/12/01 Akito Kobayashi '* 更新 'i '* Function PopPeekStack( _ ByRef stack As ST_STACK _ , ByRef val As String _ , ByVal isPeek As Integer _ ) As Integer Dim ret As Integer ret = 0 ' If stack Is Nothing Then ' ret = -1 ' ElseIf stack.sp <= 0 Then If stack.sp <= 0 Then ret = -2 Else val = stack.reg(stack.sp - 1) If isPeek = 0 Then stack.sp = stack.sp - 1 End If PopPeekStack = ret End Function '*******************2*********3*******************5*********6*********7** '* 機能 : スタックから取り出す '引数 : IN : stack :スタック構造体への参照 'val: スタックの値への 'OUT: val '取り出した 'stack スタック構造体のメ 'stack. sp = stack. sp + 1 I '返却 : = 0 E * '%3-2 スタックは空 '* Pest 2014/12/01 Akito Kobayashi '+ * * Function PopStack( _ ByRef stack As ST_STACK _ , ByRef val As String _ ) As Integer PopStack = PopPeekStack(stack, val, 0) End Function '*****************2*********3***********************7** '機能 スタックをの '引数 IN stack スタック構造体への参照 'val 'スタックの値への 'OUT: val 'のぞいた値 '返却 : %3D0 正常 '=-2 スタックは空 '作成 2014/12/01 Akito Kobayashi '更新 Function PeekStack( _ ByRef stack As ST_STACK _ , ByRef val As String _ ) As Integer PeekStack = PopPeekStack(stack, val, 1) End Function '*1*********2*********3******* *********5*********6*********** '* 機能:スタックをサーチし、なければ登録する '引数 : IN : stack スタック構造体への参照 'val 'スタックに登録する値への 'Optional opt 0x01=1 : 登録する(default=0) 'OUT stack スタック構造体のメンバ 'stack.sp = stack.sp + 1 'i 'stack.reg(stack.sp) = val '返却:>0 登録位置 + 1 '=-2 スタックオーバ '作成 2018/03/15 Aki to Kobayashi '更新 Function SrchStack( _ ByRef stack As ST_STACK _ , ByRef val As String _ , Optional opt As Integer = 0 _ ) As Integer Dim ret As Integer Dim i As Integer ret = 0 For i = 0 To stack.sp - 1 If stack.reg(i) = val Then SrchStack = i + 1 Exit Function End If Next If (opt And &H1) > 0 Then ret = PushStack(stack, val) SrchStack = ret End Function '******************2*********3*******************5*********6*********7** '* 機能 「ログインユーザのネットワーク属性名を取得する '* 31 IN net_nam(: R 22510 'ドメイン 'nam(1) : E- 'nam (2) : 1-2% 'DE 2015/04/06 Akito Kobayashi 'nam (0) Sub GetUserNetwork(ByRef net_nam() As String) Dim nam As String Dim dat As String Dim i As Integer Dim pos As Integer net_nam(0) = "" net_nam(1) = "" net_nam(2) = "" For i = 1 To 100 dat = Environ(i) If dat = "" Then Exit For pos = InStr(dat, "=") If pos > 0 Then nam = UCase(Left(dat, pos - 1)) dat = Mid(dat, pos + 1) If nam = "USERNAME" Then net_nam(2) = dat ElseIf nam = "COMPUTERNAME" Then net_nam(1) = dat ElseIf nam = "USERDOMAINE" Then net_nam(0) = dat End If End If Next End Sub '********1*********2*********3*********4*********5*********6*********7** '* 名称 : set_bit_mask * '* 機能 : 指定のマスクでビットをON/OFFする * '* IN : lval : ビット操作対象 * '* mask : ビットマスク * '* iset : 操作 : >0 ビットON * '* =0 操作なし * '* <0 ビットOFF * '* OUT : なし * '* 返却 : ビット操作結果 * '* 作成 : 2017/07/28 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function set_bit_mask(ByVal lval As Long, ByVal mask As Long, ByVal iset As Integer) As Long If iset > 0 Then lval = lval Or mask ElseIf iset < 0 Then lval = lval And (&HFFFFFFFF Xor mask) End If set_bit_mask = lval End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : flist_init * '* 機能 : フリーリストを初期化する * '* IN : flista() : フリーリストへの参照 * '* max_flista : フリーリストの長さ * '* OUT : flista() : 初期化されたフリーリスト * '* flista(0) = max_flista * '* flista(1) = 1 使用可能リスト番号 * '* この番号+1の位置に入って * '* いる番号が次の番号 * '* flista(2) = 2 * '* flista(max_flista) = max_flista * '* flista(max_flista+1) = 0 * '* 返却 : = 0 正常 * '* =-1 max_flista <= 0 * '* =-2 flista()のサイズ 0 フリー番号 * '* = 0 フリー番号なし * '* 作成 : 2017/08/09 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function get_flist( _ ByRef flista() As Integer _ ) As Integer Dim ret As Integer Dim i As Integer ret = flista(1) If ret > 0 Then flista(1) = flista(ret + 1) flista(ret + 1) = 0 End If get_flist = ret End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : put_flist * '* 機能 : フリーリストにフリー番号を返却する * '* IN : flista() : フリーリストへの参照 * '* free_no : フリー番号 * '* OUT : flista() : 更新されたフリーリスト * '* (ソースコメントを参照) * '* 返却 : = 0 正常 * '* =-1 フリー番号が範囲外 * '* =-2 フリー番号は返却済み * '* 作成 : 2017/08/09 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function put_flist( _ ByRef flista() As Integer _ , ByVal free_no As Integer _ ) As Integer Dim ret As Integer Dim i As Integer Dim ii As Integer If free_no < 1 Or free_no > flista(0) Then ret = -1 Else ret = 0 ii = flista(1) For i = 1 To flista(0) If ii = 0 Then Exit For ElseIf ii = free_no Then put_flist = -2 Exit Function End If ii = flista(ii + 1) Next i = flista(1) 'フリーリストの先頭から次に登録可能な位置を退避する flista(1) = free_no 'そこに今回返却した番号(位置)を格納 flista(free_no + 1) = i 'フリーリストの今回返却した位置(次の次に登録可能な '位置となる位置)に退避した位置を格納 End If put_flist = ret End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : ulist_new * '* 機能 : ユーズドリスト配列を確保して初期化する * '* IN : ulista() : ユーズドリストへの参照 * '* max_ulista : ユーズドリストの長さ * '* OUT : ulista() : 初期化されたユーズドリスト * '* 返却 : = 0 正常 * '* =-1 max_ulista <= 0 * '* 作成 : 2020/02/17 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function ulist_new( _ ByRef ulista() As Integer _ , ByVal max_ulista As Integer _ ) As Integer Dim ret As Integer Dim i As Integer ret = 0 If max_ulista < 1 Then ret = -1 Else ReDim ulista(max_ulista + 1) ulista(0) = max_ulista End If ulist_new = ret End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : xflist_new * '* 機能 : 自動拡張フリーリストを初期化する * '* IN : xflist : 自動拡張フリーリストへの参照 * '* max_flista : フリーリストの長さ * '* OUT : xflist : 初期化された自動拡張フリーリスト * '* 返却 : = 0 正常 * '* =-1 max_flista <= 0 * '* 作成 : 2020/01/28 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function xflist_new( _ ByRef xflist As ST_XFLIST _ , ByVal max_flista As Integer _ ) As Integer Dim ret As Integer Dim i As Integer ret = 0 If max_flista < 1 Then ret = -1 Else ret = flist_new(xflist.flista, max_flista) xflist.flista = max_flista End If xflist_new = ret End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : get_xflist * '* 機能 : 自動拡張フリーリストからフリー番号を取得する * '* IN : xflist : 自動拡張フリーリストへの参照 * '* OUT : xflist : 更新された自動拡張フリーリスト * '* xflist.flista(1) = 次に使用可能リスト番号 * '* この番号+1の位置に入って * '* いる番号が次の次の番号 * '* 返却 : > 0 フリー番号 * '* 作成 : 2020/01/28 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function get_xflist( _ ByRef xflist As ST_XFLIST _ ) As Integer Dim ret As Integer Dim i As Integer Dim ii As Integer Dim max_fliat0 As Integer Dim max_fliata As Integer ret = get_flista(xflist.flista) If ret = 0 Then max_flist0 = xflist.flista(0) max_flista = max_flist0 + xflist.max_flist ReDim Preserve xflist.flista(max_flista) For i = 1 To xflist.max_flist xflist.flista(ii) = ii ii = ii + 1 Next xflist.flista(max_flista + 1) = 0 xflist.flista(0) = max_flista ii = max_flist0 + 1 xflist.flista(1) = ii xflist.flista(ii) = 0 ret = get_flist(xflist.flista) End If get_xflist = ret End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : put_xflist * '* 機能 : 自動拡張フリーリストにフリー番号を返却する * '* IN : xflist : 自動拡張フリーリストへの参照 * '* free_no : フリー番号 * '* OUT : flista() : 更新された自動拡張フリーリスト * '* (ソースコメントを参照) * '* 返却 : = 0 正常 * '* =-1 フリー番号が範囲外 * '* =-2 フリー番号は返却済み * '* 作成 : 2020/01/28 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function put_xflist( _ ByRef xflist As ST_XFLIST _ , ByVal free_no As Integer _ ) As Integer put_xflist = put_flist(xflist.flista, free_no) End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : xulist_new * '* 機能 : 自動拡張ユーズドリストを初期化する * '* IN : ulista() : 自動拡ユーズドリストへの参照 * '* max_ulista : ユーズドリストの長さ * '* OUT : ulista() : 初期化されたユーズドリスト * '* 返却 : = 0 正常 * '* =-1 max_ulista <= 0 * '* 作成 : 2020/02/17 Akito Kobayashi * '* 更新 : * '*********************************************************************** Function xulist_new( _ ByRef xulist As ST_XFLIST _ , ByVal max_ulista As Integer _ ) As Integer Dim ret As Integer Dim i As Integer ret = 0 If max_ulista < 1 Then ret = -1 Else ret = ulist_new(xulist.flista, max_ulista) xulist.ulista(0) = max_ulista End If xulist_new = ret End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : normalize_num_atra * '* 機能 : 数値文字列配列を大小比較できるように正規化する * '* 整数部は右詰め、小数点の位置を合わせる * '* IN : atra() : データタイプ配列 * '* = 2〜4 : 数値 * '* = その他: 数値以外(何もしない) * '* da() : 数値文字列配列 * '* nda : 数値文字列配列の数(<2 のときは、何もしない) * '* OUT : da() : 正規化された数値文字列配列 * '* 作成 : 2018/05/14 Akito Kobayashi * '* 更新 : 2019/02/15 Akito Kobayashi Add 整数部の前ゼロ削除 * '* Mod use normalize_num_1(), * '* nda<=1でも処理する * '*********************************************************************** Sub normalize_num_atra( _ ByRef atra() As Integer _ , ByRef da() As String _ , ByVal nda As Integer _ ) Dim i As Integer Dim i0 As Integer Dim atr As Integer Dim pos2 As Integer Dim len2 As Integer Dim max_len As Integer Dim sei2 As String Dim syo2 As String Dim dat2 As String Dim c2 As String i0 = 0 max_len = 0 For i = 0 To nda - 1 atr = atra(i) If atr >= 2 And atr <= 4 Then dat2 = da(i) pos2 = InStr(dat2, ".") If pos2 > 0 Then sei2 = Left(dat2, pos2 - 1) Else sei2 = dat2 End If c2 = Left(sei2, 1) If c2 = "+" Or c2 = "-" Then sei2 = axLTrim(Mid(sei2, 2), "0") If sei2 = "" Then sei2 = "0" len2 = Len(sei2) If len2 > max_len Then max_len = len2 End If Next For i = 0 To nda - 1 atr = atra(i) If atr >= 2 And atr <= 4 Then da(i) = normalize_num_1(da(i), max_len) End If Next End Sub '********1*********2*********3*********4*********5*********6*********7** '* 名称 : normalize_num_1 * '* 機能 : 数値文字列配列を指定の長さに正規化する * '* 数字を含まないか、数値文字以外を含むときは、空文字にする * '* 整数部は指定の長さになるように、左0パディングする * '* 小数部は、右0サプレスする * '* IN : da0 : 対象数値文字列 * '* Optional max_len : 整数部正規化文字列長 (default=15) * '* OUT : なし * '* 返却 : 正規化された数値文字 * '* 作成 : 2019/02/15 Akito Kobayashi * '* 更新 : 2020/02/19 Akito Kobayashi Mod 数字を含まないか、数字以外を * '* 含むときは、空文字にする * '*********************************************************************** Function normalize_num_1( _ ByRef dat0 As String _ , Optional ByVal max_len As Integer = 15 _ ) As String Dim pos2 As Integer Dim len2 As Integer Dim sei2 As String Dim syo2 As String Dim c2 As String Dim dat2 As String Dim dat As String dat2 = Trim(dat0) dat = "" If dat2 <> "" Then If (chk_char_kind(dat2) And 64) <> 0 Then pos2 = InStr(dat2, ".") If pos2 > 0 Then sei2 = Left(dat2, pos2 - 1) syo2 = axRTrim(Mid(dat2, pos2), "0") If syo2 = "." Then syo2 = "" If syo2 = "" Then syo2 = "0" Else sei2 = dat2 syo2 = "" End If c2 = Left(sei2, 1) If c2 = "+" Or c2 = "-" Then sei2 = Mid(sei2, 2) If c2 <> "-" Then c2 = "" len2 = Len(sei2) If len2 < max_len Then sei2 = LPad(sei2, max_len, "0") dat = c2 & sei2 & syo2 End If End If normalize_num_1 = dat End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : comp_normalize_num * '* 機能 : 正規化数値文字列どうしを比較する * '* IN : dat1 : 正規化数値文字列1 * '* dat2 : 正規化数値文字列2 * '* OUT : なし * '* 返却 : >0 : dat1 > dat2 または dat1<>"" and dat2="" * '* =0 : dat1 = dat2 または dat1="" and dat2="" * '* <0 : dat1 < dat2 または dat1="" and dat2<>"" * '* 作成 : 2019/02/14 Akito Kobayashi * '* 更新 : 2020/02/20 Akito Kobayashi Add dai1="" or dat2="" * '*********************************************************************** Function comp_normalize_num( _ ByRef dat1 As String _ , ByRef dat2 As String _ ) As Integer Dim c1 As String Dim c2 As String Dim wdat1 As String Dim wdat2 As String Dim d As Integer If dat1 = "" And dat2 = "" Then d = 0 ElseIf dat1 = "" Then d = -1 ElseIf dat2 = "" Then d = 1 Else c1 = Left(dat1, 1) c2 = Left(dat2, 1) If c1 = "-" And c2 = "-" Then wdat1 = Mid(dat1, 2) wdat2 = Mid(dat2, 2) ElseIf c1 = "-" Then d = -1 ElseIf c2 = "-" Then d = 1 ElseIf dat1 = dat2 Then d = 0 ElseIf dat1 < dat2 Then d = -1 Else d = 1 End If End If comp_normalize_num = d End Function '********1*********2*********3*********4*********5*********6*********7** '* 名称 : byte_array_copy * '* 機能 : バイト配列のコピー * '* IN : d() : コピー先領域 * '* s() : コピー元領域 * '* nary : コピー要素数 * '* Optional dpos : コピー先の開始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* Optional spos : コピー元の開始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* OUT : d() : コピーされたデータ * '* 作成 : 2020/07/29 Akito Kobayashi * '* 更新 : * '*********************************************************************** Sub byte_array_copy( _ ByRef d() As Byte _ , ByRef s() As Byte _ , ByVal nary As Integer _ , Optional ByVal dpos As Integer = 0 _ , Optional ByVal spos As Integer = 0 _ ) Call bcopy(d, dpos, s, spos, nary) End Sub '********1*********2*********3*********4*********5*********6*********7** '* 名称 : int_array_copy * '* 機能 : Integer配列のコピー * '* IN : d() : コピー先領域 * '* s() : コピー元領域 * '* nary : コピー要素数 * '* Optional dpos : コピー先の開始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* Optional spos : コピー元の開始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* OUT : d() : コピーされたデータ * '* 作成 : 2018/04/19 Akito Kobayashi * '* 更新 : * '*********************************************************************** Sub int_array_copy( _ ByRef d() As Integer _ , ByRef s() As Integer _ , ByVal nary As Integer _ , Optional ByVal dpos As Integer = 0 _ , Optional ByVal spos As Integer = 0 _ ) Dim i As Integer If dpos < 0 Then dpos = 0 If spos < 0 Then spos = 0 For i = 0 To nary - 1 d(i + dpos) = s(i + spos) Next End Sub '********1*********2*********3*********4*********5*********6*********7** '* 名称 : long_array_copy * '* 機能 : Long配列のコピー * '* IN : d() : コピー先領域 * '* s() : コピー元領域 * '* nary : コピー要素数 * '* Optional dpos : コピー先の開始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* Optional spos : コピー元の開始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* OUT : d() : コピーされたデータ * '* 作成 : 2018/04/19 Akito Kobayashi * '* 更新 : * '*********************************************************************** Sub long_array_copy( _ ByRef d() As Long _ , ByRef s() As Long _ , ByVal nary As Integer _ , Optional ByVal dpos As Integer = 0 _ , Optional ByVal spos As Integer = 0 _ ) Dim i As Integer If dpos < 0 Then dpos = 0 If spos < 0 Then spos = 0 For i = 0 To nary - 1 d(i + dpos) = s(i + spos) Next End Sub '********1*********2*********3*********4*********5*********6*********7** '* 名称 : str_array_copy * '* 機能 : String配列のコピー * '* IN : d() : コピー先領域 * '* s() : コピー元領域 * '* nary : コピー要素数 * '* Optional dpos : コピー先の開始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* Optional spos : コピー元の開始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* OUT : d() : コピーされたデータ * '* 作成 : 2018/04/19 Akito Kobayashi * '* 更新 : * '*********************************************************************** Sub str_array_copy( _ ByRef d() As String _ , ByRef s() As String _ , ByVal nary As Integer _ , Optional ByVal dpos As Integer = 0 _ , Optional ByVal spos As Integer = 0 _ ) Dim i As Integer If dpos < 0 Then dpos = 0 If spos < 0 Then spos = 0 For i = 0 To nary - 1 d(i + dpos) = s(i + spos) Next End Sub '********1*********2*********3*********4*********5*********6*********7** '* 名称 : byte_array_clear * '* 機能 : バイト配列のクリア * '* IN : d() : クリア領域 * '* val : クリア値 * '* nary : クリア要素数 * '* Optional dpos : クリア始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* OUT : d() : クリアされたデータ * '* 作成 : 2020/07/29 Akito Kobayashi * '* 更新 : * '*********************************************************************** Sub byte_array_clear( _ ByRef d() As Byte _ , ByVal val As Byte _ , ByVal nary As Integer _ , Optional ByVal dpos As Integer = 0 _ ) Call bset(d, val, nary, dpos) End Sub '********1*********2*********3*********4*********5*********6*********7** '* 名称 : int_array_clear * '* 機能 : Integer配列のクリア * '* IN : d() : クリア領域 * '* val : クリア値 * '* nary : クリア要素数 * '* Optional dpos : クリア始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* OUT : d() : クリアされたデータ * '* 作成 : 2019/07/19 Akito Kobayashi * '* 更新 : * '*********************************************************************** Sub int_array_clear( _ ByRef d() As Integer _ , ByVal val As Integer _ , ByVal nary As Integer _ , Optional ByVal dpos As Integer = 0 _ ) Dim i As Integer If dpos < 0 Then dpos = 0 For i = 0 To nary - 1 d(i + dpos) = val Next End Sub '********1*********2*********3*********4*********5*********6*********7** '* 名称 : long_array_clear * '* 機能 : Long配列のクリア * '* IN : d() : クリア領域 * '* val : クリア値 * '* nary : クリア要素数 * '* Optional dpos : クリア始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* OUT : d() : クリアされたデータ * '* 作成 : 2019/07/19 Akito Kobayashi * '* 更新 : * '*********************************************************************** Sub long_array_clear( _ ByRef d() As Long _ , ByVal val As Long _ , ByVal nary As Integer _ , Optional ByVal dpos As Integer = 0 _ ) Dim i As Integer If dpos < 0 Then dpos = 0 For i = 0 To nary - 1 d(i + dpos) = val Next End Sub '********1*********2*********3*********4*********5*********6*********7** '* 名称 : str_array_clear * '* 機能 : String配列のクリア * '* IN : d() : クリア領域 * '* val : クリア値 * '* nary : クリア要素数 * '* Optional dpos : クリア始位置 (先頭は0) (default=0) * '* <0のときは、0 と見なす * '* OUT : d() : クリアされたデータ * '* 作成 : 2019/07/19 Akito Kobayashi * '* 更新 : * '*********************************************************************** Sub str_array_clear( _ ByRef d() As String _ , ByRef val As String _ , ByVal nary As Integer _ , Optional ByVal dpos As Integer = 0 _ ) Dim i As Integer If dpos < 0 Then dpos = 0 For i = 0 To nary - 1 d(i + dpos) = val Next End Sub