在庫管理

在庫管理システム－その他

2022年10月15日

簡易マニュアル
ダウンロード
テーブル一覧
ログイン
　フォーム
　VBAコード
メインメニュー
　フォーム
　VBAコード
入出庫処理
　フォーム
　VBAコード
入出庫履歴
　フォーム
　クエリ
　VBAコード
在庫検索
　クエリ
　VBAコード
安全在庫
　フォーム
　クエリ
　VBAコード
在庫転送
　フォーム
　VBAコード
単位変換
　フォーム
　VBAコード
インポートとテーブルクリア
　フォーム
　VBAコード
マスタ
BOM構成
　フォーム
　VBAコード
エラーログ
その他
　ハッシュ値
　参照設定
　バーコード
　完成したら
　標準モジュールVBAコード

その他

ハッシュ値

パスワードのハッシュ値を求めます。今まで「VBエディタのイミディエイトウィンドウにて」と記述していましたが、この処理を追加しました。
求めたい文字列を入力しますと、ハッシュ値が表示されます。同時にクリップボードにコピーしてあります。

参照設定

Ver.2.00βにて追加した機能の中には参照設定を追加したものもあります。この設定がこのファイルに保存されているのか、PCのレジストリなどに設定されているのかわかっていません。とりあえず、現行の参照設定を示しておきます。チェックが入っている項目のうち、下の3つは必要かと思われます。

VBエディタの「ツール」-「参照設定」

バーコード

各種コードをバーコードで表示させる方法を簡単に記しておきました。（Excelによる帳票サンプル付き）
2021年7月8日、バーコードフォントをインストールしなくても実現できるように作り直しました。

在庫管理システム－その他
参考記事
バーコード帳票印刷（サンプル付き）
管理している品目にバーコードを付けてバーコードリーダで読み取らせたい場合もあるかと思います。一般的にはバーコードフォントをインストールしますが、バーコードコントロールを使用することによりフォントのインストールを回避しました。

完成したら

自社で利用できるようにカスタマイズが終わりましたら、一般ユーザーがソースコードを見たり編集したりできないようにする必要があります。

データベースの分割

必ずバックアップをとってください。

方法は【データベースツール】タブから【Accessデータベース】を選びます。これでファイルが2つに分割されます。テーブルのファイルをファイルサーバ上に置いておきます。下図３つ目で分割されるファイルを保存します。

コンパイルファイルの保存

次にコンパイルファイルを保存します。名前を付けて保存にてコンパイルファイル（ACCDEの作成）を選択して保存します。この時にエラーメッセージがあって終了した場合には、何かしらコンパイルエラーがあったということです。
VBエディタにて【デバッグ】-【○○のコンパイル】を実行しますと、エラー箇所がわかります。修正を繰り返して【○○のコンパイル】でエラーがなくなりましたら、再度名前を付けて保存作業をしてください。

注意

保存したファイルを移動させるとアクセスできなくなります。

VBAコードの修正

「F_ログイン」と「F_メイン」のVBAコードにおいて「'CloseWindow Application.hWndAccessApp」の行頭のシングルクォーテーション（'）を削除してください。
２つのフォームに記載しているのは、ログインを必要とせずにF_メインを起動フォームとした場合を想定しているためです。

Private Sub Form_Load()
On Error GoTo 終了
    Dim txtVer As String
    Dim txtβ As String
    
    'CloseWindow Application.hWndAccessApp       'Accessを最小化する
Private Sub Form_Load()
On Error GoTo 終了
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    'CloseWindow Application.hWndAccessApp       'Accessを最小化する
    Call FormInit(Me)

同様に２つのフォームの終了時の処理にて「'DoCmd.Quit」の行頭のシングルクォーテーションを削除してください。
これにより、フォームを閉じた瞬間にAccessは終了します。編集は一切できなくなります。
編集ができないということは、一般ユーザーにもソースコードを見ることすらできなくさせます。以降、バグが見つかったり、機能を変更したりするときはバックアップしていたファイルで行い、コンパイルしたファイルをユーザーに配布して入れ替えます。

Private Sub cmd_閉じる_Click()
    DoCmd.Close
    'DoCmd.Quit     'コメントを外すと、終了時にAccessを閉じます。
End Sub
Private Sub cmd_閉じる_Click()
On Error GoTo 終了  'ログインなしに開いた場合にエラーになるため
    Dim dbs As Database
    Dim rst As DAO.Recordset
    Dim sql As String
    
    Set dbs = CurrentDb
    Set rst = CurrentDb.OpenRecordset("T_ログイン履歴")
    With rst
        .MoveLast                       '一旦最後に移動しないと機能しない
        .AbsolutePosition = intID - 1   'ID=intIDの行に移動
        .Edit
        .Fields("ログアウト日時") = Now
        .Update
        .Close
    End With
    Set rst = Nothing
    
    DoCmd.Close
    'DoCmd.Quit     'コメントを外すと、終了時にAccessを閉じます。
    Exit Sub
終了:
    Call エラーログ("F_メイン", "cmd_閉じる_Click")
    DoCmd.Close
End Sub

バックアップ

私は経験したことがありませんが、データベースはたまに破損するようです。
こまめにバックアップを取って万が一に備えましょう。

自動最適化

データベースはほっておくと勝手にファイルサイズが増大します。
定期的に最適化をすることが好ましいようです。
当在庫管理システムではオプション設定により、ファイルを閉じる際に最適化を実行するような設定にしております。

標準モジュール

Ver.2未満ではModule1、Module2としていました。いろいろルーチンが増えましたので、Ver.2.00βから機能別に標準モジュールファイルを分けました。
下記ソースコードはVer.2.10

M_Initialize

F_メインが開かれるタイミングでT_各種設定の情報などを読み込む処理を行っています。

Option Compare Database
Option Explicit

'---------------------------------
'フォームに共通するSub・Function
'---------------------------------
Public lngLoginID As Long       'ログインした社員コード
Public bAdmin As Boolean        '管理者かどうか、管理者ならTrue、そうでなければFalse
Public strFileName As String    'デフォルトのフォルダは「マイドキュメント」です。
Public lngDisplayRes As Long    '画面の解像度（1920x1080、1366x768などによってフォームのサイズを変更する場合にしようします）
Public intID As Integer         'ログインした際のログイン履歴のIDフィールド
Public lngBomID As Long
Public strMaster As String     'F_各種設定がどのコマンドボタンから呼ばれたか
Public str検索フィルタ As String
Public lng親品目上限 As Long
Public lng親品目下限 As Long
Public lng子品目上限 As Long
Public lng子品目下限 As Long

'---------------------------------
'フォームを最小化
'---------------------------------
Declare Function CloseWindow Lib "user32" (ByVal hwnd As Long) As Long

'---------------------------------
'フォームをドラッグ
'---------------------------------
Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Sub ReleaseCapture Lib "user32.dll" ()
 
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2

'---------------------------------
Public Sub 初期値()
On Error GoTo 終了
    '---------------------------------
    '関数GetWindowSizeはM_画面にあります
    '関数GetDatabaeLastはM_在庫管理にあります
    '---------------------------------
    lngDisplayRes = GetWindowSize   '画面の解像度を取得する
    strFileName = ReadDatabase("T_各種設定", "パラメータ", "ExcelFileName", "設定値")
    str検索フィルタ = ReadDatabase("T_各種設定", "パラメータ", "検索フィルタ", "設定値")
    lng親品目上限 = Val(ReadDatabase("T_各種設定", "パラメータ", "親品目上限", "設定値"))
    lng親品目下限 = Val(ReadDatabase("T_各種設定", "パラメータ", "親品目下限", "設定値"))
    lng子品目上限 = Val(ReadDatabase("T_各種設定", "パラメータ", "子品目上限", "設定値"))
    lng子品目下限 = Val(ReadDatabase("T_各種設定", "パラメータ", "子品目下限", "設定値"))
    strMaster = ""
    Exit Sub
終了:
    Call エラーログ("M_Initialize", "初期値")
End Sub

M_在庫管理

在庫管理システムにて使用する共通する関数・サブルーチンを集めたものです。

Option Compare Database
Option Explicit

'---------------------------------
'検索履歴をT_検索履歴に記録するサブルーチン
'txt：検索ワード
'---------------------------------
Sub 検索履歴(txt As String)
On Error GoTo 終了
    Dim rst As DAO.Recordset
    
    '重複データなら検索履歴として追記しない
    If Nz(DLookup("検索履歴", "T_検索履歴", "検索履歴 = '" & txt & "'"), "empty") = "empty" Then
        Set rst = CurrentDb.OpenRecordset("T_検索履歴")
        With rst
            .AddNew
            .Fields("検索履歴") = Nz(txt, "")
            .Update
        End With
        
        rst.Close
        Set rst = Nothing
    End If
    Exit Sub
終了:
    Call エラーログ("M_在庫管理", "検索履歴")
End Sub

'---------------------------------
'サブフォームの項目をダブルクリックした時の処理
'strForm：サブフォーム名
'---------------------------------
Public Sub 処理(strForm As Form)
On Error GoTo 終了
    Select Case strForm.Parent.Name 'サブフォームの親フォーム名で処理を振り分け
        Case "F_安全在庫"
            '特になし
        Case "F_在庫検索"
            '特になし
        Case "F_在庫転送"
            If Forms![F_在庫転送]![SF_在庫転送]![削除].Value = True Then
                MsgBox "削除された品目です"
                GoTo 終了
            Else
                Forms![F_在庫転送]![cmb_品目].Value = Forms![F_在庫転送]![SF_在庫転送]![品目コード].Value
                Forms![F_在庫転送]![lbl_品目].Caption = Forms![F_在庫転送]![SF_在庫転送]![品目型式].Value
                Forms![F_在庫転送]![cmb_転送元].Value = Forms![F_在庫転送]![SF_在庫転送]![保管場所コード].Value
                Forms![F_在庫転送]![lbl_転送元].Caption = Forms![F_在庫転送]![SF_在庫転送]![保管場所].Value
                Forms![F_在庫転送]![cmb_単位].Value = Forms![F_在庫転送]![SF_在庫転送]![単位コード].Value
                Forms![F_在庫転送]![lbl_単位].Caption = Forms![F_在庫転送]![SF_在庫転送]![単位].Value
                Forms![F_在庫転送]![cmb_品目].BackColor = vbWhite
                Forms![F_在庫転送]![cmb_転送元].BackColor = vbWhite
                Forms![F_在庫転送]![cmb_単位].BackColor = vbWhite
                Forms![F_在庫転送]![txt_数量].SetFocus
            End If
        Case "F_単位変換"
            If Forms![F_単位変換]![SF_単位変換]![削除].Value = True Then
                MsgBox "削除された品目です"
                GoTo 終了
            Else
                Forms![F_単位変換]![cmb_品目].Value = Forms![F_単位変換]![SF_単位変換]![品目コード].Value
                Forms![F_単位変換]![lbl_品目].Caption = Forms![F_単位変換]![SF_単位変換]![品目型式].Value
                Forms![F_単位変換]![cmb_保管場所].Value = Forms![F_単位変換]![SF_単位変換]![保管場所コード].Value
                Forms![F_単位変換]![cmb_変換前単位].Value = Forms![F_単位変換]![SF_単位変換]![単位コード].Value
                Forms![F_単位変換]![lbl_変換前単位].Caption = Forms![F_単位変換]![SF_単位変換]![単位].Value
                Forms![F_単位変換]![cmb_品目].BackColor = vbWhite
                Forms![F_単位変換]![cmb_保管場所].BackColor = vbWhite
                Forms![F_単位変換]![cmb_変換前単位].BackColor = vbWhite
                Forms![F_単位変換]![txt_変換前数量].SetFocus
            End If
        Case "F_入出庫履歴"
            '特になし
        Case "F_BOM"
                Forms![F_BOM]![cmb_親品目コード].Value = Forms![F_BOM]![SF_BOM]![親品目コード].Value
                Forms![F_BOM]![lbl_親品目型式].Caption = Forms![F_BOM]![SF_BOM]![T_品目.品目型式].Value
                Forms![F_BOM]![cmb_子品目コード].Value = Forms![F_BOM]![SF_BOM]![品目コード].Value
                Forms![F_BOM]![lbl_子品目型式].Caption = Forms![F_BOM]![SF_BOM]![T_品目_1.品目型式].Value
                Forms![F_BOM]![txt_数量].Value = Forms![F_BOM]![SF_BOM]![数量].Value
                Forms![F_BOM]![cmb_単位].Value = Forms![F_BOM]![SF_BOM]![T_単位.単位コード].Value
                Forms![F_BOM]![lbl_単位].Caption = Forms![F_BOM]![SF_BOM]![T_単位.単位].Value
                Forms![F_BOM]![cmb_保管場所].Value = Forms![F_BOM]![SF_BOM]![T_保管場所.保管場所コード].Value
                Forms![F_BOM]![lbl_保管場所].Caption = Forms![F_BOM]![SF_BOM]![T_保管場所.保管場所].Value
        Case "F_入出庫処理"
            If Forms![F_入出庫処理]![SF_品目]![削除].Value = True Then
                MsgBox "削除された品目です"
                GoTo 終了
            Else
                Forms![F_入出庫処理]![cmb_品目].Value = Forms![F_入出庫処理]![SF_品目]![品目コード].Value
                Forms![F_入出庫処理]![lbl_品目].Caption = Forms![F_入出庫処理]![SF_品目]![品目型式].Value
                Forms![F_入出庫処理]![cmb_品目].BackColor = vbWhite
                Forms![F_入出庫処理]![txt_数量].SetFocus
            End If
    End Select
    Exit Sub
終了:
    Call エラーログ("M_在庫管理", "ReadDatabase")
End Sub

'---------------------------------
'テーブルからの読み込み
'引数1 : strTable : テーブル
'引数2 : strField : 項目
'返り値 ： フィールドの値（文字列）
'---------------------------------
Public Function ReadDatabase(ByVal strTable As String, ByVal strField1 As String, ByVal strParameter As String, ByVal strField2 As String) As String
On Error GoTo 終了
    Dim sql As String
    Dim rst As DAO.Recordset
    
    sql = "SELECT * FROM " & strTable & " WHERE " & strField1 & "= '" & strParameter & "'"
    Set rst = CurrentDb.OpenRecordset(sql)
    ReadDatabase = Nz(rst.Fields(strField2), "")
    
    rst.Close
    Set rst = Nothing
    Exit Function
終了:
    Call エラーログ("M_在庫管理", "ReadDatabase")
End Function

'---------------------------------
'テーブルの最終行のフィールド名のデータを取得する
'strTable=テーブル名
'strFiele=フィールド名
'---------------------------------
Public Function GetDatabaeLast(ByVal strTable As String, ByVal strField As String) As String
On Error GoTo 終了
    Dim sql As String
    Dim rst As DAO.Recordset
    
    If IsNull(strTable) Or IsNull(strField) Then
        GetDatabaeLast = ""
        Exit Function
    End If
    
    sql = "SELECT * FROM " & strTable
    Set rst = CurrentDb.OpenRecordset(sql)
    rst.MoveLast
    GetDatabaeLast = Nz(rst.Fields(strField), "")

    rst.Close
    Set rst = Nothing
    Exit Function
終了:
    Call エラーログ("M_在庫管理", "GetDatabaeLast")
End Function

'---------------------------------
' Excelからのインポート
'---------------------------------
Public Sub ImportFromExcel(strTable As String)
On Error GoTo 終了
    If strFileName = "" Then strFileName = "在庫管理システム・元データ"
    Dim str範囲 As String
    Dim strTable2 As String

    Dim rst As DAO.Recordset
    strTable2 = "T_" & strTable
    Set rst = CurrentDb.OpenRecordset(strTable2)
    
    Select Case strTable2
        Case "T_社員"
            str範囲 = strTable & "!B1:I65535"
        Case "T_品目"
            str範囲 = strTable & "!B1:K65535"
        Case "T_仕入先"
            str範囲 = strTable & "!B1:J65535"
    End Select
    
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, strTable2, strFileName, True, str範囲
    MsgBox "インポートしました"
    rst.Close
    Set rst = Nothing
    Exit Sub
終了:
    Call エラーログ("M_在庫管理", "ImportFromExcel")
    If Err.Number = 3011 Then
        MsgBox "ファイルが見つかりませんでした。" & vbCr & "ファイルはマイドキュメントにおいてください。"
    Else
        MsgBox "インポートできませんでした"
        Debug.Print Err.Number
    End If
End Sub

'---------------------------------
Public Sub 並び替え(ByVal subForm As Control, ByVal strField As String)
    
    subForm.Form.OrderBy = strField '並べ替えの基準とするフィールドを設定
    subForm.Requery

End Sub

'---------------------------------
Public Sub エラーログ(ByVal m As String, ByVal p As String)
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_エラーログ")
    With rst
        .AddNew
        .Fields("日時") = Now
        .Fields("エラー番号") = Err.Number
        .Fields("エラーメッセージ") = Err.Description
        .Fields("エラーモジュール") = m
        .Fields("エラープロシージャ") = p
        .Update
        .Close
    End With
    Set rst = Nothing
End Sub

M_画面

フォームサイズを変更する際の処理や、画面の解像度を取得してフォームサイズを変更したり（うまく動作してません）のルーチンです。

'---------------------------------
'フォームとは無関係のSub・Function
'---------------------------------
Option Compare Database
Option Explicit

'デスクトップサイズ取得関係のAPIの宣言
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
  x1 As Long
  y1 As Long
  x2 As Long
  y2 As Long
End Type

'---------------------------------
Declare Function CloseWindow Lib "user32" (ByVal hwnd As Long) As Long

'---------------------------------
'画面の解像度を取得する
'---------------------------------
Public Function GetWindowSize()
    Dim r As RECT
    Dim hwnd As Long
    Dim lngWidth As Long
    Dim lngHeight As Long
    
    hwnd = GetDesktopWindow()
    
    GetWindowRect hwnd, r
    
    lngWidth = r.x2 - r.x1
    lngHeight = r.y2 - r.y1
    
    'MsgBox "ディスプレイの解像度は " & lngWidth & "×" & lngHeight
    
    GetWindowSize = lngWidth
End Function

'---------------------------------
'サブフォームの大きさを変更するサブルーチン
'frm：フォーム
'ctl：コントロール
'---------------------------------
Public Sub AdjustWidth(strForm As Form, strCtrl As Control, lngTop As Long)
    If strForm.InsideHeight < 6500 Then strForm.InsideHeight = 6500
    
    strCtrl.Height = strCtrl.Height * 0.8              '最初にフォームの内側を小さくしておく
    strForm.Section(acFooter).Height = strForm.InsideHeight - strForm.Section(acDetail).Height - strForm.Section(acHeader).Height - lngTop
    strCtrl.Height = strForm.Section(acFooter).Height
    '
    strCtrl.Left = 0
    strCtrl.Width = strForm.InsideWidth
End Sub

'---------------------------------
Public Sub FormInit(frm As Form)
On Error GoTo 終了
    If lngDisplayRes >= 1920 Then frm.Width = 20000 Else frm.Width = 17000
    
    frm.RecordSelectors = False     'レコードセレクタを非表示
    frm.NavigationButtons = False   '移動ボタン非表示
    frm.ShortcutMenu = False        '右クリック禁止
    frm.ShortcutMenuBar = False
    Exit Sub
終了:
    Call エラーログ("M_画面", "FormInit")
End Sub

M_文字列

新パスワードのチェックに使う文字列関連のコードです。

Option Compare Database

'---------------------------------
    'ASCIIコードについて
    '数字:48～57
    'アルファベット大文字:65～90
    'アルファベット小文字:97～122
    '記号:33～47と58～64と91～96と123～126
    '本来なら正規表現で書くとよいのですが、Regex.IsMatchがなぜか使えず。
'---------------------------------

'---------------------------------
'ログインパスワードの文字チェックを行う
'引数1：strText（パスワード文字列）
'引数2:t（判定するタイプ）
'返り値:True/False
'---------------------------------
Public Function Is英数記号(ByVal strText As String, ByVal t As Byte) As Boolean
On Error GoTo 終了
    '---------------------------------
    'tはタイプ(0~3)
    '0:英数（区別なし）
    '1:英数区別（大文字小文字区別）
    '2:英数記号（区別なし）
    '3:英数記号区別（大文字小文字区別）
    '---------------------------------
    Dim intASC As Integer  'ASCIIコード
    Dim b大文字 As Boolean '大文字かどうか
    Dim b小文字 As Boolean '小文字かどうか
    Dim b数字 As Boolean   '数字かどうか
    Dim b記号 As Boolean   '記号かどうか
    Dim cnt As Byte 'ループカウント
    
    '初期値入力
    cnt = 1
    b大文字 = False
    b小文字 = False
    b数字 = False
    b記号 = False
    
    '文字列の文字数分だけループ処理
    Do While cnt <= Len(strText)
    
        'Asc関数を使用して、任意の文字の文字コードを取得
        intASC = Asc(Mid(strText, cnt, 1))
        
        '取得した文字コードが英数字かどうかチェック
        If Is数字(intASC) = True Then b数字 = True
        If Is大文字(intASC) = True Then b大文字 = True
        If Is小文字(intASC) = True Then b小文字 = True
        If Is記号(intASC) = True Then b記号 = True
        'ループ用変数のカウントアップ
        cnt = cnt + 1
    Loop
    
    If b数字 = False Then  '数字は必須
        Is英数記号 = False
        Exit Function
    End If
    
    Select Case t
        Case 0    '0:英数（区別なし）
            If b大文字 = True Or b小文字 = True Then Is英数記号 = True Else Is英数記号 = False
        Case 1    '1:英数（大文字小文字区別）
            If b大文字 = True And b小文字 = True Then Is英数記号 = True Else Is英数記号 = False
        Case 2    '2:英数記号（区別なし）
            If b記号 = True And (b大文字 = True Or b小文字 = True) Then Is英数記号 = True Else Is英数記号 = False
        Case 3    '3:英数記号（大文字小文字区別）
            If b記号 = True And b大文字 = True And b小文字 = True Then Is英数記号 = True Else Is英数記号 = False
    End Select
    Exit Function
終了:
    Call エラーログ("M_文字列", "Is英数記号")
End Function

'---------------------------------
Private Function Is数字(num As Integer) As Boolean
On Error GoTo 終了
        '取得した文字が数字かどうかチェック
        If (num >= 48 And num <= 57) Then
            Is数字 = True
        Else
            Is数字 = False
        End If
    Exit Function
終了:
    Call エラーログ("M_文字列", "Is数字")
End Function

'---------------------------------
Private Function Is大文字(num As Integer) As Boolean
On Error GoTo 終了
        '取得した文字コードが大文字かどうかチェック
        If (num >= 65 And num <= 90) Then
            Is大文字 = True
        Else
            Is大文字 = False
        End If
    Exit Function
終了:
    Call エラーログ("M_文字列", "Is大文字")
End Function

'---------------------------------
Private Function Is小文字(num As Integer) As Boolean
On Error GoTo 終了
        '取得した文字コードが小文字かどうかチェック
        If (num >= 97 And num <= 122) Then
            Is小文字 = True
        Else
            Is小文字 = False
        End If
    Exit Function
終了:
    Call エラーログ("M_文字列", "Is小文字")
End Function

'---------------------------------
Private Function Is記号(num As Integer) As Boolean
On Error GoTo 終了
        '取得した文字コードが記号かどうかチェック
        If (num >= 33 And num <= 47) Or _
            (num >= 58 And num <= 64) Or _
            (num >= 91 And num <= 96) Or _
            (num >= 123 And num <= 126) _
        Then
            Is記号 = True
        Else
            Is記号 = False
        End If
    Exit Function
終了:
    Call エラーログ("M_文字列", "Is記号")
End Function

'---------------------------------
Public Sub SetCB(ByVal strSet As String)
On Error GoTo 終了
'クリップボードにstrSetを貼り付ける
    '文字化け対策のためTextBoxを使用
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True '複数行入力可
        .Text = strSet
        .SelStart = 0
        .SelLength = .textlength
        .Copy
    End With
    Exit Sub
終了:
    Call エラーログ("M_文字列", "SetCB")
End Sub

M_外部データベース

旧バージョンの在庫管理システムからデータをインポートするのに必要なコードです。

Option Compare Database

'---------------------------------
'＊　Accessデータベース接続
'参照：https://808hanablog.com/how-to-connect-to-external-access-with-vba
'---------------------------------
Public ADO_CN As ADODB.Connection 'ADOコネクション

'---------------------------------
Public Function ADO_CONNECTION() As Boolean
On Error GoTo 終了
    Dim ACCESS_FILEPATH As String 'Accessファイルパス
    
    'Accessファイルパス
    ACCESS_FILEPATH = GetAccessFile
    If ACCESS_FILEPATH <> "" Then
        'Connectionオブジェクトのインスタンス化
        Set ADO_CN = New ADODB.Connection
        'Access接続
        ADO_CN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & ACCESS_FILEPATH & ";"
        ADO_CONNECTION = True
    Else
        ADO_CONNECTION = False
    End If
    Exit Function
終了:
    Call エラーログ("M_外部データベース", "ADO_CONNECTION")
End Function

'---------------------------------
'＊　Accessデータベース接続解除
'---------------------------------
Public Sub ADO_DISCONNECTION()
    
    '接続解除
    ADO_CN.Close
    Set ADO_CN = Nothing
End Sub

'---------------------------------
'参照：https://officevba.info/filedialog/
'要Microsoft Office ○○ Object Library
'[ツール]-[参照設定]にて設定
'---------------------------------
Public Function GetAccessFile()
On Error GoTo 終了
    Dim i
    Dim WSH As Object
    Set WSH = CreateObject("Wscript.Shell")
    Dim DesktopPath As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "ファイルの選択"   'ダイアログのタイトル
        .Filters.Clear
        .Filters.Add "Access", "*.mdb; *.accdb"
        If .Show = True Then
            For i = 1 To .SelectedItems.Count
                GetAccessFile = .SelectedItems(i)
            Next i
        End If
    End With
    Set WSH = Nothing
    Exit Function
終了:
    Call エラーログ("M_外部データベース", "GetAccessFile")
End Function

'---------------------------------
Public Sub Import()
On Error GoTo 終了
    Dim objRec As ADODB.Recordset
    
    If ADO_CONNECTION = False Then
        MsgBox "インポートはキャンセルされました"
        Exit Sub
    End If
    
    '---------------------------------
    Call 品目
    Call 社員
    Call 仕入先
    Call 単位
    Call 保管場所
    Call 入出庫
    Call 指図番号
    Call サイド番号
    Call 入出庫処理
    Call 検索クリア
    Call ログイン履歴
    '↓Ver.2.00より
    Call テーブル
    Call マスタ更新履歴
    Call 各種設定
    '↓Ver.2.10より
    Call BOM
    
    '---------------------------------
    MsgBox ("インポートが完了しました")
    Call ADO_DISCONNECTION
    Exit Sub
終了:
    Call エラーログ("M_外部データベース", "Import")
End Sub

'---------------------------------
Public Sub 品目()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_品目")
    
    'T_品目
    Set objRec = ADO_CN.Execute("T_品目", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_品目"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("品目コード") = objRec.Fields("品目コード").Value
            .Fields("品目型式") = objRec.Fields("品目型式").Value
            .Fields("メーカー") = objRec.Fields("メーカー").Value
            .Fields("安全在庫") = objRec.Fields("安全在庫").Value
            .Fields("最小ロット") = objRec.Fields("最小ロット").Value
            .Fields("標準ロット") = objRec.Fields("標準ロット").Value
            .Fields("標準納期") = objRec.Fields("標準納期").Value
            .Fields("仕入先コード") = objRec.Fields("仕入先コード").Value
            .Fields("WEBサイト") = objRec.Fields("WEBサイト").Value
            .Fields("削除") = objRec.Fields("削除").Value
            .Update
        End With
        
        objRec.MoveNext
    Wend
終了:
End Sub

'---------------------------------
Public Sub 社員()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_社員")
    
    'T_社員
    Set objRec = ADO_CN.Execute("T_社員", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_社員"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("社員コード") = objRec.Fields("社員コード").Value
            .Fields("社員") = objRec.Fields("社員").Value
            .Fields("所属") = objRec.Fields("所属").Value
            .Fields("権限") = objRec.Fields("権限").Value
            .Fields("パスワード") = objRec.Fields("パスワード").Value
            '.Fields("平文") = objRec.Fields("平文").Value
            .Fields("登録日") = objRec.Fields("登録日").Value
            .Fields("初期パスワード") = objRec.Fields("初期パスワード").Value
            .Fields("削除") = objRec.Fields("削除").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'---------------------------------
Public Sub 仕入先()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_仕入先")
    
    'T_仕入先
    Set objRec = ADO_CN.Execute("T_仕入先", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_仕入先"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("仕入先コード") = objRec.Fields("仕入先コード").Value
            .Fields("仕入先会社名") = objRec.Fields("仕入先会社名").Value
            .Fields("郵便番号") = objRec.Fields("郵便番号").Value
            .Fields("住所") = objRec.Fields("住所").Value
            .Fields("電話番号") = objRec.Fields("電話番号").Value
            .Fields("FAX番号") = objRec.Fields("FAX番号").Value
            .Fields("営業担当者") = objRec.Fields("営業担当者").Value
            .Fields("携帯電話番号") = objRec.Fields("携帯電話番号").Value
            .Fields("Eメールアドレス") = objRec.Fields("Eメールアドレス").Value
            .Fields("削除") = objRec.Fields("削除").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'---------------------------------
Public Sub 単位()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_単位")
    
    'T_単位
    Set objRec = ADO_CN.Execute("T_単位", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_単位"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("単位コード") = objRec.Fields("単位コード").Value
            .Fields("単位") = objRec.Fields("単位").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'---------------------------------
Public Sub 指図番号()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_指図番号")
    
    'T_指図番号
    Set objRec = ADO_CN.Execute("T_指図番号", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_指図番号"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("指図番号") = objRec.Fields("指図番号").Value
            .Fields("予算") = objRec.Fields("予算").Value
            .Fields("工数") = objRec.Fields("工数").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'---------------------------------
Public Sub サイド番号()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_サイド番号")
    
    'T_サイド番号
    Set objRec = ADO_CN.Execute("T_サイド番号", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_サイド番号"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("サイド番号") = objRec.Fields("サイド番号").Value
            .Fields("名前") = objRec.Fields("名前").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'---------------------------------
Public Sub 入出庫()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_入出庫")
    
    'T_入出庫
    Set objRec = ADO_CN.Execute("T_入出庫", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_入出庫"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("入出庫コード") = objRec.Fields("入出庫コード").Value
            .Fields("入出庫") = objRec.Fields("入出庫").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'---------------------------------
Public Sub 保管場所()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_保管場所")
    
    'T_保管場所
    Set objRec = ADO_CN.Execute("T_保管場所", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_保管場所"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("保管場所コード") = objRec.Fields("保管場所コード").Value
            .Fields("保管場所") = objRec.Fields("保管場所").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'---------------------------------
Public Sub 検索クリア()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_検索履歴")
    
    'T_検索履歴
    Set objRec = ADO_CN.Execute("T_検索履歴", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_検索履歴"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("検索履歴") = objRec.Fields("検索履歴").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'---------------------------------
Public Sub ログイン履歴()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_ログイン履歴")
    
    'T_ログイン履歴
    Set objRec = ADO_CN.Execute("T_ログイン履歴", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_ログイン履歴"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("社員コード") = objRec.Fields("社員コード").Value
            .Fields("日時") = objRec.Fields("日時").Value
            .Fields("成功or失敗") = objRec.Fields("成功or失敗").Value
            .Fields("IPアドレス") = objRec.Fields("IPアドレス").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'---------------------------------
Public Sub 入出庫処理()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_入出庫処理")
    
    'T_入出庫処理
    Set objRec = ADO_CN.Execute("T_入出庫処理", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_入出庫処理"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("日付") = objRec.Fields("日付").Value
            .Fields("社員コード") = objRec.Fields("社員コード").Value
            .Fields("品目コード") = objRec.Fields("品目コード").Value
            .Fields("入出庫コード") = objRec.Fields("入出庫コード").Value
            .Fields("数量") = objRec.Fields("数量").Value
            .Fields("単位コード") = objRec.Fields("単位コード").Value
            .Fields("保管場所コード") = objRec.Fields("保管場所コード").Value
            .Fields("指図番号") = objRec.Fields("指図番号").Value
            .Fields("削除") = objRec.Fields("削除").Value
            .Fields("削除日付") = objRec.Fields("削除日付").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'Ver.2.00βより追加
'---------------------------------
Public Sub テーブル()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_テーブル")
    
    'T_テーブル
    Set objRec = ADO_CN.Execute("T_テーブル", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_テーブル"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("テーブルコード") = objRec.Fields("テーブルコード").Value
            .Fields("テーブル") = objRec.Fields("テーブル").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'Ver.2.00βより追加
'---------------------------------
Public Sub マスタ更新履歴()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_マスタ更新履歴")
    
    'T_マスタ更新履歴
    Set objRec = ADO_CN.Execute("T_マスタ更新履歴", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_マスタ更新履歴"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("日時") = objRec.Fields("日時").Value
            .Fields("社員コード") = objRec.Fields("社員コード").Value
            .Fields("テーブルコード") = objRec.Fields("テーブルコード").Value
            .Fields("項目") = objRec.Fields("日時").Value
            .Fields("更新前") = objRec.Fields("更新前").Value
            .Fields("更新後") = objRec.Fields("更新後").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'Ver.2.00βより追加
'---------------------------------
Public Sub 各種設定()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_各種設定")
    
    'T_各種設定
    Set objRec = ADO_CN.Execute("T_各種設定", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_各種設定"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("パラメータ") = objRec.Fields("パラメータ").Value
            .Fields("設定値") = objRec.Fields("設定値").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

'Ver.2.10より追加
'---------------------------------
Public Sub BOM()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_BOM")
    
    'T_BOM
    Set objRec = ADO_CN.Execute("T_BOM", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_BOM"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("親品目コード") = objRec.Fields("親品目コード").Value
            .Fields("品目コード") = objRec.Fields("品目コード").Value
            .Fields("数量") = objRec.Fields("数量").Value
            .Fields("単位コード") = objRec.Fields("単位コード").Value
            .Fields("保管場所コード") = objRec.Fields("保管場所コード").Value
            .Fields("社員コード") = objRec.Fields("社員コード").Value
            .Fields("変更日時") = objRec.Fields("変更日時").Value
            .Fields("削除") = objRec.Fields("削除").Value
            .Fields("削除日時") = objRec.Fields("削除日時").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

M_メール

将来に向けてEメールによるアラーム送信機能を実装するためのものです。Ver.2.10では使われていません。
T_各種設定に必要な設定を記入する必要があります。
送信の際のパスワードを記述しますので、Accessファイルのテーブルを分割する処理などが必要になります。

Option Compare Database

'------------------------------------------------------------
'   処理内容:CDOメール送信
'   引数:txt宛先、txt本文、txt件名、txtCC
'   戻り値:True/False
'   参考Webサイト：https://asbepartners.com/send_mail/
'------------------------------------------------------------
Public Function cdoSendMail(ByVal txt宛先 As String, txt本文 As String, Optional txt件名 As String, Optional txtCC As String) As Boolean
    Dim objCDO
    Dim MSgw
    
    Dim txtSMTP_Server As String
    Dim intSMTP_Port As Integer
    Dim txtアドレス As String
    Dim txtパスワード As String
    Dim txCharset As String
    Dim bSSL認証 As Boolean
    Dim intタイムアウト As Integer
    Dim int認証方式 As Integer
    
    Dim sql As String
    Dim rst As DAO.Recordset
    
    'テーブル・T_各種設定からパラメータを読み込む
    sql = "SELECT * FROM T_各種設定 WHERE パラメータ = 'Charset'"
    Set rst = CurrentDb.OpenRecordset(sql)
    txCharset = rst.Fields("設定値")
    
    sql = "SELECT * FROM T_各種設定 WHERE パラメータ = 'タイムアウト'"
    Set rst = CurrentDb.OpenRecordset(sql)
    intタイムアウト = Int(Val(rst.Fields("設定値")))
    
    sql = "SELECT * FROM T_各種設定 WHERE パラメータ = 'SSL認証'"
    Set rst = CurrentDb.OpenRecordset(sql)
    bSSL認証 = Val(rst.Fields("設定値"))
    
    sql = "SELECT * FROM T_各種設定 WHERE パラメータ = '認証方式'"
    Set rst = CurrentDb.OpenRecordset(sql)
    int認証方式 = Int(Val(rst.Fields("設定値")))
    
    sql = "SELECT * FROM T_各種設定 WHERE パラメータ = '管理者アドレス'"
    Set rst = CurrentDb.OpenRecordset(sql)
    txtアドレス = rst.Fields("設定値")
    
    sql = "SELECT * FROM T_各種設定 WHERE パラメータ = '管理者アドレス'"
    Set rst = CurrentDb.OpenRecordset(sql)
    txtアドレス = rst.Fields("設定値")
    
    sql = "SELECT * FROM T_各種設定 WHERE パラメータ = '管理者パスワード'"
    Set rst = CurrentDb.OpenRecordset(sql)
    txtパスワード = rst.Fields("設定値")
    
    sql = "SELECT * FROM T_各種設定 WHERE パラメータ = 'SMTPサーバー'"
    Set rst = CurrentDb.OpenRecordset(sql)
    txtSMTP_Server = rst.Fields("設定値")
    
    sql = "SELECT * FROM T_各種設定 WHERE パラメータ = 'SMTPポート'"
    Set rst = CurrentDb.OpenRecordset(sql)
    intSMTP_Port = Int(Val(rst.Fields("設定値")))
    
    On Error GoTo Err_Exit
    
    '戻り値の初期化
    cdoSendMail = False
      
    Set objCDO = CreateObject("CDO.Message")
    
    'CDOのスキーマを定義
    MSgw = "http://schemas.microsoft.com/cdo/configuration/"
    
    With objCDO.Configuration.Fields
        'メール送信方法
        .Item(MSgw & "sendusing") = 2
        'SMTPサーバーのアドレス
        .Item(MSgw & "smtpserver") = txtSMTP_Server 'T_各種設定にて設定してください
        'SMTPサーバーのポート
        .Item(MSgw & "smtpserverport") = intSMTP_Port 'T_各種設定にて設定してください
        '差出人ユーザー名
        .Item(MSgw & "sendusername") = txtアドレス
        '認証コード
        .Item(MSgw & "sendpassword") = txtパスワード
        'SSL認証要
        .Item(MSgw & "smtpusessl") = bSSL認証 'True
        '認証方式(1)
        .Item(MSgw & "smtpauthenticate") = int認証方式 'cdoBasic
        'タイムアウト
        .Item(MSgw & "smtpconnectiontimeout") = intタイムアウト
        .Update
    End With
     
    '差出人メールアドレス
    objCDO.From = txtアドレス
    
    'あて先メールアドレス
    objCDO.To = txt宛先 '管理者のメールアドレスなどに書き換えてください
    
    'CCメールアドレス
    'objCDO.CC = txtCC '必要に応じて書き換えてください
    
    '件名
    objCDO.subject = txt件名 '必要に応じて書き換えてください
    '本文
    objCDO.textBody = txt本文 '必要に応じて書き換えてください
    
    '文字化け対応のため追加
    objCDO.TextBodyPart.Charset = txCharset '"ISO-2022-JP"
     
    objCDO.send
    
    MsgBox "メールを送信しました。", vbOKOnly + vbInformation, "送信完了"
    
    '正常終了
    cdoSendMail = True
    
    Set rst = Nothing
    rst.Close
    
    Exit Function
    
Err_Exit:
    MsgBox Err.Number & ":" & Err.Description, vbOKOnly + vbCritical, "cdoSendMail()"

End Function

M_SHA256

パスワードの平文からSHA256のハッシュ値に変換するための関数です。

Option Compare Database

'---------------------------------
'SHA256ハッシュ値を求める関数
's：ハッシュ値を求める文字列
'---------------------------------
Function SHA256(s As String) As String
    Dim objSHA256
    Dim objUTF8

    Dim bytes() As Byte
    Dim hash() As Byte

    Dim i
    Dim wk

    ' INIT
    Set objSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")
    Set objUTF8 = CreateObject("System.Text.UTF8Encoding")

    ' 文字列を UTF8 にエンコードし、バイト配列に変換
    bytes = objUTF8.GetBytes_4(s)

    ' ハッシュ値を計算（バイナリ）
    hash = objSHA256.ComputeHash_2((bytes))

    ' バイナリを16進数文字列に変換
    For i = 1 To UBound(hash) + 1
        wk = wk & Right("0" & Hex(AscB(MidB(hash, i, 1))), 2)
    Next i

    ' 結果を返す
    SHA256 = LCase(wk)

End Function

オートメーションエラー、又は下記メッセージが表示された際には.Net Flamework3.5がインストールされていません。
Windowsの機能の有効化と無効化にて有効化するか、Microsoftのページからダウンロードとインストールをしてください。

M_IPアドレス

ログインユーザーのIPアドレスを取得する関数です。
Ver.2.01βより、コンピュータ名・ユーザー名を追加しました。ユーザー名とログイン時のT_社員の社員とは別です。

Option Compare Database

    ' 関数の宣言
    ' ユーザー名を取得
    Private Declare PtrSafe Function GetUserName Lib "advapi32.dll" _
        Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
    ' コンピュータ名を取得
    Private Declare PtrSafe Function GetComputerName Lib "kernel32.dll" _
        Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
    ' コンピュータ名を取得
    Private Declare PtrSafe Function GetComputerNameEx Lib "kernel32.dll" _
        Alias "GetComputerNameExA" (ByVal NameType As Long, ByVal lpBuffer As String, lpnSize As Long) As Long
    ' 参考Webサイト：https://mt-soft.sakura.ne.jp/kyozai/excel_vba/300_vba_kiso/70_getinfo/index.htm

'---------------------------------
'IPアドレスを取得する関数
'---------------------------------
Function GetIPAddress() As String

    Dim NetAdapters, objNic, strIPAddress
    Set NetAdapters = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2") _
                           .ExecQuery("Select * from Win32_NetworkAdapterConfiguration " & _
                           "Where (IPEnabled = TRUE)")

    For Each objNic In NetAdapters 'ネットワークアダプターは、複数ある場合がある
        For Each strIPAddress In objNic.IPAddress 'IPは、複数割り当てられている場合がある
            GetIPAddress = strIPAddress
            Exit For        ' １回のみ
        Next
        Exit For        ' １回のみ
    Next

End Function

'---------------------------------
' ログインユーザ名を取得する
'---------------------------------
Public Function UserName() As String
' ユーザー名の長さを示す定数
    Const UNLEN = 256 + 1

    Dim strUserNameBuffer As String * UNLEN
    Dim lngUserNameLength As Long
    Dim lngResult         As Long
 
    ' ユーザー名の長さを設定
    lngUserNameLength = Len(strUserNameBuffer)
    ' ユーザー名を取得
    lngResult = GetUserName(strUserNameBuffer, lngUserNameLength)
    ' ユーザー名を表示
    UserName = Left(strUserNameBuffer, InStr(strUserNameBuffer, vbNullChar) - 1)
End Function

'---------------------------------
' コンピュータ名を取得する
'---------------------------------
Public Function ComputerName() As String
    ' コンピュータ名の長さ
    Const MAX_COMPUTERNAME_LENGTH = 15 + 1
    
    Dim strComputerNameBuffer As String * MAX_COMPUTERNAME_LENGTH
    Dim lngComputerNameLength As Long
    Dim lngResult             As Long
 
    ' コンピュータ名の長さを設定
    lngComputerNameLength = Len(strComputerNameBuffer)
    ' コンピュータ名を取得
    lngResult = GetComputerName(strComputerNameBuffer, lngComputerNameLength)
    ' コンピュータ名を取り出し
    ComputerName = Left(strComputerNameBuffer, InStr(strComputerNameBuffer, vbNullChar) - 1)
End Function

-在庫管理