antonio.manoj.derose
Registered User.
- Local time
- Today, 16:12
- Joined
- Jul 4, 2013
- Messages
- 62
Hi All,
I am not able to save a file after processing, I am not able to see the dialog window being opened, to enter a name for the file to be saved.
I am getting an error, error is attached, and am pasting the code for the section below.
The code which breaks, is mentioned in red font.
Please help me, office suite MS 2010, 64 BIT
Thanks,
Antonio
I am not able to save a file after processing, I am not able to see the dialog window being opened, to enter a name for the file to be saved.
I am getting an error, error is attached, and am pasting the code for the section below.
The code which breaks, is mentioned in red font.
Code:
Option Compare Database
'Option Explicit
Private Type TSBAPI_OPENFILE
strFilter As String ' Filter string
intFilterIndex As Long ' Initial Filter to display.
strInitialDir As String ' Initial directory for the dialog to open in.
strInitialFile As String ' Initial file name to populate the dialog with.
strDialogTitle As String ' Dialog title
strDefaultExtension As String ' Default extension to append to file if user didn't specify one.
lngFlags As Long ' Flags (see constant list) to be used.
strFullPathReturned As String ' Full path of file picked.
strFileNameReturned As String ' File name of file picked.
intFileOffset As Integer ' Offset in full path (strFullPathReturned) where the file name (strFileNameReturned) begins.
intFileExtension As Integer ' Offset in full path (strFullPathReturned) where the file extension begins.
End Type
Private Type TSBAPI_WINOPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustrFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustrData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Declare Function TSBAPI_GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenfilename As TSBAPI_WINOPENFILENAME) _
As Boolean
Public Sub Rec()
Dim rs As New ADODB.Recordset
'Dim conn As New ADODB.Connection
'Dim cmd As New ADODB.Command
Dim filename As String
Dim rsIn As DAO.Recordset
Dim db As Database
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlWrksht As Excel.Worksheet
Dim xlRange As Excel.Range
Dim colIdx As Integer
Dim sFile As Variant
Dim strPath As String
'Dim templatefile As String
'Dim rowidx As Integer
'Dim i As Integer
On Error GoTo Rec_Error
templatefile = templateLocationException '(filename)
If templatefile <> "" Then
If Dir(templatefile) = "" Then
'MsgBox "Please select the template to export to", vbCritical, "Template file not found"
MsgBox "Please check for the template Exception, if it is missing in C:\Main", vbCritical
'Call sabin_PRG_Meter("CLOSE", 0)
Exit Sub
'setTemplateLocation removed on the 26th 09 2013
'templatefile = templateLocationException(filename) removed on the 26th 09 2013
End If
'Else removed on the 26th 09 2013
'MsgBox "Please select the template file to export to", vbCritical, "Template not selected" removed on the 26th 09 2013
'setTemplateLocation removed on the 26th 09 2013
'templatefile = templateLocationException(filename) removed on the 26th 09 2013
End If
'reconciling part which would check the data in the table tblMobileClaimform and the Payments table before producing an excel sheet, this is for already paid
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(templatefile)
Set xlWrksht = xlBook.Sheets("Already Paid")
Set rsIn = CurrentDb().OpenRecordset("qryConsolidatedAlreadyPaidClaims")
'Dim bark As Long
'Dim init As Long
'bark = rsIn.RecordCount
If rsIn.RecordCount > 0 Then
'For init = 1 To bark
'Call sabin_PRG_Meter1("START", "Loading Claim services...", "", bark, 0)
'Call sabin_PRG_Meter1("ADD", "Loading Claim services...", "", bark, init)
rsIn.MoveLast
rsIn.MoveFirst
rowidx = 2
With xlWrksht
While Not rsIn.EOF
For i = 1 To rsIn.Fields.Count ' - 1
'good debug point Debug.Print rsIn.Fields(i - 1).Value
.Cells(rowidx, i) = rsIn.Fields(i - 1).Value
Next i
rsIn.MoveNext
rowidx = rowidx + 1
Wend
End With
'Next init
'Call sabin_PRG_Meter1("CLOSE", "Loading Claim services...", "", bark, 0)
End If
'Set rsIn.RecordCount = 0
'section for the suspect matches under Mobile
Set xlWrksht = xlBook.Sheets("Suspect Matches")
Set rsIn = CurrentDb().OpenRecordset("qryConsolidatedSuspectClaims")
'bark = rsIn.RecordCount
If rsIn.RecordCount > 0 Then
'For init = 1 To bark
'Call sabin_PRG_Meter1("START", "Loading Claim services...", "", bark, 0)
'Call sabin_PRG_Meter1("ADD", "Loading Claim services...", "", bark, init)
rsIn.MoveLast
rsIn.MoveFirst
rowidx = 2
With xlWrksht
While Not rsIn.EOF
For i = 1 To rsIn.Fields.Count ' - 1
'good debug point Debug.Print rsIn.Fields(i - 1).Value
.Cells(rowidx, i) = rsIn.Fields(i - 1).Value
Next i
rsIn.MoveNext
rowidx = rowidx + 1
Wend
End With
'Next init
'Call sabin_PRG_Meter1("CLOSE", "Loading Claim services...", "", bark, 0)
'Set rsIn = Nothing
End If
'Set rsIn.RecordCount = 0
'Section for checking Duplicates under Mobile
Set xlWrksht = xlBook.Sheets("Duplicates")
Set rsIn = CurrentDb().OpenRecordset("qryConsolidatedDuplicateClaims")
'bark = rsIn.RecordCount
If rsIn.RecordCount > 0 Then
'For init = 1 To bark
'Call sabin_PRG_Meter1("START", "Loading Claim services...", "", bark, 0)
'Call sabin_PRG_Meter1("ADD", "Loading Claim services...", "", bark, init)
rsIn.MoveLast
rsIn.MoveFirst
rowidx = 2
With xlWrksht
While Not rsIn.EOF
For i = 1 To rsIn.Fields.Count ' - 1
'good debug point Debug.Print rsIn.Fields(i - 1).Value
.Cells(rowidx, i) = rsIn.Fields(i - 1).Value
Next i
rsIn.MoveNext
rowidx = rowidx + 1
Wend
End With
'Next init
'Call sabin_PRG_Meter1("CLOSE", "Loading Claim services...", "", bark, 0)
'Set rsIn = Nothing
End If
'Set rsIn.RecordCount = 0
strPath = "C:\Rec_Exception\"
If Len(Dir("C:\Rec_Exception", vbDirectory)) = 0 Then
MkDir "C:\Rec_Exception"
End If
'strPath = "C\Rec_Exception"
'MsgBox "Please choose a directory to save data for EXCEPTION", vbOKOnly, "Save file path" removed on the 13th September 2013
MsgBox "Please enter file name to save data for EXCEPTION"
'Dim FileMonth As String
'Dim FileSaveName As String
'FileMonth = ThisWorkbook.name
'GetName:
'FileSaveName = Application.GetSaveAsFilename(FileMonth, _
'fileFilter:="(*.xlsm), *.xlsm, (*.xlsx), *.xlsx,(*.xls), *.xls")
' FileMonth is the Workbook name, filter options to save a older version file
'If Dir(FileSaveName) = "" Then
'ActiveWorkbook.SaveAs FileSaveName
'Else
'If MsgBox("That file exists. Overwrite?", vbYesNo) = vbNo Then GoTo GetName
'Application.DisplayAlerts = False
'ActiveWorkbook.SaveAs FileSaveName
'Application.DisplayAlerts = True
'End If
sFile = GetSaveFile_TSB(strPath, "Save Payment File As...", "")
'Dim ecstasy As String
'ecstasy = "C:\Main\Exception" & Format(Date, "ddmmyyyy") & ".xls"
'xlBook.SaveAs ecstasy 'strPath & "Exception" & Format(Date, "yyyymmdd") & ".xls"
xlBook.SaveAs sFile
xlBook.Close (0)
xlApp.Quit
MsgBox "File has been saved in " & sFile & " "
'templatefile = templateLocationValid(filename)
templatefile = templateLocationValid
If templatefile <> "" Then
If Dir(templatefile) = "" Then
'MsgBox "Please select the template to export to", vbCritical, "Template file not found" removed on the 26th September 2013
MsgBox "Please check for the template Valid, if it is missing in C:\Main", vbCritical
'Call sabin_PRG_Meter("CLOSE", 0)
Exit Sub
'setTemplateLocation removed on the 26th September 2013
'templatefile = templateLocationValid(filename) removed on the 26th Sepetember 2013
End If
'Else removed on the 26th of September 2013
'MsgBox "Please select the template file to export to", vbCritical, "Template not selected" removed on the 26th September 2013
'setTemplateLocation removed on the 26th of the September 2013
'templatefile = templateLocationValid(filename) removed on the 26th September 2013
End If
'Section for checking Valid Claims under Mobile
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(templatefile)
'Set xlWrksht = xlBook.Sheets("Services For Claim")
Set xlWrksht = xlBook.Sheets("Claim Form")
''''Call PctMeter(75, 100)
'Call sabin_PRG_Meter("ADD", 75)
Set rsIn = CurrentDb().OpenRecordset("qryConsolidatedValidClaims")
'bark = rsIn.RecordCount
If rsIn.RecordCount > 0 Then
'For init = 1 To bark
'Call sabin_PRG_Meter1("START", "Loading Claim services...", "", bark, 0)
'Call sabin_PRG_Meter1("ADD", "Loading Claim services...", "", bark, init)
rsIn.MoveLast
rsIn.MoveFirst
xlWrksht.Cells(5, 3) = rsIn("Store_Code").Value
xlWrksht.Cells(7, 3) = rsIn("Premise_State").Value
xlWrksht.Cells(9, 3) = rsIn("Store_Name").Value
xlWrksht.Cells(11, 3) = rsIn("Email_Address").Value
xlWrksht.Cells(13, 3) = rsIn("Date_Emailed_to_Telstra").Value
xlWrksht.Cells(5, 8) = rsIn("Total_value_claim").Value
xlWrksht.Cells(11, 9) = rsIn("Original_Claim_Number").Value
'xlWrksht.Cells(5, 3) = rsIn("Premise_Code").Value
rowidx = 23
With xlWrksht
While Not rsIn.EOF
colIdx = 2
For i = 8 To rsIn.Fields.Count ' - 1
.Cells(rowidx, colIdx) = rsIn.Fields(i - 1).Value
colIdx = colIdx + 1
Next i
rsIn.MoveNext
rowidx = rowidx + 1
Wend
End With
'Next init
'Call sabin_PRG_Meter1("CLOSE", "Loading Claim services...", "", bark, 0)
'Set rsIn = Nothing
End If
'rsIn.RecordCount = 0
'end of code after the export.
DoCmd.SetWarnings True
'If Right(templatefile, 4) <> ".xls" Then templatefile = Replace(templatefile, ".xlt", ".xls")
'above was removed on the 10/10/2013
strPath = "C:\Rec_Valid\"
If Len(Dir("C:\Rec_Valid", vbDirectory)) = 0 Then
MkDir "C:\Rec_Valid"
End If
MsgBox "Please enter a file name to save data for VALID CLAIMS"
sFile = GetSaveFile_TSB(strPath, "Save Payment File As...", "")
xlBook.SaveAs sFile
xlBook.Close (0)
xlApp.Quit
''''''Call PctMeter(100, 100)
'Call sabin_PRG_Meter("ADD", 100)
'Call sabin_PRG_Meter("CLOSE", 0)
MsgBox "File has been saved in " & sFile & " "
rsIn.Close
Set rsIn = Nothing
'conn.Close
'Set conn = Nothing
'Call PctMeter(100, 100)
'End If
'rsIn.Close
IncorrectFile:
On Error GoTo 0
Exit Sub
Rec_Error:
'Newly added on the 11th of September 2013, in order to handle the error with the message 1004
'If Err.Number = 1004 Then
' MsgBox "Unable to continue due to incorrect filename, please try re-running the claims reconciliation process"
' Err.Clear
' Exit Sub
'Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Rec of Module Import"
'End If
End Sub
'Public Function templateLocationException(filename As String) As String
Public Function templateLocationException() As String
On Error GoTo templateLocationException_Error
'If Mid(filename, InStrRev(filename, "\") + 1, 6) = "Mobile" Then
'Set rs = CurrentDb().OpenRecordset("Select parValue from META_Parameters where parFunction = 'templateLocation' and ID = 1")
'End If
'If Mid(filename, InStrRev(filename, "\") + 1, 5) = "Fixed" Then
'Set rs = CurrentDb().OpenRecordset("Select parValue from META_Parameters where parFunction = 'templateLocation' and ID = 2")
'End If
'Dim rs As New ADODB.Recordset
Set rs = CurrentDb().OpenRecordset("Select parValue from META_Parameters where parFunction = 'templateLocation' and ID = 1")
If rs.RecordCount > 0 Then
templateLocationException = Nz(rs!parValue, "")
Else
templateLocationException = ""
End If
rs.Close
Set rs = Nothing
On Error GoTo 0
Exit Function
templateLocationException_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure templateLocation of Module Import"
End Function
'Public Function templateLocationValid(filename As String) As String
Public Function templateLocationValid() As String
On Error GoTo templateLocationValid_Error
'If Mid(filename, InStrRev(filename, "\") + 1, 6) = "Mobile" Then
'Set rs = CurrentDb().OpenRecordset("Select parValue from META_Parameters where parFunction = 'templateLocation' and ID = 4")
'End If
'If Mid(filename, InStrRev(filename, "\") + 1, 5) = "Fixed" Then
'Set rs = CurrentDb().OpenRecordset("Select parValue from META_Parameters where parFunction = 'templateLocation' and ID = 3")
'End If
Set rs = CurrentDb().OpenRecordset("Select parValue from META_Parameters where parFunction = 'templateLocation' and ID = 2")
If rs.RecordCount > 0 Then
templateLocationValid = Nz(rs!parValue, "")
Else
templateLocationValid = ""
End If
rs.Close
Set rs = Nothing
On Error GoTo 0
Exit Function
templateLocationValid_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure templateLocationValid of Module Import"
End Function
Public Sub setTemplateLocation()
Dim filename As String
On Error GoTo setTemplateLocation_Error
filename = importFileName(".xls")
If filename <> "" Then
If Right(filename, 15) = "\Claim Form.xls" Then
DoCmd.RunSQL ("update META_Parameters set parValue = """ & filename & """ where parFunction = ""templateLocation""")
Else
MsgBox "Correct template file not selected.", vbCritical, "Wrong file"
End If
Else
MsgBox "Template File Location not updated", vbCritical
End If
On Error GoTo 0
Exit Sub
setTemplateLocation_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure setTemplateLocation of Module Import"
End Sub
Function GetSaveFile_TSB(strInitialDir As String, strTitle As String, strDefName As String) As String
' Comments : Simple file save routine. For additional options, use GetFileSaveEX_TSB()
' Parameters: strInitialDir - path for the initial directory, or blank for the current directory
' strTitle - title for the dialog
' strDefName - default file name and extension to use
' Returns : string path, name and extension of the file specified
'
Dim fOK As Boolean
Dim typWinOpen As TSBAPI_WINOPENFILENAME
Dim typOpenFile As TSBAPI_OPENFILE
Dim strFilter As String
On Error GoTo PROC_ERR
' Set reasonable defaults
strFilter = CreateFilterString_TSB("Excel Files (*.XLS)", "*.XLS", "Excel Files (*.XLSM)", "*.XLSM", "All Files (*.*)", "*.*")
If strInitialDir <> "" Then
typOpenFile.strInitialDir = strInitialDir
Else
typOpenFile.strInitialDir = CurDir()
End If
If strDefName <> "" Then
typOpenFile.strInitialFile = strDefName
End If
If strTitle <> "" Then
typOpenFile.strDialogTitle = strTitle
End If
typOpenFile.strFilter = strFilter
typOpenFile.lngFlags = OFN_HIDEREADONLY Or OFN_SHOWHELP Or OFN_OVERWRITEPROMPT
' Convert the TSB structure to a Win structure
ConvertTSB2Win typOpenFile, typWinOpen
' Call the Common dialog
fOK = TSBAPI_GetSaveFileName(typWinOpen)
'Debug.Print Len(Dir(sFile)) 'antonio
' Convert the Win structure back to a TSB structure
[COLOR=red]ConvertWin2TSB typWinOpen, typOpenFile[/COLOR]
GetSaveFile_TSB = typOpenFile.strFullPathReturned
'spot to be noted
'
'
'If (myFileExi = False) Then
'fOK = TSBAPI_GetSaveFileName(typWinOpen)
'End If
Proc_Exit:
Exit Function
PROC_ERR:
GetSaveFile_TSB = ""
Resume Proc_Exit
End Function
Function CreateFilterString_TSB(ParamArray varFilt() As Variant) As String
' Comments : Builds a Windows formatted filter string for "file type"
' Parameters: varFilter - parameter array in the format:
' Text, Filter, Text, Filter ...
' Such as:
' "All Files (*.*)", "*.*", "Text Files (*.TXT)", "*.TXT"
' Returns : windows formatted filter string
'
Dim strFilter As String
Dim intCounter As Integer
Dim intParamCount As Integer
On Error GoTo PROC_ERR
' Get the count of paramaters passed to the function
intParamCount = UBound(varFilt)
If (intParamCount <> -1) Then
' Count through each parameter
For intCounter = 0 To intParamCount
strFilter = strFilter & varFilt(intCounter) & Chr$(0)
Next
' Check for an even number of parameters
If (intParamCount Mod 2) = 0 Then
strFilter = strFilter & "*.*" & Chr$(0)
End If
End If
CreateFilterString_TSB = strFilter
Proc_Exit:
Exit Function
PROC_ERR:
CreateFilterString_TSB = ""
Resume Proc_Exit
End Function
Sub ConvertTSB2Win(TSB_Struct As TSBAPI_OPENFILE, Win_Struct As TSBAPI_WINOPENFILENAME)
' Comments : Converts the passed TSBAPI structure to a Windows structure
' Parameters: TSB_Struct - record of type TSBAPI_OPENFILE
' Win_Struct - record of type TSBAPI_WINOPENFILENAME
' Returns : Nothing
'
Dim strFile As String * 512
On Error GoTo PROC_ERR
Win_Struct.hWndOwner = Application.hWndAccessApp
Win_Struct.hInstance = 0
If TSB_Struct.strFilter = "" Then
Win_Struct.lpstrFilter = ALLFILES & Chr$(0) & "*.*" & Chr$(0)
Else
Win_Struct.lpstrFilter = TSB_Struct.strFilter
End If
Win_Struct.nFilterIndex = TSB_Struct.intFilterIndex
Win_Struct.lpstrFile = String(512, 0)
Win_Struct.nMaxFile = 511
Win_Struct.lpstrFileTitle = String$(512, 0)
Win_Struct.nMaxFileTitle = 511
Win_Struct.lpstrTitle = TSB_Struct.strDialogTitle
Win_Struct.lpstrInitialDir = TSB_Struct.strInitialDir
Win_Struct.lpstrDefExt = TSB_Struct.strDefaultExtension
Win_Struct.Flags = TSB_Struct.lngFlags
Win_Struct.lStructSize = Len(Win_Struct)
Proc_Exit:
Exit Sub
PROC_ERR:
Resume Proc_Exit
End Sub
Sub ConvertWin2TSB(Win_Struct As TSBAPI_WINOPENFILENAME, TSB_Struct As TSBAPI_OPENFILE)
' Comments : Converts the passed TSBAPI structure to a Windows structure
' Parameters: Win_Struct - record of type TSBAPI_WINOPENFILENAME
' TSB_Struct - record of type TSBAPI_OPENFILE
' Returns : Nothing
'
On Error GoTo PROC_ERR
TSB_Struct.strFullPathReturned = Left(Win_Struct.lpstrFile, InStr(Win_Struct.lpstrFile, vbNullChar) - 1)
TSB_Struct.strFileNameReturned = RemoveNulls_TSB(Win_Struct.lpstrFileTitle)
TSB_Struct.intFileOffset = Win_Struct.nFileOffset
TSB_Struct.intFileExtension = Win_Struct.nFileExtension
Proc_Exit:
Exit Sub
PROC_ERR:
Resume Proc_Exit
End Sub
Function RemoveNulls_TSB(strIn As String) As String
' Comments : Removes terminator from a string
' Parameters: strIn - string to modify
' Return : modified string
'
Dim intChr As Integer
intChr = InStr(strIn, Chr$(0))
If intChr > 0 Then
RemoveNulls_TSB = Left$(strIn, intChr - 1)
Else
RemoveNulls_TSB = strIn
End If
End Function
Function myFileExists(ByVal strPath As String) As Boolean
'Function returns true if file exists, false otherwise
If Len(Dir(strPath)) > 0 Then
myFileExists = False
Else
myFileExists = True
End If
End FunctionPlease help me, office suite MS 2010, 64 BIT
Thanks,
Antonio
Attachments
-
1004.JPG
