by Amzad Ali Khan (1 Submission)
Category: Windows System Services
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Wed 27th June 2001
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
To create and config the System Dsn Through the Program.
VBcoders
'as commandline argument
Attribute VB_Name = "modDsn"
Option Explicit
'---------------------------------------------------------------------------------
'Module : ModDsn
'WrittenBy : Amzad Ali Khan
'Written on : June 1st 01
'---------------------------------------------------------------------------------
'Constants For fileSearch Function
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260
'constants for SqlConfigDsn Function
Private Const ODBC_ADD_SYS_DSN = 4 ' Add data source
Private Const ODBC_CONFIG_DSN = 2 ' Configure (edit) data source
Private Const ODBC_REMOVE_SYS_DSN = 6 ' Remove data source
Private Const vbAPINull As Long = 0 ' NULL Pointer
'Type decleration for FileTime
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'type decleration for win32data
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Sub PathStripPath Lib "shlwapi.dll" Alias "PathStripPathA" (ByVal pszPath As String)
Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Integer, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
'main Function must be called by external Application
Sub Main()
'------------------------------------------------------------------------
Dim cmd As String
Dim filename As String
Dim dsnflag As String
Dim pos As String
Dim retval As Long
'------------------------------------------------------------------------
cmd = Command() 'command line arguments (filename(without extention,type(add or remove))
'MsgBox cmd
'cmd = "c:\amz\work\ch17031ao ,add"
If cmd = "" Then
MsgBox "!!Sorry You Can't Config The Dsn Without Arguments " + vbCrLf + "First Arg : DataBase Name (fullpath without extension)" + vbCrLf + "Second Arg : Method (add or remove)" + vbCrLf + "Seperated by comma", vbOKOnly, "Config Dsn"
Exit Sub
End If
pos = InStr(1, cmd, ",", vbTextCompare)
filename = Trim(Mid(cmd, 1, pos - 1))
If (filename = "") Then
MsgBox "with out Filename How Can I create A Dsn !? "
Exit Sub
End If
If Not FileExists(filename) Then
MsgBox "File " & filename & "Not Found "
Exit Sub
End If
dsnflag = UCase(Trim(Right(cmd, Len(cmd) - pos)))
If (dsnflag = "") Then
MsgBox "you Must Specify Weather To Remove Or Add A Dsn !"
Exit Sub
End If
If dsnflag = "ADD" Then
retval = dsnAdd(filename)
If Not retval Then
MsgBox "Unable to Create Dsn"
End If
Else
If (dsnflag = "REMOVE") Then
retval = dsnRemove(filename)
If Not retval Then
MsgBox "Unable to Remove Dsn probably there is no Dsn Exists"
End If
End If
End If
End Sub
'-----------------------------------------------------------------------------------------------------
'function : fileExists
'purpose : checks the file is exists . this is to check weather mdb exists or not
'-----------------------------------------------------------------------------------------------------
Private Function FileExists(ByVal source As String) As Boolean
'this is to test if a file exists
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long
source = source + ".mdb"
hFile = FindFirstFile(source, WFD)
FileExists = hFile <> INVALID_HANDLE_VALUE
Call FindClose(hFile)
End Function
Private Function initDrv(ByRef strattributes As String, ByRef strdriver As String, ByVal dbName As String)
Dim rootfile As String
rootfile = dbName
PathStripPath (rootfile)
dbName = dbName + ".mdb"
strdriver = "microsoft Access driver (*.mdb)"
strattributes = strattributes & "DESCRIPTION= " & rootfile & Chr$(0)
'MsgBox strAttributes
strattributes = strattributes & "DSN=" & rootfile & Chr$(0)
'MsgBox strAttributes
strattributes = strattributes & "UID=" & Chr$(0)
strattributes = strattributes & "PWD=" & Chr$(0)
strattributes = strattributes & "DBQ=" & dbName & Chr$(0)
End Function
Private Function dsnAdd(ByVal filename As String) As Boolean
Dim intret As Long
Dim strdriver As String
Dim strattributes As String
Dim mdb As String
'mdb = "c:\amz\sample"
Call initDrv(strattributes, strdriver, filename)
'To show dialog, use Form1.Hwnd instead of vbAPINull.
intret = SQLConfigDataSource(vbAPINull, ODBC_ADD_SYS_DSN, _
strdriver, strattributes)
dsnAdd = intret
End Function
Private Function dsnRemove(ByVal filename As String) As Boolean
Dim intret As Long
Dim strdriver As String
Dim strattributes As String
Dim mdb As String
'mdb = "c:\amz\sample"
Call initDrv(strattributes, strdriver, filename)
'To show dialog, use Form1.Hwnd instead of vbAPINull.
intret = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_SYS_DSN, _
strdriver, strattributes)
dsnRemove = intret
End Function
