Getting the cursor location in Visual Studio to clipboard - visual-studio

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

Related

Converting PPT file to PDF

I have a macro which opens a PowerPoint file stored on the workbook and then modifies it using the below code
Set PApp = CreateObject("PowerPoint.Application")
PApp.Visible = True
Pth = ThisWorkbook.Path
ErrorPopUp = True
Dim TsyTemplate As Object
Set TsyTemplate = ThisWorkbook.Sheets("Report Templates").OLEObjects(“Report 1”)
TsyTemplate.Copy
Sheets("Version Control").Paste
Set TsyTemplate = ThisWorkbook.Sheets("Book 1").OLEObjects(1)
TsyTemplate.Verb Verb:=xlOpen
Set TsyTemplate = Nothing
Set PPres = PApp.ActivePresentation
This works fine however I want to add some code which then converts the open PowerPoint file into a PDF file. I would prefer it to just convert it without saving it somewhere but I don't believe this is possible so I am using he below code to save it as a PDF FILE
PDFName = ActiveWorkbook.Path & "/test.pdf"
PPres.ExportAsFixedFormat Path:=PDFName, FixedFormatType:=ppFixedFormatTypePDF, RangeType:=ppPrintSelection
This isn't working though as I get the error message "type mismatch"
Does anyone have any suggestions as to what I am doing wrong.
Thanks
Full code:
Global PApp As Object
Global PPres As Object
Global PPTFileName As String
Global ppFixedFormatTypePDF As Long
Global ppPrintSelection As Long
Sub Test_Printing_To_PDF()
Set PApp = CreateObject("PowerPoint.Application")
PApp.Visible = True
Pth = ThisWorkbook.Path
ErrorPopUp = True
Dim TsyTemplate As Object
Set TsyTemplate = ThisWorkbook.Sheets("Report Templates").OLEObjects("Report 1")
TsyTemplate.Copy
Sheets("Version Control").Paste
Set TsyTemplate = ThisWorkbook.Sheets("Version Control").OLEObjects(1)
TsyTemplate.Verb Verb:=xlOpen
Set TsyTemplate = Nothing
Set PPres = PApp.ActivePresentation
PPres.Slides(1).Shapes("Presentation_Title").TextFrame.TextRange.Text = "Test printing code"
ppFixedFormatTypePDF = 2
ppPrintSelection = 2
PDFName = ActiveWorkbook.Path & "/test.pdf"
PPres.ExportAsFixedFormat Path:=PDFName, FixedFormatType:=ppFixedFormatTypePDF, RangeType:=ppPrintSelection
End Sub
I removed some of your Excel code so that I could try this here; since it seems to have nothing to do with the PDF export from PPT, shouldn't make any difference. New (working) code below with comments:
Option Explicit
Global PApp As Object
Global PPres As Object
Global PPTFileName As String
Global ppFixedFormatTypePDF As Long
Global ppPrintSelection As Long
Const ppSaveAsPDF As Long = 32
Sub Test_Printing_To_PDF()
' Always include Option Explicit and DIM all variables
Dim Pth As String
Dim ErrorPopUp As Boolean
Dim PDFName As String
Set PApp = CreateObject("PowerPoint.Application")
PApp.Visible = True
Pth = ThisWorkbook.Path
ErrorPopUp = True
' Just invoking PowerPoint doesn't necessarily create a presentation.
' You need to add one (or open an existing one)
Set PPres = PApp.presentations.Add
' And creating a new presentation doesn't necessarily add slides so:
PPres.slides.Add 1, 1
' Unless you've opened a presentation that happens to have a shape named
' Presentation_Title on the first slide, this will fail:
'PPres.slides(1).Shapes("Presentation_Title").TextFrame.TextRange.Text = "Test printing code"
' So I've changed it to this:
PPres.slides(1).Shapes(1).TextFrame.TextRange.Text = "Test printing code"
' / isn't a valid character:
'PDFName = ActiveWorkbook.Path & "/test.pdf"
' so I changed it to this:
PDFName = ActiveWorkbook.Path & "\test.pdf"
' And there are all sorts of reports all over the net about
' the Export routine being buggy. Substitute this and it works:
PPres.SaveAs PDFName, ppSaveAsPDF
End Sub

Excel VBA Copying Pic/Chart to another workbook

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

Transfering windows-specific macro to run on Mac Excel

I've recently changed from a PC to a Mac. I run a lot of a macros and 99% of them are running fine, but I have one that doesn't work on a Mac.
It runs a set of other macros across all workbooks in a file. To do this it uses strings like this:
Function BrowseFolder(Title As String, _
Optional InitialFolder As String = vbNullString, _
Optional InitialView As Office.MsoFileDialogView = _
msoFileDialogViewList) As String
When I try to run this on the Mac it comes back with an error:
"compile error: variable not defined"
I wonder if anyone could help me with porting this macro over to run on Mac. It was built on Excel 2007 Windows and I'm trying to run it on Excel 2011 Mac.
Option Explicit
Function GetFolder(Optional strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
If Not IsEmpty(strPath) Then
.InitialFileName = strPath
End If
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Private Sub test()
Dim v As Variant
'V = GetFolder()
v = BrowseFolder("Select folder")
End Sub
Function BrowseFolder(Title As String, _
Optional InitialFolder As String = vbNullString, _
Optional InitialView As Office.MsoFileDialogView = _
msoFileDialogViewList) As String
Dim v As Variant
Dim InitFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = Title
.InitialView = InitialView
If Len(InitialFolder) > 0 Then
If Dir(InitialFolder, vbDirectory) <> vbNullString Then
InitFolder = InitialFolder
If Right(InitFolder, 1) <> "\" Then
InitFolder = InitFolder & "\"
End If
.InitialFileName = InitFolder
End If
End If
.Show
On Error Resume Next
Err.Clear
v = .SelectedItems(1)
If Err.Number <> 0 Then
v = vbNullString
End If
End With
BrowseFolder = CStr(v)
End Function
msoFileDialogViewList refers to a specific view of the Windows standard file dialog. The Mac standard file dialog doesn't have equivalent modes; my guess is that the InitialView parameter either doesn't exist or is ignored on the Mac platform.
I'd advise either removing the parameter entirely or using the equivalent integer value (1) instead of the symbolic name.

Using ItextSharp I am getting Unbalanced begin/end text operators. But they are Matched

I working on a app that uses ItextSharp to generate PDF files for students to print name tags and parking permits... However it keeps throwing: Unbalanced begin/end text operators. at the doc.close()
The blocks appear to be properly openned and closed.. Below is the function:
Function ID_and_Parking(ByVal id As Integer) As ActionResult
Dim _reg_info As reg_info = db.reg_info.Single(Function(r) r.id = id)
Dim _conf_info As conf_info = db.conf_info.Single(Function(f) f.id = 0)
Dim _LastName As String = _reg_info.last_name
Dim _Employer As String = _reg_info.business_name
Dim _Class_1 As String = _reg_info.tues_class
Dim _Class_2 As String = _reg_info.wed_class
Dim _Class_3 As String = _reg_info.thur_class
Dim _Class_4 As String = _reg_info.fri_class
Dim _BeginDate As String = _conf_info.conf_start_date
Dim _endDate As String = _conf_info.conf_end_date
If IsDBNull(_reg_info.tues_class) Then
_Class_1 = ""
End If
If IsDBNull(_reg_info.wed_class) Then
_Class_2 = ""
End If
If IsDBNull(_reg_info.thur_class) Then
_Class_3 = ""
End If
If IsDBNull(_reg_info.fri_class) Then
_Class_4 = ""
End If
'Dim pdfpath As String = Server.MapPath("PDFs")
'Dim imagepath As String = Server.MapPath("Images")
Dim pdfpath As String = "C:\temp\"
Dim imagepath As String = "C:\temp\"
Dim doc As New Document
doc.SetPageSize(iTextSharp.text.PageSize.A4)
doc.SetMargins(0, 0, 2, 2)
Try
Dim writer As PdfWriter = PdfWriter.GetInstance(doc, New FileStream(pdfpath + "/Images.pdf", FileMode.Create))
doc.Open()
Dim cb As PdfContentByte = writer.DirectContent
cb.BeginText()
cb.SetTextMatrix(100, 400)
cb.ShowText(_LastName)
cb.EndText()
doc.Add(New Paragraph("JPG"))
Dim jpg As Image = Image.GetInstance(imagepath + "/Asads_Tags.jpg")
jpg.Alignment = iTextSharp.text.Image.UNDERLYING
jpg.ScaleToFit(576, 756)
doc.Add(jpg)
Catch dex As DocumentException
Response.Write(dex.Message)
Catch ioex As IOException
Response.Write(ioex.Message)
Catch ex As Exception
Response.Write(ex.Message)
Finally
doc.Close()
End Try
Return RedirectToAction("Index")
End Function
Anyone know where I could be going wrong at??????
The Try Catch block is what caused the unbalanced start/end exception.....Once I moved the doc.close() up to the bottom of try the error went away... Oh well maybe someone else will need the insight... –

Where is Outlook's save FileDialog?

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

Resources