VBA
AS400
PersonalCommunications
PCOMM

VBAとPersonalCommunicationsでAS400へアクセスする関数群

More than 1 year has passed since last update.

もうこれ相当限られた人しか使わないと思うけど、AS400からVBAでPCOMMを使ってデータ転送したい人へ。なお、今の職場はもうAS400使ってなくて動作確認もできないのであしからず。

関連:CommonModule

AS400Module
Attribute VB_Name = "AS400Module"
Option Explicit
'---------------------------------------------------------------------------------------------------------------
'[プログラム名] AS400転送処理用モジュール
'[処理概要]     AS400の転送機能を操作する関数群を定義する
'[作成者]       
'[作成日]       
'[更新日]       
'[備考]         CommonModule要必要
'[動作確認]     Excel2003
'---------------------------------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------------------------------
'共通定数
'---------------------------------------------------------------------------------------------------------------
Private Const SYSTEM_NAME As String = "xxxxxxxx"

'---------------------------------------------------------------------------------------------------------------
'共通変数
'---------------------------------------------------------------------------------------------------------------
Public transExePath As String                               'AS転送用プログラムパス

'---------------------------------------------------------------------------------------------------------------
'[機能名] 初期処理
'[返り値] 無し
'[引数]   無し
'[概要]   初期処理をする
'[備考]   CommonModuleのcommonInitを事前に実行すること
'---------------------------------------------------------------------------------------------------------------
Public Function as400init() As Boolean

    Dim path As Variant
    Dim pathList As Variant

    'AS転送用プログラムパス候補設定
    pathList = Array("C:\Program Files\IBM\Personal Communications\PCSFT5.EXE", "C:\Program Files\Personal Communications\PCSFT5.EXE", "C:\Program Files (x86)\IBM\Personal Communications\PCSFT5.EXE", "C:\Program Files (x86)\Personal Communications\PCSFT5.EXE")

    'AS転送用プログラムを検索する
    transExePath = ""
    For Each path In pathList
        If fso.FileExists(path) Then transExePath = path
    Next path

    If transExePath = "" Then
        MsgBox "AS400転送用プログラムが見つかりません。"
        as400init = False
        Exit Function
    End If

    'PCOMMが立ち上がっているかチェックする
    If Not TaskExists("pcsws.exe") Then
        MsgBox "AS400が立ち上がっていないため、転送処理ができません。"
        as400init = False
        Exit Function
    End If

    as400init = True

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] PC->AS転送処理
'[返り値] 無し
'[引数]   lib: AS側ライブラリ名、 pf: AS側物理ファイル名、 pcFile: PC側転送ファイルパス、 fdfFile: FDFファイルパス
'[概要]   PCからASへデータ転送する
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Sub AS400send(lib As String, pf As String, pcFile As String, fdfFile As String)

    Dim fileNo As Integer
    Dim definFile As String

    '転送定義ファイルパス生成(一時フォルダへ生成)
    definFile = fso.GetSpecialFolder(2) & "\" & fso.GetBaseName(fso.GetTempName) & ".tfr"

    fileNo = FreeFile
    Open definFile For Output As #fileNo

    Print #fileNo, "[Profile]"
    Print #fileNo, "TRFRPC"
    Print #fileNo, "Description="
    Print #fileNo, "TO          " & lib & "/" & pf
    Print #fileNo, pcFile
    Print #fileNo, "11"
    Print #fileNo, fdfFile
    Print #fileNo, "32    1"
    Print #fileNo, ""
    Print #fileNo, ""
    Print #fileNo, ""
    Print #fileNo, "SYSTEM      " & SYSTEM_NAME

    Close #fileNo

    '転送実行
    CreateObject("Wscript.Shell").Run """" & transExePath & """" & " " & """" & definFile & """", 5, True

    '転送定義ファイル削除
    fso.DeleteFile (definFile)

End Sub

'---------------------------------------------------------------------------------------------------------------
'[機能名] AS->PC転送処理
'[返り値] 無し
'[引数]   lib: AS側ライブラリ名、 pf: AS側物理ファイル名、 pcFile: PC側転送ファイルパス
'         pcTypeFlag: "ascii", "basics", "basicr", "dif"、 overWriteFlag: true or false (trueでPC側ファイル上書き)
'         fdfFlag: true or false(trueでFDFファイルを使用する)、 fdfFile: FDFファイルパス
'[概要]   ASからPCへデータ転送する
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Sub AS400recv(lib As String, pf As String, pcFile As String, pcTypeFlag As String, overWriteFlag As Boolean, fdfFlag As Boolean, fdfFile As String)

    Dim fileNo As Integer
    Dim definFile As String
    Dim pcType As String
    Dim overWrite As String
    Dim fdf As String

    'PCファイルタイプ設定
    Select Case pcTypeFlag
    Case "ascii"
        pcType = "1"
    Case "basics"
        pcType = "3"
    Case "basicr"
        pcType = "4"
    Case "dif"
        pcType = "5"
    End Select

    '上書きフラグ設定
    If overWriteFlag Then
        overWrite = "1"
    Else
        overWrite = "2"
    End If

    'FDFフラグ設定
    If fdfFlag Then
        fdf = "1"
    Else
        fdf = "2"
    End If

    '転送定義ファイルパス生成(一時フォルダへ生成)
    definFile = fso.GetSpecialFolder(2) & "\" & fso.GetBaseName(fso.GetTempName) & ".tto"

    fileNo = FreeFile
    Open definFile For Output As #fileNo

    Print #fileNo, "[Profile]"
    Print #fileNo, "TRTOPC"
    Print #fileNo, "Description="
    Print #fileNo, "FROM        " & lib & "/" & pf
    Print #fileNo, "SELECT      *"
    Print #fileNo, "WHERE"
    Print #fileNo, "ORDER BY"
    Print #fileNo, "3"
    Print #fileNo, pcFile
    Print #fileNo, pcType & "3" & overWrite & fdf
    Print #fileNo, "13211 661"
    Print #fileNo, fdfFile
    Print #fileNo, "12"
    Print #fileNo, "JOIN BY"
    Print #fileNo, "GROUP BY"
    Print #fileNo, "HAVING"
    Print #fileNo, "SYSTEM      " & SYSTEM_NAME
    Print #fileNo, "OPTIONS     2:/.HMSYMDN11"

    Close #fileNo

    '転送実行
    CreateObject("Wscript.Shell").Run """" & transExePath & """" & " " & """" & definFile & """", 5, True

    '転送定義ファイル削除
    fso.DeleteFile (definFile)

End Sub