I get an hresult 0x800a01b6 on the seccond passing of my code.
When it runs the first time it works but fails seccond time around. IE opens then program stops.
Dim pID As String
Dim mesg As String
Dim pw As String
Dim Id As String
Dim ie As Object
Dim l As String
'For Each Id In ListBox2.Items'
For i As Integer = 0 To Me.ListBox2.Items.Count - 1
Id = Me.ListBox2.Items(i).ToString
If Id = "me " Then
Id = "466901"
ElseIf "you" Then
Id = "466942"
End If
ie = CreateObject("InternetExplorer.Application")
ie.Navigate("http://www.webpage.com.au/")
ie.Visible = True
mesg = TextBox1.Text.ToString()
pw = "....."
ie.Document.All("password").Value = pw
ie.Document.All("idpagers").Value = Id
ie.Document.All("message").Value = mesg
ie.Document.All("Send").Click()
pID = ie.Document.All().ToString
'MessageBox.Show(pID)
MessageBox.Show(l & mesg & pw, "Test")'
Next
End Sub
Related
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
I currently have code written to take the fields of one workbook and copy into another workbook. I currently take a range and 'snapshot' it then save that as a separate .bmp file.
I also would like to take this snapshot and attach it into a cell of the workbook I'm copying everything over into. Anybody have any advice, or see here i can add code for this?
Sub Macro4()
'
' Record and File report
Dim Model As String
Dim IssueDate As String
Dim ConcernNo As String
Dim IssuedBy As String
Dim FollowedSEC As String
Dim FollowedBy As String
Dim RespSEC As String
Dim RespBy As String
Dim Timing As String
Dim Title As String
Dim PartNo As String
Dim Block As String
Dim Supplier As String
Dim Other As String
Dim Detail As String
Dim CounterTemp As String
Dim CounterPerm As String
Dim VehicleNo As String
Dim OperationNo As String
Dim Line As String
Dim Remarks As String
Dim ConcernMemosMaster As Workbook
Dim LogData As String
Dim newFile As String
Dim fName As String
Dim Filepath As String
Dim DTAddress As String
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
'Determines if any required cells are empty and stops process if there are. displays error message.
If IsEmpty(Range("c2")) Or IsEmpty(Range("AT3")) Or IsEmpty(Range("BI2")) Or IsEmpty(Range("M7")) Or IsEmpty(Range("C10")) Or IsEmpty(Range("AP14")) Or IsEmpty(Range("C14")) Or IsEmpty(Range("C23")) Or IsEmpty(Range("C37")) Or IsEmpty(Range("J51")) Or IsEmpty(Range("AA51")) Or IsEmpty(Range("C55")) Or IsEmpty(Range("AR51")) Then
MsgBox "Please fill out all required fields and retry.", vbOKOnly
Exit Sub
End If
If Dir("N:\") = "" Then '"N" drive not found, abort sub
MsgBox "Error: Drive, path or file not found. Please email copy of file to: "
Exit Sub
End If
'assigns fields
Worksheets("ConcernMemo").Select
Model = Range("c2")
IssueDate = Range("AT3")
ConcernNo = Range("BC3")
IssuedBy = Range("BI2")
FollowedSEC = Range("BA9")
FollowedBy = Range("BD9")
RespSEC = Range("BG9")
RespBy = Range("BJ9")
Timing = Range("M7")
Title = Range("C10")
PartNo = Range("AP14")
Block = Range("AP16")
Supplier = Range("AP18")
Other = Range("AZ14")
Detail = Range("C14")
CounterTemp = Range("C23")
CounterPerm = Range("C37")
VehicleNo = Range("J51")
OperationNo = Range("AA51")
Remarks = Range("C55")
Line = Range("AR51")
LogData = Format(Now(), "mm_dd_yyyy_hh_mmAMPM")
fName = Range("BC3").Value
newFile = fName & "_" & Format(Now(), "mmddyyyy_hhmmAMPM")
Filepath = "N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Records\" & fName & "_" & Format(Now(), "mmddyyyy_hhmmAMPM")
DTAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator
'asks user is they are ready to send to database
If MsgBox("Are you ready to send record to database?", vbYesNo) = vbNo Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set pic_rng = Worksheets("ConcernMemo").Range("AK22:BK49")
Set ShTemp = Worksheets.Add
'Takes snapshot of image/sketch and saves to sharedrive
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
End With
ChTemp.Export fileName:="N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Images\" & newFile & ".bmp", FilterName:="bmp"
ShTemp.Delete
'opens db file on sharedrive and copies fields over
Set ConcernMemosMaster = Workbooks.Open("N:\Newell K\Concern_Memo\concern_memos_DBMASTER.xlsx")
Worksheets("sheet1").Select
Worksheets("sheet1").Range("a1").Select
RowCount = Worksheets("sheet1").Range("a1").CurrentRegion.Rows.Count
With Worksheets("sheet1")
.Range("a1").Offset(RowCount, 0) = Model
.Range("b1").Offset(RowCount, 0) = IssueDate
.Range("c1").Offset(RowCount, 0) = ConcernNo
.Range("d1").Offset(RowCount, 0) = IssuedBy
.Range("e1").Offset(RowCount, 0) = FollowedSEC
.Range("f1").Offset(RowCount, 0) = FollowedBy
.Range("g1").Offset(RowCount, 0) = RespSEC
.Range("h1").Offset(RowCount, 0) = RespBy
.Range("i1").Offset(RowCount, 0) = Timing
.Range("j1").Offset(RowCount, 0) = Title
.Range("k1").Offset(RowCount, 0) = PartNo
.Range("l1").Offset(RowCount, 0) = Block
.Range("m1").Offset(RowCount, 0) = Supplier
.Range("n1").Offset(RowCount, 0) = Other
.Range("o1").Offset(RowCount, 0) = Detail
.Range("p1").Offset(RowCount, 0) = CounterTemp
.Range("q1").Offset(RowCount, 0) = CounterPerm
.Range("r1").Offset(RowCount, 0) = VehicleNo
.Range("s1").Offset(RowCount, 0) = OperationNo
.Range("t1").Offset(RowCount, 0) = Remarks
.Range("U1").Offset(RowCount, 0) = PicTemp
.Range("V1").Offset(RowCount, 0) = LogData
.Range("w1").Offset(RowCount, 0) = Filepath
.Range("x1").Offset(RowCount, 0) = Line
'saves a copy to of entire file to sharedrive
ThisWorkbook.SaveCopyAs fileName:="N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Records\" & newFile & ".xlsm"
'Saves copy to desktop
Application.DisplayAlerts = True
ThisWorkbook.SaveCopyAs DTAddress & newFile & ".xlsm"
MsgBox "A copy has been saved to your desktop"
ThisWorkbook.SendMail Recipients:="kaitlin.newell#nissan-usa.com", _
Subject:="New Concern Memo"
End With
ConcernMemosMaster.Save
ConcernMemosMaster.Close
Application.DisplayAlerts = True
MsgBox "Please close out file without saving"
End Sub
Try this out :
Range("A1:D4").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Range("A6").PasteSpecial
It will paste a copy of the "snapshot" of Range("A1:D4") at the cell A6.
EDIT : Since you have already set an object of that "target" workbook, you can use it to easily paste into it. Try this :
ConcernMemosMaster.Worksheets("sheet1").Range("A1:X1").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
ConcernMemosMaster.Worksheets("sheet1").Range("B1").PasteSpecial
I am having a problem while searching for an item in datagridview
here is my code but whenever i search for an item which already exist in the database, it is telling not found
If txtfirstname.Text = "" Then
MsgBox("Please enter first name!")
Else
Dim totalrow As Integer = DataGridView1.RowCount - 2
Dim rowin As Integer
Dim flag As Boolean = False
Dim sear As String = CStr(txtfirstname.Text)
For rowin = 0 To totalrow
Dim id As String = DataGridView1.Item(0, rowin).Value
If sear = id Then
DataGridView1.ClearSelection()
DataGridView1.Rows(rowin).Selected = True
DataGridView1.CurrentCell = DataGridView1.Item(0, rowin)
flag = True
Exit Sub
Else
flag = False
End If
Next rowin
If flag = False Then
MessageBox.Show("Firstname " & txtfirstname.Text & " is not found in database.", "Search Information", MessageBoxButtons.OK, MessageBoxIcon.Information)
End If
End If
By setting
Dim totalrow As Integer = DataGridView1.RowCount - 2
you are always missing the last record in your dataset.
Try
Dim totalrow As Integer = DataGridView1.RowCount - 1
to set the upper bound value of your For loop.
Often when describing an issue in code, I need to reference it by line/column/function.
Is there a macro/add-in for Visual Studio that copies that information for me?
It would be perfect if it could copy to clipboard: File, Line, column, function name
But I'd take any combination :).
Thanks!
I ended up doing a macro. Unfortunately I was unable to access the clipboard from the macro so I had to use NirCmd for that part. Other than that, it works great!
Public Sub CopyLocation()
Dim fileName = DTE.ActiveDocument.Name
Dim line = ""
Dim column = ""
Dim functionName = ""
Dim className = ""
Dim textDocument = TryCast(DTE.ActiveDocument.Object, TextDocument)
If textDocument IsNot Nothing Then
Dim activePoint = textDocument.Selection.ActivePoint
column = activePoint.DisplayColumn
line = activePoint.Line
Dim codeElement As CodeElement
codeElement = activePoint.CodeElement(vsCMElement.vsCMElementFunction)
If codeElement IsNot Nothing Then
functionName = codeElement.Name
End If
codeElement = activePoint.CodeElement(vsCMElement.vsCMElementClass)
If codeElement IsNot Nothing Then
className = codeElement.Name
End If
End If
Dim output As String = String.Format("File: {0} ", fileName)
If (String.IsNullOrEmpty(line) = False) Then output = output & String.Format("Line: {0} ", line)
If (String.IsNullOrEmpty(column) = False) Then output = output & String.Format("Column: {0} ", column)
If (String.IsNullOrEmpty(className) = False) Then output = output & String.Format("at {0}", className)
If (String.IsNullOrEmpty(functionName) = False) Then output = output & String.Format(".{0}", functionName)
Dim process As System.Diagnostics.Process
process.Start("c:\NoInstall files\nircmd.exe", String.Format("clipboard set ""{0}""", output))
End Sub
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