I am successfully able to download the defects using the below code, but how to get the count of linked TCs with status 'Failed or Blocked' against each defect?
Sub GetDefectsByFilter()
On Error Resume Next
Dim a
Dim intIndex As Integer
Dim sngPercent As Single
Dim BugFactory, BugList, BgFilter
Dim Response As VbMsgBoxResult
Dim DefectID As String
If TDC Is Nothing Then ConnecttoQC
Set BugFactory = TDC.BugFactory
Set BgFilter = BugFactory.Filter
DefectID = frmDefectFilter.txtDefectID
BgFilter.Filter("BG_BUG_ID") = DefectID
Set BugList = BgFilter.NewList
Dim Bug, Row, Count As Integer
Count = 1
Row = 2
ActiveSheet.Cells(1, 1).Value = "Defect ID"
ActiveSheet.Cells(1, 2).Value = "Application"
ActiveSheet.Cells(1, 3).Value = "Status"
For Each Bug In BugList
ActiveSheet.Cells(Row, 1).Value = Bug.Field("BG_BUG_ID")
ActiveSheet.Cells(Row, 2).Value = Bug.Field("BG_USER_06")
ActiveSheet.Cells(Row, 3).Value = Bug.Field("BG_STATUS")
Row = Row + 1
Count = Count + 1
Next
frmDefectFilter.Hide
End Sub
Thanks #Roland. The below code snippet helped me.
Sub ViewLinks()
'------------------------------------------------------
' Output all bug links.
Dim BugF As BugFactory, bList As List
Dim aBug As Bug
Dim bugL As ILinkable, LinkList As List, linkF As LinkFactory
'tdc is the global TDConnection object.
Set BugF = tdc.BugFactory
Set bList = BugF.NewList("")
For Each aBug In bList
'Cast the Bug object to an ILinkable reference
' to get the link factory.
Set bugL = aBug
Set linkF = bugL.LinkFactory
Set LinkList = linkF.NewList("")
Dim SourceObj As Object, TargetObj As Object, InitObj As Object, lnk As Link
Debug.Print: Debug.Print "---------------------------------"
Debug.Print "Source Type"; Tab; "ID"; Tab; "Target Type"; _
Tab; "ID"; Tab; "Initiated by"
For Each lnk In LinkList
With lnk
Set SourceObj = .SourceEntity
Set TargetObj = .TargetEntity
Set InitObj = .LinkedByEntity
Debug.Print TypeName(SourceObj); Tab; CStr(SourceObj.ID); _
Tab; TypeName(TargetObj); Tab; CStr(TargetObj.ID); _
Tab; TypeName(InitObj); Spc(3); InitObj.ID
End With
Next lnk
Next aBug
End Sub
Related
Excel File Link
This is a code from an you-tube video. The below code is giving an Compiler error : Userdefined Type not defined.
Sub SendEmail(what_address As String, Subject_line As String, mail_body As String)
'Dim olApp As Outlook.Application
Set olApp = CreateObject("outlook.Application")
'Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = what_address
olMail.Subject = Subject_line
olMail.body = mial_body
olMail.send
End Sub
Sub SendMassEmail()
row_number = 1
Do
DoEvents
row_number = row_number + 1
Dim mail_body_message As String
Dim full_name As String
Dim Promoscode As String
mail_body_message = Sheet1.Range("J2")
full_name = Sheet1.Range("B" & row_number) & " " & Sheet1.Range("C" & row_number)
promo_code = Sheet1.Range("D" & row_number)
mial_body_message = Replace(mail_body_message, "replace_name_here", full_name)
Call SendEmail(Sheet1.Range("A1" & row_number), "This is a test e-mail", mail_body_message)
Loop Until row_number = 6
End Sub
I am having an compiler error, I have checked everything but...not sure what is cousing this issue.
Use the Recipients property of the MailItem class to specify the recipients instead of the To property.
The Recipients class provides the Add method which allows to create and add a new recipient to the collection. Then use the Resolve method to attempt to resolve a Recipient object against the Address Book.
Sub AssignTask()
Dim myItem As Outlook.TaskItem
Dim myDelegate As Outlook.Recipient
Set MyItem = Application.CreateItem(olTaskItem)
MyItem.Assign
Set myDelegate = MyItem.Recipients.Add("DL name")
myDelegate.Resolve
If myDelegate.Resolved Then
myItem.Subject = "Prepare Agenda For Meeting"
myItem.DueDate = Now + 30
myItem.Display
myItem.Send
End If
End Sub
I've gone nuts on this, and I'm sure the error is right in front of me, I just cant see it. appreciate all the help in debugging the statements below.
I have multiple slides in a ppt presentation. in some of the slides, there is a star shape, and a textbox with text "Hold" or "Yearly". I want to change the color of the star only if there is no textbox with "Hold" or "Yearly".
Sub Set_Star_Shape_Color_Green_Test()
Dim PPApp As Object ' As PowerPoint.Application
Dim PPPres As Object ' As PowerPoint.Presentation
Dim PPSlide As Object ' As PowerPoint.Slide
Dim iShpCnt1 As Integer
Dim iShpCnt2 As Integer
Dim iShpCnt3 As Integer
Dim iSlideCnt As Integer
Dim iBoxTopPos As Integer
Dim sHold As String
Dim sStar As String
Dim sTbox As String
Dim sTColor As String
Dim oShp As Shape
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
iShpCnt0 = PPSlide.Shapes.Count
For iShpCnt1 = 1 To iShpCnt0 'PPSlide.Shapes.Count
iBoxTopPos = 260
' iSlideCnt = 2 removed
sHold = ""
sStar = ""
iShpCnt1 = 1
For iShpCnt1 = 1 To PPSlide.Shapes.Count
If iShpCnt1 <= PPSlide.Shapes.Count Then
**Set oSh = PPApp.ActivePresentation.Slides(iSlideCnt).Shapes(iShpCnt1) ' this is where i am getting the integer out of range error**
If oSh.Name.Text Like "*Hold*" Or oSh.Name.Text Like "*Yearly*" Then
sHold = oSh.Name
End If
If oSh.Name Like "*Star*" Then
sStar = oSh.Name
End If
End If
Next
For iShpCnt2 = 1 To iShpCnt0 ' this fixed the error
Set oSh = PPApp.ActivePresentation.Slides(iSlideCnt).Shapes(iShpCnt2)
If oSh.Name Like "*Star*" And sHold = "" Then
oSh.Fill.ForeColor.RGB = RGB(50, 205, 50) ' change the color to green
End If
Next
' go to next slide
If PPSlide.SlideIndex + 1 < PPPres.Slides.Count Then
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex + 1
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex + 1)
End If
Next
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
You are setting the iterator to two.
For iSlideCnt = 1 To PPPres.Slides.Count
iBoxTopPos = 260
iSlideCnt = 2 <--- right here
It will go out of bounds if you have just one slide.
I am trying to do vlookup through the find function in vba. I have a list of numbers in loan sheet and property sheet and If the number is found in the loan sheet then it copies the entire row and pastes it in another sheet called query. This is the code I have currently but the code just hangs as I have too many cells to find around 100,000. Any guidance in any errors in the code would be really helpful.
Option Explicit
Sub FindCopy_lall()
Dim calc As Long
Dim Cel As Range
Dim LastRow As Long
Dim LastRow2 As Long
Dim rFound As Range
Dim LookRange As Range
Dim CelValue As Variant
' Speed
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Get Last row of Property SheetColumn
LastRow = Worksheets("Property").Cells(Rows.Count, "E").End(xlUp).Row
LastRow2 = Worksheets("Loan").Cells(Rows.Count, "D").End(xlUp).Row
' Set range to look in
Set LookRange = Worksheets("Property").Range("E2:E" & LastRow)
' Loop on each value (cell)
For Each Cel In LookRange
' Get value to find
CelValue = Cel.Value
' Look on IT_Asset
' With Worksheets("Loan")
' Allow not found error
On Error Resume Next
Set rFound = Worksheets("Loan").Range("D2:D" & LastRow2).Find(What:=CelValue, _
LookIn:=xlValues, _
Lookat:=xlWhole, MatchCase:=False)
' Reset
On Error GoTo endo
' Not found, go next
If rFound Is Nothing Then
GoTo nextCel
Else
Worksheets("Loan").Range("rFound:rFound").Select
Selection.Copy
Worksheets("Query").Range("Cel:Cel").Select
ActiveSheet.Paste
End If
'End With
nextCel:
Next Cel
'Reset
endo:
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
Running Find() many times in a loop can be very slow - I usually create a lookup using a Dictionary: typically thus is much faster and makes the loop easier to code.
Sub FindCopy_lall()
Dim calc As Long
Dim Cel As Range, LookRange As Range
Dim LastRow As Long
Dim LastRow2 As Long
Dim CelValue As Variant
Dim dict As Object
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
LastRow = Worksheets("Property").Cells(Rows.Count, "E").End(xlUp).Row
LastRow2 = Worksheets("Loan").Cells(Rows.Count, "D").End(xlUp).Row
Set dict = RowMap(Worksheets("Loan").Range("D2:D" & LastRow2))
Set LookRange = Worksheets("Property").Range("E2:E" & LastRow)
For Each Cel In LookRange
CelValue = Cel.Value
If dict.exists(CelValue) Then
'just copy values (5 cols, resize to suit)
Cel.Offset(0, 1).Resize(1, 5).Value = _
dict(CelValue).Offset(0, 1).Resize(1, 5).Value
'...or copy the range
'dict(CelValue).Offset(0, 1).Resize(1, 5).Copy Cel.Offset(0, 1)
End If
Next Cel
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
'map a range's values to their respective cells
Function RowMap(rng As Range) As Object
Dim rv As Object, c As Range, v
Set rv = CreateObject("scripting.dictionary")
For Each c In rng.Cells
v = c.Value
If Not rv.exists(v) Then
rv.Add v, c
Else
MsgBox "Duplicate value detected!"
Exit For
End If
Next c
Set RowMap = rv
End Function
There are many things that needs to be re-written
A) Variables inside the quotes become a string. For example "rFound:rFound" Also you do not need to specify Worksheets("Loan"). before it. It is understood.
You can simply write it as rFound.Select
B) Avoid the Use of .Select It slows down the code. You might want to see this LINK. For example
Worksheets("Loan").Range("rFound:rFound").Select
Selection.Copy
Worksheets("Query").Range("Cel:Cel").Select
ActiveSheet.Paste
The above can be written as
rFound.Copy Cel
Work with Variables/Objects. Try and ignore the use of On Error Resume Next and unnecessary GO TOs if possible.
Try this (UNTESTED)
Option Explicit
Sub FindCopy_lall()
Dim calc As Long, LrowWsI As Long, LrowWsO As Long
Dim Cel As Range, rFound As Range, LookRange As Range
Dim wsI As Worksheet, wsO As Worksheet
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set wsI = ThisWorkbook.Sheets("Property")
Set wsO = ThisWorkbook.Sheets("Loan")
LrowWsI = wsI.Range("E" & wsI.Rows.Count).End(xlUp).Row
LrowWsO = wsO.Range("D" & wsI.Rows.Count).End(xlUp).Row
Set LookRange = wsI.Range("E2:E" & LrowWsI)
For Each Cel In LookRange
Set rFound = wsO.Range("D2:D" & LrowWsO).Find(What:=Cel.Value, _
LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
If Not rFound Is Nothing Then
'~~> You original code was overwriting the cel
'~~> I am writing next to it. Chnage as applicable
rFound.Copy Cel.Offset(, 1)
End If
Next Cel
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
Besides the possible bugs the two big performance issues are
doing an Excel .Find.. inside your loop over all your source rows, which as has already been noted, is very slow. And
actually cutting and pasting a lot of rows is also pretty slow. If you only care about the values, then you can use range-array data copies instead which are very fast.
This is how I would do it, which should be very fast:
Option Explicit
Option Compare Text
Sub FindCopy_lall()
Dim calc As Long, CelValue As Variant
Dim LastRow As Long, LastRow2 As Long, r As Long, sr As Long
Dim LookRange As Range, FindRange As Range, rng As Range
Dim LastLoanCell As Range, LastLoanCol As Long
Dim rowVals() As Variant
' Speed
calc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'capture the worksheet objects
Dim wsProp As Worksheet: Set wsProp = Worksheets("Property")
Dim wsLoan As Worksheet: Set wsLoan = Worksheets("Loan")
Dim wsQury As Worksheet: Set wsQury = Worksheets("Query")
'Get Last row of Property SheetColumn
LastRow = wsProp.Cells(Rows.Count, "E").End(xlUp).Row
LastRow2 = wsLoan.Cells(Rows.Count, "D").End(xlUp).Row
Set LastLoanCell = wsLoan.Cells.SpecialCells(xlCellTypeLastCell)
LastLoanCol = LastLoanCell.Column
' Set range to look in; And get it's data
Set LookRange = wsProp.Range("E2:E" & LastRow)
Dim Look() As Variant: ReDim Look(2 To LastRow, 1 To 1)
Look = LookRange
' Index the source values
Dim colIndex As New Collection
For r = 2 To UBound(Look, 1)
' ignore duplicate key errors
On Error Resume Next
colIndex.Add r, CStr(CelValue)
On Error GoTo endo
Next
'Set the range to search; and get its data
Set FindRange = wsLoan.Range("D2:D" & LastRow2)
Dim Find() As Variant: ReDim Find(2 To LastRow2, 1 To 1)
Find = FindRange
' Loop on each value (cell) in the Find range
For r = 2 To UBound(Find, 1)
'Try to find it in the Look index
On Error Resume Next
sr = colIndex(CStr(CelValue))
If Err.Number = 0 Then
'was found in index, so copy the row
On Error GoTo endo
' pull the source row values into an array
Set rng = wsLoan.Range(wsLoan.Cells(r, 1), wsLoan.Cells(r, LastLoanCol))
ReDim rowVals(1 To rng.Rows.Count, 1 To rng.Columns.Count)
rowVals = rng
' push the values out to the target row
Set rng = wsQury.Range(wsQury.Cells(sr, 1), wsQury.Cells(sr, LastLoanCol))
rng = rowVals
End If
On Error GoTo endo
Next r
endo:
'Reset
Application.Calculation = calc
Application.ScreenUpdating = True
End Sub
As others have noted, we cannot tell from your code where the output rows are actually supposed to go on the Query sheet, so I made a guess, but you made need to change that.
Can anybody tell me how to read an Excel file in visual basic 6.0 and import all the values into a listview or datagridview,want to use a simple and efficient technique to achieve this. can anyone help me to solve this
This should import data from an Excel file into a ListView:
Dim ExcelObj As Object
Dim ExcelBook As Object
Dim ExcelSheet As Object
Dim i As Integer
Set ExcelObj = CreateObject("Excel.Application")
Set ExcelSheet = CreateObject("Excel.Sheet")
ExcelObj.WorkBooks.Open App.Path & "\ExcelFile.xls"
Set ExcelBook = ExcelObj.WorkBooks(1)
Set ExcelSheet = ExcelBook.WorkSheets(1)
Dim l As ListItem
lvwList.ListItems.Clear
With ExcelSheet
i = 1
Do Until .cells(i, 1) & "" = ""
Set l = lvwList.ListItems.Add(, , .cells(i, 1))
l.SubItems(1) = .cells(i, 2)
l.SubItems(2) = .cells(i, 3)
l.SubItems(3) = .cells(i, 4)
i = i + 1
Loop
End With
ExcelObj.WorkBooks.Close
Set ExcelSheet = Nothing
Set ExcelBook = Nothing
Set ExcelObj = Nothing
I'd be a lot more likely to use a grid control of some sort rather than a ListView for this, but...
Since you're merely bringing in values without metadata (formatting) you can use one of Jet's Excel IISAMs to do this and it even works on machines where Excel is not installed!
Dim SheetName As String
Dim RS As ADODB.Recordset
Dim LI As ListItem
Dim I As Integer
'Look up 1st Worksheet (or just hardcode its Name).
'
'Notes:
' o Can use Excel 8.0 or Excel 5.0 to read most Excel 7.0/97
' Workbooks, but there is no IISAM specifically for Excel 7.0.
' o Use HDR=Yes if your Worksheet has a header row.
With CreateObject("ADOX.Catalog")
.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" _
& App.Path & "\sample.xls';" _
& "Extended Properties='Excel 5.0;HDR=No'"
SheetName = .Tables(0).Name
Set RS = New ADODB.Recordset
Set RS.ActiveConnection = .ActiveConnection
End With
'The "Table" name can be a range too, e.g. [Sheet1$A1C7]
With RS
.Open "[" & SheetName & "]", _
, _
adOpenForwardOnly, _
adLockReadOnly, _
adCmdTable
ListView.ListItems.Clear
ListView.View = lvwReport
For I = 0 To .Fields.Count - 1
ListView.ColumnHeaders.Add , , .Fields(I).Name
Next
Do Until .EOF
Set LI = ListView.ListItems.Add(, , CStr(.Fields(0).Value))
For I = 1 To .Fields.Count - 1
LI.SubItems(I) = CStr(.Fields(I).Value)
Next
.MoveNext
Loop
.Close
End With
I'm working on an Outlook add-in that requires the Office specific FileDialog to interoperate with a Sharepoint site; the common file dialog doesn't have the interoperability. I know that both Word and Excel have a get_fileDialog method under Globals.ThisAddIn.Application.Application, but Outlook doesn't seem to. How do I launch an Outlook FileDialog? Is it even possible?
Microsoft Common Dialog
If you have COMDLG32.OCX ("Common Dialog ActiveX Control") installed, then you can use this - it's explained here, with an example. (Scroll down just past the screenshot entitled "FIGURE 2: Don't try to select more than one file in Word! ").
It appears that Outlook's Application object does not offer FileDialog. But a simple workaround, if you are willing to have an Excel reference, is:
Dim fd As FileDialog
Set fd = Excel.Application.FileDialog(msoFileDialogFolderPicker)
Dim folder As Variant
If fd.Show = -1 Then
For Each folder In fd.SelectedItems
Debug.Print "Folder:" & folder & "."
Next
End If
'Add a "Module". Then add the declarations like this to it.
Option Explicit
Private Declare Function GetOpenFileName _
Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Function MyOpenFiledialog() As String
Dim OFName As OPENFILENAME
OFName.lStructSize = Len(OFName)
'Set the parent window
OFName.hwndOwner = Application.hWnd
'Set the application's instance
OFName.hInstance = Application.hInstance
'Select a filter
OFName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
'create a buffer for the file
OFName.lpstrFile = Space$(254)
'set the maximum length of a returned file
OFName.nMaxFile = 255
'Create a buffer for the file title
OFName.lpstrFileTitle = Space$(254)
'Set the maximum length of a returned file title
OFName.nMaxFileTitle = 255
'Set the initial directory
OFName.lpstrInitialDir = "C:\"
'Set the title
OFName.lpstrTitle = "Open File - VB Forums.com"
'No flags
OFName.flags = 0
'Show the 'Open File'-dialog
If GetOpenFileName(OFName) Then
MsgBox "File to Open: " + Trim$(OFName.lpstrFile)
MyOpenFiledialog = Trim$(OFName.lpstrFile)
Else
MsgBox "Cancel was pressed"
MyOpenFiledialog = vbNullString
End If
End Sub 'Usage:
Private Sub Command1_Click()
Text1.Text = MyOpenFiledialog
End Sub
Public Sub TestFileDialog()
Dim otherObject As Excel.Application
Dim fdFolder As office.FileDialog
Set otherObject = New Excel.Application
otherObject.Visible = False
Set fdFolder = otherObject.Application.FileDialog(msoFileDialogFolderPicker)
fdFolder.Show
Debug.Print fdFolder.SelectedItems(1)
otherObject.Quit
Set otherObject = Nothing
End Sub
Private Sub multiEML2MSG()
Const PR_ICON_INDEX = &H10800003
Dim objPost As Outlook.PostItem
Dim objSafePost As Redemption.SafePostItem
Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
Set objNS = Outlook.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objPost = objInbox.Items.Add(OlItemType.olPostItem)
Set objSafePost = New Redemption.SafePostItem
Dim xlObj As Excel.Application
Dim fd As Office.FileDialog
Set xlObj = New Excel.Application
Set fd = xlObj.Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select your PST File"
.ButtonName = "Ok"
.Show
If fd.SelectedItems.Count <> 0 Then
xDirect$ = fd.SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
licznik = 1
Do While xFname$ <> ""
XPathEML = xDirect$ & xFname$
XPathMSG = Replace(XPathEML, ".eml", ".msg", , , vbTextCompare)
Debug.Print XPath, Replace(XPath, ".eml", ".msg", , , vbTextCompare)
objPost.Save
objSafePost.Item = objPost
objSafePost.Import XPathEML, Redemption.RedemptionSaveAsType.olRFC822
objSafePost.MessageClass = "IPM.Note"
objSafePost.Fields(PR_ICON_INDEX) = none
objSafePost.SaveAs XPathMSG, Outlook.OlSaveAsType.olMSG
xFname$ = Dir
licznik = licznik + 1
Loop
End If
End With
xlObj.Quit
Set xlObj = Nothing
Set objSafePost = Nothing
Set objPost = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End Sub