Private Sub cmdSaveAs_Click()
Dim intDecision As Integer
On Error GoTo Error_cmdSaveAs
'Opens a Treeview control that displays the directories in a computer
Dim lpIDList As Long
Dim sBuffer As String
Dim sNewDir As String
Dim sNewSaveBuffer As String
Dim sTempString As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
Dim sDateDir As String
Dim sNewFolder As String
szTitle = "Location to Save Data"
With tBrowseInfo
.hWndOwner = Me.hwnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
Me.Form.Visible = False
MsgBox "Winstabs Data will be saved in " & vbCrLf & vbCrLf & _
sBuffer
Else
MsgBox "Export Action Canceled.", vbOKOnly, "Action Canceled by User."
Exit Sub
End If
sDateDir = "\WData" & DLookup("Year", "tblTreasID") & "_L" & _
DLookup("LocalNo", "tblTreasID") & "_" & Format(CStr(Right(Year(Now), 4)), "0000") & _
"-" & Format(CStr(Month(Now)), "00") & "-" & Format(CStr(Day(Now)), "00") & "_" & _
Format(CStr(Hour(Now)), "00") & "h" & Format(CStr(Minute(Now)), "00") & "m"
sNewDir = sBuffer & sDateDir
If Mid(sNewDir, 3, 2) = "\\" Then
sTempString = Left(sNewDir, 3) & Right(sNewDir, (Len(sNewDir) - 4))
sNewDir = sTempString
sTempString = ""
End If
MkDir sNewDir
DoCmd.Hourglass True
sNewSaveBuffer = sNewDir & "\wstabs01.txt"
DoCmd.TransferText acExportDelim, , "exportpopup", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs02.txt"
DoCmd.TransferText acExportDelim, , "tblMemberRecord", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs03.txt"
DoCmd.TransferText acExportDelim, , "tblBillingHistory", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs04.txt"
DoCmd.TransferText acExportDelim, , "tblInsurance", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs05.txt"
DoCmd.TransferText acExportDelim, , "tblE49", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs06.txt"
DoCmd.TransferText acExportDelim, , "ExportPayrollTax", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs07.txt"
DoCmd.TransferText acExportDelim, , "tblTransfers", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs08.txt"
DoCmd.TransferText acExportDelim, , "tblPayroll", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs09.txt"
DoCmd.TransferText acExportDelim, , "tblMileage", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs10.txt"
DoCmd.TransferText acExportDelim, , "tblCheckbook", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs11.txt"
DoCmd.TransferText acExportDelim, , "tblBilling", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs12.txt"
DoCmd.TransferText acExportDelim, , "tblBilling2", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs13.txt"
DoCmd.TransferText acExportDelim, , "tblTreasID", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs14.txt"
DoCmd.TransferText acExportDelim, , "tblTreasurer", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs16.txt"
DoCmd.TransferText acExportDelim, , "tblMinutes", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs17.txt"
DoCmd.TransferText acExportDelim, , "tblE49History", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs18.txt"
DoCmd.TransferText acExportDelim, , "tblBillingHistoryPg3", sNewSaveBuffer, True
DoCmd.Hourglass False
sNewFolder = Right(sDateDir, Len(sDateDir) - 1)
MsgBox "Files Exported Successfully to a Folder Named " & vbCrLf & vbCrLf & _
sNewFolder, vbOKOnly, "Export Complete - " & sNewDir
Me.Form.Visible = True
intDecision = _
MsgBox("Do you wish to make another Backup?", vbYesNo, "Backup Completed")
If intDecision = vbNo Then
DoCmd.Close
Else
Exit Sub
End If
Exit_cmdSaveAs:
Exit Sub
Error_cmdSaveAs:
' MsgBox Err.Description
Me.Form.Visible = True
Resume Exit_cmdSaveAs
End Sub