写真を決めたフォルダに決まった名前で保存して表示させる。美容室向け顧客管理システム　開発日記9日目

2020/03/16

Accessでアプリを作ってます。今日はお客様一覧に写真を選択して表示させるダイアログ関係をつくりました。

動作の手順としては以下のような感じ

  • ファイル選択ダイアログで取り込みたい写真を選択
  • ファイル名を「ID+氏名+拡張子」に変更して アプリで指定したフォルダへコピー
  • 変更後のファイル名をMST_お客様のテーブルに「写真FileName」の項目で登録（実際にはTextBoxに文字列として書き込む）

今回は参照設定の追加が２つ必要です。ファイルダイアログを使うために、Microsoft Scripting Runtime。ファイルの名前と拡張子を分離するためにMicrosoft Office 16.0 Object Libralyを追加しました。拡張子の分離などについては標準関数をつかった文字列操作でも可能ですが、今回はファイルオブジェクトから抜き出してみました。以下のようなコードになりました。

Private Sub btn_写真取り込み_Click()
  On Error Resume Next
  
  Dim fso As New Scripting.FileSystemObject
  Dim filePath As String
  Dim ExtentionName As String
  
  
    '変数定義
    Dim intRet As Integer         'ダイアログ用変数
    Dim GetFileName As String     'フルパスの値
    Dim oldFileName As String     '元の写真のファイル名
    Dim newFileName As String     '[ID] & [姓] & [名] & "," & 拡張子
    

    With Application.FileDialog(msoFileDialogOpen)
        'ダイアログのタイトルを設定
        .title = "ファイルを開くダイアログ"
        'ファイルの種類を設定
        .Filters.Clear
        .Filters.Add "写真ファイル", "*.jpg,*.gif,*.png"
        .FilterIndex = 1
        '複数ファイル選択を許可しない
        .AllowMultiSelect = False
        '初期パスを設定
        '.InitialFileName = CurrentProject.Path
        'ダイアログを表示
        intRet = .Show

        If intRet <> 0 Then
          'ファイルが選択されたとき
          'そのフルパスを返り値に設定
          filePath = Trim(.SelectedItems.Item(1))
          
          拡張子 = fso.GetExtensionName(filePath)
           oldFileName = fso.GetFileName(filePath)
  
        Set fso = Nothing

        Else
          'ファイルが選択されなければブランク
          GetFileName = ""
          Exit Sub
        End If
    End With
    
    '選択されたフルパスをテキストボックスへ表示
    newFileName = [ID] & [姓] & [名] & "." & 拡張子  '新しいファイルネームを作る
    'ファイル名だけをMST_お客様の写真FileNameに保存するので、TextBoxに書き込む
    Me.写真FileName.Value = newFileName
    
    newFileName = DLookup("写真フォルダ", "ローカル設定") & newFileName  'パスを加える
    
    '指定場所に名前を変えてコピーする。
    If Dir(newFileName) <> "" Then
        ret = MsgBox("同名のファイルが存在します。" & vbCrLf & _
                  "上書きしますか？", vbYesNo)
        If ret = vbNo Then Exit Sub
    End If
    FileCopy filePath, newFileName
    

    DoCmd.SelectObject acForm, "F_お客様情報詳細"

End Sub

動作テストしてみます

まず、適当な場所にあるお客様の写真を選択します。あとでファイル名はお客様の名前に変換されるので、この時点で写真のファイル名はなんでも構いません。

コードの以下の部分で、ファイル名を変更して、指定のフォルダにコピーしています。

    '選択されたフルパスをテキストボックスへ表示
    newName = [ID] & [姓] & [名] & "," & 拡張子
    newFileName = DLookup("写真フォルダ", "ローカル設定") & newName
    
    '指定場所に名前を変えてコピーする。
    If Dir(newFileName) <> "" Then
        ret = MsgBox("同名のファイルが存在します。" & vbCrLf & _
                  "上書きしますか？", vbYesNo)
        If ret = vbNo Then Exit Sub
    End If
    FileCopy filePath, newFileName

Dlookupを使っている部分があります。これはこのアプリで写真を一括保存してためておくフォルダ名です。コードのあちこちでフォルダ名を直接打ち込んでしまうと、あとで変更したいときに大変なので、アプリの環境変数的なものをテーブルに保存しておくことにしました。テーブルは以下のような状態になっています。ほかにも必要な項目があればふやしていけそうです。

写真の表示はイメージオブジェクトをからの状態で置く

写真を表示させたい位置にイメージオブジェクトを置きます。置いた直後にはファイルを選択するようにダイアログが出ますが、キャンセルでとじてしまいます。

イメージのプロパティのコントロールソースには、以下のような指定をしておきます。写真取り込みボタンの左側には非表示のテキストボックス。コントロールソースにはDlookupをつかった保存フォルダとファイル名を連結することで表示ができるようになりました。

=DLookUp("写真フォルダ","ローカル設定") & [写真FileName]

ほかの一覧表示にも写真を表示させる

仕組みは同じなのでほかの一覧表示にも写真を表示させます。お客様詳細画面ではテキストボックスにファイル名が入っているので、その値を使いましたが、一覧ではお客様IDをキーに、こちらもDlookupを使ってファイル名も一緒に検索してしまうことができました。長いけれど要領は同じです。

=DLookUp("写真フォルダ","ローカル設定") & DLookUp("写真FileName","MST_お客様","ID = " & [お客様ID])

写真が入るとそれっぽくなってきましたね。一気にお客様一覧がにぎやかになってきました。

できてくると次やりたいことが見えてくる

画面の左には一覧のタブだけがありますが、お客様にカテゴリ付けして、ここで女性、男性とか学生、成人など切り替えられるようにするってのはどうかしらと検討中です。

あと、欄だけ用意していますが、最終来店日ってのは美容院には必要な項目かしら？と思ってつけてみました。DM送るときの目安にもなるし。

プログラミング,美容院向け顧客管理システムMS Access 美容院向け顧客管理

Posted by ダディー