DSN Module and UserName

Public Function CreateDSN(ODBCType As ODBC_TYPE, DBType As DSN_DATABASE_TYPE, pstrDSN As String, pstrDesc As String, pstrPath As String, Optional pstrSQLServer As String) As Boolean
 
  Dim lngRet As Long
  Dim strDriver As String
  Dim strAttributes As String
  Select Case DBType
    Case MICROSOFT_ACCESS
      strDriver = "Microsoft Access Driver (*.mdb)" & Chr(0)
      strAttributes = "DSN=" & pstrDSN & Chr(0)
      strAttributes = strAttributes & "Description=" & pstrDesc & Chr(0)
      strAttributes = strAttributes & "Uid=Admin" & Chr(0) & "pwd=" & Chr(0)
      strAttributes = strAttributes & "DBQ=" & pstrPath & Chr(0)
    Case MICROSOFT_SQL_SERVER
      strDriver = "SQL Server" & Chr(0)
      strAttributes = "DSN=" & pstrDSN & Chr(0)
      strAttributes = strAttributes & "Description=" & pstrDesc & Chr(0)
      strAttributes = strAttributes & "SERVER=" & pstrSQLServer & Chr(0)
      strAttributes = strAttributes & "DATABASE=" & pstrPath & Chr(0)
      strAttributes = strAttributes & "Trusted_Connection=Yes" & Chr(0)
      '"SERVER=MySQL\0ADDRESS=MyServer\0NETWORK=dbmssocn\0"
  End Select
 
  If ODBCType = ODBC_USER_DNS Then
    lngRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, strDriver, strAttributes)
  Else
    lngRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_SYS_DSN, strDriver, strAttributes)
  End If
  
  CreateDSN = (lngRet = 1)
 
End Function
Public Function ModifyDSN(ODBCType As ODBC_TYPE, DBType As DSN_DATABASE_TYPE, pstrDSN As String, pstrDesc As String, pstrPath As String, Optional pstrSQLServer As String) As Boolean
 
  Dim lngRet As Long
  Dim strDriver As String
  Dim strAttributes As String
  Select Case DBType
    Case MICROSOFT_ACCESS
      strDriver = "Microsoft Access Driver (*.mdb)" & Chr(0)
      strAttributes = "DSN=" & pstrDSN & Chr(0)
      strAttributes = strAttributes & "Description=" & pstrDesc & Chr(0)
      strAttributes = strAttributes & "Uid=Admin" & Chr(0) & "pwd=" & Chr(0)
      strAttributes = strAttributes & "DBQ=" & pstrPath & Chr(0)
    Case MICROSOFT_SQL_SERVER
      strDriver = "SQL Server" & Chr(0)
      strAttributes = "DSN=" & pstrDSN & Chr(0)
      strAttributes = strAttributes & "Description=" & pstrDesc & Chr(0)
      strAttributes = strAttributes & "SERVER=" & pstrSQLServer & Chr(0)
      strAttributes = strAttributes & "DATABASE=" & pstrPath & Chr(0)
      strAttributes = strAttributes & "Trusted_Connection=Yes" & Chr(0)
  End Select
  
  If ODBCType = ODBC_USER_DNS Then
    lngRet = SQLConfigDataSource(vbAPINull, ODBC_CONFIG_DSN, strDriver, strAttributes)
  Else
    lngRet = SQLConfigDataSource(vbAPINull, ODBC_CONFIG_SYS_DSN, strDriver, strAttributes)
  End If
  ModifyDSN = (lngRet = 1)
 
End Function
Public Function DeleteDSN(ODBCType As ODBC_TYPE, DBType As DSN_DATABASE_TYPE, pstrDSN As String) As Boolean
 
  Dim lngRet As Long
  Dim strDriver As String
  Dim strAttributes As String
  Select Case DBType
    Case MICROSOFT_ACCESS
      strDriver = "Microsoft Access Driver (*.mdb)" & Chr(0)
    Case MICROSOFT_SQL_SERVER
      strDriver = "SQL Server" & Chr(0)
  End Select
 
  strAttributes = "DSN=" & pstrDSN & Chr(0)
 
  If ODBCType = ODBC_USER_DNS Then
    lngRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, strDriver, strAttributes)
  Else
    lngRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_SYS_DSN, strDriver, strAttributes)
  End If
  DeleteDSN = (lngRet = 1)
  
End Function
Public Function DetectDSN(ODBCType As ODBC_TYPE, pstrDSNName As String) As Boolean
  Dim intRet As Integer
  Dim strDSN As String
  Dim strDriver As String
  Dim intDSNLen As Integer
  Dim intDriverLen As Integer
  Dim lngEnvHandle As Long
  Dim blnFound As Boolean
 
  blnFound = False
  pstrDSNName = Trim$(pstrDSNName)
  intRet = SQLAllocEnv(lngEnvHandle)
  strDSN = Space(1024)
  strDriver = Space(1024)
  
  If ODBCType = ODBC_USER_DNS Then
    intRet = SQLDataSources(lngEnvHandle, SQL_FETCH_FIRST_USER, strDSN, 1024, intDSNLen, strDriver, 1024, intDriverLen)
  Else
    intRet = SQLDataSources(lngEnvHandle, SQL_FETCH_FIRST_SYSTEM, strDSN, 1024, intDSNLen, strDriver, 1024, intDriverLen)
  End If
 
  If intRet = SQL_SUCCESS Then
    If Trim$(strDSN) <> "" Then
      strDSN = Mid$(strDSN, 1, intDSNLen)
      If Trim$(strDSN) = pstrDSNName Then
        blnFound = True
      End If
    End If
 
    Do Until (intRet <> SQL_SUCCESS) Or blnFound
      strDSN = Space(1024)
      strDriver = Space(1024)
      intRet = SQLDataSources(lngEnvHandle, SQL_FETCH_NEXT, strDSN, 1024, intDSNLen, strDriver, 1024, intDriverLen)
    
      If Trim$(strDSN) <> "" Then
        strDSN = Mid$(strDSN, 1, intDSNLen)
        If Trim$(strDSN) = pstrDSNName Then
          blnFound = True
        End If
      End If
    Loop
  End If
 
  intRet = SQLFreeEnv(lngEnvHandle)
  DetectDSN = blnFound
 
End Function
Private Function GetServers(Optional ServerType As SV_TYPE = SV_TYPE_ALL) As String
 'lists all servers of the specified type
 'that are visible in a domain.
 
  Dim sDomain As String
  Dim bufptr     As Long
  Dim dwEntriesread  As Long
  Dim dwTotalentries As Long
  Dim dwResumehandle As Long
  Dim se100      As SERVER_INFO_100
  Dim success     As Long
  Dim nStructSize   As Long
  Dim cnt       As Long
  Dim St       As String
  nStructSize = LenB(se100)
  
 'Call passing MAX_PREFERRED_LENGTH to have the
 'API allocate required memory for the return values.
 '
 'The call is enumerating all machines on the
 'network (SV_TYPE_ALL); however, by Or'ing
 'specific bit masks for defined types you can
 'customize the returned data. For example, a
 'value of 0x00000003 combines the bit masks for
 'SV_TYPE_WORKSTATION (0x00000001) and
 'SV_TYPE_SERVER (0x00000002).
 '
 'dwServerName must be Null. The level parameter
 '(100 here) specifies the data structure being
 'used (in this case a SERVER_INFO_100 structure).
 '
 'The domain member is passed as Null, indicating
 'machines on the primary domain are to be retrieved.
 'If you decide to use this member, pass
 'StrPtr("domain name"), not the string itself.
  success = NetServerEnum(0&, _
              100, _
              bufptr, _
              MAX_PREFERRED_LENGTH, _
              dwEntriesread, _
              dwTotalentries, _
              ServerType, _
              0&, _
              dwResumehandle)
 'if all goes well
  If success = NERR_SUCCESS And _
   success <> ERROR_MORE_DATA Then
   
  'loop through the returned data, adding each
  'machine to the list
   For cnt = 0 To dwEntriesread - 1
     
    'get one chunk of data and cast
    'into an SERVER_INFO_100 struct
    'in order to add the name to a list
     CopyMemory se100, ByVal bufptr + (nStructSize * cnt), nStructSize
      
     St = St & IIf(St = "", "", vbCrLf) & GetPointerToByteStringW(se100.sv100_name)
     
   Next
   
  End If
  
 'clean up regardless of success
  Call NetApiBufferFree(bufptr)
  
 'return entries as sign of success
  GetServers = St
End Function
Private Function GetPointerToByteStringW(ByVal dwData As Long) As String
 
  Dim tmp() As Byte
  Dim tmplen As Long
  
  If dwData <> 0 Then
  
   tmplen = lstrlenW(dwData) * 2
   
   If tmplen <> 0 Then
   
     ReDim tmp(0 To (tmplen - 1)) As Byte
     CopyMemory tmp(0), ByVal dwData, tmplen
     GetPointerToByteStringW = tmp
     
   End If
   
  End If
  
End Function
Function CurrentPrimaryDomainController() As String
  CurrentPrimaryDomainController = GetServers(SV_TYPE_DOMAIN_CTRL)
End Function
Function CurrentLogonUserName(Optional ByVal sUser As String = "") As String
  Dim sNom As String
  Dim sUserName As String
  Dim sPrenom As String
  
  On Error GoTo CurrentLogonUserName_Err
  
  If sUser = "" Then sUser = CurrentLogonUser()
  Dim MyObj As Object
  Set MyObj = GetObject("WinNT://" & CurrentPrimaryDomainController() & "/" & sUser & ",user")
  sUserName = MyObj.Fullname
  If InStr(sUserName, ",") > 0 Then
    sNom = Mid$(sUserName, 1, InStr(sUserName, ",") - 1)
    sNom = Trim$(sNom)
    sPrenom = Mid$(sUserName, InStr(sUserName, ",") + 1)
    sPrenom = Trim$(sPrenom)
    If sPrenom <> "" Then
      sUserName = sPrenom & " " & sNom
    Else
      sUserName = sNom
    End If
    sUserName = Trim$(sUserName)
  End If
CurrentLogonUserName_Err:
  If Err.Number <> 0 Then Err.Clear
  Set MyObj = Nothing
  If sUserName = "" Then sUserName = sUser
  CurrentLogonUserName = sUserName
End Function
Function CurrentLogonUser() As String
  Dim UserLoginName As String
  UserLoginName = Space(200)
  Call GetUserName(UserLoginName, 200)
  UserLoginName = Trim$(UserLoginName)
  UserLoginName = Mid$(UserLoginName, 1, Len(UserLoginName) - 1)
  CurrentLogonUser = UCase$(UserLoginName)
End Function
Function CurrentComputerName() As String
  Dim St As String
  St = Space(1024)
  Call GetComputerName(St, 1024)
  CurrentComputerName = Mid$(St, 1, InStr(St, Chr(0)) - 1)
End Function