Private Sub slExportInvoice(ByVal sFileN As String) 'Start by jiang 2002/10/11 On Error GoTo ErrHandler Dim lsCaseno As String Dim lsInvoice As String Dim lsContainer As String Dim myworkspace As Workspace Dim mydatabase As Database Dim mytable As Recordset Dim iloop As Integer Dim sFileName As String Dim sPathN As String Dim exlApp As Excel.Application Dim lRow As Long Dim lCol As Long Dim lInvRow1 As Long Dim lConRow1 As Long Dim lCasRow1 As Long
'Start by jiang 2002/10/11
On Error GoTo ErrHandler
Dim lsCaseno As String
Dim lsInvoice As String
Dim lsContainer As String
Dim myworkspace As Workspace
Dim mydatabase As Database
Dim mytable As Recordset
Dim iloop As Integer
Dim sFileName As String
Dim sPathN As String
Dim exlApp As Excel.Application
Dim lRow As Long
Dim lCol As Long
Dim lInvRow1 As Long
Dim lConRow1 As Long
Dim lCasRow1 As Long
Me.Enabled = False
Me.MousePointer = vbHourglass
lblts.Visible = True
lblts.Caption = "ﾊｾﾝﾗﾉﾖﾐ..."
DoEvents
Set myworkspace = Workspaces(0)
Set mydatabase = myworkspace.OpenDataBase(G_PATH_WMDB & "\" & GS_MDB_INVOICE_PRT)
Set mytable = mydatabase.OpenRecordset("select * from [invoice attached] order by invoice,conterner,[LOT CASE/MODULE NO],[PART NO]", dbOpenDynaset, dbReadOnly)' If Dir(G_PATH_EXPORT, vbDirectory) = "" Then 'ｼ・鯡ﾇｷ贇ﾚｵｼｳｿﾂｼ
' MkDir G_PATH_EXPORT
' End If
'
' sPathN = G_PATH_EXPORT & "\" & "Invoice "
sPathN = sFileN
Set exlApp = CreateObject("excel.application")
With exlApp
.ScreenUpdating = False
.DisplayAlerts = False
lbl_NewInvoice:
.Workbooks.Add (1)
'ﾉ靹ﾃﾁﾐｿ・
.Columns(1).ColumnWidth = 12
.Columns(2).ColumnWidth = 14
.Columns(3).ColumnWidth = 12
.Columns(4).ColumnWidth = 14
.Columns(5).ColumnWidth = 40
.Columns(6).ColumnWidth = 8
.Columns(7).ColumnWidth = 8
.Columns(8).ColumnWidth = 10
''Header
.Rows(2).HorizontalAlignment = xlCenter
'Bold
.Rows(2).Font.Size = 14
.Rows(2).Font.Bold = True
.Cells(2, 4) = "INVOICE ATTACHED LIST(PARTS)"
.Rows(4).Font.Size = 10
.Rows(4).Font.Bold = True
.Rows(4).HorizontalAlignment = xlCenter
.Cells(4, 1) = "INVOICE NO. :"
.Cells(4, 2) = "CONTAINER NO."
.Cells(4, 3) = "CASE NO."
.Cells(4, 4) = "PART NO."
.Cells(4, 5) = "DESCRIPTION OF GOODS"
.Cells(4, 6) = "Q'TY(PCS)"
.Cells(4, 7) = "UNIT PRICE"
.Cells(4, 8) = "FOB AMOUNT"
'add by tl
' .Cells(4, 1) = "INVOICE NO. :"
' .Cells(5, 1) = "CONTAINER NO."
' .Cells(6, 1) = "CASE NO."
' .Cells(6, 2) = "PART NO."
' .Cells(6, 3) = "DESCRIPTION OF GOODS"
' .Cells(6, 4) = "Q'TY(PCS)"
' .Cells(6, 5) = "UNIT PRICE"
' .Cells(6, 6) = "FOB AMOUNT"
'end
'ﾉ靹ﾃｱﾟﾏﾟ
.Cells.Select
.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With .Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.Rows("1:3").Select
.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
.Selection.Borders(xlEdgeLeft).LineStyle = xlNone
.Selection.Borders(xlEdgeTop).LineStyle = xlNone
.Selection.Borders(xlEdgeRight).LineStyle = xlNone
.Selection.Borders(xlInsideVertical).LineStyle = xlNone
.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
.Range("B9").Select
'Title
lRow = 5
lsCaseno = ""
lsContainer = ""
lsInvoice = ""
lInvRow1 = 5
lConRow1 = 5
lCasRow1 = 5
While mytable.EOF = False
.Rows(lRow).Font.Size = 10
'Invoiceｱ莉ｯ
If lsInvoice <> mytable.Fields("invoice") Then
If lsInvoice <> "" Then
.Range("A" & lInvRow1, "A" & lRow - 1).Select
.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
.Range("B" & lConRow1, "B" & lRow - 1).Select
.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
.Range("C" & lCasRow1, "C" & lRow - 1).Select
.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
sFileName = sPathN & lsInvoice
.ActiveWorkbook.SaveAs sFileName
.ActiveWorkbook.Close
GoTo lbl_NewInvoice
End If
lsInvoice = mytable.Fields("invoice")
.Cells(lRow, 1) = lsInvoice
If lRow > lInvRow1 Then
.Range("A" & lInvRow1, "A" & lRow - 1).Select
.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
lInvRow1 = lRow
End If
End If
'Container noｷ｢ﾉ﨑莉ｯ
If lsContainer <> mytable.Fields("conterner") & "" Then
lsContainer = mytable.Fields("conterner") & ""
.Cells(lRow, 2) = lsContainer
If lRow > lConRow1 Then
.Range("B" & lConRow1, "B" & lRow - 1).Select
.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
lConRow1 = lRow
End If
End If
'case noｱ莉ｯ
If lsCaseno <> mytable.Fields("LOT CASE/MODULE NO") & "" Then
lsCaseno = mytable.Fields("LOT CASE/MODULE NO") & ""
.Cells(lRow, 3) = lsCaseno
If lRow > lCasRow1 Then
.Range("C" & lCasRow1, "C" & lRow - 1).Select
.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
lCasRow1 = lRow
End If
End If
.Cells(lRow, 4) = mytable.Fields("part no")
.Cells(lRow, 5) = mytable.Fields("description of goods")
.Cells(lRow, 6) = mytable.Fields("q'ty") & ""
.Cells(lRow, 7) = mytable.Fields("unit price") & ""
.Cells(lRow, 8) = mytable.Fields("fob amount") & ""
lRow = lRow + 1
mytable.MoveNext
Wend
www.cellsoft.cc上下载