'--------------Job No 0900408 --------------'--DIM PART ONE ONLINE Update Order Qty'''主要新加過程名 RefreshOrderQty() 用于每次查詢即時更新數據源中的Lot Qty，保持與Protex的一致'-Add by Shiny Dong Imports System.IOImports Microsoft.VisualBasicImports Microsoft.Win32Imports System.Text.RegularExpressionsNamespace BogartMis.Cls Public Class gSub Private Const mSTRALL = "" '該方法是用來填充列表框的選項 Public Overloads Sub FillYYMM(ByVal cbo As ComboBox, Optional ByVal Droplist As ComboBoxStyle = ComboBoxStyle.DropDownList, Optional ByVal FirstEmpty As Boolean = True) Try With cbo Dim y As Integer Dim m As Integer .Items.Clear() .DropDownStyle = Droplist If FirstEmpty = True Then .Items.Add("") End If For y = Now.AddYears(1).Year To 2003 Step -1 For m = 12 To 1 Step -1 .Items.Add(y & "-" & IIf(m.ToString.Length = 1, "0" & m, m)) Next Next End With Catch ex As Exception End Try End Sub#Region "填充下拉選擇框的方法" Public Overloads Sub FillComboBox(ByVal cbo As ComboBox, ByVal strSQL As String, ByVal aConn As ADODB.Connection, Optional ByVal CustomValue As String = "", Optional ByVal SelectIndex As Integer = 0) Try Dim i As Integer Dim rs As New ADODB.Recordset rs.Open(strSQL, aConn, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockOptimistic) If rs.RecordCount > 0 Then cbo.Items.Clear() With cbo If CustomValue.Trim.Length > 0 Then .Items.Add(CustomValue) End If For i = 0 To rs.RecordCount - 1 .Items.Add(Trim(rs.Fields(0).Value)) rs.MoveNext() Next i If .Items.Count >= SelectIndex Then .SelectedIndex = SelectIndex End If End With End If Catch End Try End Sub Public Overloads Sub FillComboBox(ByVal cbo As ComboBox, ByVal Arrary As String(), Optional ByVal SelectIndex As Integer = 0) Try Dim value As String With cbo .Items.Clear() For Each value In Arrary .Items.Add(value) Next If .Items.Count >= SelectIndex Then .SelectedIndex = SelectIndex End If End With Catch End Try End Sub Public Overloads Sub FillComboBox(ByVal rs As ADODB.Recordset, ByVal cbo As ComboBox, Optional ByVal FieldIndex As Integer = 0, Optional ByVal AddALL As Boolean = False, Optional ByVal SelectIndex As Integer = 0) Try '將recordset的資料填充給combobox cbo.Items.Clear() If rs.RecordCount > 0 Then While Not rs.EOF If Not IsDBNull(rs.Fields(FieldIndex).Value) Then cbo.Items.Add(rs.Fields(FieldIndex).Value) End If rs.MoveNext() End While End If If AddALL = True Then cbo.Items.Insert(0, mSTRALL) End If If cbo.Items.Count >= SelectIndex Then cbo.SelectedIndex = SelectIndex End If Catch End Try End Sub Public Overloads Sub FillComboBox(ByVal netView As DataView, ByVal cbo As ComboBox, Optional ByVal ColumnsIndex As Integer = 0, Optional ByVal AddALL As Boolean = False, Optional ByVal SelectIndex As Integer = 0) Try '將recordset的資料填充給combobox cbo.Items.Clear() Dim i As Integer If netView.Count > 0 Then For i = 0 To netView.Count If Not IsDBNull(netView(i)(ColumnsIndex)) Then cbo.Items.Add(netView(i)(ColumnsIndex)) End If Next End If If AddALL = True Then cbo.Items.Insert(0, mSTRALL) End If If cbo.Items.Count >= SelectIndex Then cbo.SelectedIndex = SelectIndex End If Catch End Try End Sub#End Region#Region "填充下拉列選框的方法" '該方法是用來填充列表框的選項 Public Overloads Sub FillListbox(ByVal lstBox As ListBox, ByVal strSQL As String, ByVal aConn As ADODB.Connection, Optional ByVal SelectIndex As Integer = 0) Try Dim i As Integer Dim rs As New ADODB.Recordset rs.Open(strSQL, aConn, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockOptimistic) lstBox.Items.Clear() If rs.RecordCount > 0 Then For i = 0 To rs.RecordCount - 1 With lstBox .Items.Add(Trim(rs.Fields(0).Value)) End With rs.MoveNext() Next i End If If lstBox.Items.Count >= SelectIndex Then lstBox.SelectedIndex = SelectIndex End If Catch Exit Sub End Try End Sub '該方法是用來填充列表框的選項 Public Overloads Sub FillListbox(ByVal lstBox As ListBox, ByVal DataV As DataView, Optional ByVal ColumnsIndex As Integer = 0, Optional ByVal SelectIndex As Integer = 0) Try Dim netRow As DataRowView With lstBox .Items.Clear() For Each netRow In DataV.Table.Rows .Items.Add(Trim(netRow.Item(ColumnsIndex))) Next If lstBox.Items.Count >= SelectIndex Then lstBox.SelectedIndex = SelectIndex End If End With Catch Exit Sub End Try End Sub#End Region#Region "填充CheckListBox的方法" '該方法是用來填充check列表框的選項 Public Sub FillCheckListbox(ByVal chklistBox As CheckedListBox, ByVal strSQL As String, ByVal aConn As ADODB.Connection) Try Dim i As Integer Dim rs As New ADODB.Recordset rs.Open(strSQL, adoConn, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockOptimistic) chklistBox.Items.Clear() If rs.RecordCount > 0 Then For i = 0 To rs.RecordCount - 1 With chklistBox .Items.Add(Trim(rs.Fields(0).Value)) End With rs.MoveNext() Next i chklistBox.SelectedIndex = 0 End If Catch Exit Sub End Try End Sub#End Region '設定窗體及內部相關控件的語言類型 '隻對窗體標題及內部label,combobox,CheckBox,RadioButton控件起作用， '對其它控件無效 Public Sub setFromLanguage(ByVal frm As Form, Optional ByVal grp As GroupBox = Nothing, Optional ByVal pal As Panel = Nothing, Optional ByVal tabC As TabControl = Nothing) On Error Resume Next Dim CT As Control Dim strField As String = "*" If g.gLanguage = LanguageType.English Then strField = "eText" ElseIf g.gLanguage = LanguageType.Simple Then strField = "sText" Else strField = "tText" End If For Each CT In frm.Controls Dim strSQL As String = "select " & strField & " from " & g.gRptdev & "g_language where lower(formname)='" & frm.Name.Trim.ToLower & "' and lower(controlName)='" & CT.Name.Trim.ToLower & "'" If (TypeOf CT Is Label) Or (TypeOf CT Is Button) Or (TypeOf CT Is CheckBox) Or (TypeOf CT Is RadioButton) Or (TypeOf CT Is TextBox) Then '如此控件名存在多語言時些取相關語言 Dim strK As String = gData.selectValue(strSQL, adoConn) CT.Text = IIf(strK = "", CT.Text, strK) End If Next If Not grp Is Nothing Then For Each CT In grp.Controls Dim strSQL As String = "select " & strField & " from " & g.gRptdev & "g_language where lower(formname)='" & frm.Name.Trim.ToLower & "' and lower(controlName)='" & CT.Name.Trim.ToLower & "'" If (TypeOf CT Is Label) Or (TypeOf CT Is Button) Or (TypeOf CT Is CheckBox) Or (TypeOf CT Is RadioButton) Or (TypeOf CT Is TextBox) Or (TypeOf CT Is GroupBox) Then '如此控件名存在多語言時些取相關語言 Dim strK As String = gData.selectValue(strSQL, adoConn) CT.Text = IIf(strK = "", CT.Text, strK) End If Next End If If Not pal Is Nothing Then For Each CT In pal.Controls Dim strSQL As String = "select " & strField & " from " & g.gRptdev & "g_language where lower(formname)='" & frm.Name.Trim.ToLower & "' and lower(controlName)='" & CT.Name.Trim.ToLower & "'" If (TypeOf CT Is Label) Or (TypeOf CT Is Button) Or (TypeOf CT Is CheckBox) Or (TypeOf CT Is RadioButton) Or (TypeOf CT Is TextBox) Or (TypeOf CT Is GroupBox) Then '如此控件名存在多語言時些取相關語言 Dim strK As String = gData.selectValue(strSQL, adoConn) CT.Text = IIf(strK = "", CT.Text, strK) End If Next End If If Not tabC Is Nothing Then For Each CT In tabC.Controls Dim strSQL As String = "select " & strField & " from " & g.gRptdev & "g_language where lower(formname)='" & frm.Name.Trim.ToLower & "' and lower(controlName)='" & CT.Name.Trim.ToLower & "'" Dim strK As String = gData.selectValue(strSQL, adoConn) CT.Text = IIf(strK = "", CT.Text, strK) Dim tabP As TabPage = CType(CT, TabPage) Dim ct2 As Control For Each ct2 In tabP.Controls Dim strSQL2 As String = "select " & strField & " from " & g.gRptdev & "g_language where lower(formname)='" & frm.Name.Trim.ToLower & "' and lower(controlName)='" & ct2.Name.Trim.ToLower & "'" If (TypeOf ct2 Is Label) Or (TypeOf ct2 Is Button) Or (TypeOf ct2 Is CheckBox) Or (TypeOf ct2 Is RadioButton) Or (TypeOf ct2 Is TextBox) Or (TypeOf ct2 Is GroupBox) Then '如此控件名存在多語言時些取相關語言 Dim strK2 As String = gData.selectValue(strSQL2, adoConn) ct2.Text = IIf(strK2 = "", ct2.Text, strK2) End If Next Next End If Dim strsqlk As String = "select " & strField & " from " & g.gRptdev & "g_language where lower(formname)='" & frm.Name.Trim.ToLower & "' and lower(controlName)='me'" Dim strT As String = gData.selectValue(strsqlk, adoConn) frm.Text = IIf(strT = "", frm.Text, strT) End Sub '設定單個控件（或控件子項）的語言類型 Public Function setControlLanguage(ByVal strFormName As String, ByVal ControlName As String, Optional ByVal strDefault As String = "NoFound") As String On Error Resume Next Dim strField As String = "*" If g.gLanguage = LanguageType.English Then strField = "eText" ElseIf g.gLanguage = LanguageType.Simple Then strField = "sText" Else strField = "tText" End If Dim strSQLk As String = "select " & strField & " from " & g.gRptdev & "g_language where lower(formname)='" & strFormName.Trim.ToLower & "' and lower(controlName)='" & ControlName.ToLower & "'" Return IIf(gData.selectValue(strSQLk, adoConn) = "", strDefault, gData.selectValue(strSQLk, adoConn)) End Function '自定義的信息框，因為.net自帶的無多語言顯示功能 '該方法得結合數據庫中的g_message表的數據 Public Function myMsg(ByVal MsgId As Integer, Optional ByVal Buttons As MsgBoxStyle = MsgBoxStyle.SystemModal) As MsgBoxResult Try Dim strField As String = "*" If g.gLanguage = LanguageType.English Then strField = "msgeText" ElseIf g.gLanguage = LanguageType.Simple Then strField = "msgsText" Else strField = "msgtText" End If Dim strSQL As String = "select " & strField & " from " & g.gRptdev & "g_message where msgid=" & MsgId Dim strMsg As String = gData.selectValue(strSQL, adoConn) If strMsg.Trim.Length > 0 Then Return MsgBox(strMsg.Trim, Buttons, "MsgNo." & MsgId.ToString) Else Return MsgBox("This Message not setting!", MsgBoxStyle.Critical, "MsgNo." & "0") End If Catch ex As Exception Exit Function End Try End Function '用來設定主窗體的狀態欄中的提示信息 Public Sub setPrompt(ByVal strTxt As String) Try gMainForm.StatusBar1.Panels(0).Text = strTxt.Trim Catch ex As Exception Exit Sub End Try End Sub '根據給定的字段名，其type生成所需的where條件 'type為針對的類型，為true時顯示的為客戶資料，其它的為供應商資料 Public Overloads Function getWhere(ByVal strField As String, Optional ByVal Type As WhereType = WhereType.Customer) As String Try Dim strWhere As String Dim decAll As Integer Dim SQL_C As String = "select ekey from orfexe" Select Case Type Case WhereType.Customer decAll = gData.selectValue("select allcust from " & g.gRptdev & "g_userid where userid='" & g.gUserId & "'", adoConn) If decAll = 0 Then '如果為1的話表當前用戶擁有全部的客戶或供應商。 strWhere = "(trim(" & strField.Trim & ") is null or trim(" & strField.Trim & ") in (select info from " & g.gRptdev & "g_userpower where trim(userid)='" & g.gUserId.Trim & "' and trim(item)='customer' and curlib='" & g.gLibrary & "'))" Else strWhere = "(trim(" & strField.Trim & ") is null or trim(" & strField.Trim & ") in (" & SQL_C & "))" End If SQL_C = "select ekey from orfexe" Case WhereType.Supplier decAll = gData.selectValue("select allsupp from " & g.gRptdev & "g_userid where userid='" & g.gUserId & "'", adoConn) SQL_C = "select skey from imfexea" If decAll = 0 Then '如果為1的話表當前用戶擁有全部的客戶或供應商。 strWhere = "(trim(" & strField.Trim & ") is null or trim(" & strField.Trim & ") in (select info from " & g.gRptdev & "g_userpower where trim(userid)='" & g.gUserId.Trim & "' and trim(item)='supplier' and curlib='" & g.gLibrary & "'))" Else strWhere = "(trim(" & strField.Trim & ") is null or trim(" & strField.Trim & ") in (" & SQL_C & "))" End If Case WhereType.ColourCustomer SQL_C = "select ekey,COLOURTE from " & g.gRptdev & "g_cussv1" Dim ekeyItem As String = "" Dim netRow1 As DataRow If g.gUserDeptId.Length > 0 Then For Each netRow1 In gData.GetDataTable(SQL_C, netConn).Rows Dim netRow2 As DataRow SQL_C = "select userid from " & g.gRptdev & "g_userid where deptid like '" & g.gUserDeptId & "%'" For Each netRow2 In gData.GetDataTable(SQL_C, netConn).Rows If Regex.IsMatch("," & netRow1.Item(1), "," & netRow2.Item(0) & ",") = True Then If ekeyItem.Length > 0 Then ekeyItem = ekeyItem & ",'" & netRow1.Item(0) & "'" Else ekeyItem = "'" & netRow1.Item(0) & "'" End If Exit For End If Next Next strWhere = "(trim(" & strField.Trim & ") is null or trim(" & strField.Trim & ") in (" & IIf(ekeyItem.Trim.Length = 0, "''", ekeyItem) & "))" Else strWhere = "1=1" End If End Select Return strWhere.Trim Catch ex As Exception 'MsgBox(ex.ToString) Return "(trim(" & strField.Trim & ") is null or trim(" & strField.Trim & ") in (''))" End Try End Function '====================================================================== 'Modified by Sanlita Han on 2009-04-14 'Description: Relevant changes of Lot Year Definition. eg. 2010=K, 2011=L...... '====================================================================== Public Overloads Function getLotDate(ByVal LotField As String) As String Try Dim i As Integer Dim strW As String = "" For i = 1 To 11 Dim strT As String = "(case when substr(" & LotField & ",3,1)='" & Chr(64 + i) & "' then '" & IIf(CType(i, String).Length = 1, "0" & i, i) & "' else xx end)" If strW = "" Then strW = Replace(strT, "xx", strT) Else strW = Replace(strW, "xx", strT) End If Next strW = Replace(strW, "xx", "'12'") Dim strSQL01 As String = "" For i = 1 To 15 Dim strSQL02 As String = "(case when substr(" & LotField.Trim & ",2,1)='" & Chr(74 + i) & "' then '" & CStr(i + 9) & "' else xx end)" If strSQL01 = "" Then strSQL01 = Replace(strSQL02, "xx", strSQL02) Else strSQL01 = Replace(strSQL01, "xx", strSQL02) End If Next strSQL01 = Replace(strSQL01, "xx", "'25'") Dim strDate As String = "'20' || (case when substr(" & LotField.Trim & ",2,1) in('0','1','2','3','4','5','6','7','8','9') then '0'||substr(" & LotField.Trim & ",2,1) else " & strSQL01 & " end) || '-' || (case when substr(" & LotField.Trim & ",3,1) in('0','1','2','3','4','5','6','7','8','9')" & _ " then substr(" & LotField.Trim & ",3,2) else " & strW & " end)" Return strDate Catch ex As Exception Return "" End Try End Function Public Overloads Function getLotDateSHS(ByVal LotField As String) As String Try Dim i As Integer Dim strW As String = "" For i = 1 To 11 Dim strT As String = "(case when substr(" & LotField & ",3,1)='" & Chr(64 + i) & "' then '" & IIf(CType(i, String).Length = 1, "0" & i, i) & "' else xx end)" If strW = "" Then strW = Replace(strT, "xx", strT) Else strW = Replace(strW, "xx", strT) End If Next strW = Replace(strW, "xx", "'12'") Dim strSQL01 As String = "" For i = 1 To 15 Dim strSQL02 As String = "(case when substr(" & LotField.Trim & ",2,1)='" & Chr(64 + i) & "' then '" & IIf(i + 7 >= 10, CStr(i + 7), "0" & CStr(i + 7)) & "' else xx end)" If strSQL01 = "" Then strSQL01 = Replace(strSQL02, "xx", strSQL02) Else strSQL01 = Replace(strSQL01, "xx", strSQL02) End If Next strSQL01 = Replace(strSQL01, "xx", "'23'") Dim strDate As String = "'20' || " & strSQL01 & " || '-' || (case when substr(" & LotField.Trim & ",3,1) in('0','1','2','3','4','5','6','7','8','9')" & _ " then substr(" & LotField.Trim & ",3,2) else " & strW & " end)" Return strDate Catch ex As Exception Return "" End Try End Function '====================================================================== 'Modified by Sanlita Han on 2009-04-14 'Description: Relevant changes of Lot Year Definition. eg. 2010=K, 2011=L...... '====================================================================== Public Overloads Function DateToLot(ByVal yymm As String) As String Try If yymm.Trim.Length <> 7 Then Return "" Dim y As String = Mid(yymm, 4, 1) Dim yy As Integer = CType(Mid(yymm, 3, 2), Integer) Dim m As Integer = CType(Mid(yymm, 6, 2), Integer) If yy >= 10 Then Return Chr(64 + yy + 1) & Chr(64 + m) Else Return y & Chr(64 + m) End If Catch ex As Exception Return "" End Try End Function Public Overloads Function DateToLotSHS(ByVal yymm As String) As String Try If yymm.Trim.Length <> 7 Then Return "" If Mid(yymm, 1, 4) & Mid(yymm, 6, 2) < "200801" Then yymm = "2008-01" End If Dim y As String = Chr(IIf(CInt(Mid(yymm, 1, 4)) < 2008, 2008, CInt(Mid(yymm, 1, 4))) - 2008 + 65) Dim m As Integer = CType(Mid(yymm, 6, 2), Integer) Return y & Chr(64 + m) Catch ex As Exception Return "" End Try End Function '根據訂單號分解出此單所屬年月條件 Public Overloads Function FormatDate(ByVal fieldY As String, ByVal fieldM As String, ByVal fieldD As String) As String Try Dim strW As String = "substr(cast(date((cast(" & fieldY.Trim & " as varchar(4)) || '-' || cast(" & fieldM & " as varchar(2)) || '-' || cast(" & fieldD & " as varchar(2)))) as char(10)),3)" Return strW Catch ex As Exception Return "" End Try End Function '根據訂單號分解出此單所屬年月日時間 條件 Public Overloads Function FormatDateTime(ByVal fieldY As String, ByVal fieldM As String, ByVal fieldD As String, ByVal fieldT As String) As String Try ' fieldT = 122512 Dim strW As String = "substr(cast((cast(" & fieldY.Trim & " as varchar(4)) || '-' || cast(" & fieldM & " as varchar(2)) || '-' || cast(" & fieldD & " as varchar(2)) || '-' || cast(" & fieldT & " as varchar(10))) as char(10)),3)" Return strW Catch ex As Exception Return "" End Try End Function '根據訂單號分解出Location Public Overloads Function FormatLocation(ByVal Loc1 As String, ByVal Loc2 As String, ByVal Loc3 As String, ByVal Loc4 As String) As String Try Dim strW As String strW = " cast(" & Loc1.Trim & " as varchar(2)) || cast(" & Loc2.Trim & " as varchar(2))|| cast(" & Loc3.Trim & " as varchar(2)) || cast(" & Loc4.Trim & " as varchar(2)) " Return strW Catch ex As Exception Return "" End Try End Function '根據訂單號分解出此單所屬年月條件 Public Overloads Function FormatDate(ByVal fieldName As String) As String Try Dim strW As String strW = strW & "('" & Year(Now).ToString.Substring(0, 2) & "' || substr(cast(" & fieldName & " as varchar(6)),length(cast(" & fieldName & " as varchar(6)))-1,2) || '-' || " strW = strW & "substr(cast(" & fieldName & " as varchar(6)),length(cast(" & fieldName & " as varchar(6)))-3,2) || '-' || " strW = strW & "( case when length(cast(rmpdat as varchar(6)))-4=1 then '0' || substr(cast(rmpdat as varchar(6)),1,length(cast(rmpdat as varchar(6)))-4)" strW = strW & "else substr(cast(rmpdat as varchar(6)),1,length(cast(rmpdat as varchar(6)))-4) end)" strW = strW & ")" Return strW Catch ex As Exception Return "" End Try End Function '主要用來設定用戶的權限，針對有些用戶有權查看單價或數量，而有些用戶無權查看！ '使用方法是用在sql的select語句中 Public Overloads Function powerPrice(ByVal FieldName As String, ByVal PriceType As PriceType) As String Try If PriceType = PriceType.RMprice Then If g.gRMprice = False Then Return "'**'" Exit Function End If ElseIf PriceType = PriceType.ProductPrice Then If g.gPOprice = False Then Return "'**'" Exit Function End If Else If g.gORprice = False Then Return "'**'" Exit Function End If End If Return FieldName Catch ex As Exception Return FieldName End Try End Function '讀取注冊表中所設定的默認值 Public Function checkDefalueLayout(ByVal formname As String) As String Try Dim regK As RegistryKey Dim regSK As RegistryKey Dim regSubKEY As RegistryKey regK = Registry.CurrentUser.OpenSubKey("Bogart") regSK = regK.OpenSubKey("Layout") Dim strLayout As String = regSK.GetValue(formname) '讀取錯誤時默認發送的郵箱 If strLayout Is Nothing Then Return "" Else Return strLayout End If Catch ex As Exception Return "" End Try End Function Public Function ReplaceSize(ByVal SizeName As String) As String Try Dim rsT As New ADODB.Recordset Dim strSize As String = SizeName rsT.Open("select * from " & g.gRptdev & "g_basic where typename='size'", adoConn) Dim m As Integer If rsT.RecordCount > 0 Then For m = 0 To rsT.RecordCount - 1 strSize = Replace(strSize, rsT.Fields("info").Value, rsT.Fields("remark").Value) rsT.MoveNext() Next End If Return strSize Catch ex As Exception Return SizeName End Try End Function 'Added by SimonCheung on 2012/05/23 Public Function ReplaceFit(ByVal SizeName As String) As String Try Dim rsT As New ADODB.Recordset Dim strSize As String = SizeName rsT.Open("select * from " & g.gRptdev & "g_basic where typename='fit'", adoConn) Dim m As Integer If rsT.RecordCount > 0 Then For m = 0 To rsT.RecordCount - 1 strSize = Replace(strSize, rsT.Fields("info").Value, rsT.Fields("remark").Value) rsT.MoveNext() Next End If Return strSize Catch ex As Exception Return SizeName End Try End Function Public Function GetLocationNameByCode(ByVal code As Int16) As String Select Case code Case 0 Return "Panyu, China" Case 1 Return "Hongkong" Case 2 Return "Thailand" Case 3 Return "Shenzhen, China" Case 4 Return "Brunet International" Case Else Return "" End Select End Function Public Sub SetExcelLogoAndHeader(ByVal xAppS As Excel.Application, ByVal StrReportID As String, ByVal StrTitle As String, Optional ByVal VH As Boolean = True) Try Dim T_Logo As DataTable = gData.GetDataTable("SELECT CompanyLogo FROM CompanyProfile WHERE CompanyCode = 'Bogart'", sqlConn) If T_Logo.Rows.Count > 0 Then Dim LogoFileName As String = Application.StartupPath & "\eLogo.jpg" Dim TmpLogo As Bitmap = ChangeImageSize(CType(T_Logo.Rows(0).Item(0), Byte()), 340, 40) TmpLogo.Save(LogoFileName) With xAppS.ActiveSheet.PageSetup .PrintTitleRows = "$1:$2" .PrintTitleColumns = "" End With xAppS.ActiveSheet.PageSetup.CenterHeaderPicture.Filename = LogoFileName xAppS.ActiveSheet.PageSetup.PrintArea = "" If VH Then With xAppS.ActiveSheet.PageSetup '''橫向顯示 .LeftHeader = "Report ID: " & StrReportID & Chr(10) & "Print By: " & g.gUserId .CenterHeader = "&""Arial,Bold""&16&G" & Chr(10) & StrTitle .RightHeader = "Print Date: &D &T" & Chr(10) & "Page &P of &N" .CenterFooter = "" .RightFooter = "" .LeftMargin = xAppS.InchesToPoints(0.748031496062992) .RightMargin = xAppS.InchesToPoints(0.748031496062992) .TopMargin = xAppS.InchesToPoints(1.18110236220472) .BottomMargin = xAppS.InchesToPoints(0.984251968503937) .HeaderMargin = xAppS.InchesToPoints(0.511811023622047) .FooterMargin = xAppS.InchesToPoints(0.511811023622047) .PrintHeadings = False .PrintGridlines = False .PrintComments = -4142 .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = 2 .Draft = False .PaperSize = 1 .FirstPageNumber = -4105 .Order = 1 .BlackAndWhite = False .Zoom = 75 .PrintErrors = 0 End With Else With xAppS.ActiveSheet.PageSetup '''縱向顯示 .LeftHeader = "Report ID: " & StrReportID & Chr(10) & "Print By: " & g.gUserId .CenterHeader = "&""Arial,Bold""&16&G" & Chr(10) & StrTitle .RightHeader = "Print Date: &D &T" & Chr(10) & "Page &P of &N" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = xAppS.InchesToPoints(0.748031496062992) .RightMargin = xAppS.InchesToPoints(0.748031496062992) .TopMargin = xAppS.InchesToPoints(0.984251968503937) .BottomMargin = xAppS.InchesToPoints(0.984251968503937) .HeaderMargin = xAppS.InchesToPoints(0.511811023622047) .FooterMargin = xAppS.InchesToPoints(0.511811023622047) .PrintHeadings = False .PrintGridlines = False .PrintComments = -4142 .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = 1 .Draft = False .PaperSize = 1 .FirstPageNumber = -4015 .Order = 1 .BlackAndWhite = False .Zoom = 100 .PrintErrors = 0 End With End If End If Catch ex As Exception MsgBox(ex.ToString) End Try End Sub Public Function ChangeImageSize(ByVal byF As Byte(), Optional ByVal x_W As Int16 = 150, Optional ByVal x_H As Int16 = 150) As System.Drawing.Bitmap Try Dim ms As New IO.MemoryStream(byF) Dim imgT As New PictureBox imgT.SizeMode = PictureBoxSizeMode.AutoSize imgT.Image = Image.FromStream(ms) Dim bmp As New System.Drawing.Bitmap(x_W, x_H) Dim grp As Graphics = Graphics.FromImage(bmp) Dim blueBrush As New SolidBrush(Color.White) grp.FillRectangle(blueBrush, 0, 0, x_W, x_H) Dim intW As Single Dim intH As Single If imgT.Width > x_W Then intW = x_W intH = imgT.Height * (x_W / imgT.Width) Else intW = imgT.Width intH = imgT.Height End If If intH > x_H Then intH = x_H intW = imgT.Width * (x_H / imgT.Height) End If grp.DrawImage(imgT.Image, (x_W - intW) / 2, (x_H - intH) / 2, intW, intH) Return bmp Catch ex As Exception Return Nothing End Try End Function Public Function SetHashTable(ByVal TT As DataTable, ByVal A() As String) As DataTable Dim HastH As New Hashtable Dim TempT As New DataTable Dim II As Int16 Dim StrTemp As String For II = 0 To A.Length - 1 TempT.Columns.Add(A(II)) If II = 0 Then StrTemp = A(II) Else StrTemp += "," & A(II) End If Next Dim R As DataRow For Each R In TT.Rows Dim StrC As String = "" For II = 0 To A.Length - 1 StrC += StrTrim(R.Item(A(II))) Next If Not HastH.ContainsKey(StrC) Then HastH.Add(StrC, "") Dim RA As DataRow = TempT.NewRow RA.BeginEdit() For II = 0 To A.Length - 1 RA.Item(A(II)) = R.Item(A(II)) Next RA.EndEdit() TempT.Rows.Add(RA) End If Next Dim TempT1 As DataTable = TempT.Clone Dim TempDV As DataView = TempT.DefaultView TempDV.Sort = StrTemp For Each Rv As DataRowView In TempDV TempT1.Rows.Add(Rv.Row.ItemArray) Next Return TempT1 End Function '-----------RefershOrderQty 參數T1要處理的Table，i_LotCount 每隔多少個Lol處理一次 Public Sub RefreshOrderQty(ByRef T1 As DataTable, ByVal i_LotCount As Int16, Optional ByVal b_ck_product As Boolean = True) ''''Job 0900408 T1 Base Table , i_LotCount Page Lot to select Try Dim s_Lot As String = "" Dim HasT As DataTable = SetHashTable(T1, Split("LotNO", ",")) Dim TmpLot As New DataTable Dim b_seadata As Boolean Dim TmpLotRow As DataRow() Dim ra As DataRow() = HasT.Select("lotno like ' %' or Lotno is null or Lotno ='' ") For i As Int16 = 0 To ra.Length - 1 ra(i).Delete() Next HasT.AcceptChanges() Dim i_HasTCount As Integer = HasT.Rows.Count - 1 For i As Integer = 0 To i_HasTCount s_Lot += "'" & Convert.ToString(HasT.Rows(i).Item("Lotno")).Trim & "'" & "," If i_LotCount = s_Lot.Split(",").Length - 1 Then b_seadata = True Else If s_Lot.Split(",").Length - 1 = (i_HasTCount + 1) Mod i_LotCount And (i_HasTCount + 1 - I) <= i_LotCount Then b_seadata = True End If End If If b_seadata Then s_Lot = GetInLot(s_Lot) TmpLot = gData.GetDataTable("SELECT C.ORQ#1||'--'||P.SZ01,C.ORQ#2||'--'||P.SZ02,C.ORQ#3||'--'||P.SZ03,C.ORQ#4||'--'||P.SZ04,C.ORQ#5||'--'||P.SZ05,C.ORQ#6||'--'||P.SZ06,C.ORQ#7||'--'||P.SZ07,C.ORQ#8||'--'||P.SZ08,C.ORQ#9||'--'||P.SZ09,C.ORQ#10||'--'||P.SZ10,C.CSTORD,C1.DEG,H.CSCOMD,C.COM,C.SCLD,P.SCLS FROM PRODA201.ORFORDC C inner join PRODA201.PCFSCLC P ON P.SCL#=C.SCL# AND P.SCLS=C.SCLS INNER JOIN PRODA201.ORFLCCH H ON H.DEG=C.DEG AND H.CSTORD=C.CSTORD AND H.COM=C.COM INNER JOIN (SELECT CSTORD, MAX(DEG) DEG FROM PRODA201.ORFORDC WHERE CSTORD IN (" & s_Lot & ") GROUP BY CSTORD) C1 ON C.CSTORD = C1.CSTORD AND C.DEG = C1.DEG AND C.CSTORD IN (" & s_Lot & ") ", netConn) For ii As Int16 = 0 To s_Lot.Split(",").Length - 1 TmpLotRow = T1.Select("lotno=" & s_Lot.Split(",")(ii) & "") For ii_s As Int16 = 0 To TmpLotRow.Length - 1 If b_ck_product Then GetLotQty(TmpLot, TmpLotRow(ii_s).Item("LOTNO"), TmpLotRow(ii_s).Item("PRODUCT"), TmpLotRow(ii_s).Item("CustColor"), TmpLotRow(ii_s).Item("PRODSIZE"), TmpLotRow(ii_s).Item("PRODFIT"), TmpLotRow(ii_s)) Else GetLotQty(TmpLot, TmpLotRow(ii_s).Item("LOTNO"), "%", TmpLotRow(ii_s).Item("CustColor"), TmpLotRow(ii_s).Item("PRODSIZE"), TmpLotRow(ii_s).Item("PRODFIT"), TmpLotRow(ii_s)) End If Next Next s_Lot = "" TmpLot.Clear() b_seadata = False End If Next Catch ex As Exception MsgBox(ex.ToString) End Try End Sub Private Sub GetLotQty(ByRef T2 As DataTable, ByVal CLot As String, ByVal Product As String, ByVal Color As String, ByVal ProdSize As String, ByVal ProdFit As String, ByRef R As DataRow) Try Dim TmpR As DataRow() = T2.Select("CSTORD='" & CLot.ToUpper.Trim & "' AND DEG LIKE '" & Product.Trim.ToUpper & "%' AND CSCOMD='" & Color.ToUpper.Trim & "' and SCLD='" & ProdFit & "'") R.Item("orderqty") = 0 For I As Int16 = 0 To TmpR.Length - 1 'tmpDs.Tables(0).Rows ' 循環行數 For II As Int16 = 1 To 10 If Strings.Split(TmpR(I).Item(II - 1) & TmpR(I).Item("SCLD"), "--").Length > 1 Then If Trim(Strings.Split((TmpR(I).Item(II - 1) & TmpR(I).Item("SCLD")), "--")(1)) = ProdSize.Trim & ProdFit.Trim Then R.Item("orderqty") = Val(Trim(Strings.Split((TmpR(I).Item(II - 1) & TmpR(I).Item("SCLD")), "--")(0))) R.Item("Colcombo") = TmpR(I).Item("COM") Exit Try End If End If Next Next Catch ex As Exception MsgBox(ex.ToString) End Try End Sub Private Function GetInLot(ByVal StrF As String) Dim TmpStr As String = "'1'" If StrF.Trim.Length > 0 Then TmpStr = Strings.Left(StrF, StrF.Length - 1) End If Return TmpStr End Function Public Function StrTrim(ByVal Str As Object, Optional ByVal ReF As String = "") As String If IsDBNull(Str) Then Return ReF Else Return (Trim(Str)) End If End Function Public Sub GetGroupName(ByVal StrFT As DataTable) Try Dim T1 As DataTable = SetHashTable(StrFT, Split("product")) For Each R As DataRow In T1.Rows Dim StrSql As String = "select coll from " & g.gLibrary & ".pcfdeg where deg=(select max(deg) deg from " & g.gLibrary & ".pcfdeg where deg like '" & R("product") & "%')" Dim T2 As DataTable = gData.GetDataTable(StrSql, netConn) If T2.Rows.Count > 0 Then Dim Rs As DataRow() = StrFT.Select("product='" & R("product") & "'") For i As Int16 = 0 To Rs.Length - 1 Rs(i).Item("groupname") = T2.Rows(0).Item("coll") Next End If Next StrFT.AcceptChanges() Catch ex As Exception MsgBox(ex.ToString) End Try End Sub Public Sub GenUserInfoTmpTable() Try Dim strF As String strF = " if object_id('tempdb..#userinfo') is null " & vbCrLf strF += " begin " & vbCrLf strF += " create table #userinfo(userid varchar(20),username varchar(30)) " & vbCrLf strF += " insert into #userinfo(userid,username)values('" & g.gUserId & "','" & g.gUserName & "') " & vbCrLf strF += " end" Dim TmpComm As New OleDb.OleDbCommand(strF, sqlConn) TmpComm.ExecuteNonQuery() TmpComm.Dispose() Catch ex As Exception MsgBox(ex.ToString) End Try End Sub '處理執行SQL語句中的“單引號” Public Function GetSingleQuote(ByVal str As String) As String Try Dim i As Int16 i = str.IndexOf("'") While i > 0 str = str.Substring(0, i) & "'" & str.Substring(i) i = str.IndexOf("'", i + 2) End While Return str Catch ex As Exception MsgBox(ex.ToString) Return "~^_^~" End Try End Function End ClassEnd Namespace