Using VB6, is it possible to get a list of all available domains in active directory?
Thanks,
Alex
Add references for ActiveDS type library, and ADO to your project.
Sub GetDomains()
Dim objRootDSE As IADs
Dim objBase As IADs
Dim path As String
Dim rsDomains As ADODB.Recordset
Dim cnADS As ADODB.Connection
Dim cmdCommand As ADODB.Command
Set objRootDSE = GetObject("LDAP://rootDSE")
path = "LDAP://" & objRootDSE.Get("rootDomainNamingContext")
Set objBase = GetObject(path)
Set cnADS = New ADODB.Connection
cnADS.Provider = "ADsDSOObject"
cnADS.Open "ADSI"
Set cmdCommand = New ADODB.Command
cmdCommand.ActiveConnection = cnADS
cmdCommand.Properties("searchScope") = ADS_SCOPE_SUBTREE
cmdCommand.CommandText = "SELECT Name, distinguishedName FROM '" & objBase.ADsPath & "' WHERE objectCategory = 'domain'"
Set rsDomains = cmdCommand.Execute
Do While rsDomains.EOF = False
List1.AddItem (rsDomains!Name)
rsDomains.MoveNext
Loop
End Sub
I have only the one domain to test this against so I hope you'll need to let me know if it gets all the domains for you. Also please note, I didn't add error handling.
Related
We have switched over to office 365 / outlook.
we have a legacy application in VB6 the was working fine with the previous version of outlook. but now we are having issues with an automated email with in VB6, that sends daily reports. Can someone tell me what is the equivalent of the following code is and what reference i need to point to?`
Dim mstrEmailTo As String 'email to addresses
Dim mstrEmailCC As String 'email cc addresses
mstrEmailTo = Text1.Text
mstrEmailCC = "TestEmail"
Dim oApp As Outlook.Application
Dim oCB As Office.CommandBar
Dim oCBTools As Office.CommandBarPopup
Dim oCBSelect As Office.CommandBarButton
Dim oInsp As Outlook.Inspector
Dim oCont As Outlook.MailItem
Set oApp = New Outlook.Application
Dim oInspLeft As Integer
Dim oContTo As String
Dim oContCC As String
Set oCont = oApp.CreateItem(olMailItem)
If mstrEmailTo <> "" Then
'objRecipients.AddMultiple mstrEmailTo, CdoTo
oCont.To = mstrEmailTo
End If
If mstrEmailCC <> "" Then
'objRecipients.AddMultiple mstrEmailCC, CdoCc
oCont.CC = mstrEmailCC
End If
'Set objNewMsg.Recipients = mobjSession.AddressBook(objRecipients, "Select recipients for the Daily report ...", , True, 2)
Set oInsp = oCont.GetInspector
oInsp.Display vbModeless
oInsp.WindowState = olNormalWindow
oInspLeft = oInsp.Left
oInsp.Left = -10000 'Set the Inspector off screen.
'Set to 250 to return it to viewable location
Set oCB = oInsp.CommandBars("Menu Bar")
Set oCBTools = oCB.Controls("&Tools")
Set oCBSelect = oCBTools.Controls("Address &Book...")
oCBSelect.Execute
oContTo = oCont.To
oContCC = oCont.CC
oCont.Close olDiscard
oInsp.Left = oInspLeft
Set oCont = Nothing
Set oCBSelect = Nothing
Set oCBTools = Nothing
Set oCB = Nothing
Set oApp = Nothing`
You don't need to simulate a button click to show an address book. You need to use SelectNamesDialog object for that - see https://learn.microsoft.com/en-us/office/vba/api/outlook.selectnamesdialog
How do you search for the last empty cell in an excel sheet from a vsto outlook addin?
I have the following code (not compiling)
Imports Excel = Microsoft.Office.Interop.Excel
Dim ExcelApp As New Excel.Application
Dim ExcelWorkbook As Excel.Workbook
Dim ExcelWorkSheet As Excel.Worksheet= ExcelWorkbook.Worksheets(1)
Dim ExcelRange As Excel.Range = ExcelWorkSheet.Range("A1","A600")
Dim currentFind As Excel.Range = Nothing
Dim firstFind As Excel.Range = Nothing
currentFind = ExcelRange.Find("*", , Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
While Not currentFind Is Nothing
' Keep track of the first range you find.
If firstFind Is Nothing Then
firstFind = currentFind
' If you didn't move to a new range, you are done.
ElseIf currentFind.Address = firstFind.Address Then
Exit While
End If
currentFind = ExcelRange.FindNext(currentFind)
End While
ExcelWorkbook.ActiveSheet.range(currentFind).Select()
I have updated it according to Scott Holtzman's comments but now I get an error message: HRESULT: 0x800A03EC
The code does not have the correct hierarchy according to the Object Model.
You cannot define a Range object without first defining a Worksheet object, which needs a Workbook object before it can be defined.
Try this:
Set ExcelApp = New Excel.Application
Dim ExcelWorkbook as Excel.Workbook
Set ExcelWorkbook = ExcelApp.Workbooks.Open("myPath") 'actually opens a workbook to work with
Dim ExcelWorksheet as Excel.Worksheet
Set ExcelWorksheet = ExcelWorkbook.Worksheets("mySheet")
Dim currentFind As Excel.Range = Nothing
Dim firstFind As Excel.Range = Nothing
Dim Fruits As Excel.Range = ExcelWorksheet.Range("A1", "A200")
Set currentFind = Fruits.Find("apples", , Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
...
Set currentFind = Fruits.FindNext(currentFind)
SOLVED: I have the following code (now compiling!)
Imports Excel = Microsoft.Office.Interop.Excel
Dim ExcelApp As New Excel.Application
Dim ExcelWorkbook As Excel.Workbook
Dim ExcelWorkSheet As Excel.Worksheet= ExcelWorkbook.Worksheets(1)
Dim LastRow As Integer
LastRow = ExcelWorkSheet.Columns(1).Find("*", , , , Excel.XlSearchOrder.xlByColumns, Excel.XlSearchDirection.xlPrevious).Row
ExcelWorkSheet.Range("A" & LastRow).Select()
My error was in the actual property library choice. Beware to choose:
XlSearchOrder.xlByColumns, Excel.XlSearchDirection.xlPrevious
I am developing winform application in vb6. I am using crystal report 4.6. I have created a crystal report which shows all data from a table (MS Access). And I unchecked save data with report and i saved the report. I just want to invoke it in application. So I included the component CrystalReportControl in my application. Now i want to set the records to be displayed in the report. The records are selected according to the user input to the text box.
Records are retrived from the database is done in following code.
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Private Sub Command1_Click()
Set conn = New ADODB.Connection
conn.Open "provider=Microsoft.jet.oledb.4.0;Data Source=" & App.Path &"\faculty.mdb"
Set rs = New ADODB.Recordset
rs.Open "select * from facultydetails where eid=1234", conn, adOpenDynamic, adLockPessimistic
CrystalReport1.ReportFileName = App.Path & "\faculty.rpt"
Set CrystalReport1.DataSource = rs
CrystalReport1.Action = 1
End Sub
Gives an error for the line: Set CrystalReport1.DataSource = rs :
as Property is write-only.
Tell me how the records of the report can be dynamic? Plz help me...
Instead of
Set CrystalReport1.DataSource = rs
do
CrystalReport1.DataSource = rs
EDIT:
Take a look at the following example and see if that will help you:
'CrystalReport1 is the name of the dsr file
Dim Report As New CrystalReport1
Dim cdoRowset As CrystalDataObject.CrystalComObject
Dim varArray() As Variant
'Open ADO Connection
Set m_cnAdo = New ADODB.Connection
m_cnAdo.ConnectionString = "DRIVER={SQL Server};UID=[UserID];PWD=[Password]" _
& ";SERVER=[Server];DATABASE=[Database]"
m_cnAdo.Open
Dim rsAdo As ADODB.Recordset
Dim cmdAdo As ADODB.Command
'Using Embedded Query
Set cmdAdo = New ADODB.Command
Set rsAdo = New ADODB.Recordset
cmdAdo.ActiveConnection = m_cnAdo
cmdAdo.CommandText = "SELECT * FROM Table WHERE Param = " & lngParam1
cmdAdo.CommandType = adCmdText
Set rsAdo = cmdAdo.Execute
Report.Database.SetDataSource rsAdo, 3, 1
I've been working quickly on a little script so that I can set and remove networks drives or create folders depending on a persons group membership, it doesn't seem to work and there are no error messages, could do with a second pair of eyes, I'd really appreciate it!
DIM CHS
SET CHS = CreateObject("Scripting.FileSystemObject")
SET CHSshell = CreateObject("WScript.Shell")
SET CHSnetwork = CreateObject("WScript.Network")
PRIVATE FUNCTION isMember( Group )
SET netCHS = CreateObject("WScript.Network")
Domain = netCHS.UserDomain
User = netCHS.UserName
isMember = false
SET userCHS = GetObject("WinNT://" & Domain & "/" & User & ",user")
FOR EACH Group in userCHS.Groups
IF (Group.Name = GroupName) THEN
isMember = true
EXIT FOR
END IF
NEXT
SET userCHS = NOTHING
SET netCHS = NOTHING
END FUNCTION
SET CHS = NOTHING
IF ( isMember("Domain Admins") = "True" ) THEN
CHSnetwork.RemoveNetworkDrive "z:"
WSript.Echo "CHSnetwork.UserName"
END IF
You call
isMember("Domain Admins")
The function
PRIVATE FUNCTION isMember( Group )
picks up the parameter in the name Group. But you (re/mis-)use Group in
FOR EACH Group in userCHS.Groups
to loop over the userCHS.Groups and in
IF (Group.Name = GroupName) THEN
to get the .Name to compare with GroupName. Where does GroupName come from?. Try to change the function's header to
PRIVATE FUNCTION isMember( GroupName )
and consider to use Option Explicit to avoid such mistakes.
This VBS script will show all groups the user belong to:
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Dim oNetwork: Set oNetwork = CreateObject("WScript.Network")
Dim sUserName: sUserName = oNetwork.UserDomain & "/" & oNetwork.UserName
sUserName = InputBox("Windows User Name","Enter Windows User Name", sUserName)
If sUserName <> "" Then
GetGroups
End If
Sub GetGroups
Const ADS_READONLY_SERVER = 4
Dim oGroup, oUser
Dim oShell: Set oShell = Wscript.CreateObject("WScript.Shell")
Dim sFolderPath: sFolderPath = GetFolderPath()
Dim oNS: Set oNS = GetObject("WinNT:")
Dim oList: Set oList = CreateObject("System.Collections.ArrayList")
Dim sFilePath: sFilePath = sFolderPath & "\" & Replace(Replace(sUserName,"\","-"),"/","-") & "_groups.txt"
Set oUser = oNS.OpenDSObject("WinNT://" & sUserName, "", "", ADS_READONLY_SERVER)
For Each oGroup In oUser.groups
oList.Add oGroup.Name
Next
oList.Sort()
Dim oLog: Set oLog = fso.CreateTextFile(sFilePath, True)
For Each sItem in oList
oLog.Write sItem & vbCrLf
Next
oLog.Close
oShell.Run sFilePath
End Sub
Function GetFolderPath()
Dim oFile 'As Scripting.File
Set oFile = fso.GetFile(WScript.ScriptFullName)
GetFolderPath = oFile.ParentFolder
End Function
How could we automatically/programmatically set the sender/contact image in outlook 2007? They are colleagues, and all employees pictures are stored in netshare.
I see that Outlook.ContactItem has an AddPicture method. Here's an example straight out of the help file:
Sub AddPictureToAContact()
Dim myNms As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myContactItem As Outlook.ContactItem
Dim strName As String
Dim strPath As String
Dim strPrompt As String
Set myNms = Application.GetNamespace("MAPI")
Set myFolder = myNms.GetDefaultFolder(olFolderContacts)
strName = InputBox("Type the name of the contact: ")
Set myContactItem = myFolder.Items(strName)
If myContactItem.HasPicture = True Then
strPrompt = MsgBox("The contact already has a picture associated with it. Do you want to overwrite the existing picture?", vbYesNo)
If strPrompt = vbNo Then
Exit Sub
End If
End If
strPath = InputBox("Type the file name for the contact: ")
myContactItem.AddPicture (strPath)
myContactItem.Save
myContactItem.Display
End Sub