Làm sao tạo sub public làm sub connect

Liên hệ QC

phuoclocvl

Thành viên thường trực
Tham gia
28/3/12
Bài viết
220
Được thích
32
Chào các Anh Chị,
Thay vì mối sub đều phải gắn đoạn bên dưới để connect tới server có cách nào tạo 1 sub riêng để mình call ở các sub khác không ạ. Xin cảm ơn,

Dim Db As New Connection
Db.CursorLocation = adUseClient
If Db.State = 1 Then Db.Close
Db.Open "Provider =IBMDASQL.DataSource.1" & _
";Catalog Library List=JDETSTDTA" & _
";Persist Security Info=True" & _
";Force Translate=0" & _
";Data Source =" & Host_Server & _
";User ID = " & Uname & "" & _
";Password = " & Upass
 
Function abc_xxx(byval Host_Server as string, byval Uname as string, byval Upass as string) as object
' code tren
' them dong nay
Set abc_xxx = Db
End function
 
Function abc_xxx(byval Host_Server as string, byval Uname as string, byval Upass as string) as object
' code tren
' them dong nay
Set abc_xxx = Db
End function
Anh cho em hỏi thêm tí

vậy trong sub này sẽ gán như thế nào ạ?

Cảm ơn anh.
Public Sub Load_MO()
Dim i As Integer
Dim adors As New Recordset
Dim Db As New Connection
Dim cmdtxt As String
Dim sh As Worksheet
'------------------------------
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
Set sh = ThisWorkbook.Sheets("Sheet1")

Set Db = New Connection
Db.CursorLocation = adUseClient
If Db.State = 1 Then Db.Close
Db.Open "Provider =IBMDASQL.DataSource.1" & _
";Catalog Library List=JDETSTDTA" & _
";Persist Security Info=True" & _
";Force Translate=0" & _
";Data Source =" & Host_Server & _
";User ID =" & Uname & "" & _
";Password =" & Upass

Set adors = New Recordset
If adors.State = 1 Then adors.Close

cmdtxt = "SELECT A.ORDNO, A.REFNO, (A.ORQTY+A.QTDEV) AS ORDQTY, A.ODUDT, A.FDESC, A.FITEM, A.ITCL, B.CITEM,B.QTREQ, B.UNMSR, B.CDESC, B.FLSTK,B.USRSQ " & _
"FROM G20ACF9V.AMFLIBW.MOMAST A , AMFLIBW.MODATA B " & _
"WHERE A.ODUDT BETWEEN '1200311' AND '1200312' AND A.STID IN ('31') AND A.ORDNO=B.ORDNO AND substr(A.REFNO,1,2) in ('MM','MB')"

adors.Open cmdtxt, Db, 3, 3

For i = 0 To adors.Fields.Count - 1
sh.Cells(1, i + 1) = adors.Fields(i).Name
Next i

sh.Range("A2").CopyFromRecordset adors
adors.Close

Set adors = Nothing
'------------------------------------------------
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
'------------------------------------------------

End Sub
 
Lần chỉnh sửa cuối:
Anh cho em hỏi thêm tí

vậy trong sub này sẽ rán như thế nào ạ?

Cảm ơn anh.
Thì rán bình thường thôi. Nhưng nhớ là code trước đó tẩm gia vị và để chừng 30 phút, và để chảo nóng hẳn mới cho dầu vào, và rắc chút muối.
 
Thì rán bình thường thôi. Nhưng nhớ là code trước đó tẩm gia vị và để chừng 30 phút, và để chảo nóng hẳn mới cho dầu vào, và rắc chút muối.
Mình không biết mới hỏi, bác cứ đùa hoài. Sai chính tả xíu á mà hihi. Chỉ giúp với bác. Cảm ơn nhiều ạ,
 
Mình không biết mới hỏi, bác cứ đùa hoài. Sai chính tả xíu á mà hihi. Chỉ giúp với bác. Cảm ơn nhiều ạ,
Nếu tôi hiểu ý thì code ở dưới.
Lưu ý: tôi không phân tích code của bạn, coi như bạn đã test và chạy thành công. Tôi chỉ giúp sửa để gọi nhiều lần - sub hichic. Mỗi lần gọi hichic thì nhập server, uname, upass và tham chiếu ô đầu tiên của dòng tiêu đề.

Mã:
Private Sub ConnectAndRead(ByVal Host_Server As String, ByVal Uname As String, ByVal Upass As String, ByVal firstCell As Range)
Dim i As Integer
Dim adors As Recordset
Dim Db As Connection
Dim cmdtxt As String
'------------------------------
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual

Set Db = New Connection
Db.CursorLocation = adUseClient
If Db.State = 1 Then Db.Close
Db.Open "Provider =IBMDASQL.DataSource.1" & _
";Catalog Library List=JDETSTDTA" & _
";Persist Security Info=True" & _
";Force Translate=0" & _
";Data Source =" & Host_Server & _
";User ID =" & Uname & "" & _
";Password =" & Upass

Set adors = New Recordset
If adors.State = 1 Then adors.Close

cmdtxt = "SELECT A.ORDNO, A.REFNO, (A.ORQTY+A.QTDEV) AS ORDQTY, A.ODUDT, A.FDESC, A.FITEM, A.ITCL, B.CITEM,B.QTREQ, B.UNMSR, B.CDESC, B.FLSTK,B.USRSQ " & _
"FROM G20ACF9V.AMFLIBW.MOMAST A , AMFLIBW.MODATA B " & _
"WHERE A.ODUDT BETWEEN '1200311' AND '1200312' AND A.STID IN ('31') AND A.ORDNO=B.ORDNO AND substr(A.REFNO,1,2) in ('MM','MB')"

adors.Open cmdtxt, Db, 3, 3

For i = 0 To adors.Fields.Count - 1
firstCell.Offset(0, i).Value = adors.Fields(i).Name
Next i

firstCell.Offset(1).CopyFromRecordset adors
adors.Close

Set adors = Nothing
'------------------------------------------------
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
'------------------------------------------------

End Sub

'    ví dụ về cách dùng, cách gọi
Public Sub hichic()
    ConnectAndRead "Ten Server", "Ten", "Mat khau", ThisWorkbook.Worksheets("Sheet1").Range("A1")
End Sub
 
Chào các Anh Chị,
Thay vì mối sub đều phải gắn đoạn bên dưới để connect tới server có cách nào tạo 1 sub riêng để mình call ở các sub khác không ạ. Xin cảm ơn,

Dim Db As New Connection
Db.CursorLocation = adUseClient
If Db.State = 1 Then Db.Close
Db.Open "Provider =IBMDASQL.DataSource.1" & _
";Catalog Library List=JDETSTDTA" & _
";Persist Security Info=True" & _
";Force Translate=0" & _
";Data Source =" & Host_Server & _
";User ID = " & Uname & "" & _
";Password = " & Upass

Lúc trước thấy bạn có post bài tương tự và cũng có hướng dẫn mà bạn loay hoay tới giờ chưa ra.
Giờ tôi demo luôn cho bạn các thủ tục, hàm để kết nối. Đây là cái class tôi viết để kết nối tới 3 loại CSDL nhưng do khả năng VBA của bạn cũng như trên nền Excel nên tôi chỉnh sửa, bỏ bớt những thứ không chạy được cũng như chưa cần đối với bạn.

Đây là code cho nút lệnh "Load_MO" của bạn:
Mã:
Public Sub Load_MO()

    On Error GoTo EH

    'Gán tham so ket noi cho bién toàn cuc
    mServerName = Worksheets("LoginInfo").Range("B2").Value2
    mDatabaseName = Worksheets("LoginInfo").Range("B3").Value2
    mUserName = Worksheets("LoginInfo").Range("B4").Value2
    mPassword = Worksheets("LoginInfo").Range("B5").Value2


    Dim adors As Object
    Dim cmdtxt As String
    Dim sh As Worksheet
    
    '------------------------------
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlManual

    Set sh = ThisWorkbook.Sheets("Data")

    If ConnectDB(dbIBMDADB2) Then
        cmdtxt = "SELECT A.ORDNO, A.REFNO, (A.ORQTY+A.QTDEV) AS ORDQTY, A.ODUDT, A.FDESC, A.FITEM, A.ITCL, B.CITEM,B.QTREQ, B.UNMSR, B.CDESC, B.FLSTK,B.USRSQ " & _
                 "FROM G20ACF9V.AMFLIBW.MOMAST A , AMFLIBW.MODATA B " & _
                 "WHERE A.ODUDT BETWEEN '1200311' AND '1200312' AND A.STID IN ('31') AND A.ORDNO=B.ORDNO AND substr(A.REFNO,1,2) in ('MM','MB')"
        Set adors = GetADORecordset(cmdtxt, EditAddDelete)

        Dim i As Integer
        For i = 0 To adors.Fields.Count - 1
            sh.Cells(1, i + 1) = adors.Fields(i).Name
        Next i
        sh.Range("A2").CopyFromRecordset adors
        adors.Close
        Set adors = Nothing
    Else
        MsgBox "Có lôi kêt nói.", vbCritical, "Thông báo"
    End If

    '------------------------------------------------
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlAutomatic
    '------------------------------------------------
    
    Exit Sub

EH:
    If Err > 0 Then
        MsgBox "Có loi phat sinh." & vbCrLf & "Ma loi: " & Err.Number & vbCrLf _
             & "Noi dung: " & Err.Description, vbCritical, "Load MO"
        Exit Sub
    End If

End Sub

- Sau đây là code dùng để kết nối, lấy recordset. Bạn copy vào Module đặt tên ví dụ là "modKetNoiDB". Bạn tự chỉnh lại chuỗi kết nối tới IBMDADb2, tôi không biết chuỗi này.

Mã:
Option Explicit

Private Const adUseClient As Long = 3
Private Const adLockReadOnly As Long = 1
Private Const adStateOpen As Long = 1
Private Const adCmdStoredProc As Long = 4
Private Const adParamOutput As Long = 2
Private Const adOpenDynamic As Long = 2
Private Const adOpenStatic As Long = 3

Public Enum DBaseType
    dbSQLServer = 1
    dbAccess = 2
    dbIBMDADB2 = 3
End Enum

Public Enum EditMode
    ReadOnly = 0
    EditAddDelete = 1
End Enum

Public mServerName As String
Public mDatabaseName As String
Public mUserName As String
Public mPassword As String
Public mConnectionString As String
Public mDataBaseType As Integer

Global oConn As Object

Function ConnectDB(ByVal DBType As DBaseType) As Boolean

    On Error GoTo ConnectDBError

    Dim strConnectSQL As String
    Dim blnNewConnect As Boolean
    Dim blnReturn As Boolean

    blnReturn = True
    blnNewConnect = True
    mDataBaseType = DBType

    Call BuildConnectionString(DBType)

    If Not oConn Is Nothing Then   'Kiem tra xem có Connection chua, có rôi thi dung ket noi cu
        If oConn.State And adStateOpen = adStateOpen Then  '-> Da có ket noi
            blnNewConnect = False
        End If
    End If

    If blnNewConnect Then
        Set oConn = New ADODB.Connection
        oConn.ConnectionString = mConnectionString
        oConn.Open
    End If


ConnectDBResume:
    ConnectDB = blnReturn
    Exit Function

ConnectDBError:
    blnReturn = False

    Select Case Err.Number
    Case -2147467259
        MsgBox "Thong so ket noi Database khong dúng.", vbCritical, "Thông báo"
    Case -2147217843
        MsgBox "Sai ten dang nhap hoac mat khau.", vbCritical, "Thông báo"
    Case Else
        MsgBox "Có loi phat sinh." & vbCrLf & "Ma loi: " & Err.Number & vbCrLf _
             & "Noi dung: " & Err.Description, vbCritical, "ConnectDB"
    End Select
    Resume ConnectDBResume

End Function

Sub CloseConnectDB()

    On Error GoTo HandleError

    'Dong ket noi toi Database
    If Not oConn Is Nothing Then
        If (oConn.State And adStateOpen) = adStateOpen Then
            oConn.Close
            Set oConn = Nothing
        End If
    End If

    Exit Sub

HandleError:
    If Err > 0 Then
        MsgBox "Có loi phat sinh." & vbCrLf & "Ma loi: " & Err.Number _
             & "Noi dung: " & Err.Description, vbCritical, "CloseConnectDB"
        Exit Sub
    End If
End Sub

Sub BuildConnectionString(ByVal DataBaseType As DBaseType)

    Select Case DataBaseType
    Case 1   'SQLServer
        If Len(mUserName) Then  'Có Username/Pass dang nhap
            mConnectionString = "Network Library=DBMSSOCN;" & _
                                "PROVIDER=SQLOLEDB;DATA SOURCE=" & mServerName & _
                                ";INITIAL CATALOG=" & mDatabaseName & _
                                ";User Id=" & mUserName & ";Password=" & mPassword & ";"
        Else
            '"Provider=SQLNCLI10;"
            mConnectionString = "Network Library=DBMSSOCN;Provider=SQLOLEDB;" & _
                                "Server=" & mServerName & ";" & _
                                "Database=" & mDatabaseName & ";" & _
                                "Trusted_Connection=Yes;"
        End If

    Case 2   'MS Access
        If Len(mPassword) Then
            mConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                                "Data Source=" & mDatabaseName & ";" & _
                                "Jet OLEDB:Database Password=" & mPassword & ";"
        Else
            mConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                                "Data Source=" & mDatabaseName & _
                                ";Persist Security Info=False;"
        End If

    Case 3  'IBMDADB2
        mConnectionString = "Provider =IBMDASQL.DataSource.1" & _
                            ";Catalog Library List=" & mDatabaseName & _
                            ";Persist Security Info=True" & _
                            ";Force Translate=0" & _
                            ";Data Source =" & mServerName & _
                            ";User ID =" & mUserName & "" & _
                            ";Password =" & mPassword
    End Select

End Sub

Function GetADORecordset(sRstSQL As String, Optional EMode As EditMode = 0, Optional sSortFld As String) As Object  'ADODB.Recordset

    On Error GoTo GRError
    
    Dim oRst As Object
    
    If ConnectDB(mDataBaseType) Then
        Set oRst = CreateObject("ADODB.Recordset")
        oRst.CursorLocation = 3    'adUseClient
        oRst.Open sRstSQL, oConn, adOpenStatic, adLockOptimistic, adCmdText
        oRst.Sort = sSortFld
        Set GetADORecordset = oRst

        'Ngat ket noi Recorset voi Database - disconnect connection.
        Select Case EMode
        Case 0  'ReadOnly
            oRst.ActiveConnection = Nothing
        Case 1  'EditAddDelete
            'Khong dong connection
        End Select
    End If
    
GRResume:
    CloseConnectDB
    Exit Function

GRError:
    MsgBox "Có loi phat sinh." & vbCrLf & "Ma loi: " & Err.Number & vbCrLf _
             & "Noi dung: " & Err.Description, vbCritical, "GetADORecordset"
    Resume GRResume
    
End Function
 

File đính kèm

  • ConnectServerIBM.xlsm
    36.5 KB · Đọc: 18
Lúc trước thấy bạn có post bài tương tự và cũng có hướng dẫn mà bạn loay hoay tới giờ chưa ra.
Giờ tôi demo luôn cho bạn các thủ tục, hàm để kết nối. Đây là cái class tôi viết để kết nối tới 3 loại CSDL nhưng do khả năng VBA của bạn cũng như trên nền Excel nên tôi chỉnh sửa, bỏ bớt những thứ không chạy được cũng như chưa cần đối với bạn.

Đây là code cho nút lệnh "Load_MO" của bạn:
Mã:
Public Sub Load_MO()

    On Error GoTo EH

    'Gán tham so ket noi cho bién toàn cuc
    mServerName = Worksheets("LoginInfo").Range("B2").Value2
    mDatabaseName = Worksheets("LoginInfo").Range("B3").Value2
    mUserName = Worksheets("LoginInfo").Range("B4").Value2
    mPassword = Worksheets("LoginInfo").Range("B5").Value2


    Dim adors As Object
    Dim cmdtxt As String
    Dim sh As Worksheet
   
    '------------------------------
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlManual

    Set sh = ThisWorkbook.Sheets("Data")

    If ConnectDB(dbIBMDADB2) Then
        cmdtxt = "SELECT A.ORDNO, A.REFNO, (A.ORQTY+A.QTDEV) AS ORDQTY, A.ODUDT, A.FDESC, A.FITEM, A.ITCL, B.CITEM,B.QTREQ, B.UNMSR, B.CDESC, B.FLSTK,B.USRSQ " & _
                 "FROM G20ACF9V.AMFLIBW.MOMAST A , AMFLIBW.MODATA B " & _
                 "WHERE A.ODUDT BETWEEN '1200311' AND '1200312' AND A.STID IN ('31') AND A.ORDNO=B.ORDNO AND substr(A.REFNO,1,2) in ('MM','MB')"
        Set adors = GetADORecordset(cmdtxt, EditAddDelete)

        Dim i As Integer
        For i = 0 To adors.Fields.Count - 1
            sh.Cells(1, i + 1) = adors.Fields(i).Name
        Next i
        sh.Range("A2").CopyFromRecordset adors
        adors.Close
        Set adors = Nothing
    Else
        MsgBox "Có lôi kêt nói.", vbCritical, "Thông báo"
    End If

    '------------------------------------------------
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlAutomatic
    '------------------------------------------------
   
    Exit Sub

EH:
    If Err > 0 Then
        MsgBox "Có loi phat sinh." & vbCrLf & "Ma loi: " & Err.Number & vbCrLf _
             & "Noi dung: " & Err.Description, vbCritical, "Load MO"
        Exit Sub
    End If

End Sub

- Sau đây là code dùng để kết nối, lấy recordset. Bạn copy vào Module đặt tên ví dụ là "modKetNoiDB". Bạn tự chỉnh lại chuỗi kết nối tới IBMDADb2, tôi không biết chuỗi này.

Mã:
Option Explicit

Private Const adUseClient As Long = 3
Private Const adLockReadOnly As Long = 1
Private Const adStateOpen As Long = 1
Private Const adCmdStoredProc As Long = 4
Private Const adParamOutput As Long = 2
Private Const adOpenDynamic As Long = 2
Private Const adOpenStatic As Long = 3

Public Enum DBaseType
    dbSQLServer = 1
    dbAccess = 2
    dbIBMDADB2 = 3
End Enum

Public Enum EditMode
    ReadOnly = 0
    EditAddDelete = 1
End Enum

Public mServerName As String
Public mDatabaseName As String
Public mUserName As String
Public mPassword As String
Public mConnectionString As String
Public mDataBaseType As Integer

Global oConn As Object

Function ConnectDB(ByVal DBType As DBaseType) As Boolean

    On Error GoTo ConnectDBError

    Dim strConnectSQL As String
    Dim blnNewConnect As Boolean
    Dim blnReturn As Boolean

    blnReturn = True
    blnNewConnect = True
    mDataBaseType = DBType

    Call BuildConnectionString(DBType)

    If Not oConn Is Nothing Then   'Kiem tra xem có Connection chua, có rôi thi dung ket noi cu
        If oConn.State And adStateOpen = adStateOpen Then  '-> Da có ket noi
            blnNewConnect = False
        End If
    End If

    If blnNewConnect Then
        Set oConn = New ADODB.Connection
        oConn.ConnectionString = mConnectionString
        oConn.Open
    End If


ConnectDBResume:
    ConnectDB = blnReturn
    Exit Function

ConnectDBError:
    blnReturn = False

    Select Case Err.Number
    Case -2147467259
        MsgBox "Thong so ket noi Database khong dúng.", vbCritical, "Thông báo"
    Case -2147217843
        MsgBox "Sai ten dang nhap hoac mat khau.", vbCritical, "Thông báo"
    Case Else
        MsgBox "Có loi phat sinh." & vbCrLf & "Ma loi: " & Err.Number & vbCrLf _
             & "Noi dung: " & Err.Description, vbCritical, "ConnectDB"
    End Select
    Resume ConnectDBResume

End Function

Sub CloseConnectDB()

    On Error GoTo HandleError

    'Dong ket noi toi Database
    If Not oConn Is Nothing Then
        If (oConn.State And adStateOpen) = adStateOpen Then
            oConn.Close
            Set oConn = Nothing
        End If
    End If

    Exit Sub

HandleError:
    If Err > 0 Then
        MsgBox "Có loi phat sinh." & vbCrLf & "Ma loi: " & Err.Number _
             & "Noi dung: " & Err.Description, vbCritical, "CloseConnectDB"
        Exit Sub
    End If
End Sub

Sub BuildConnectionString(ByVal DataBaseType As DBaseType)

    Select Case DataBaseType
    Case 1   'SQLServer
        If Len(mUserName) Then  'Có Username/Pass dang nhap
            mConnectionString = "Network Library=DBMSSOCN;" & _
                                "PROVIDER=SQLOLEDB;DATA SOURCE=" & mServerName & _
                                ";INITIAL CATALOG=" & mDatabaseName & _
                                ";User Id=" & mUserName & ";Password=" & mPassword & ";"
        Else
            '"Provider=SQLNCLI10;"
            mConnectionString = "Network Library=DBMSSOCN;Provider=SQLOLEDB;" & _
                                "Server=" & mServerName & ";" & _
                                "Database=" & mDatabaseName & ";" & _
                                "Trusted_Connection=Yes;"
        End If

    Case 2   'MS Access
        If Len(mPassword) Then
            mConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                                "Data Source=" & mDatabaseName & ";" & _
                                "Jet OLEDB:Database Password=" & mPassword & ";"
        Else
            mConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                                "Data Source=" & mDatabaseName & _
                                ";Persist Security Info=False;"
        End If

    Case 3  'IBMDADB2
        mConnectionString = "Provider =IBMDASQL.DataSource.1" & _
                            ";Catalog Library List=" & mDatabaseName & _
                            ";Persist Security Info=True" & _
                            ";Force Translate=0" & _
                            ";Data Source =" & mServerName & _
                            ";User ID =" & mUserName & "" & _
                            ";Password =" & mPassword
    End Select

End Sub

Function GetADORecordset(sRstSQL As String, Optional EMode As EditMode = 0, Optional sSortFld As String) As Object  'ADODB.Recordset

    On Error GoTo GRError
   
    Dim oRst As Object
   
    If ConnectDB(mDataBaseType) Then
        Set oRst = CreateObject("ADODB.Recordset")
        oRst.CursorLocation = 3    'adUseClient
        oRst.Open sRstSQL, oConn, adOpenStatic, adLockOptimistic, adCmdText
        oRst.Sort = sSortFld
        Set GetADORecordset = oRst

        'Ngat ket noi Recorset voi Database - disconnect connection.
        Select Case EMode
        Case 0  'ReadOnly
            oRst.ActiveConnection = Nothing
        Case 1  'EditAddDelete
            'Khong dong connection
        End Select
    End If
   
GRResume:
    CloseConnectDB
    Exit Function

GRError:
    MsgBox "Có loi phat sinh." & vbCrLf & "Ma loi: " & Err.Number & vbCrLf _
             & "Noi dung: " & Err.Description, vbCritical, "GetADORecordset"
    Resume GRResume
   
End Function
Dạ cảm ơn anh nhiều, bài rất chi tiết ạ.
 
Web KT
Back
Top Bottom