FrozenMana
Registered User.
- Local time
- Today, 09:34
- Joined
- Aug 10, 2015
- Messages
- 27
Hello, I have yet another database which I have been assigned the task of converting from 32-bit to 64-bit.
I have used http://www.jkp-ads.com/articles/apideclarations.asp as a reference to update what I could however since I am not fully sure what the database does outside of importing a file and am not receiving the debug message.:banghead:
I have made a few changes however it results in nothing happening when I click the cmdFile button.
Below is the original coding:
I have made the below changes to the code
Any advice or points in the right direction is helpful. Thank you in advance.

I have used http://www.jkp-ads.com/articles/apideclarations.asp as a reference to update what I could however since I am not fully sure what the database does outside of importing a file and am not receiving the debug message.:banghead:
I have made a few changes however it results in nothing happening when I click the cmdFile button.
Below is the original coding:
Code:
Option Compare Database
' everything from here to "' finish" is for browser button
Option Explicit
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Public CDCaption, CDSearchString, CDInitDir As String
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter 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
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
LParam As Long
iImage As Long
End Type
Sub Browser1(X)
Dim strPath As String, FilePath As Object
Select Case X
Case 1: Set FilePath = Me.txtFile
' Case 2: Set FilePath = txtFile2
' Case 3: Set FilePath = txtFile3
End Select
CDSearchString = "*.*"
CDCaption = "Select File to Attach..."
If IsNull(FilePath.Value) Or FilePath.Value = "" Then
CDInitDir = "C:\"
Else
CDInitDir = FilePath.Value
End If
strPath = LaunchCD(Me)
If strPath <> "None Selected" Then FilePath.Value = strPath
End Sub
Function LaunchCD(strForm As Form) As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String
OpenFile.lStructSize = Len(OpenFile)
OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrTitle = "Select File..."
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
LaunchCD = "None Selected"
Else
LaunchCD = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
End If
End Function
Public Function BrowseFolder(szDialogTitle As String) As String
Dim X As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer
With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With
dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If X Then
wPos = InStr(szPath, Chr(0))
BrowseFolder = Left$(szPath, wPos - 1)
Else
BrowseFolder = vbNullString
End If
End Function
Function BrowseForFolder(strComment As String, Optional OpenAt As Variant) As Variant
'code found at: http://www.vbaexpress.com/kb/getarticle.php?kb_id=284
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, strComment, 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Private Sub cmdFile_Click()
Call Browser1(1)
End Sub
Private Sub cmdFolder_Click()
Me.txtFolder = BrowseFolder("Please select the folder in which to save the individual RA's:")
End Sub
Private Sub cmdGO_Click()
'On Error GoTo ERROR_1
'Import RA File
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete * from tblImport"
DoCmd.SetWarnings True
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "tblImport", Me.txtFile, True
'create recordset
Dim rstX As DAO.Recordset
Dim qdfX As QueryDef
Dim strHub As String
Set qdfX = CurrentDb.QueryDefs("qryTblImport")
strHub = InputBox("Which delivery hub would you like to Export?")
qdfX.Parameters(0) = strHub
Set rstX = qdfX.OpenRecordset
'rstX.MoveFirst
Select Case rstX.RecordCount
Case Is > 0
Case Else
MsgBox "You have selected an RA File which is empty. Please select a valid RA file.", vbCritical, "WARNING!"
Exit Sub
End Select
'create Excel Application
Dim xlApp As Excel.Application
Set xlApp = CreateObject("Excel.Application")
xlApp.Workbooks.Add
'On Error GoTo ERROR_2
'create variables to use
Dim dteA As Date
Dim strB As String
Dim strC As String
Dim strD As String
Dim dteE As Date
Dim strF As String
Dim strG As String
Dim strH As String
Dim strI As String
Dim strJ As String
Dim strK As String
Dim strL As String
Dim dteM As Date
Dim strN As String
Dim strO As String
Dim strP As String
Dim strQ As String
Dim strR As String
Dim strS As String
Dim strT As String
Dim strU As String
Dim strV As String
Dim strW As String
Dim strX As String
Dim strY As String
'create workbook and create correct number of worksheets
rstX.MoveLast
rstX.MoveFirst
Select Case rstX.RecordCount
Case Is > xlApp.Worksheets.Count
Do Until rstX.RecordCount = xlApp.Worksheets.Count
xlApp.Worksheets.Add
Loop
Case Is < xlApp.Worksheets.Count
Do Until rstX.RecordCount = xlApp.Worksheets.Count
xlApp.Worksheets(xlApp.Worksheets.Count).Delete
Loop
End Select
'Loop through rstX and export into Excel Sheet and save workbook
'create worksheet counting int
Dim intX As Integer
intX = 1
Do Until rstX.EOF
'fill variables
If Not IsNull(rstX.Fields(0)) Then
dteA = rstX.Fields(0)
End If
If Not IsNull(rstX.Fields(1)) Then
strB = rstX.Fields(1)
End If
If Not IsNull(rstX.Fields(2)) Then
strC = rstX.Fields(2)
End If
If Not IsNull(rstX.Fields(3)) Then
strD = rstX.Fields(3)
End If
If Not IsNull(rstX.Fields(4)) Then
dteE = rstX.Fields(4)
End If
If Not IsNull(rstX.Fields(5)) Then
strF = rstX.Fields(5)
End If
If Not IsNull(rstX.Fields(6)) Then
strG = rstX.Fields(6)
End If
If Not IsNull(rstX.Fields(7)) Then
strH = rstX.Fields(7)
End If
If Not IsNull(rstX.Fields(8)) Then
strI = rstX.Fields(8)
End If
If Not IsNull(rstX.Fields(9)) Then
strJ = rstX.Fields(9)
End If
If Not IsNull(rstX.Fields(10)) Then
strK = rstX.Fields(10)
End If
If Not IsNull(rstX.Fields(11)) Then
strL = rstX.Fields(11)
End If
If Not IsNull(rstX.Fields(12)) Then
dteM = rstX.Fields(12)
End If
If Not IsNull(rstX.Fields(13)) Then
strN = rstX.Fields(13)
End If
If Not IsNull(rstX.Fields(14)) Then
strO = rstX.Fields(14)
End If
If Not IsNull(rstX.Fields(15)) Then
strP = rstX.Fields(15)
End If
If Not IsNull(rstX.Fields(16)) Then
strQ = rstX.Fields(16)
End If
If Not IsNull(rstX.Fields(17)) Then
strR = rstX.Fields(17)
End If
If Not IsNull(rstX.Fields(18)) Then
strS = rstX.Fields(18)
End If
If Not IsNull(rstX.Fields(19)) Then
strT = rstX.Fields(19)
End If
If Not IsNull(rstX.Fields(20)) Then
strU = rstX.Fields(20)
End If
If Not IsNull(rstX.Fields(21)) Then
strV = rstX.Fields(21)
End If
If Not IsNull(rstX.Fields(22)) Then
strW = rstX.Fields(22)
End If
If Not IsNull(rstX.Fields(23)) Then
strX = rstX.Fields(23)
End If
If Not IsNull(rstX.Fields(24)) Then
strY = rstX.Fields(24)
End If
'select worksheet and format
xlApp.Worksheets(intX).Select
'format cells
xlApp.Range("A1:J1").Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
End With
xlApp.Selection.Merge
xlApp.ActiveCell.FormulaR1C1 = "JCPENNEY FACTORY SHIP RETURN AUTHORIZATION"
xlApp.Range("A3").Select
xlApp.ActiveCell.FormulaR1C1 = "EXEL HUB:"
xlApp.Range("A5").Select
xlApp.ActiveCell.FormulaR1C1 = "CASE:"
xlApp.Range("A7").Select
xlApp.ActiveCell.FormulaR1C1 = "CONSIGNEE:"
xlApp.Range("A9").Select
xlApp.ActiveCell.FormulaR1C1 = "JCPENNEY ORDER #:"
xlApp.Range("A11").Select
xlApp.ActiveCell.FormulaR1C1 = "INVOICE DATE:"
xlApp.Range("A13").Select
xlApp.ActiveCell.FormulaR1C1 = "ADDRESS:"
xlApp.Range("A15").Select
xlApp.ActiveCell.FormulaR1C1 = "PHONE NUMBER:"
xlApp.Range("A17").Select
xlApp.ActiveCell.FormulaR1C1 = "NOTIFY # IF DIFFERENT:"
xlApp.Range("A19").Select
xlApp.ActiveCell.FormulaR1C1 = "MERCHANDISE:"
xlApp.Range("A20").Select
xlApp.Range("A23").Select
xlApp.ActiveCell.FormulaR1C1 = "COMMENTS:"
xlApp.Range("A26").Select
xlApp.ActiveCell.FormulaR1C1 = "REASON FOR RETURN:"
xlApp.Range("A30").Select
xlApp.ActiveCell.FormulaR1C1 = "PLEASE ARRANGE FOR COLLECTION OF FREIGHT CHARGES"
xlApp.Range("A31").Select
xlApp.ActiveCell.FormulaR1C1 = "SEND BILLING TO: JCPENNEY, PO BOX 45111, SALT LAKE CITY, UT 84145"
xlApp.Range("A33").Select
xlApp.ActiveCell.FormulaR1C1 = "RETURN MERCHANDISE TO:"
xlApp.Range("E33").Select
xlApp.ActiveCell.FormulaR1C1 = "JCPENNEY DISTRIBUTION / RETURN DOCK"
xlApp.Range("E34").Select
xlApp.ActiveCell.FormulaR1C1 = "ADDRESS"
xlApp.Range("A37").Select
xlApp.ActiveCell.FormulaR1C1 = "RA #:"
xlApp.Range("D37").Select
xlApp.ActiveCell.FormulaR1C1 = "TRACKING #:"
xlApp.Range("G37").Select
xlApp.ActiveCell.FormulaR1C1 = "DATE ISSUED:"
xlApp.Range("G3").Select
xlApp.ActiveCell.FormulaR1C1 = "FROM:"
xlApp.Cells.Select
xlApp.Selection.Font.Bold = True
xlApp.ActiveWindow.Zoom = 80
With xlApp.Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
xlApp.Cells(1, 1).Select
With xlApp.Selection.Font
.Name = "Arial"
.Size = 16
End With
'format columns and rows
xlApp.Columns("B:B").ColumnWidth = 12
xlApp.Columns("C:C").ColumnWidth = 13.57
xlApp.Columns("D:D").ColumnWidth = 17.71
xlApp.Columns("E:E").ColumnWidth = 12.86
xlApp.Columns("G:G").ColumnWidth = 18.57
xlApp.Columns("H:H").ColumnWidth = 15
xlApp.Range("4:4,6:6,8:8,10:10,12:12,14:14,16:16,18:18,32:32").Select
xlApp.Selection.RowHeight = 7.5
'format printing
' With ActiveSheet.PageSetup
' .PrintTitleRows = ""
' .PrintTitleColumns = ""
' End With
' ActiveSheet.PageSetup.PrintArea = ""
With xlApp.ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = xlApp.InchesToPoints(0.75)
.RightMargin = xlApp.InchesToPoints(0.75)
.TopMargin = xlApp.InchesToPoints(1)
.BottomMargin = xlApp.InchesToPoints(1)
.HeaderMargin = xlApp.InchesToPoints(0.5)
.FooterMargin = xlApp.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
xlApp.ActiveSheet.PageSetup.PrintArea = "$A$1:$J$38"
'select cell A1
xlApp.Cells(1, 1).Select
'place variables on sheet
'strS
xlApp.Range("D3").Value = strS
'strN
xlApp.Range("D5").Value = strN
'strF
xlApp.Range("D7").Value = strF
'strD
xlApp.Range("D9").Value = strD
'dteE
xlApp.Range("D11").Value = dteE
'strG,strH,strI,strJ
xlApp.Range("D13").Value = strG & ", " & strH & ", " & strI & " " & strJ
'strV
xlApp.Range("D15").Value = strV
'strW
xlApp.Range("D17").Value = strW
'strK
xlApp.Range("D19").Value = strK
'strP,strQ,strR
xlApp.Range("D20").Value = strP & ", " & strQ & ", " & strR
'strX
xlApp.Range("D23").Value = strX
'strC,strL
xlApp.Range("D26").Value = strC & ", " & strL
'strT
Select Case True
Case strT = "JCPCOL"
xlApp.Range("E34").Value = "555 SCARBOROUGH BLVD, COLUMBUS, OH 43232"
Case strT = "JCPMAN"
xlApp.Range("E34").Value = "1339 TOLLAND TURNPIKE, MANCHESTER, CT 06040"
Case strT = "JCPLEN"
xlApp.Range("E34").Value = "10500 LACKMAN ROAD, LENEXA, KS 66250"
Case strT = "JCPREN"
xlApp.Range("E34").Value = "11111 STEAD BLVD, ANDERSON ACRES, NV 89506"
End Select
'strB
xlApp.Range("B37").Value = strB
'strD
xlApp.Range("E37").Value = strD
'dteA
xlApp.Range("H37").Value = dteA
'strY
xlApp.Range("H3").Value = strY
'name sheet
xlApp.Worksheets(intX).Name = Replace(strB, "/", "_") & "_" & intX
'add to counter
intX = intX + 1
rstX.MoveNext
Loop
xlApp.Worksheets(1).Select
'Save Excel Application
Dim strfile As String
strfile = BrowseForFolder("Please select a folder in which to save the Return Authorizations for " & strHub & "...") & "\" & strHub & "_RA_" & Format(Now(), "yyyymmdd") & ".xls"
xlApp.ActiveWorkbook.SaveAs strfile
MsgBox "DONE! The export Excel file has been saved at " & strfile & "."
xlApp.Visible = True
'xlApp.Quit
Set xlApp = Nothing
Set rstX = Nothing
Set qdfX = Nothing
Exit Sub
ERROR_1:
Set qdfX = Nothing
Set rstX = Nothing
MsgBox "ERROR #1", vbCritical, "WARNING!"
Exit Sub
ERROR_2:
'xlApp.Quit
xlApp.ActiveWorkbook.Close False
xlApp.Quit
Set xlApp = Nothing
Set rstX = Nothing
Set qdfX = Nothing
MsgBox "ERROR #2", vbCritical, "WARNING!"
End Sub
Private Sub Command32_Click()
On Error GoTo Err_Command32_Click
DoCmd.Quit
Exit_Command32_Click:
Exit Sub
Err_Command32_Click:
MsgBox Err.Description
Resume Exit_Command32_Click
End Sub
I have made the below changes to the code
Code:
Option Compare Database
' everything from here to "' finish" is for browser button
Option Explicit
Public CDCaption, CDSearchString, CDInitDir As String
[B] Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As LongPtr
hInstance As LongPtr
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter 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
lCustData As Long
lpfnHook As LongPtr
lpTemplateName As String
End Type
Private Type BROWSEINFO
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
End Type
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As LongPtr
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As LongPtr, ByVal pszPath As String) As Boolean
Private Const BIF_RETURNONLYFSDIRS = &H1
[/B]
[B]Public Function BrowseFolder(szDialogTitle As String) As String
Dim X As Long, dwIList As LongPtr
Dim bi As BROWSEINFO
Dim szPath As String, wPos As Integer
With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With
dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If X Then
wPos = InStr(szPath, Chr(0))
BrowseFolder = Left$(szPath, wPos - 1)
Else
BrowseFolder = vbNullString
End If
End Function[/B]
Any advice or points in the right direction is helpful. Thank you in advance.
