XLSVBA02/CodeStore/index.xlsm_Module1.bas

Attribute VB_Name = "Module1"
'**************** MySQL變數 ******************
Const server_name = "ms1.tc-clothing.com"        ' 伺服器IP，127.0.0.1為目前本機
Const database_name = "clothing"  ' 連線資料庫名稱
Const user_id = "clothing"        ' 資料庫登入帳號
Const UPassword = "clo256"         ' 資料庫登入密碼
'********************************************
Public PYEAR As Integer
Public PCOMPANY As Integer
Public XLSfile As String


Public Function Cnmyopen() As ADODB.Connection
Dim conn As New ADODB.Connection
Dim connStr As String  '資料庫連線字串，其中5.3為ODBC驅動程式版本，要配合你安裝的驅動。
    connStr = "DRIVER={MariaDB ODBC 3.2 Driver}" _
                    & ";SERVER=" & server_name _
                    & ";DATABASE=" & database_name _
                    & ";UID=" & user_id _
                    & ";PWD=" & UPassword
    conn.Open connStr
Set Cnmyopen = conn
' 傳回Connection
End Function

Public Function Cnxnopen(strSQL As String, v_imex As String) As ADODB.Connection
' strSQL 寫入檔案 v_imex 1=唯讀 0=寫入
Dim conn As New ADODB.Connection
Dim connStr As String  '資料庫連線字串
    connStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Excel.ThisWorkbook.path & _
        strSQL & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=" & v_imex & ";"";"
    conn.Open connStr
Set Cnxnopen = conn
' 傳回Connection
End Function

Public Function rstCnxnopen(strXLSfile As String, strSQL As String) As ADODB.Recordset
' 開啟Excel表
Dim Cnxn As ADODB.Connection
Dim rstXLS As New ADODB.Recordset
Set Cnxn = Cnxnopen(strXLSfile, "1")
    rstXLS.Open strSQL, Cnxn, adOpenStatic, adLockOptimistic, adCmdText
Set rstCnxnopen = rstXLS
' 傳回Recordset
End Function

Public Function rstCnmyopen(Cnmy As ADODB.Connection, strSQL As String) As ADODB.Recordset
' 開啟Mysql表
Dim rstSQL As ADODB.Recordset
Set rstSQL = New ADODB.Recordset
    rstSQL.CursorLocation = 3         'mysql RecordCount連線BUG by 藍色小舖 老頑童
    rstSQL.Open strSQL, Cnmy
Set rstCnmyopen = rstSQL
' 傳回Recordset
End Function

Public Function sqlCnxnexec(strXLSfile As String, strSQL As String)
' 執行SQL
Dim cn As New ADODB.Connection
' Dim Cnxn As ADODB.Connection
' Set Cnxn = Cnxnopen(strXLSfile, "1")
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
         "Data Source=" & Excel.ThisWorkbook.path & strXLSfile & ";" & _
         "Extended Properties=""Excel 8.0;HDR=YES;IMEX=0"""
cn.Execute strSQL

End Function

Public Sub truncate_data(Cnmy As ADODB.Connection, SQLYear As Variant, SQLCompany As Variant)
' SQLYear 年度 SQLCompany 公司代碼
Dim strSQL As String
    strSQL = "delete FROM CUSTOMER where id BETWEEN " & SQLYear & SQLCompany & "0000 AND " & SQLYear & SQLCompany & "9999;"
    ' debug.print strSQL
    Cnmy.Execute strSQL     '刪除名冊
    strSQL = "delete FROM SELLUP where id BETWEEN " & SQLYear & SQLCompany & "0000 AND " & SQLYear & SQLCompany & "9999;"
    ' debug.print strSQL
    Cnmy.Execute strSQL     '刪除購買
' 清除舊資料
End Sub

Public Sub insert_data(Cnmy As ADODB.Connection, rstTBL As ADODB.Recordset, SQLYear As Variant, SQLCompany As Variant)
' 匯入名冊資料 量身尺寸
' rstTBL Excel檔案 SQLYear 年度 SQLCompany 公司
Dim sb As StringBuilder
Set sb = New StringBuilder
'====================================+
Dim p As Long                       '+
Dim diag As New ProgressDialogue    '+
'====================================+
' 建立正規表示法變數
Dim Regex As New RegExp
'===================================================================================+
p = 0                                                                              '+
diag.Configure "更新資料時間", "Now wasting your time...", 0, rstTBL.RecordCount    '+
diag.Show                                                                          '+
'===================================================================================+
    sb.Append "INSERT INTO CUSTOMER(id,regdate,company,department,seat,cus_no,cus_name,cus_sex,chest,waist,hip,leg,height,weight,trousers,tailor) VALUES "
    While Not rstTBL.EOF
        With rstTBL.Fields
            If Not IsNull(.item("c_name")) Then
                sb.Append "(" & .item("ID") & ","               'Field id
                sb.Append "'" & .item("regdate") & "',"         'Field regdate
                sb.Append "" & .item("company") & ","           'Field company
                sb.Append "" & .item("depart") & ","            'Field department
                sb.Append "" & .item("seat") & ","              'Field seat
                sb.Append "'" & .item("cus_no") & "',"          'Field cus_no
                ' 設定匹配規則
                Regex.Pattern = "[^\u4E00-\u9FA5\u3000-\u303F\uFF00-\uFFEF\u0000-\u007F\u201c-\u201d]"
                If Regex.test(.item("c_name")) Then Debug.Print .item("ID")
                sb.Append "'" & .item("c_name") & "',"          'Field cus_name
                sb.Append "" & .item("sex") & ","               'Field cus_sex
                sb.Append "" & .item("chest") & ","             'Field chest
                sb.Append "" & .item("waist") & ","             'Field waist
                sb.Append "" & .item("hip") & ","               'Field hip
                sb.Append "" & .item("leg") & ","               'Field leg
                sb.Append "" & .item("height") & ","            'Field height
                sb.Append "" & .item("weight") & ","            'Field weight
                sb.Append "" & .item("trousers") & ","          'Field trousers
                sb.Append "" & .item("tailor") & ")"           'Field tailor
            End If
        End With
        rstTBL.MoveNext
        If Not rstTBL.EOF Then sb.Append ","
'================================================+
diag.SetValue p                                 '+
diag.SetStatus "Now wasting your time... " & p  '+
p = p + 1                                       '+
'================================================+
    Wend
    ' strSQL = Left(strSQL, Len(strSQL) - 1)
' Debug.Print sb.tostring
    Cnmy.Execute sb.ToString
'============+
diag.Hide   '+
'============+
'更新服裝尺碼
    ' Application.Calculation = xlAutomatic ' 設置自動重算
    ' MsgBox "更新完成！"
End Sub

Public Sub insert_data2(Cnmy As ADODB.Connection, rstXLS As ADODB.Recordset, SQLYear As Variant, SQLCompany As Variant)
' 新增資料段2 服裝尺碼
Dim sb As StringBuilder
Set sb = New StringBuilder
Dim rstGoodsUse As New ADODB.Recordset
' Debug.Print rstXLS!itsz1,rstXLS!item1
    strSQL = "Select pno,mtmodel,mtname,mtcolor,wtmodel,wtname,wtcolor,tomeasure" & _
            " FROM GoodsUse" & _
            " WHERE corp_use=" & SQLCompany & _
            " and Depart_Use=(select department from CUSTOMER" & _
            " where id BETWEEN " & SQLYear & SQLCompany & "0000 AND " & SQLYear & SQLCompany & "9999" & _
            " limit 1)order by pno"
    rstGoodsUse.CursorLocation = 3          'mysql RecordCount連線BUG by 藍色小舖 老頑童
    rstGoodsUse.Open strSQL, Cnmy
' Debug.Print rstGoodsUse.RecordCount
    ItCount = rstGoodsUse.RecordCount       '處理項目數
    sb.Append "insert into SELLUP(id"
    For i = 1 To ItCount
        sb.Append "," & "itsz" & i & ",item" & i
    Next i
    sb.Append ") VALUES "
    '資料來源動態設定
    While Not rstXLS.EOF
        sb.Append "(" & rstXLS!ID & ","
        rstGoodsUse.MoveFirst
        i = 1
        While Not rstGoodsUse.EOF
            sb.Append "goodsid('" & rstXLS.Fields.item("itsz" & i) & "'," & IIf(rstXLS!sex, rstGoodsUse!mtmodel, rstGoodsUse!wtmodel) & ")," & _
                    rstXLS.Fields.item("item" & i)
            i = i + 1
            rstGoodsUse.MoveNext
            If Not rstGoodsUse.EOF Then sb.Append ","
        Wend
        sb.Append ")"
        rstXLS.MoveNext
        If Not rstXLS.EOF Then sb.Append ","
    Wend
    sb.Append ";"
' Debug.Print sb.tostring
    Cnmy.Execute sb.ToString
rstGoodsUse.Close
' 完成資料新增
End Sub

Public Sub XLS_init()
' debug.print Worksheets("售價").Cells(3, 11)
    PYEAR = Worksheets("售價").Cells(3, 11)
' debug.print Worksheets("售價").Cells(5, 11)
    PCOMPANY = Worksheets("售價").Cells(5, 11)
' debug.print Worksheets("售價").Cells(7, 11)
    XLSfile = Worksheets("售價").Cells(7, 11)
End Sub