强制拉链打开解压缩到特定位置

时间:2012-09-05 14:24:37

标签: vba ms-access access-vba unzip winzip

我正在使用excel(用于批量数据输入)和Access(用于存放数据)创建一个非常基本的数据输入和数据库系统应用程序。我玩它作为一个zip文件分发。为了使它工作,我需要保持文件结构不变并解压缩到c:/ drive。是否有强制zip文件解压缩到特定位置?

我需要这个的原因是自动上传输入的数据。据我所知,在Access VBA中,您必须在VBA中指定完整的文件路径以导入数据。

* 更新

感谢Remou让我走出困境。为了后人的缘故,这就是我解决它的方式。不是最漂亮的代码,但它完成了这项工作。首先是导入功能,然后是导出功能。

导入,上传文件仍然需要命名约定,但它们可以来自任何地方。该文件名与它们将存储的表有关。在excel表的后端,数据输入表被分成两个(Rec和Occ)

代码如下:

函数importData_Click(可选varDirectory As String,_     可选varTitleForDialog As String)As String

Dim strFilter As String
Dim lngFlags As Long
Dim varFileName As String
Dim strFileName As String
Dim strTableName As String
Dim strColumnName As String
Dim The_Year As Long
Dim occNumber As Long



'Get combobox value and assign relavent values to occNumber
The_Year = Forms![Upload Data]!Year_Combo.value

'Ask the to check value
If MsgBox("Uploading " & The_Year & " data" & vbCrLf & "Continue?", VbMsgBoxStyle.vbYesNo) = 7 Then
    Exit Function
End If



If The_Year = 2012 Then
    occNumber = 1000
    ElseIf The_Year = 2013 Then
    occNumber = 2000
End If

' Specify that the chosen file must already exist,
' don't change directories when you're done
' Also, don't bother displaying
' the read-only box. It'll only confuse people.
lngFlags = ahtOFN_FILEMUSTEXIST Or _
            ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
If IsMissing(varDirectory) Then
    varDirectory = ""
End If
If IsMissing(varTitleForDialog) Then
    varTitleForDialog = ""
End If

strFilter = ahtAddFilterItem("Excel Files (*.xlsx)", "*.xlsx")

varFileName = ahtCommonFileOpenSave( _
                                openFile:=True, _
                                InitialDir:=varDirectory, _
                                Filter:=strFilter, _
                                Flags:=lngFlags, _
                                DialogTitle:=varTitleForDialog)
If Not IsNull(varFileName) Then
    varFileName = TrimNull(varFileName)

End If
importData_Click = varFileName

'Sets filename
strFileName = Dir(varFileName)

'Sets TableName
strTableName = Left(strFileName, 4)

If IsNull(strFileName) Then
    MsgBox "Upload cancelled"
    Exit Function
End If






    'Checks naming convetions of filenames

    If strTableName Like "*MN" Or strTableName Like "*OP" Or strTableName Like "*DA" Or strTableName Like "*TR" Then

            'Checks if data is Opportunistic
            If strTableName Like "*OP" Then

            strColumnName = "Year_" & strTableName


                        'Checks to see if that year's data already exists
                        If DLookup(strColumnName, strTableName & "_Rec", "" & strColumnName & " = " & The_Year & "") Then

                        MsgBox "2012 data is already present"

                        ElseIf DLookup(strColumnName, strTableName & "_Rec", "" & strColumnName & " = " & The_Year & "") Then

                        MsgBox "2013 data is already present"

                        Else

                        'Uploads data to relevant table
                        DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, strTableName & "_Rec", varFileName, True, "Rec_Prep$"

                        MsgBox "Upload successful"

                        End If



            Exit Function

            Else

            strColumnName = "Occasion_" & strTableName




                        'Checks Occasions to see if that year exists
                        If DLookup(strColumnName, strTableName & "_Rec", "" & strColumnName & " = " & occNumber & "") Then

                        MsgBox "2012 data is already present"

                        ElseIf DLookup(strColumnName, strTableName & "_Rec", "" & strColumnName & " = " & occNumber & "") Then

                        MsgBox "2013 data is already present"

                        Else
                        'Uploads to Records table and Occasion table
                        DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, strTableName & "_Occ", varFileName, True, "Occ_Prep$"

                        DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, strTableName & "_Rec", varFileName, True, "Rec_Prep$"

                        MsgBox "Upload successful"

                        End If

            End If

    Else

    MsgBox "Your file is named incorrectly! & vbCrLf & Please refer to the Data Dictionary & vbCrLf & for correct naming conventions"

    Exit Function

    End If





'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "BaMN_AllData", strSaveFileName



End Function


Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer

intPos = InStr(strItem, vbNullChar)
If intPos > 0 Then
    TrimNull = Left(strItem, intPos - 1)
Else
    TrimNull = strItem
End If
End Function

然后导出使用命令按钮的名称(与表名匹配)导出到用户想要的位置:

 Dim queryYear As Variant

'Function to export data to location of users choice.  Query name is automatically     detected from the control button used
'Year is derived from the combobox value on [Extract Data] form, null value defaults to all years.
 Function exportData_Click()


Dim strFilter As String
Dim strSaveFileName As String
Dim The_Year As Variant

Dim ctlCurrentControl As Control
Dim queryName As String



'Get the name of the control button clicked (corresponds to query name to be run)
Set ctlCurrentControl = Screen.ActiveControl
queryName = ctlCurrentControl.Name



'Get combobox value and assign relavent values to The_Year
The_Year = Forms![Extract Data]!Extract_Year.value


'Change the year from a variant to what we need in the SQL

If The_Year Like "20*" Then
    The_Year = CInt(The_Year)
    MsgBox The_Year & "Data Type = " & VarType(The_Year)
Else: The_Year = "*"
MsgBox The_Year & "Data Type = " & VarType(The_Year)
End If

'Set queryYear variable
setYear (The_Year)


'Check the variable is correct
'MsgBox getYear()

'Open the Save as Dialog to choose location of query save

strFilter = ahtAddFilterItem("Excel Files (*.xlsx)", "*.xlsx")

strSaveFileName = ahtCommonFileOpenSave( _
                                openFile:=False, _
                                Filter:=strFilter, _
                Flags:=ahtOFN_OVERWRITEPROMPT Or ahtOFN_READONLY)

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, queryName, strSaveFileName

End Function
 'Function to set queryYear used in data extraction queries
Public Function setYear(The_Year As Variant)

 queryYear = The_Year

End Function

 'Function to get queryYear used in data extraction queries
 Function getYear()

  getYear = queryYear

 End Function

应该注意的是,文件保存和文件打开代码部分不是我的。他们来自Ken Getz,整个代码可以在这里找到:

http://access.mvps.org/access/api/api0001.htm

1 个答案:

答案 0 :(得分:2)

最好使用应用程序路径(例如currentproject.Path)或要求用户指定数据存储的位置,而不是试图强制安装在用户可能无法使用的位置。根本不需要对路径进行硬编码。在Access中,您可以在表中存储与项目相关的信息,包括数据路径。您可以从Excel中查找MS Access。