分享
三行代码  ›  专栏  ›  技术社区  ›  azam

在VBA MicrosoftAccess中打开FileDialog,只选择特定的文件扩展名并复制到特定的动态目标

  •  1
  • azam  · 技术社区  · 6 天前

    我想用Open 文件对话框 在Microsoft Access中,使用VBA编程语言将文件复制到目标。

    1 回复  |  直到 6 天前
        1
  •  1
  •   Ali Najaf Zadeh    6 天前

    首先在窗体中添加一个按钮,然后在单击事件中使用以下子项:

    Private Sub Command21_Click()
    On Error GoTo Err_cmdTest_Click
    'Must 1st set a Reference to the Microsoft Office XX.X Object Library
    Dim varItem As Variant
    Dim Target As String
    Dim objFSO As Object
    Dim a As Integer
    Target = CurrentProject.Path & "\PicsFolder\"
    CheckDir Target
    With Application.FileDialog(msoFileDialogFilePicker)
       With .Filters
         .Clear
         '.Add "Bitmap Files", "*.bmp"
         .Add "JPEG Files", "*.jpg"
         .Add "PNG Files", "*.png"
         .Add "Graphic Interchange Format Files", "*.gif"
       End With
           'The Show Method returns True if 1 or more files are selected
           .AllowMultiSelect = False
           .FilterIndex = 1     'Bitmap files
           .ButtonName = "Select Graphic"
           .InitialFileName = vbNullString
           .InitialView = msoFileDialogViewDetails
           .Title = "Load Graphic File!"
              If .Show Then
                    'Can due this because AllowMultiSelect = False
                    'Me![Image1].Picture = .SelectedItems(1)
                    Dim Source As String
                    Dim Path  As String
                    Source = CurrentDb.Name
                    Target = Target & "BackupFile" & Format(Now(), "yy-mm-dd-hh-MM-ss" & UdfRandString(8)) & "." & get_file_extension(.SelectedItems(1))
                    MsgBox Target
                    Set objFSO = CreateObject("Scripting.FileSystemObject")
                    a = objFSO.CopyFile(.SelectedItems(1), Target, True)
    InsertPicPathIntoDb (Replace(Target, CurrentProject.Path, ""))
              End If
    End With
    
    Exit_cmdTest_Click:
      Exit Sub
    
    Err_cmdTest_Click:
      MsgBox Err.Description, vbExclamation, "Error in cmdTest_Click()"
      Resume Exit_cmdTest_Click
    End Sub
    

    使用下面的功能,您可以检查目标文件夹,如果不存在,它可以创建文件夹。

    Function CheckDir(Path As String)
    
        If Dir(Path, vbDirectory) = "" Then
            MkDir (Path)
            'MsgBox "Making Directory!"
        'End If
        Else
            'MsgBox "Dir Exists!"
        End If
    
    End Function
    

    InsertPicPathIntoDb (Replace(Target, CurrentProject.Path, ""))
    

    插入子项如下:

    Sub InsertPicPathIntoDb(StrPicPath As String)
        Dim dbs As DAO.Database
        Set dbs = OpenDatabase(CurrentDb.Name)
        dbs.Execute " INSERT INTO tblPersonPictures (PersID, PicturePath) VALUES " & "('" & LblPersonCode.Caption & "', '" & StrPicPath & "');"
        dbs.Close
    End Sub
    
    Function get_file_extension(sFileName As String) As String
        Dim sFileExtension As String
        Dim iLastDot As Double
        iLastDot = VBA.InStrRev(sFileName, ".")
        sFileExtension = VBA.Right(sFileName, VBA.Len(sFileName) - iLastDot)
        get_file_extension = sFileExtension
    End Function
    

    只需创建一个具有上述结构的表,就可以享受了。