I need to take a range from Excel and have it paste over into an Outlook email message. The issue being when I do this it just pastes the text and not the table. Below is the code. I tried picture, but I don't want to have to embed it, don't understand why it won't just paste it like any other time I copy an image. I am working with Office 2013.
Private Sub btnSubmit_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnSubmit.Click
Dim objexcel As New Excel.Application
Dim objWorkbook As Excel.Workbook
Dim objWorksheet As Excel.Worksheet
Dim Range As Excel.Range
objexcel.DisplayAlerts = False
objWorkbook = objexcel.Workbooks.Open("c://Derp")
objWorksheet = CType(objWorkbook.Worksheets.Item("Sheet1"), Excel.Worksheet)
objWorksheet.Unprotect()
objWorksheet.Cells(2, 1).value = txtTravEmails.Text
objWorksheet.Cells(2, 4).value = Txttravemdate.Text
objWorksheet.Cells(3, 1).value = txtTravUnread.Text
objWorksheet.Cells(3, 4).value = Txttravundate.Text
objWorksheet.Cells(6, 1).value = txtITweb.Text
objWorksheet.Cells(6, 4).value = Txtwebdate.Text
objWorksheet.Cells(7, 1).value = txtITAPI.Text
objWorksheet.Cells(7, 4).value = Txtapidate.Text
objWorksheet.Cells(8, 1).value = txtITpend.Text
objWorksheet.Cells(8, 4).value = Txtpenddate.Text
'objWorksheet.Range("A1:D9").CopyPicture()
Range = objWorksheet.Range("A1:D9")
Range.Copy()
If Chkmorning.Checked = True Then
Dim Email As New Email_Templates
Email.Morning()
ElseIf Chkmid.Checked = True Then
Dim Email As New Email_Templates
Email.Mid()
ElseIf Chkevening.Checked = True Then
Dim Email As New Email_Templates
Email.Evening()
ElseIf Chkmidnight.Checked = True Then
Dim Email As New Email_Templates
Email.Midnight()
End If
objWorkbook.Save()
objWorkbook.Close()
objexcel.Quit()
End Sub
Public Sub Morning()
Dim Morning As String = "<html>" +
"<HEAD>" +
"<TITLE>Email</TITLE>" +
"</HEAD>" +
"<BODY>" +
"<font face=Calibri>" +
"<b> This is the morning report sent at " + DateAndTime.Now.ToShortTimeString + " EST! " +
"<br><br>" + Clipboard.GetText +
"</font>" +
"</BODY>" +
"</HTML>"
mail.Recipients.Add("derp#derp.com")
mail.BCC = ""
mail.Subject = Date.Now.ToShortDateString
mail.HTMLBody = Morning
'mail.Body = "This is the morning report sent at " & DateAndTime.Now.ToShortTimeString & " EST!" & vbNewLine & Clipboard.GetText
mail.Display()
End Sub
You have to pass the format that you want off the clipboard data.
Dim Morning As String = "<html>" +
"<HEAD>" +
"<TITLE>Email</TITLE>" +
"</HEAD>" +
"<BODY>" +
"<font face=Calibri>" +
"<b> This is the morning report sent at " + DateAndTime.Now.ToShortTimeString + " EST! " +
"<br><br>" + Clipboard.GetText(TextDataFormat.Html) +
"</font>" +
"</BODY>" +
"</HTML>"
The Clipboard.GetText method has an optional format parameter using the TextDataFormat constants.
Added the following to the morning sub
Dim Report As String
Report = Clipboard.GetText(TextDataFormat.Html)
Report = Report.Substring(Report.IndexOf("<html"))
and changed
mail.HTMLBody = Midnight & Report
Removed the sourceurl information before the pasted table
Related
I made a code to send some emails, using HCL NOTES and Excel, but I have been stuck.
ERROR 3000 appears when going through the line ".SEND 0, vaRecipient". I think what happens is that the connection with the database is lost, after going through the procedure of attaching an image to the body of the mail. Since if I remove those lines of code, no error arises.
Sub SendQuoteToEmail()
Dim NSession As Object
Dim NDatabase As Object
Dim NUIWorkSpace As Object
Dim NDoc As Object
Dim NUIdoc As Object
Dim NRichTextItem As Object
Dim NrichTextHeader As Object
Dim NMimeImage As Object
Dim strImageType As String
Dim WordApp As Object
Dim EmbedObj As Object
Dim Body As Object
Dim NStream As Object
Dim Subject As String
Dim MailAddress As String
Dim MailAddressCC As String
Dim MailAddressCC2 As String
Dim MailAddressCCO As String
Dim MailAddressCCO2 As String
Dim AttchFiles1, AttchFiles2, AttchFiles3, AttchFiles4 As String
Dim AddImage As String
Dim pf As Integer
Dim Uf As Integer
Dim x As Double
'On Error Resume Next
Set a = ThisWorkbook.Sheets("Base Emails")
pf = 4
Uf = 0
Do While Uf = 0
cuit = Range("a" & pf).Value
If cuit <> Empty Then
Subject = UserForm1.SubjectBox & a.Cells(pf, "D") & " - CUIL N°: " & a.Cells(pf, "A") '
MailAddress = a.Cells(pf, "F")
MailAddressCC = UserForm1.TextBoxCC
MailAddressCC2 = UserForm1.TextBoxCC2
MailAddressCCO = UserForm1.TextBoxCCO
MailAddressCCO2 = UserForm1.TextBoxCCO2
Set NSession = CreateObject("Notes.NotesSession")
Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GETDATABASE("", "")
If Not NDatabase.IsOpen Then NDatabase.OPENMAIL
Set NDoc = NDatabase.CREATEDOCUMENT
With NDoc
.SendTo = MailAddress
.CopyTo = MailAddressCC & ", " & MailAddressCC2
.Subject = Subject
.Body = UserForm1.FirstLineBox & vbLf & vbLf & _
UserForm1.FirstParagraphBox & vbLf & vbLf & _
UserForm1.SecondParagraphBox & vbLf & vbLf & _
UserForm1.ThirdParagraphBox & vbLf
.SAVEMESSAGEONSEND = True
End With
AddImage = ThisWorkbook.Path & "\Image\" & Worksheets("Files").Range("A" & 5)
If AddImage <> "" Then
Set NStream = NSession.CREATESTREAM
Call NStream.Open(AddImage)
Set Body = NDoc.CreateMIMEEntity("memo")
Set richTextHeader = Body.CreateHeader("Content-Type")
Call richTextHeader.SetHeaderVal("multipart/mixed")
Set mimeImage = Body.CreateChildEntity()
strImageType = "image/jpeg; image/gif" '" Other formats are "image/gif" "image/bmp" -
Call mimeImage.SetContentFromBytes(NStream, strImageType, ENC_IDENTITY_BINARY)
Call NStream.Close
End If
AttchFiles1 = ThisWorkbook.Path & "\Files\" & Worksheets("Files").Range("A" & 1)
If AttchFiles1 <> "" Then
Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment1")
Set EmbedObj = AttachMe.EmbedObject(1454, "", AttchFiles1, "Adjunto")
End If
AttchFiles2 = ThisWorkbook.Path & "\Files\" & Worksheets("Files").Range("A" & 2)
If AttchFiles2 <> "" Then
Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment2")
Set EmbedObj = AttachMe.EmbedObject(1454, "", AttchFiles2, "Adjunto")
End If
AttchFiles3 = ThisWorkbook.Path & "\Files\" & Worksheets("Files").Range("A" & 3)
If AttchFiles3 <> "" Then
Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment3")
Set EmbedObj = AttachMe.EmbedObject(1454, "", AttchFiles3, "Adjunto")
End If
AttchFiles4 = ThisWorkbook.Path & "\Files\" & Worksheets("Files").Range("A" & 4)
If AttchFiles4 <> "" Then
Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment4")
Set EmbedObj = AttachMe.EmbedObject(1454, "", AttchFiles4, "Adjunto")
End If
With NDoc
.PostedDate = Now()
.SEND 0, vaRecipient '<--- ERROR 3000
End With
Set NStream = Nothing
Set NDoc = Nothing
Set WordApp = Nothing
Set NSession = Nothing
Set EmbedObj = Nothing
pf = pf + 1
Else
Uf = 1
Exit Do
End If
Loop
VbMessage = "Sent messages"
Call Clean
End Sub
If I remove these lines of code, the procedure works. So I suppose that by manipulating "NSession", something happens, but I don't know what.
AddImage = ThisWorkbook.Path & "\Image\" & Worksheets("Files").Range("A" & 5)
If AddImage <> "" Then
Set NStream = NSession.CREATESTREAM
Call NStream.Open(AddImage)
Set Body = NDoc.CreateMIMEEntity("memo")
Set richTextHeader = Body.CreateHeader("Content-Type")
Call richTextHeader.SetHeaderVal("multipart/mixed")
Set mimeImage = Body.CreateChildEntity()
strImageType = "image/jpeg; image/gif" '" Other formats are "image/gif" "image/bmp" -
Call mimeImage.SetContentFromBytes(NStream, strImageType, ENC_IDENTITY_BINARY)
Call NStream.Close
End If
You've got two pieces of incompatible code here.
.Body = UserForm1.FirstLineBox & vbLf & vbLf & _
UserForm1.FirstParagraphBox & vbLf & vbLf & _
UserForm1.SecondParagraphBox & vbLf & vbLf & _
UserForm1.ThirdParagraphBox & vbLf
And
Set Body = NDoc.CreateMIMEEntity("memo")
Set richTextHeader = Body.CreateHeader("Content-Type")
Call richTextHeader.SetHeaderVal("multipart/mixed")
Set mimeImage = Body.CreateChildEntity()
strImageType = "image/jpeg; image/gif" '" Other formats are "image/gif" "image/bmp" -
Call mimeImage.SetContentFromBytes(NStream, strImageType, ENC_IDENTITY_BINARY)
You can't work with the message body both as Notes rich text (the first piece of code) and as MIME. You need to pick one or the other. I'm guessing you're going to pick MIME, in which case you are going to need to create a text/plain part and populate it with your three paragraphs of text.
I'm looking through the following macro I inherited and trying to figure out why it's importing duplicate images when it pulls unique photos from the same folder. Any help would be much appreciated, I don't have a lot of experience with VBA.
The purpose of the macro is to pull all image files in the same folder as the word document and embed them in the word document itself. Right now it's taking the first image in the folder and embedding it multiple times. I think it's an issue with the loop logic but I'm pretty new to VBA and having trouble fixing it.
Option Explicit
Dim msPath As String
Dim msPictures() As String
Dim mlPicturesCnt As Long
Public Sub ImportJPGFiles()
On Error GoTo Err_ImportJPGFiles
Dim lngCount As Long
Dim lngPicture As Long
Dim strMsg As String
Dim sngBEGTime As Single
Dim sngENDTime As Single
'Assume JPG files are in same directory as
'as the Word document containing this macro.
msPath = Application.ActiveDocument.Path & "\"
lngCount = LoadPicturesArray
'Let user browse to correct folder if pictures aren't in the same
'folder as Word document
While lngCount < 0
strMsg = "Unable to find any JPG files in the following" & vbCrLf & _
"directory:" & vbCrLf & vbCrLf & _
msPath & vbCrLf & vbCrLf & _
"Press the 'OK' button if you want to browse to" & vbCrLf & _
"the directory containing your JPG files. Press" & vbCrLf & _
"the 'Cancel' button to end this macro."
If (MsgBox(strMsg, vbOKCancel + vbInformation, "Technical Difficulties")) = vbOK Then
With Application
.WindowState = wdWindowStateMinimize
msPath = BrowseForDirectory
.WindowState = wdWindowStateMaximize
End With
If LenB(msPath) <> 0 Then
If Right$(msPath, 1) <> "\" Then
msPath = msPath & "\"
End If
lngCount = LoadPicturesArray
Else
Exit Sub
End If
Else
Exit Sub
End If
Wend
Application.ScreenUpdating = False
sngBEGTime = Timer
For lngPicture = 0 To lngCount
Application.StatusBar = "Importing picture " & _
CStr(lngPicture + 1) & " of " & _
CStr(lngCount + 1) & " pictures..."
With Selection
.EndKey Unit:=wdStory
.MoveUp Unit:=wdLine, Count:=21, Extend:=wdExtend
.Copy
.EndKey Unit:=wdStory
.InsertBreak Type:=wdPageBreak
.Paste
.MoveUp Unit:=wdLine, Count:=24
.InlineShapes.AddPicture FileName:=msPath & msPictures(lngPicture), _
LinkToFile:=False, _
SaveWithDocument:=True
End With
Next lngPicture
sngENDTime = Timer
strMsg = "Import Statistics: " & vbCrLf & vbCrLf & _
"Pictures Imported: " & CStr(lngCount + 1) & vbCrLf & _
"Total Seconds: " & Format((sngENDTime - sngBEGTime), "###0.0") & vbCrLf & _
"Seconds/Picture: " & Format((sngENDTime - sngBEGTime) / (lngCount + 1), "###0.00")
MsgBox strMsg, , "Finished"
Exit_ImportJPGFiles:
With Application
.StatusBar = "Ready"
.ScreenUpdating = True
End With
Exit Sub
Err_ImportJPGFiles:
MsgBox Err.Number & " - " & Err.Description, , "ImportJPGFiles"
Resume Exit_ImportJPGFiles
End Sub
Public Function LoadPicturesArray() As Long
On Error GoTo Err_LoadPicturesArray
Dim strName As String
strName = Dir(msPath)
mlPicturesCnt = 0
ReDim msPictures(0)
Do While strName <> ""
If strName <> "." And strName <> ".." _
And strName <> "pagefile.sys" Then
If UCase(Right$(strName, 3)) = "JPG" Then
msPictures(mlPicturesCnt) = strName
mlPicturesCnt = mlPicturesCnt + 1
ReDim Preserve msPictures(mlPicturesCnt)
'Debug.Print strName
End If
End If
strName = Dir
Loop
Call QSort(msPictures, 0, mlPicturesCnt - 1)
' Dim i As Integer
' Debug.Print "----AFTER SORT----"
' For i = 0 To mlPicturesCnt - 1
' Debug.Print msPictures(i)
' Next i
LoadPicturesArray = mlPicturesCnt - 1
Exit_LoadPicturesArray:
Exit Function
Err_LoadPicturesArray:
MsgBox Err.Number & " - " & Err.Description, , "LoadPicturesArray"
Resume Exit_LoadPicturesArray
End Function
Public Sub QSort(ListArray() As String, lngBEGOfArray As Long, lngENDOfArray As Long)
Dim i As Long
Dim j As Long
Dim strPivot As String
Dim strTEMP As String
i = lngBEGOfArray
j = lngENDOfArray
strPivot = ListArray((lngBEGOfArray + lngENDOfArray) / 2)
While (i <= j)
While (ListArray(i) < strPivot And i < lngENDOfArray)
i = i + 1
Wend
While (strPivot < ListArray(j) And j > lngBEGOfArray)
j = j - 1
Wend
If (i <= j) Then
strTEMP = ListArray(i)
ListArray(i) = ListArray(j)
ListArray(j) = strTEMP
i = i + 1
j = j - 1
End If
Wend
If (lngBEGOfArray < j) Then QSort ListArray(), lngBEGOfArray, j
If (i < lngENDOfArray) Then QSort ListArray(), i, lngENDOfArray
End Sub
So I have a code-block that currently checks to see whether an excel file is present at a given location and if present, imports its contents into a list-box. If absent, it triggers an error message. I'm using the Try...catch code block to execute this.
I want to trigger an error message when the data to be imported is not in the appropriate format. The code block is below. Any help will be deeply appreciated.
Private Sub Button1_Click_1(sender As System.Object, e As System.EventArgs) Handles butImport.Click
Dim MyFileDialog As New System.Windows.Forms.OpenFileDialog
' Configure the dialog to show both text and excel files
' Set its title and set the filename field blank for the moment.
MyFileDialog.Filter = "(*.xlsx)|*.xlsx"
MyFileDialog.Title = " Open an excel file"
MyFileDialog.FileName = ""
' Show the dialog and see if the user pressed ok.
If MyFileDialog.ShowDialog() = Windows.Forms.DialogResult.OK Then
' Check to see if they selected a file and that it exists.
If File.Exists(MyFileDialog.FileName) Then
Dim strFile As String = MyFileDialog.FileName
Dim textextension As String
Dim testFile As System.IO.FileInfo
Try
' Setup a file stream reader to read the text file.
textextension = Path.GetExtension(strFile)
If textextension = ".xlsx" Then
Dim oExcel As Object = CreateObject("Excel.Application")
Dim oBook As Object = oExcel.Workbooks.Open(strFile)
Dim oSheet As Object = oBook.Worksheets(1)
Dim i As Integer
Dim cellA As String
Dim cellB As String
Dim cellC As String
Dim cellD As String
Dim cellE As String
lstGradeLength.Items.Add("Grade (in Radians)" & vbTab & " Length (in Miles)" & vbTab & vbTab & "Radius (in Feet)" & vbTab & vbTab & "Super-elevation (in Decimal)" & vbTab & vbTab & "Angle (in Degrees)")
For i = 0 To AscW(lstGradeLength.Items.Count.ToString()(i = i + 1)) - 1
cellA = "A" & Convert.ToString(i + 1)
cellB = "B" & Convert.ToString(i + 1)
cellC = "C" & Convert.ToString(i + 1)
cellD = "D" & Convert.ToString(i + 1)
cellE = "E" & Convert.ToString(i + 1)
cellA = oSheet.Range(cellA).Value
cellB = oSheet.Range(cellB).Value
cellC = oSheet.Range(cellC).Value
cellD = oSheet.Range(cellD).Value
cellE = oSheet.Range(cellE).Value
If cellA = "" And cellB = "" And cellC = "" And cellD = "" And cellE = "" Then
Exit For
Else
RichTextBox1.AppendText(cellA & " " & cellB & " " & cellC & " " & cellD & " " & cellE & vbCrLf)
End If
Next
oExcel.Quit()
Dim m As Integer
For m = 1 To CInt(UBound(RichTextBox1.Lines))
ReDim Preserve Grade(m)
ReDim Preserve Length(m)
ReDim Preserve Radius(m)
ReDim Preserve Superelevation(m)
ReDim Preserve Angle(m)
Grade(m) = RichTextBox1.Lines(m - 1).Split(" ").First
Length(m) = RichTextBox1.Lines(m - 1).Split(" "c)(1)
Radius(m) = RichTextBox1.Lines(m - 1).Split(" "c)(2)
Superelevation(m) = RichTextBox1.Lines(m - 1).Split(" ")(3)
Angle(m) = RichTextBox1.Lines(m - 1).Split(" ")(4)
lstGradeLength.Items.Add(Grade(m) & vbTab & vbTab & vbTab & Length(m) & vbTab & vbTab & vbTab & Radius(m) & vbTab & vbTab & vbTab & Superelevation(m) & vbTab & vbTab & vbTab & Angle(m) & vbCrLf)
butGradeLength.Enabled = False
Next
testFile = My.Computer.FileSystem.GetFileInfo(strFile)
lblPath.Text = testFile.FullName
txtNumSections.Text = lstGradeLength.Items.Count - 1
End If
Catch ex As FileNotFoundException
' If the file was not found, tell the user.
MessageBox.Show("File was Not found. Please try again.")
End Try
End If
Else
txtNumSections.Text = ""
butImport.Enabled = True
butGradeLength.Enabled = True
butClear.Enabled = True
Exit Sub
End If
butImport.Enabled = False
butCompute.Enabled = True
End Sub
Private Sub Button1_Click_1(sender As System.Object, e As System.EventArgs) Handles butImport.Click
Dim MyFileDialog As New System.Windows.Forms.OpenFileDialog
' Configure the dialog to show only excel files
' Set its title and set the filename field blank for the moment.
MyFileDialog.Filter = "(*.xlsx)|*.xlsx"
MyFileDialog.Title = " Open an excel file"
MyFileDialog.FileName = ""
' Show the dialog and see if the user pressed ok.
If MyFileDialog.ShowDialog() = Windows.Forms.DialogResult.OK Then
' Check to see if they selected a file and that it exists.
If File.Exists(MyFileDialog.FileName) Then
Dim strFile As String = MyFileDialog.FileName
Dim textextension As String
Dim testFile As System.IO.FileInfo
Try
'Setup a file stream reader to read the excel file.
textextension = Path.GetExtension(strFile)
If textextension = ".xlsx" Then
Dim oExcel As Object = CreateObject("Excel.Application")
Dim oBook As Object = oExcel.Workbooks.Open(strFile)
Dim oSheet As Object = oBook.Worksheets(1)
Dim i As Integer
Dim cellA As String
Dim cellB As String
Dim cellC As String
Dim cellD As String
Dim cellE As String
lstGradeLength.Items.Add("Grade (in Radians)" & vbTab & " Length (in Miles)" & vbTab & vbTab & "Radius (in Feet)" & vbTab & vbTab & "Super-elevation (in Decimal)" & vbTab & vbTab & "Angle (in Degrees)")
For i = 0 To AscW(lstGradeLength.Items.Count.ToString()(i = i + 1)) - 1
cellA = "A" & Convert.ToString(i + 1)
cellB = "B" & Convert.ToString(i + 1)
cellC = "C" & Convert.ToString(i + 1)
cellD = "D" & Convert.ToString(i + 1)
cellE = "E" & Convert.ToString(i + 1)
cellA = oSheet.Range(cellA).Value
cellB = oSheet.Range(cellB).Value
cellC = oSheet.Range(cellC).Value
cellD = oSheet.Range(cellD).Value
cellE = oSheet.Range(cellE).Value
If cellA = "" And cellB = "" And cellC = "" And cellD = "" And cellE = "" Then
Exit For
Else
RichTextBox1.AppendText(cellA & " " & cellB & " " & cellC & " " & cellD & " " & cellE & vbCrLf)
End If
Next
oExcel.Quit()
End If
Catch ex As FileNotFoundException
' If the file was not found, tell the user.
MessageBox.Show("File was not found. Please try again.")
End Try
Try
'Setup a file stream reader to read the excel file.
textextension = Path.GetExtension(strFile)
If textextension = ".xlsx" Then
Dim m As Integer
For m = 1 To CInt(UBound(RichTextBox1.Lines))
ReDim Preserve Grade(m)
ReDim Preserve Length(m)
ReDim Preserve Radius(m)
ReDim Preserve Superelevation(m)
ReDim Preserve Angle(m)
Grade(m) = RichTextBox1.Lines(m - 1).Split(" ").First
Length(m) = RichTextBox1.Lines(m - 1).Split(" "c)(1)
Radius(m) = RichTextBox1.Lines(m - 1).Split(" "c)(2)
Superelevation(m) = RichTextBox1.Lines(m - 1).Split(" ")(3)
Angle(m) = RichTextBox1.Lines(m - 1).Split(" ")(4)
lstGradeLength.Items.Add(Grade(m) & vbTab & vbTab & vbTab & Length(m) & vbTab & vbTab & vbTab & Radius(m) & vbTab & vbTab & vbTab & Superelevation(m) & vbTab & vbTab & vbTab & Angle(m) & vbCrLf)
butGradeLength.Enabled = False
Next
testFile = My.Computer.FileSystem.GetFileInfo(strFile)
lblPath.Text = testFile.FullName
txtNumSections.Text = lstGradeLength.Items.Count - 1
End If
Catch ex As Exception
' If the data is in an incorrect format, tell the user.
MessageBox.Show("Data is in incorrect format")
End Try
lstGradeLength.Items.Clear()
End If
Else
txtNumSections.Text = ""
butImport.Enabled = True
butGradeLength.Enabled = True
butClear.Enabled = True
Exit Sub
End If
butImport.Enabled = False
butCompute.Enabled = True
End Sub
While it is good to have at least one generic exception handler, I don't see the point of catching FileNotFoundException since you are testing the file existence with If File.Exists(MyFileDialog.FileName) Then just before. Of course plenty of bad things can happen during program execution but I don't think there is any reason to handle this exception in particular since it is unlikely to happen.
And in fact if this condition is not met: If File.Exists(MyFileDialog.FileName) Then then your program does not even alert the user, it just resets a few UI controls. A simplified view of your block is like this:
If MyFileDialog.ShowDialog() = Windows.Forms.DialogResult.OK Then
' Check to see if they selected a file and that it exists.
If File.Exists(MyFileDialog.FileName) Then
...
End If
Else
txtNumSections.Text = ""
butImport.Enabled = True
butGradeLength.Enabled = True
butClear.Enabled = True
Exit Sub
End If
I am not sure this is what you want. If you let the user pick a file, but they play games by removing or renaming the file maybe you should alert them, not just ignore this little problem. At least the program is not going to crash on this exception but it is still an unexpected condition.
Here is my problem:
Duplicate versions
I checked the version history on the Sharepoint site and it doesn't show any duplicates.
Here is the code im using:
Sub versionhistory()
'
' versionhistory Macro
On Error Resume Next
' On Error GoTo message
Dim dlvVersions As Office.DocumentLibraryVersions
Dim dlvVersion As Office.DocumentLibraryVersion
Dim strVersionInfo As String
Set dlvVersions = ThisDocument.DocumentLibraryVersions
'MsgBox ActiveDocument.Bookmarks.Count
Dim tbl As Word.Table
'Set tbl = ActiveDocument.Tables.Item(2)
Set tbl = ActiveDocument.Bookmarks("VersionTable").Range.Tables(1)
If dlvVersions.IsVersioningEnabled Then
strVersionInfo = "This document has " & dlvVersions.Count & " versions: " & vbCrLf
Call InsertVersionHistory(tbl, dlvVersions)
For Each dlvVersion In dlvVersions
strVersionInfo = strVersionInfo & _
" - Version #: " & dlvVersion.Index & vbCrLf & _
" - Modified by: " & dlvVersion.ModifiedBy & vbCrLf & _
" - Modified on: " & dlvVersion.Modified & vbCrLf & _
" - Comments: " & dlvVersion.Comments & vbCrLf
Next
Else
strVersionInfo = "Versioning not enabled for this document."
End If
'MsgBox strVersionInfo, vbInformation + vbOKOnly, "Version Information"
Set dlvVersion = Nothing
Set dlvVersions = Nothing
Call GetUserName
'message:
'MsgBox Err.Description
MsgBox ("Insert Version Number in the Header and type a Title in the [Insert Title here] on the front page. It will be automatically updated in the footer." & vbNewLine & vbNewLine & "Do Not Type in the Review and Version tables.")
End Sub
Private Function InsertVersionHistory(oVerTbl As Word.Table, oVersions As Office.DocumentLibraryVersions)
Dim rowIndex As Integer
Dim oVersion As Office.DocumentLibraryVersion
Dim oNewRow As Row
'test
Dim versionIndex As Integer
For rowIndex = 2 To oVerTbl.Rows.Count
oVerTbl.Rows.Item(2).Delete
Next rowIndex
rowIndex = 1
'test
versionIndex = oVersions.Count
For Each oVersion In oVersions
If (rowIndex > 5) Then
Return
End If
rowIndex = rowIndex + 1
oVerTbl.Rows.Add
Set oNewRow = oVerTbl.Rows(oVerTbl.Rows.Count)
oNewRow.Shading.BackgroundPatternColor = wdColorWhite
oNewRow.Range.Font.TextColor = wdBlack
oNewRow.Range.Font.Name = "Tahoma"
oNewRow.Range.Font.Bold = False
oNewRow.Range.Font.Size = 12
oNewRow.Range.ParagraphFormat.SpaceAfter = 4
With oNewRow.Cells(1)
'.Range.Text = oVersion.Index
.Range.Text = versionIndex
End With
With oNewRow.Cells(2)
.Range.Text = FormUserFullName(GetUserFullName(oVersion.ModifiedBy))
End With
With oNewRow.Cells(3)
.Range.Text = oVersion.Modified
End With
With oNewRow.Cells(4)
.Range.Text = oVersion.Comments
End With
versionIndex = versionIndex - 1
Next
Set oVersion = Nothing
End Function
Function GetUserFullName(userName As String) As String
Dim WSHnet, UserDomain, objUser
Set WSHnet = CreateObject("WScript.Network")
'UserDomain = WSHnet.UserDomain
'Set objUser = GetObject("WinNT://" & UserDomain & "/" & userName & ",user")
userName = Replace(userName, "\", "/")
Set objUser = GetObject("WinNT://" & userName & ",user")
'MsgBox objUser.FullName
GetUserFullName = objUser.FullName
End Function
Function FormUserFullName(userName As String) As String
Dim arrUserName As Variant
Dim changedUserName As String
arrUserName = Split(userName, ",")
Dim length As Integer
length = UBound(arrUserName) - LBound(arrUserName) + 1
If length >= 2 Then
changedUserName = arrUserName(1) & " " & arrUserName(0)
Else
changedUserName = userName
End If
FormUserFullName = changedUserName
End Function
Private Function GetUserName()
Dim userName As String
userName = ActiveDocument.BuiltInDocumentProperties("Author")
ActiveDocument.BuiltInDocumentProperties("Author") = FormUserFullName(userName)
End Function
I know this is old, but I was looking for the same thing and found this article. I'm still trying it out, but wanted to share before I got distracted with my real job.
From: SixSigmaGuy on microsoft.public.sharepoint.development-and-programming.narkive.com/...
Wanted to share my findings, so far. Surprisingly, I could not find
anything in the SharePoint Designer object/class that supported versions,
but the Office, Word, Excel, and PowerPoint objects do support it.. It
wasn't easy to find, but once I found it, it works great, as long as the
file in the document library is one of the Office documents.
Here's some sample code, written in Excel VBA, showing how to get the
version information for a paritcular SharePoint Document Library file
created in Excel:
Public viRow As Long
Function fCheckVersions(stFilename As String) As Boolean
' stFilename is the full URL to a document in a Document Library.
'
Dim wb As Excel.Workbook
Dim dlvVersions As Office.DocumentLibraryVersions
Dim dlvVersion As Office.DocumentLibraryVersion
Dim stExtension As String
Dim iPosExt As Long
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 1) = stFilename
If Workbooks.CanCheckOut(stFilename) = True Then
Set wb = Workbooks.Open(stFilename, , True)
Set dlvVersions = wb.DocumentLibraryVersions
If dlvVersions.IsVersioningEnabled = True Then
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 3) = "Num
Versions = " & dlvVersions.Count
For Each dlvVersion In dlvVersions
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 4) = "Version: " & dlvVersion.Index
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 5) = "Modified Date: " & dlvVersion.Modified
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 6) = "Modified by: " & dlvVersion.ModifiedBy
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 7) = "Comments: " & dlvVersion.Comments
viRow = viRow + 1
Next dlvVersion
End If
wb.Close False
End If
Set wb = Nothing
DoEvents
End Function`
Fortunately, I discovered that Excel can open non-Excel files in most
cases. I.e., I can, for example, open a jpg file in Excel and use the
dlvVersions collection for that file.
I am splitting a single MS Word document into multiple using a custom delimiter. I am able to create multiple files in MS Word format, but I want to create multiple .txt files instead.
The code that I am using now is:
Sub SplitNotes(delim As String, strFilename As String)
Dim doc As Document
Dim arrNotes
Dim I As Long
Dim X As Long
Dim Response As Integer
arrNotes = Split(ActiveDocument.Range, delim)
Response = MsgBox("This will split the document into " &
UBound(arrNotes) + 1 & " sections. Do you wish to proceed?", 4)
If Response = 7 Then Exit Sub
For I = LBound(arrNotes) To UBound(arrNotes)
If Trim(arrNotes(I)) <> "" Then
X = X + 1
Set doc = Documents.Add
doc.Range = arrNotes(I)
doc.SaveAs ThisDocument.Path & "\" & strFilename & Format(X, "000")
doc.Close True
End If
Next I
End Sub
Sub test()
' delimiter & filename
SplitNotes "%%%%%%%%%%%%%%", "Notes "
End Sub
Can anyone help me with this please?
Try this and see if it does what you want.
Sub SplitNotes(delim As String, strFilename As String)
Dim doc As Document
Dim arrNotes
Dim I As Long
Dim X As Long
Dim Response As Integer
arrNotes = Split(ActiveDocument.Range, delim)
Response = MsgBox("This will split the document into " & UBound(arrNotes) + 1 & " sections. Do you wish to proceed?", 4)
If Response = 7 Then Exit Sub
For I = LBound(arrNotes) To UBound(arrNotes)
If Trim(arrNotes(I)) <> "" Then
X = X + 1
Set doc = Documents.Add
doc.Range = arrNotes(I)
doc.SaveAs ThisDocument.Path & "\" & strFilename & ".txt"
doc.Close True
End If
Next I
End Sub
Sub test()
' delimiter & filename
SplitNotes "///", "Notes "
End Sub