Option Explicit
[green]
'Copyright Michael Mooney --mmooney512@yahoo.com--EIPSoftware
'Getting Peachtree data through DDE
'Microsoft wrote a bunch of stuff on DDE & Windows, all of their approprate copyrights
'hold true. The rest I figured out.
'Purpose: Open the dde channel, find the info, spit it back into xls and move on.
[/green]
Sub GetInvInfo()
Dim ddeChannel As String, ItemID As String, cmpName As String
Dim ctr1 As Integer, InvRows As Long
On Error GoTo std_err 'standard error handler
InvRows = NumberofRows("InventoryPriceSheet", "A", "5", 3) 'Find how many rows of Inventory Items are there
cmpName = Cells(1, 2).Value 'what's the name of the company in CELL B2
ddeChannel = Application.DDEInitiate("PeachW", cmpName) 'the name of the DDE channel
'Get New Values assumes first item is in row 5
For ctr1 = 5 To InvRows 'loop thru the Inventory Items
ItemID = Cells(ctr1, 1).Value 'Grab first Item ID
Cells(ctr1, 2).Value = _
Application.DDERequest(ddeChannel, "FILE=LINEITEM,KEY=" & ItemID & ",FIELD=NAME") 'Name of Item put in Col B
Cells(ctr1, 3).Value = _
Application.DDERequest(ddeChannel, "FILE=LINEITEM,KEY=" & ItemID & ",FIELD=ITEMCOST") 'Cost put in Col C
Cells(ctr1, 4).Value = _
Application.DDERequest(ddeChannel, "FILE=LINEITEM,KEY=" & ItemID & ",FIELD=QTYONHAND") 'Qty on Hand put in Col D
Cells(ctr1, 5).Value = _
Application.DDERequest(ddeChannel, "FILE=LINEITEM,KEY=" & ItemID & ",FIELD=PRICE") 'Price level 1 put in Col E
Cells(ctr1, 6).Value = _
Application.DDERequest(ddeChannel, "FILE=LINEITEM,KEY=" & ItemID & ",FIELD=SALESPRICE2") 'Price level 2 put in Col F
Next ctr1
Application.DDETerminate (ddeChannel) 'close the DDE Channel
Exit Sub
std_err:
Select Case Err.Number
Case 13 'Case 13 will come up if PT can't find the data files.
MsgBox "Could not find company", vbInformation, "No Company"
Case Default
MsgBox Err.Number & Chr$(13) & _
Err.Description, vbCritical, "Error in Program"
End Select
End Sub
[green]
'Copyright Michael Mooney --mmooney512@yahoo.com--EIPSoftware
'Purpose of the function is find the number of rows on a worksheet
'When searching for the last row you have the option of determing the last row
'for a particular column and starting at a particular row. How many additional
'rows to search to see if there is any additional information.
[/green]
Function NumberofRows(WorkSheetName As String, Optional ByVal ColumnLetter As String, _
Optional ByVal StartingRow As Long, Optional ByVal ConsectiveEmptyRows As Long)
On Error GoTo std_err 'standard error handler
If ColumnLetter = "" Then ColumnLetter = "A" 'if the optional values are empty
If StartingRow = 0 Then StartingRow = 1 'fill in default values
If ConsectiveEmptyRows = 0 Then ConsectiveEmptyRows = 1
Dim ctr1 As Long 'counter For..Next Loop
Dim flgEmptyRow As Boolean 'Flag indicates if the Row is empty
Dim priorWrkSht As String 'String to hold the name of the worksheet
priorWrkSht = ActiveSheet.Name 'copy the active sheets name
Worksheets(WorkSheetName).Activate 'move to the worksheet you want to search
Range(ColumnLetter & StartingRow).Select 'move to default/specified cell
Selection.End(xlDown).Select 'xls function to move to last row
If ConsectiveEmptyRows > 1 Then 'if you want to find more then 1 empty cell
'to determine the last row
Do While ActiveCell.Row < 65535 'Make sure we haven't exceeded xls max row
For ctr1 = 1 To ConsectiveEmptyRows 'Loop till we find x amount of empty cells or
StartingRow = ActiveCell.Row + ctr1 'find a non empty cell
If Range(ColumnLetter & StartingRow).Value = Empty Then
flgEmptyRow = True 'flag to hold if the cell is empty
Else
flgEmptyRow = False 'flag indicates the cell is not empty
Selection.End(xlDown).Select 'xls function to move to last row
Exit For
End If
Next ctr1
If flgEmptyRow = True Then Exit Do 'uses the flag to determine whether to exit the loop
Loop
End If
Normal_Exit:
If ActiveCell.Row = 65536 Then 'Since their may be nothing on the xls worksheet
NumberofRows = 1 'xls will move to the highest possible row
Else 'give 1 as default value
NumberofRows = ActiveCell.Row
End If
Worksheets(priorWrkSht).Activate 'move back to the prior worksheet
Exit Function
std_err: 'if an error is generated I move back to the prior
Worksheets(priorWrkSht).Activate 'worksheet and just return a value of 1
NumberofRows = 1
Exit Function
End Function
