VBA 備忘録２

Public Function CK_Excel(frmTargetForm As Form, FilePath As String) As Boolean
CK_Excel = True
Dim Fso As New Scripting.FileSystemObject
Dim ExteName As String

FilePath = frmTargetForm.txtFilePath
ExteName = Fso.GetExtensionName(FilePath)
If ExteName <> "xlsx" Then
    MsgBox "Excelファイルを選択してください"
    CK_Excel = False
End If

'ファイル名が社員名簿か確認
Dim FileName        As String
FileName = Fso.getFileName(FilePath)
If FileName <> "社員名簿.xlsx" Then
    MsgBox "社員名簿のファイルを選択してください"
    CK_Excel = False
End If

'エクセルファイルを開く
Dim xlsApp          As Object
Dim xlsWkB          As Object
Dim xlsWS           As Object
Set xlsApp = CreateObject("Excel.application")
xlsApp.Visible = True
Set xlsWkB = xlsApp.workbooks.Open(FilePath)

'シート名が社員名簿か確認
Dim WsName          As String
Dim i               As Integer
    
For i = 1 To xlsWkB.sheets.Count
    If xlsWkB.sheets(i).Name = "社員名簿" Then
        WsName = "社員名簿"
        Set xlsWS = xlsWkB.worksheets(WsName)
        Exit For
    End If
Next i

Dim Col     As Integer
With xlsWS
    If .cells(1, 1) <> "従業員コード" Then
        CK_Excel = False
    End If
End With

xlsWkB.Close savechanges:=False
Set xlsWkB = Nothing

xlsApp.Quit
Set xlsApp = Nothing

Set Fso = Nothing

End Function

Public Function getFileName(tmpFilePath As String) As String

Dim intRet As Integer

With Application.FileDialog(msoFileDialogOpen)

'ダイアログのタイトルを設定
    .Title = "ファイル選択ダイアログ"
    
    'ファイルの種類（拡張子）を指定
    .Filters.Clear
    .Filters.Add "EXCELファイル", "*.xls, *.xlsx"

' .Filters.Add "テキストファイル", "*.csv, *.tsv"

    'ファイルの種類の初期値を設定
    .FilterIndex = 1
    
    '複数ファイル選択を許可しない
    .AllowMultiSelect = False
    
    '初期パスを設定
    .InitialFileName = tmpFilePath
    
    'ダイアログを表示
    intRet = .Show
    If intRet <> 0 Then
        'ファイルが選択されたときフルパスを返り値に設定
        getFileName = Trim(.SelectedItems.Item(1))
    Else
        'ファイルが選択されなければ長さゼロの文字列を返す
        getFileName = ""
    End If
End With

End Function

Private Sub btn_Get_FilePath_Click()
Dim strFilePath As String
Dim GetPath As String

Me.txtFilePath = getFileName(strFilePath)

End Sub

Private Sub btn_Import_Click()
'importクリック
'エクセルファイルか確認
Dim FilePath As String
If CK_Excel(Me, FilePath) = False Then
GoTo Exit_
End If

'WK_Tableのデータを削除
Dim sSelect         As String
Dim sFrom           As String
Dim sWhere          As String
Dim sSQL            As String

sSelect = "Delete * from WK_Employe "
DoCmd.RunSQL (sSelect)

'WK_Tableにインポート
DoCmd.TransferSpreadsheet acImport, 10, "WK_Employe", FilePath, True

'クエリーを実行し、M_Employeeにいんぽーと
DoCmd.OpenQuery "Q_F50_03MEmployee"
DoCmd.OpenQuery "Q_F50_04TEmployeeList"

' Q_F50_03MEmployee
Exit Sub
Err_:

Exit_:
End Sub