とあるPGの備考録

この広告は30日以上更新がないブログに表示されております。
新規記事の投稿を行うことで、非表示にすることが可能です。

EBCDIC→UTF8だと環境依存文字があっても
文字化けした状態で書き出せている模様。

なお、出力結果をUTF8→S-JISに変換しようとすると
エラーとなります。

***********************************
Dim cn As Object ' ADODB.Connection
Dim rs As Object ' ADODB.Recordset

Dim strSQL As String

Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=IBMDA400;Data Source=192.168.1.1;User ID=QSECOFR;Password=QSECOFR;"

strSQL = ""
strSQL = strSQL & "SELECT * "
strSQL = strSQL & "FROM S000000.LIB.FILE MEMBER"

Set rs = CreateObject("ADODB.Recordset")

rs.CursorLocation = 2

rs.Open strSQL, cn


Dim stream
Dim csvStr As String

Const adTypeText = 2 ' ストリームタイプ（テキスト）
Const adSaveCreateOverWrite = 2 ' ファイル書き込みモード（既存ファイル上書き）

'ADODBストリームをテキスト（文字コード：UFT-8）でオープン
Set stream = CreateObject("ADODB.Stream")
stream.Open
stream.Type = adTypeText
stream.Charset = "UTF-8"

Dim CSV_Path, CSV_FileName As String


CSV_Path = Environ("UserProfile") & "\Downloads"
CSV_FileName = "\DATA.CSV"


Dim Buffer As String: Buffer = ""
Dim i As Long

' １行目にフィールド名出力
For i = 0 To rs.Fields.Count - 1
If Buffer <> "" Then
Buffer = Buffer & ","
End If
'Buffer = Buffer & rs.Fields(i).Name　'フィールド名
Buffer = Buffer & rs.Fields(i).Properties(3) 'COLHDG
Next
'Buffer = Buffer & vbCrLf '改行コード
stream.WriteText Buffer, 1 'adWriteLine

' データ出力
Dim dbl_qut As String: dbl_qut = Chr(34) 'Chr(34) = ダブルコーテーション
Dim DataType As Long
Do While Not rs.EOF
Buffer = ""
For i = 0 To rs.Fields.Count - 1

'データタイプがテキストであれば、”　”をつける
DataType = rs.Fields(i).Type
Select Case DataType
Case 14 'adDecimal
If Buffer <> "" Then
Buffer = Buffer & ","
End If
Buffer = Buffer & rs.Fields(i).Value

Case 131 'adNumeric
If Buffer <> "" Then
Buffer = Buffer & ","
End If
Buffer = Buffer & rs.Fields(i).Value

Case 200 'adVarChar
If Buffer <> "" Then
Buffer = Buffer & ","
End If
Buffer = Buffer & dbl_qut & rs.Fields(i).Value & dbl_qut

Case Else '念のためダブルコーテーションをつける
If Buffer <> "" Then
Buffer = Buffer & ","
End If
Buffer = Buffer & dbl_qut & rs.Fields(i).Value & dbl_qut
End Select

Next
stream.WriteText Buffer, 1 'adWriteLine

rs.movenext
Loop


'CSVデータをファイルに保存する（既存ファイルは上書き）
stream.SaveToFile (CSV_Path & CSV_FileName), adSaveCreateOverWrite

cn.Close
Set rs = Nothing
Set cn = Nothing

カンマ区切りCSV(S-JIS)を出力する。

EBCDIC→S-JISなので、フィールドの値に機種依存文字等があると
「CSV.WriteLine Buffer」でエラーが発生する。

当方はRPGで該当文字を配列でチェック・ブランク(0x4040)に置換して
DL用ファイルに書き出して、DL用ファイルから落とすようにした。

***********************
Dim cn As Object ' ADODB.Connection
Dim rs As Object ' ADODB.Recordset

Dim strSQL As String

Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=IBMDA400;Data Source=192.168.1.1;User ID=QSECOFR;Password=QSECOFR;"

strSQL = ""
strSQL = strSQL & "SELECT * "
strSQL = strSQL & "FROM S0000000.LIB.FILE MEMBER"

Set rs = CreateObject("ADODB.Recordset")

rs.CursorLocation = 2

rs.Open strSQL, cn

' 出力ファイルオープン

'参照設定あり　　ツール⇒　参照設定⇒　Microsoft Scripting Runtime にチェックあり
Dim FS As Scripting.FileSystemObject
Set FS = New Scripting.FileSystemObject

Dim CSV As TextStream
Dim CSV_Path, CSV_FileName As String


CSV_Path = Environ("UserProfile") & "\Downloads"
CSV_FileName = "\DATA.CSV"

Set CSV = FS.CreateTextFile(CSV_Path & CSV_FileName)

Dim Buffer As String: Buffer = ""
Dim i As Long

' １行目にフィールド名出力
For i = 0 To rs.Fields.Count - 1
If Buffer <> "" Then
Buffer = Buffer & ","
End If
'Buffer = Buffer & rs.Fields(i).Name　'フィールド名
Buffer = Buffer & rs.Fields(i).Properties(3) 'COLHDG
Next
CSV.WriteLine Buffer

' データ出力
Dim dbl_qut As String: dbl_qut = Chr(34) 'Chr(34) = ダブルコーテーション
Dim DataType As Long
Do While Not rs.EOF
Buffer = ""
For i = 0 To rs.Fields.Count - 1

'データタイプがテキストであれば、”　”をつける
DataType = rs.Fields(i).Type
Select Case DataType
Case 14 'adDecimal
If Buffer <> "" Then
Buffer = Buffer & ","
End If
Buffer = Buffer & rs.Fields(i).Value

Case 131 'adNumeric
If Buffer <> "" Then
Buffer = Buffer & ","
End If
Buffer = Buffer & rs.Fields(i).Value

Case 200 'adVarChar
If Buffer <> "" Then
Buffer = Buffer & ","
End If
Buffer = Buffer & dbl_qut & rs.Fields(i).Value & dbl_qut

Case Else '念のためダブルコーテーションをつける
If Buffer <> "" Then
Buffer = Buffer & ","
End If
Buffer = Buffer & dbl_qut & rs.Fields(i).Value & dbl_qut
End Select

Next
CSV.WriteLine Buffer
rs.movenext
Loop

CSV.Close

cn.Close
Set rs = Nothing
Set cn = Nothing

************

ADO接続で、カラムヘディングを取ってくる情報が少なかったので載せてみる

*********

Dim Data_SH_Name As String: Data_SH_Name = "DATA"
With Sheets.Add(After:=Sheets(Sheets.Count))
.Name = Data_SH_Name
End With

Dim cn As Object ' ADODB.Connection
Dim rs As Object ' ADODB.Recordset

Dim strSQL As String

Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=IBMDA400;Data Source=192.168.1.1;User ID=QSECOFR;Password=QSECOFR;"

strSQL = ""
strSQL = strSQL & "SELECT * "
strSQL = strSQL & "FROM S0000000.LIB.FILE MEMBER"

Set rs = CreateObject("ADODB.Recordset")

rs.CursorLocation = 2

rs.Open strSQL, cn

Dim XLSX_Path, XLSX_FileName As String
XLSX_Path = Environ("UserProfile") & "\Downloads"
XLSX_FileName = "\データ.XLSX"

Dim i As Long
' 3行目にフィールド名出力
For i = 0 To rs.Fields.Count - 1
Worksheets(Data_SH_Name).Cells(3, i + 1) = rs.Fields(i).Properties(3) 'COLHDG
Next

' 4行目からデータ出力
If Not rs.EOF Then
Worksheets(Data_SH_Name).Range("A4").CopyFromRecordset rs
End If

cn.Close
Set rs = Nothing
Set cn = Nothing

***************

RTX1210　(NTT光HS）　<==>　　RTX1200　(BBIQ　ギガコース）

iperf3で60M bits/sec前後でした。
ご参考まで。

saポリシー
ipsec sa policy 1 1 esp aes-cbc sha-hmac

NTTのBIZBOX　N1200（RTX1200)で
リモートVPN（L2TP/IPSEC）接続で、はまった話です。

クライアントからVPN接続はできるが
リモート接続先の同一セグメント機器との通信ができない。

答えは下記の設定が抜けていた為でした

　ip lan1 proxyarp on

【症状】
　クライアントからルータへのPINGが通る
　ルーターからクライアントへPINGが通る
　同一セグメントの端末へPINGが通らない

原因しらべるのに、1日費やしてしまいました。

AS400のHDDの空き容量が、通常のペースとは異なり
日に日に少なくなっていく現象が発生。

【環境】
　　system i7.3
　　バックアップ環境　RDX

光ディスク装置に関する
内部オブジェクトが増加するのが
原因らしい。

下記条件で発生する。

　光ディスク装置へのバックアップ運用
　毎日、IPL実施している。その際はPWRDWNSYS *IMMED


以下のいずれかで改善する。

　�@PTFをあてる　
　�A偶にRTVDSKINFを行う
　�BIPLの前に装置記述をOFFする。
　　　VRYCFG CFGOBJ(RMS01) CFGTYPE(*DEV) STATUS(*OFF)

VBA Excel Listview lvwReport　変数定義のエラーがでる。
その後、解決した事例。

別のブックにUserForm1をエクスポートした際に発生。

エクスポート先のツールボックスにはLiViewが表示されている。
ListViewコントロールのチェックもあるがエラーがでる。

UserForm1のオブジェクトに、
ツールボックスから、とりあえずListView2を追加したら
エラーが出なくなった。

その後、ListView2を削除した。
使用しているのは、Listrview1。

Excel　→TESTS（ストアドプロシジャ）→TESTC（CLP）→TEST(RPG)

【Excel】

Private Sub TEST()

Dim ReturnField As String

Dim cn As Object
Dim cmd As Object

Dim parm1 As Object
Dim parm2 As Object
Dim parm3 As Object

Set cn = CreateObject("ADODB.Connection")
Set cmd = CreateObject("ADODB.Command")

Set parm1 = CreateObject("ADODB.Parameter")
Set parm2 = CreateObject("ADODB.Parameter")
Set parm3 = CreateObject("ADODB.Parameter")

Dim label1 As String

Dim strCON As String


strCON = "Provider=IBMDA400;Data Source=192.168.1.1;User ID=QSECOFR;Password=QSECOFR;"

cn.Open strCON

cmd.ActiveConnection = cn
cmd.CommandType = 1 'adCmdText

cmd.CommandText = "CALL QGPL.TESTS(?, ?, ?)"
cmd.Parameters.Append cmd.CreateParameter("parm1", 129, 1, 2, "10")
cmd.Parameters.Append cmd.CreateParameter("parm2", 129, 1, 8, "20190327")
cmd.Parameters.Append cmd.CreateParameter("parm3", 129, 3, 1, " ")

cmd.Execute

label1 = cmd.Parameters(2).Value

cn.Close

End Sub

【CL】　TESTC

PGM PARM(&IN1 &IN2 &OUT1)

DCL VAR(&IN1) TYPE(*CHAR) LEN(2)
DCL VAR(&IN2) TYPE(*CHAR) LEN(8)
DCL VAR(&OUT1) TYPE(*CHAR) LEN(1)
CHGVAR VAR(&OUT1) VALUE('0')

CALL PGM(TEST) PARM(&IN1 &IN2)
MONMSG MSGID(CPF0000) EXEC+
(CHGVAR VAR(&OUT1) VALUE('1') )
ENDPGM

【TESTS】STRSQL　を導入していないので、iナビゲーターからストアドプロシジャを作成

CREATE PROCEDURE QGPL.TESTS(IN PARM1 CHAR(2),IN PARM2 CHAR(8),OUT PARM3 CHAR (1)) LANGUAGE CL NOT DETERMINISTIC NO SQL EXTERNAL NAME MYLIB.TESTC PARAMETER STYLE GENERAL

resyncのLogをメール転送させる。

タスクマネージャーから指定時間に　batファイル　→　powershellの流れで処理を行う。
メールサーバーはOCNのホスティングになります。





【sendmail_resync.batの内容】

powershell -NoProfile -ExecutionPolicy Unrestricted C:\sendmail\sendmail_resync.ps1

【sendmail_resync.ps1 の内容】


$user = "user01"
$pass = "*********"
$SmtpHost = "xxxx.mail.com"
$FromAddr = "user01@xxxx.co.jp"
$SmtpPort = 587
$ToAddr = "user01@xxxx.co.jp"
$Date = GET-DATE -Format "yyyy/MM/dd"

$mail = New-Object System.Net.Mail.MailMessage
$mail.from = $FromAddr
$mail.to.Add($ToAddr)
$mail.Subject = "Resync バックアップ状況"
$mail.Body = $Date + "バックアップ状況を転送します。Logファイルの添付がない場合は注意が必要です。"

$FileName = get-date -format yyMMdd
$FilePath="C:\Program Files\rsync193\" + $FileName +".log"

if (Test-Path $FilePath) {

$File=@(Get-ChildItem $FilePath)
$Attachment=New-Object Net.Mail.Attachment($File)
$mail.Attachments.Add($Attachment)

}



$sc = New-Object Net.Mail.SmtpClient($SmtpHost)
$Credentials = new-object System.Net.networkCredential($user, $pass)

$sc.UseDefaultCredentials = $true
$sc.EnableSsl = $true
$sc.Credentials=$Credentials
$sc.Port = $SmtpPort
$sc.Send($mail)

メルコのスイッチ　LSW5-GT-8EPL/WH　とアイオーのNAS　HDL-C1.0　相性（？）問題が発生。

両方とも1000BASE-T対応ですが、接続できない問題が発生しました。
PC等のほかの端末は接続できる。

YAMAHAのルーターについている、スイッチに入れると
問題なく1000BASE-Tで認識され通信できる。

　SW側のLANポートのランプがつかない
　Pingが応答しない

NASのファームは1.01で、最新のファームを上げると解決するのかもしれないが
使用できているので後回しにしている。