Excel 2003 macro won't work in Excel 2010

[texan22]

I have an Excel 2003 macro that will not run in Excel 2010. The macro allows me to extract data from our accounting business system into Excel. However, since we have upgraded to Excel 2010 and Windows 7, the macro will not work. I'm told it is because 2010 is 64bit and runs a newer VBA7.
I know almost nothing about VBA programing. Is there something I can do to make Excel 2010 run the old 32 bit macro? Is there a magic combatability switch?

[BigBas]

I can't guarantee assistance on this, but can you post the code? That might help forum members identify lines that are incompatible. Also, when you say the macro doesn't work, do you mean it doesn't do anything, or does it throw an error code?

[texan22]

Thanks BigAs,
I get a Compile Error:
The code in this project must be updated for use on 64-bit systems. Please review and update Declare statements and then mark them with the PtrSafe attribute.

There appears to be multiple macros that run.
-------------------
-------------------

Option Explicit

Sub AUTO_OPEN()

    Dim oMenu As CommandBarPopup
    Dim oItem As CommandBarPopup
    Dim oSub1 As CommandBarButton
    Dim oSub2 As CommandBarButton
    Dim oSub3 As CommandBarButton
    Dim oSub4 As CommandBarButton
        
    Dim Msg, Style, Title
    Dim InputSheet As Worksheet
    Dim rng As Range

    On Error GoTo ErrHandler
     
    'do not prompt the user to save the file
    Application.DisplayAlerts = False
         
    Set oMenu = CommandBars("Worksheet Menu Bar").Controls("Data")
    Set oItem = oMenu.Controls.Add(Type:=msoControlPopup, Temporary:=True)
    oItem.Caption = "JDIS D&ata Extractor"
    oItem.BeginGroup = True
    
    ' NOTE: setting of the CONTROL keys is really done in the XLS in the Macros Options
    Set oSub1 = oItem.Controls.Add(Type:=msoControlButton, Temporary:=True)
    'oSub1.Caption = "&Customer YTD Sales Inquiry                        Ctrl+T"
    oSub1.OnAction = "CSTFM"
    oSub1.Caption = "&Customer YTD Sales Inquiry"
    oSub1.Control.ShortcutText = "Ctrl+T"
                                                                                                                                                                                                                                           
    Set oSub2 = oItem.Controls.Add(Type:=msoControlButton, Temporary:=True)
    'oSub2.Caption = "&Vendor Payment Group Detail                     Ctrl+Q"
    oSub2.OnAction = "VendorPaymentGroupDetail"
    oSub2.Caption = "&Vendor Payment Group Detail"
    oSub2.Control.ShortcutText = "Ctrl+Q"  ' NOTE: Q not in caption...
                                                            
    Set oSub3 = oItem.Controls.Add(Type:=msoControlButton, Temporary:=True)
    'oSub3.Caption = "I&mport Extract Files                                     Ctrl+M"
    oSub3.OnAction = "ExtractFileDetail"
    oSub3.Caption = "I&mport Extract Files"
    oSub3.Control.ShortcutText = "Ctrl+M"
                                                            
    Set oSub4 = oItem.Controls.Add(Type:=msoControlButton, Temporary:=True)
    'oSub4.Caption = "JDIS &Data Extractor User's Guide                Ctrl+D"
    oSub4.OnAction = "DEDOC"
    oSub4.Caption = "JDIS &Data Extractor User's Guide"
    oSub4.Control.ShortcutText = "Ctrl+D"
    
    Set InputSheet = CreateInputSheet
    
    On Error Resume Next

    oSub1.FaceId = 17
    oSub2.FaceId = 176
    oSub3.FaceId = 265
    oSub4.FaceId = 353
   
    Exit Sub

ErrHandler:
    
    Beep
    Msg = CStr(Err.Description)
    Style = vbOKOnly
    Title = "JDIS Data Extractor - VBError"
    MsgBox Msg, Style, Title

End Sub

Function CreateInputSheet() As Worksheet

Dim InpSheet As Worksheet
Dim countsheet As Integer
Dim rng As Range
 
Set InpSheet = Nothing
For countsheet = 1 To ActiveWorkbook.Sheets.Count
    Set InpSheet = ActiveWorkbook.Sheets(countsheet)
    If InpSheet.Name = "Inputs" Then
         Exit For
    Else
        Set InpSheet = Nothing
    End If
Next

If InpSheet Is Nothing Then
    Set InpSheet = ActiveWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
    InpSheet.Name = "Inputs"
    
    Set rng = InpSheet.Cells(1, 1)
    rng.AddComment ("For Excel driven inquiries (Customer YTD Sales, Vendor Payment Group Detail, etc.), enter beginning value here")

    Set rng = InpSheet.Range("A1")
    rng.ColumnWidth = 12
    Set rng = InpSheet.Range("B1")
    rng.ColumnWidth = 12

    Set rng = InpSheet.Range("C1")
    rng.ColumnWidth = 100
    
    InpSheet.Cells(6, 3) = "Notes:"
    InpSheet.Cells(7, 3) = "1) JDIS Data Extractor Functionality is accessed from the Data -> JDIS Data Extractor menu options"
    InpSheet.Cells(8, 3) = "2) Additional documentation is available from the Data -> JDIS Data Extractor -> JDIS Data Extractor User's Guide option"
    InpSheet.Cells(9, 3) = "3) All cell data entry must be completed before executing any JDIS Data Extractor query"
    
    InpSheet.Cells(11, 3) = "Customer YTD Sales Inquiry"
    InpSheet.Cells(12, 3) = "1) Enter the customer numbers and / or customer ranges to be extracted"
    InpSheet.Cells(13, 3) = "   a) To enter a single customer number, enter the customer number in cell A1 on the spreadsheet"
    InpSheet.Cells(14, 3) = "   b) To enter a range of customer numbers, enter the beginning customer number in cell A1 and "
    InpSheet.Cells(15, 3) = "      enter the ending customer number in cell B1"
    InpSheet.Cells(16, 3) = "   c) Combinations of single customers and customer ranges may be entered within the same inquiry by"
    InpSheet.Cells(17, 3) = "      making similar entries in subsequent rows (A2 for an individual or A2 and B2 for a customer range, etc)"
    InpSheet.Cells(18, 3) = "2) From the Data menu, select JDIS Data Extractor -> Customer YTD Sales Inquiry"
    InpSheet.Cells(19, 3) = "3) If prompted with dialogs, fill out the appropriate Business System Info"
    InpSheet.Cells(20, 3) = "4) Results will be displayed in the Results tab at the bottom of the Excel workbook"
    
    InpSheet.Cells(22, 3) = "Vendor Payment Group Detail"
    InpSheet.Cells(23, 3) = "1) Enter the vendor numbers and / or vendor ranges to be extracted"
    InpSheet.Cells(24, 3) = "   a) To enter a single vendor number, enter the vendor number in cell A1 on the spreadsheet"
    InpSheet.Cells(25, 3) = "   b) To enter a range of vendor numbers, enter the beginning customer number in cell A1 and "
    InpSheet.Cells(26, 3) = "      enter the ending vendor number in cell B1"
    InpSheet.Cells(27, 3) = "   c) Combinations of single vendors and vendor ranges may be entered within the same inquiry by"
    InpSheet.Cells(28, 3) = "      making similar entries in subsequent rows (A2 for an individual or A2 and B2 for a vendor range, etc)"
    InpSheet.Cells(29, 3) = "2) From the Data menu, select JDIS Data Extractor -> Vendor Payment Group Detail"
    InpSheet.Cells(30, 3) = "3) If prompted with dialogs, fill out the appropriate Business System Info"
    InpSheet.Cells(31, 3) = "4) Results will be displayed in the Results tab at the bottom of the Excel workbook"
        
    InpSheet.Cells(33, 3) = "Import Extract Files"
    InpSheet.Cells(34, 3) = "1) Create ANY data extract file on your business system (See JDIS Data Extractor User's Guide for details)"
    InpSheet.Cells(35, 3) = "2) From the Data menu, select JDIS Data Extractor -> Import Extract Files"
    InpSheet.Cells(36, 3) = "3) When the file selection dialog box appears, enter the business system file name, from step # 1, to be imported"
    InpSheet.Cells(37, 3) = "4) Results will be displayed in the Results tab at the bottom of the Excel worksheet"

    Set rng = InpSheet.Range("C6")
    rng.Font.Bold = True
    rng.Interior.ColorIndex = 15
    rng.BorderAround ColorIndex:=xlColorIndexAutomatic, Weight:=xlThin
    
    Set rng = InpSheet.Range("C11")
    rng.Font.Bold = True
    rng.Interior.ColorIndex = 15
    rng.BorderAround ColorIndex:=xlColorIndexAutomatic, Weight:=xlThin
    
    Set rng = InpSheet.Range("C22")
    rng.Font.Bold = True
    rng.Interior.ColorIndex = 15
    rng.BorderAround ColorIndex:=xlColorIndexAutomatic, Weight:=xlThin
   
    Set rng = InpSheet.Range("C33")
    rng.Font.Bold = True
    rng.Interior.ColorIndex = 15
    rng.BorderAround ColorIndex:=xlColorIndexAutomatic, Weight:=xlThin
    
    Set rng = InpSheet.Range("A1")
    With rng.EntireColumn.Validation
        .Add Type:=xlValidateWholeNumber, _
            AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="1", Formula2:="9999999999"
        '.InputTitle = "JDIS Data Extractor"
        .ErrorTitle = "JDIS Data Extractor"
        '.InputMessage = "Enter a valid customer"
        .ErrorMessage = "Invalid customer number,valid customer number range 1-9999999999"
    End With
   
    Set rng = InpSheet.Range("B1")
    With rng.EntireColumn.Validation
        .Add Type:=xlValidateWholeNumber, _
            AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="1", Formula2:="9999999999"
        '.InputTitle = "JDIS Data Extractor"
        .ErrorTitle = "JDIS Data Extractor"
        '.InputMessage = "Enter a valid customer"
        .ErrorMessage = "Invalid customer number,valid customer number range 1-9999999999"
    End With
    
End If

Set CreateInputSheet = InpSheet

End Function

--------------------
--------------------

[texan22]

Sub ExtractFileDetail()
On Error GoTo ErrHandler

Dim rng As Range
Dim Row As Long
Dim Col As Integer
Dim strFileName As String
Dim strParam As String
Dim ErrorSheet As Worksheet
Dim ResultSheet As Worksheet
Dim countsheet As Integer
Dim Msg, Style, Title
Dim ObjJDDE As JDISDATAEXTRACTOR_003Lib.JDISDataExtractor
Dim JDDEOutputRec As ADODB.Recordset
Dim lRetVal As Long
Dim Fld As ADODB.Field
Dim reg As Registry
Dim rk As RegKey
Dim ClearStatus As Boolean
Dim DeleteStatus As Boolean
Dim InputSheet As Worksheet
Dim strKeyName As String
Dim strFileName2 As String
Dim vColumns As Variant
Dim vColFormats As Variant
Dim vColAligns As Variant
Dim vColWidths As Variant

strKeyName = "ExtractDetailFileLocation"
strFileName2 = "" '"/JDIS/DATA/MF/FINGEXT"

'do not prompt the user to save the file
Application.DisplayAlerts = False

On Error Resume Next
'get the default filename from registry
'if key not found,create the same wih a hardcoded default
Set reg = New Registry
Set rk = reg.RegKeyFromString("\HKEY_LOCAL_MACHINE\SOFTWARE\John Deere Information Systems\JDIS Data Extractor")
If Err.Number <> 0 Then
    Set rk = reg.RegKeyFromString("\HKEY_LOCAL_MACHINE\SOFTWARE")
    rk.SubKeys.Add ("John Deere Information Systems\JDIS Data Extractor")
    Set rk = reg.RegKeyFromString("\HKEY_LOCAL_MACHINE\SOFTWARE\John Deere Information Systems\JDIS Data Extractor")
    rk.Values.Add strKeyName, strFileName2, rvString
End If
strFileName = rk.Values(strKeyName).Value
If Err.Number <> 0 Then
    rk.Values.Add strKeyName, strFileName2, rvString
    strFileName = rk.Values(strKeyName).Value
End If
On Error GoTo ErrHandler

'get the filename from the user with the default displayed
strFileName = InputBox("Please enter the fully qualified filename of the extract data file on the Dealer Business System to import:", "Extract File Detail Selection", strFileName)

If Len(strFileName) = 0 Then  'user clicked cancel
    'Rng.Value = "Error - Invalid File Name, Please try again"
    'Beep
    'Msg = "Invalid File Name,Please try again"
    'Style = vbOKOnly
    'Title = "General Ledger Inquiry"
    'MsgBox Msg, Style, Title
    Exit Sub
End If
   
'set the filename as default value in the registry to be displayed next time
On Error Resume Next
rk.Values(strKeyName).Value = strFileName
On Error GoTo ErrHandler
   
'valid input given..continue processing

'Clear Results and Errors Sheet
ClearStatus = ClearResultSheet()
ClearStatus = ClearErrorSheet()
   
Set ObjJDDE = New JDISDATAEXTRACTOR_003Lib.JDISDataExtractor
Set JDDEOutputRec = New ADODB.Recordset
Set JDDEOutputRec = ObjJDDE.ExtractFileDetail(strFileName, vColumns, vColFormats, vColAligns, vColWidths)

On Error Resume Next
Set InputSheet = Worksheets("Inputs")
InputSheet.Activate
InputSheet.Range("A1").Activate
On Error GoTo ErrHandler

'1)check for output record
'when JDDEOutputRec is empty,display error and exit
If JDDEOutputRec Is Nothing Then
    Beep
    Set ErrorSheet = CommonFunctions.CreateErrorSheet
    ErrorSheet.Activate
    ErrorSheet.Range("A2").Activate
    ErrorSheet.Cells(1, 1) = "Error Code"
    ErrorSheet.Cells(1, 2) = "Error Description"
    ErrorSheet.Cells(2, 1) = "N/A"
    ErrorSheet.Cells(2, 2) = "No data exists for the given file"
    'DeleteStatus = DelResultSheet()
    
    Set rng = ErrorSheet.Range("A1:C1")
    rng.EntireColumn.WrapText = True
    
    Exit Sub

[texan22]

End If
        JDDEInputRec("CID") = strInput
        Row = Row + 1
    Else
        bContinue = False
    End If
Wend

Set InputSheet = Worksheets("Inputs")
InputSheet.Activate
InputSheet.Range("A1").Activate

If Len(strInput) = 0 Then
    Beep
    Msg = "Please enter the customer id or the range in the Inputs sheet and then try again"
    Style = vbOKOnly
    Title = "Customer YTD Sales Inquiry"
    MsgBox Msg, Style, Title
    Exit Sub
End If

'valid input given..continue processing

'Clear Results and Errors Sheet
ClearStatus = ClearResultSheet()
ClearStatus = ClearErrorSheet()

JDDEInputRec.MoveFirst
Set ObjJDDE = New JDISDATAEXTRACTOR_003Lib.JDISDataExtractor
Set JDDEOutputRec = New ADODB.Recordset
Set JDDEOutputRec = ObjJDDE.CustomerYTDSales(JDDEInputRec)

JDDEInputRec.Close
Set JDDEInputRec = Nothing
 
'1)check for output record
'when JDDEOutputRec is empty,display error and exit
If JDDEOutputRec Is Nothing Then
    Beep
    Set ErrorSheet = CreateErrorSheet
    ErrorSheet.Activate
    ErrorSheet.Range("A2").Activate
    ErrorSheet.Cells(1, 1) = "Error Code"
    ErrorSheet.Cells(1, 2) = "Error Description"
    ErrorSheet.Cells(2, 1) = "N/A"
    ErrorSheet.Cells(2, 2) = "No customer exists for the given Input"
    
    Set rng = ErrorSheet.Range("A1:C1")
    rng.EntireColumn.WrapText = True
    
    Exit Sub
End If


If JDDEOutputRec.RecordCount = 0 Then
    Beep
    Set ErrorSheet = CreateErrorSheet
    ErrorSheet.Activate
    ErrorSheet.Range("A2").Activate
    ErrorSheet.Cells(1, 1) = "Error Code"
    ErrorSheet.Cells(1, 2) = "Error Description"
    ErrorSheet.Cells(2, 1) = "N/A"
    ErrorSheet.Cells(2, 2) = "No customer exists for the given Input"
    
    Set rng = ErrorSheet.Range("A1:C1")
    rng.EntireColumn.WrapText = True
    
    Exit Sub
End If


Set ResultSheet = CreateResultSheet
ResultSheet.Activate
ResultSheet.Range("A2").Activate

'2a)Display rows where EC value is not set in Results Sheet
RowWithECFlag = False
RowWithNoECFlag = False
Row = 1
Col = 1
'Hard coding of columns..Col not used
For lcount = 1 To 27
    ResultSheet.Cells(Row, lcount) = JDDEOutputRec.Fields(lcount - 1).Name
Next
ResultSheet.Cells(Row, 28) = JDDEOutputRec.Fields(29).Name

While Not JDDEOutputRec.EOF
    'check if EC value is not set
    If JDDEOutputRec.Fields(27).Value = 0 Then
        RowWithNoECFlag = True
        Row = Row + 1
        For lcount = 1 To 27
            ResultSheet.Cells(Row, lcount) = JDDEOutputRec.Fields(lcount - 1).Value
        Next
        ResultSheet.Cells(Row, 28) = JDDEOutputRec.Fields(29).Value
    Else
        RowWithECFlag = True
    End If
    JDDEOutputRec.MoveNext
Wend
JDDEOutputRec.MoveFirst

'2b)Display rows where EC value is set in Errors Sheet
'If no errors, delete the Errors sheet if exists (based on the flag)
If RowWithECFlag Then
    Set ErrorSheet = CreateErrorSheet
    ErrorSheet.Activate
    ErrorSheet.Range("A2").Activate
    Row = 1
    ErrorSheet.Cells(Row, 1) = JDDEOutputRec.Fields(27).Name
    ErrorSheet.Cells(Row, 2) = JDDEOutputRec.Fields(28).Name
    ErrorSheet.Cells(Row, 3) = JDDEOutputRec.Fields(0).Name
    
    While Not JDDEOutputRec.EOF
        'check if EC value is not set
        If JDDEOutputRec.Fields(27).Value <> 0 Then
            Row = Row + 1
            ErrorSheet.Cells(Row, 1) = CStr(JDDEOutputRec.Fields(27).Value)
            ErrorSheet.Cells(Row, 2) = CStr(JDDEOutputRec.Fields(28).Value)
            ErrorSheet.Cells(Row, 3) = CStr(JDDEOutputRec.Fields(0).Value)
        End If
        JDDEOutputRec.MoveNext
    Wend
    JDDEOutputRec.MoveFirst
    
    Set rng = ErrorSheet.Range("A1:C1")
    rng.EntireColumn.WrapText = True


Else
    DeleteStatus = DelErrorSheet()
End If


If RowWithNoECFlag Then
    ResultSheet.Activate
        
    Set rng = ResultSheet.Range("A1:AB1")
    rng.EntireColumn.WrapText = True

Else
    ResultSheet.Cells.Clear
    'DeleteStatus = DelResultSheet()
End If

' if both Results and Errors exist
If RowWithNoECFlag And RowWithECFlag Then
    
    Msg = "Encountered Errors and/or warnings, would you like to view them now? "
    Style = vbYesNo + vbDefaultButton2 + vbQuestion
    Title = "Customer YTD Sales Inquiry"
    Response = MsgBox(Msg, Style, Title)
    
    If Response = vbYes Then
        ErrorSheet.Activate
    End If
 End If


JDDEOutputRec.Close
Set JDDEOutputRec = Nothing
Exit Sub

ErrHandler:

'DeleteStatus = DelResultSheet()
Set ErrorSheet = CreateErrorSheet
ErrorSheet.Activate
ErrorSheet.Range("A2").Activate

ErrorSheet.Cells(1, 1) = "Error Code"
ErrorSheet.Cells(1, 2) = "Error Description"
ErrorSheet.Cells(1, 3) = "Customer ID"
ErrorSheet.Cells(2, 1) = "N/A"
ErrorSheet.Cells(2, 2) = CStr(Err.Description)
ErrorSheet.Cells(2, 3) = "N/A"

Set rng = ErrorSheet.Range("A1:C1")
rng.EntireColumn.WrapText = True

'Beep
'Msg = CStr(Err.Description)
'Style = vbOKOnly
'Title = "Customer YTD Sales Inquiry - VBError"
'MsgBox Msg, Style, Title

End Sub
Function CreateErrorSheet() As Worksheet
'Find the Error Sheet
Dim ErrSheet As Worksheet
Dim countsheet As Integer
Dim rng As Range

Set ErrSheet = Nothing
For countsheet = 1 To ActiveWorkbook.Sheets.Count
    Set ErrSheet = ActiveWorkbook.Sheets(countsheet)
    If ErrSheet.Name = "Errors & Warnings" Then
         Exit For
    Else
        Set ErrSheet = Nothing
    End If
Next
If ErrSheet Is Nothing Then
   Set ErrSheet = ActiveWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
   ErrSheet.Name = "Errors & Warnings"
End If

ErrSheet.Cells.Clear

Set rng = ErrSheet.Range("A1:C1")
'Rng.EntireColumn.HorizontalAlignment = xlLeft
rng.EntireRow.Font.Bold = True
rng.EntireRow.HorizontalAlignment = xlCenter
rng.EntireRow.VerticalAlignment = xlCenter
rng.ColumnWidth = 30
'rng.EntireColumn.WrapText = True

Set rng = ErrSheet.Range("A1:B1")
rng.EntireColumn.NumberFormat = "@"

Set CreateErrorSheet = ErrSheet

End Function
Function CreateResultSheet() As Worksheet
'Find the Error Sheet
Dim ResSheet As Worksheet
Dim countsheet As Integer
Dim rng As Range
 
Set ResSheet = Nothing
For countsheet = 1 To ActiveWorkbook.Sheets.Count
    Set ResSheet = ActiveWorkbook.Sheets(countsheet)
    If ResSheet.Name = "Results" Then
         Exit For
    Else
        Set ResSheet = Nothing
    End If
Next
If ResSheet Is Nothing Then
    Set ResSheet = ActiveWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
    ResSheet.Name = "Results"
End If

ResSheet.Cells.Clear
Set rng = ResSheet.Range("A1:AZ1")
rng.ColumnWidth = 10

'Set rng = ResSheet.Range("A1:AB1")
'Rng.EntireColumn.HorizontalAlignment = xlLeft
rng.EntireRow.Font.Bold = True
rng.EntireRow.HorizontalAlignment = xlCenter
rng.EntireRow.VerticalAlignment = xlCenter
'rng.EntireColumn.WrapText = True

Set rng = ResSheet.Range("A1:J1")
rng.ColumnWidth = 20
Set rng = ResSheet.Range("AB1")
rng.ColumnWidth = 20

Set rng = ResSheet.Range("B1:K1")
rng.EntireColumn.NumberFormat = "@"
Set rng = ResSheet.Range("L1")
rng.EntireColumn.NumberFormat = "#,##0.00"
Set rng = ResSheet.Range("M1:O1")
rng.EntireColumn.NumberFormat = "@"
Set rng = ResSheet.Range("P1:AA1")
rng.EntireColumn.NumberFormat = "#,##0.00"
Set rng = ResSheet.Range("AB1")
rng.EntireColumn.NumberFormat = "@"

Set CreateResultSheet = ResSheet

End Function
------------------
------------------
Sub AUTO_CLOSE()

    On Error Resume Next

    Dim oMenu As CommandBarPopup
    Set oMenu = CommandBars("Worksheet Menu Bar").Controls("Data")
    oMenu.Controls("JDIS D&ata Extractor").Delete

End Sub

[texan22]

End If
If JDDEOutputRec.RecordCount = 0 Then
    Beep
    Set ErrorSheet = CommonFunctions.CreateErrorSheet
    ErrorSheet.Activate
    ErrorSheet.Range("A2").Activate
    ErrorSheet.Cells(1, 1) = "Error Code"
    ErrorSheet.Cells(1, 2) = "Error Description"
    ErrorSheet.Cells(2, 1) = "N/A"
    ErrorSheet.Cells(2, 2) = "No data exists for the given file"
    'DeleteStatus = DelResultSheet()
    
    Set rng = ErrorSheet.Range("A1:C1")
    rng.EntireColumn.WrapText = True
    
    Exit Sub
End If

'2)Display all rows in Results Sheet ( no check for EC)
Set ResultSheet = CreateResultSheet(vColumns, vColFormats, vColAligns, vColWidths)
ResultSheet.Activate
ResultSheet.Range("A2").Activate
Row = 1
Col = 1
For Each Fld In JDDEOutputRec.Fields
    Set rng = ResultSheet.Cells(Row, Col)
    rng.Value = Fld.Name
    Col = Col + 1
Next
Set rng = Nothing
While Not JDDEOutputRec.EOF
    Row = Row + 1
    Col = 1
    For Each Fld In JDDEOutputRec.Fields
        Set rng = ResultSheet.Cells(Row, Col)
        rng.Value = CStr(Fld.Value)
        Col = Col + 1
    Next
    JDDEOutputRec.MoveNext
Wend

JDDEOutputRec.Close
Set JDDEOutputRec = Nothing
    
Set rng = ResultSheet.Range("A1:AZ1")
rng.EntireColumn.WrapText = True

DeleteStatus = DelErrorSheet()
Exit Sub

ErrHandler:

'DeleteStatus = DelResultSheet()
Set ErrorSheet = CommonFunctions.CreateErrorSheet
ErrorSheet.Activate
ErrorSheet.Range("A2").Activate

ErrorSheet.Cells(1, 1) = "Error Code"
ErrorSheet.Cells(1, 2) = "Error Description"
ErrorSheet.Cells(2, 1) = "N/A"
ErrorSheet.Cells(2, 2) = CStr(Err.Description)

Set rng = ErrorSheet.Range("A1:C1")
rng.EntireColumn.WrapText = True

'Beep
'Msg = CStr(Err.Description)
'Style = vbOKOnly
'Title = "General Ledger Inquiry - VBError"
'MsgBox Msg, Style, Title

End Sub

Function CreateResultSheet(ByRef vColumnsIn As Variant, ByRef vColFormatsIn As Variant, ByRef vColAlignsIn As Variant, ByRef vColWidthsIn As Variant) As Worksheet
Dim ResSheet As Worksheet
Dim countsheet As Integer
Dim rng As Range
Dim Columns As Integer
Dim i As Integer
Dim strColumn As String
Dim strColFormat As String
Dim strColAlign As String
Dim strColWidth As String

Set ResSheet = Nothing
For countsheet = 1 To ActiveWorkbook.Sheets.Count
    Set ResSheet = ActiveWorkbook.Sheets(countsheet)
    If ResSheet.Name = "Results" Then
         Exit For
    Else
        Set ResSheet = Nothing
    End If
Next
If ResSheet Is Nothing Then
    Set ResSheet = ActiveWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
    ResSheet.Name = "Results"
End If

' same for all sheets
ResSheet.Cells.Clear
Set rng = ResSheet.Range("A1:AZ1")
rng.ColumnWidth = 10

' now do the dynamic stuff based on data from COBOL
If Not IsEmpty(vColFormatsIn) Then
    Columns = UBound(vColumnsIn)

    If Columns > 0 And Columns = UBound(vColFormatsIn) And Columns = UBound(vColAlignsIn) And Columns = UBound(vColWidthsIn) Then
        For i = 0 To Columns - 1
            strColumn = vColumnsIn(i)
            strColFormat = vColFormatsIn(i)
            strColAlign = vColAlignsIn(i)
            strColWidth = vColWidthsIn(i)
                
            If (Len(strColumn) > 0) Then
                Set rng = ResSheet.Range(strColumn)
                
                If (Len(strColFormat) > 0) Then
                    rng.EntireColumn.NumberFormat = strColFormat
                End If
                                
                If (Len(strColAlign) > 0) Then
                    If strColAlign = "C" Or strColAlign = "c" Then
                        rng.EntireColumn.HorizontalAlignment = xlCenter
                    ElseIf strColAlign = "R" Or strColAlign = "r" Then
                        rng.EntireColumn.HorizontalAlignment = xlRight
                    ElseIf strColAlign = "L" Or strColAlign = "l" Then
                        rng.EntireColumn.HorizontalAlignment = xlLeft
                    End If
                End If
                
                If (Len(strColWidth) > 0) Then
                    rng.ColumnWidth = Val(strColWidth)
                End If
            End If
        Next
    End If
End If

' same for all sheets
Set rng = ResSheet.Range("A1:AZ1")
rng.EntireRow.Font.Bold = True
rng.EntireRow.HorizontalAlignment = xlCenter
rng.EntireRow.VerticalAlignment = xlCenter

Set CreateResultSheet = ResSheet

End Function

----------------
----------------
Option Explicit
  
Sub CSTFM()

On Error GoTo ErrHandler

Dim rng As Range
Dim NextRng As Range

Dim Row As Long

Dim Col As Integer
Dim bContinue As Boolean
Dim strInput As String
Dim strZeros As String
Dim countsheet As Integer
Dim RowWithECFlag As Boolean
Dim RowWithNoECFlag As Boolean
Dim Msg, Style, Title, Response
Dim ErrorSheet As Worksheet
Dim ResultSheet As Worksheet
Dim ObjJDDE As JDISDATAEXTRACTOR_003Lib.JDISDataExtractor
Dim JDDEInputRec As ADODB.Recordset
Dim JDDEOutputRec As ADODB.Recordset
Dim Fld As ADODB.Field
Dim lcount As Long
Dim ClearStatus As Boolean
Dim DeleteStatus As Boolean
Dim reg As Registry
Dim rk As RegKey


Dim InputSheet As Worksheet

'get the default filename from registry
'if key not found,create the same wih a hardcoded default
On Error Resume Next
Set reg = New Registry
Set rk = reg.RegKeyFromString("\HKEY_LOCAL_MACHINE\SOFTWARE\John Deere Information Systems\JDDataAccess\Queries\CustomerYTDSalesEx")
If (Not (Err.Number <> 0)) Then
    CustomerYTDSalesEx
    Exit Sub
End If
On Error GoTo ErrHandler

'do not prompt the user to save the file
Application.DisplayAlerts = False

'As of now when Inputs sheet is not existing,this macro is not creating it
If ActiveWorkbook.ActiveSheet.Name <> "Inputs" Then
    Beep
    Msg = "You cannot run the macro from the current sheet, Please switch to Inputs sheet and then try again"
    Style = vbOKOnly
    Title = "Customer YTD Sales Inquiry"
    MsgBox Msg, Style, Title
    Exit Sub
End If

'Collect the customer numbers from the cells and store it in the ADO record set
'Inputs are in Col 1 and 2
strZeros = "0000000000"
Set JDDEInputRec = New ADODB.Recordset
JDDEInputRec.Fields.Append "CID", adBSTR
JDDEInputRec.Open
bContinue = True
Row = 1
While bContinue
    Set rng = ActiveWorkbook.ActiveSheet.Cells(Row, 1)
    If rng Then
        JDDEInputRec.AddNew
        Set NextRng = ActiveWorkbook.ActiveSheet.Cells(Row, 2)
        If NextRng Then
            If rng.Value < NextRng.Value Then
                strInput = "2" + Format$(rng.Value, strZeros) + Format$(NextRng.Value, strZeros)
            Else
                strInput = "2" + Format$(NextRng.Value, strZeros) + Format$(rng.Value, strZeros)
            End If
        Else
            strInput = "1" + Format$(rng.Value, strZeros)

[Cutter]

@ texan22

Welcome to the forum.

Please notice that code tags have been added to your post(s). The forum rules require them so please keep that in mind and add them yourself whenever showing code in any of your future posts. To see instructions for applying them, click on the Forum Rules button at top of the page and read Rule #3.
Thanks.

[royUK]

Why have you split the code across 4 posts? Firstly it is attempting to create a commandbar which are no longer supported in Excel 2010. Attach a workbook with the code in

[JosephP]

commandbars are supported in 2010.

I reckon that either the JDISDATAEXTRACTOR_003Lib.JDISDataExtractor library is the problem or there are some api calls that have not been posted.

[royUK]

I was a bit short of time this morning, but CommandBars are not supported as such, they can be viewed in the Addins Tab

[JosephP]

the shortcut menus (like Cell and Row) are commandbars and you can still create your own popup menus so they are still supported just not used for the main toolbars. ;-)

[texan22]

Sorry about the multiple posts. I'm new. I tried to put the code in a "quick reply".

I have attempted to attach a sample workbook.

[JosephP]

you have api calls in module4 which need updating. the other referenced library may also be incompatible-hard to say without having it

[texan22]

Thankyou all.
It sounds like this is "above my pay-grade". I guess I will continue to use my work-a-round until we can hire someone to fix it. I was hoping there was a simple answer.

[JosephP]

I can probably fix the apis for you-just not right this second. will try and do it after work if I have time or maybe tomorrow.

[texan22]

@JP
that would be great! Thanks

[JosephP]

replace the code in your module4 with this and let me know if you have any problems

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias _
            "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpszOp As String, _
                            ByVal lpszFile As String, ByVal lpszParams As String, _
                             ByVal lpszDir As String, ByVal FsShowCmd As Long) As LongPtr

    Private Declare Function GetDesktopWindow Lib "user32" () As LongPtr

#Else

    Private Declare Function ShellExecute Lib "shell32.dll" Alias _
                            "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As String, _
                            ByVal lpszFile As String, ByVal lpszParams As String, _
                              ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long

    Private Declare Function GetDesktopWindow Lib "user32" () As Long
#End If
Const SW_SHOWNORMAL = 1

Const SE_ERR_FNF = 2&
Const SE_ERR_PNF = 3&
Const SE_ERR_ACCESSDENIED = 5&
Const SE_ERR_OOM = 8&
Const SE_ERR_DLLNOTFOUND = 32&
Const SE_ERR_SHARE = 26&
Const SE_ERR_ASSOCINCOMPLETE = 27&
Const SE_ERR_DDETIMEOUT = 28&
Const SE_ERR_DDEFAIL = 29&
Const SE_ERR_DDEBUSY = 30&
Const SE_ERR_NOASSOC = 31&
Const ERROR_BAD_FORMAT = 11&
Function StartDoc(DocName As String)
    Dim Scr_hDC
    Scr_hDC = GetDesktopWindow()
    StartDoc = ShellExecute(Scr_hDC, "Open", DocName, _
                            "", ThisWorkbook.Path, SW_SHOWNORMAL)
End Function
Sub DEDOC()

    On Error GoTo ErrHandler

    Dim r
    Dim Msg, Style, Title

    r = StartDoc("JDIS Data Extractor.pdf")
    If r <= 32 Then
        'There was an error
        Select Case r
        Case SE_ERR_FNF
            Msg = "Acrobat file not found"
        Case SE_ERR_PNF
            Msg = "Path not found"
        Case SE_ERR_ACCESSDENIED
            Msg = "Access denied"
        Case SE_ERR_OOM
            Msg = "Out of memory"
        Case SE_ERR_DLLNOTFOUND
            Msg = "DLL not found"
        Case SE_ERR_SHARE
            Msg = "A sharing violation occurred"
        Case SE_ERR_ASSOCINCOMPLETE
            Msg = "Incomplete or invalid file association"
        Case SE_ERR_DDETIMEOUT
            Msg = "DDE Time out"
        Case SE_ERR_DDEFAIL
            Msg = "DDE transaction failed"
        Case SE_ERR_DDEBUSY
            Msg = "DDE busy"
        Case SE_ERR_NOASSOC
            Msg = "No association for file extension"
        Case ERROR_BAD_FORMAT
            Msg = "Invalid EXE file or error in EXE image"
        Case Else
            Msg = "Acrobat file open error"
        End Select
        Style = vbOKOnly
        Title = "JDIS Data Extractor Overview - Acrobat file open"
        MsgBox Msg, Style, Title
    End If

    Exit Sub


ErrHandler:

    Beep
    Msg = CStr(Err.Description)
    Style = vbOKOnly
    Title = "JDIS Data Extractor Overview - VBError"
    MsgBox Msg, Style, Title

End Sub

[texan22]

@JP
Forgive my ignorance. Here is what I did. I simply copied the new code from you and then highlighted the old code in Module4 and pasted. It appears to have replaced the old with the new. However, I'm still receiving the error

Compile error:
The code in the project must be updated for use on 64-bit systems.
Please review and updated Declare statements and then mark them with PtrSafe attribute.

[JosephP]

my bad - was tired and I missed one. replace module4 code again with this

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias _
            "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpszOp As String, _
                            ByVal lpszFile As String, ByVal lpszParams As String, _
                             ByVal lpszDir As String, ByVal FsShowCmd As Long) As LongPtr

    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr

#Else

    Private Declare Function ShellExecute Lib "shell32.dll" Alias _
                            "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As String, _
                            ByVal lpszFile As String, ByVal lpszParams As String, _
                              ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long

    Private Declare Function GetDesktopWindow Lib "user32" () As Long
#End If
Const SW_SHOWNORMAL = 1

Const SE_ERR_FNF = 2&
Const SE_ERR_PNF = 3&
Const SE_ERR_ACCESSDENIED = 5&
Const SE_ERR_OOM = 8&
Const SE_ERR_DLLNOTFOUND = 32&
Const SE_ERR_SHARE = 26&
Const SE_ERR_ASSOCINCOMPLETE = 27&
Const SE_ERR_DDETIMEOUT = 28&
Const SE_ERR_DDEFAIL = 29&
Const SE_ERR_DDEBUSY = 30&
Const SE_ERR_NOASSOC = 31&
Const ERROR_BAD_FORMAT = 11&
Function StartDoc(DocName As String)
    Dim Scr_hDC
    Scr_hDC = GetDesktopWindow()
    StartDoc = ShellExecute(Scr_hDC, "Open", DocName, _
                            "", ThisWorkbook.Path, SW_SHOWNORMAL)
End Function
Sub DEDOC()

    On Error GoTo ErrHandler

    Dim r
    Dim Msg, Style, Title

    r = StartDoc("JDIS Data Extractor.pdf")
    If r <= 32 Then
        'There was an error
        Select Case r
        Case SE_ERR_FNF
            Msg = "Acrobat file not found"
        Case SE_ERR_PNF
            Msg = "Path not found"
        Case SE_ERR_ACCESSDENIED
            Msg = "Access denied"
        Case SE_ERR_OOM
            Msg = "Out of memory"
        Case SE_ERR_DLLNOTFOUND
            Msg = "DLL not found"
        Case SE_ERR_SHARE
            Msg = "A sharing violation occurred"
        Case SE_ERR_ASSOCINCOMPLETE
            Msg = "Incomplete or invalid file association"
        Case SE_ERR_DDETIMEOUT
            Msg = "DDE Time out"
        Case SE_ERR_DDEFAIL
            Msg = "DDE transaction failed"
        Case SE_ERR_DDEBUSY
            Msg = "DDE busy"
        Case SE_ERR_NOASSOC
            Msg = "No association for file extension"
        Case ERROR_BAD_FORMAT
            Msg = "Invalid EXE file or error in EXE image"
        Case Else
            Msg = "Acrobat file open error"
        End Select
        Style = vbOKOnly
        Title = "JDIS Data Extractor Overview - Acrobat file open"
        MsgBox Msg, Style, Title
    End If

    Exit Sub


ErrHandler:

    Beep
    Msg = CStr(Err.Description)
    Style = vbOKOnly
    Title = "JDIS Data Extractor Overview - VBError"
    MsgBox Msg, Style, Title

End Sub

[texan22]

@JP
one more thing. This line was highlighted in the ExtractDetail (Code):
Dim ObjJDDE As JDISDATAEXTRACTOR_003Lib.JDISDataExtractor

---------- Post added at 09:44 AM ---------- Previous post was at 09:35 AM ----------

MISSING: Registration Manipulation Classes
MISSING: JDIS Data Extractor Type Library 3.0

[texan22]

@JP
I really appreciate your help.

Ok. I closed and reopened the workbook. In Excel 2003, from the menu at the top, I would go to DATA>JDIS DATA EXTRACTOR>IMPORT EXTRACT FILES(Ctrl+M). From there I could give it the directory location in the JDIS Database. Since I don't have that option in Excel 2010, I tried to Ctrl+M (i presume that is the shortcut) and Now I have a new error.

Compile error:
Can't find project or library

I suspect that it is trying to find the database file?

[JosephP]

your buttons should be on the addins tab.

open the vb editor and check tools-references to see if any are listed as MISSING:

[JosephP]

either you are missing some programs on your machine now or you need to try and find the new location of the .dll files in use. the references dialog should tell you the name of the dll files and you can search for them on your pc (make sure to search in hidden and system folders too). if you can't find them you will probably need to talk to your tech support team.

[texan22]

either you are missing some programs on your machine now or you need to try and find the new location of the .dll files in use. the references dialog should tell you the name of the dll files and you can search for them on your pc (make sure to search in hidden and system folders too). if you can't find them you will probably need to talk to your tech support team.

That sounds managable. I will check into that.
Thanks JP!