How to embed large (max 10Mb) text files into an Excel file - vba

What is the best way to store a large text file (max 10Mb) in an Excel file?
I have a couple of requirements:
It has to be embedded so that the excel file can be moved and sent to a different computer and all the text files will follow.
It needs to be done from a macro.
And a macro needs to be able to read the file contents after it has been embedded.
I already tried to store it by breaking the text into several chunks enough small to fit into a cell (~32 000 chars), but it didn't work. After my macro had inserted the first 150 000 characters it gave me an "Out of Memory" error.
I remember seeing one web page with a couple of options for this I but cannot find it anymore. Any suggestions are most welcome. I will try them out if you are not sure if it works or not.

It would likely be best to simply save the .txt file alongside the Excel file, and have the macro pull the text as needed from that folder. To read more on importing files see this:
http://answers.microsoft.com/en-us/office/forum/office_2010-customize/vba-code-to-import-multiple-text-files-from/525bd388-0f7d-4b4a-89f9-310c67227458
Keeping the .txt within the Excel file itself is not necessary and will likely make it harder to transfer files in the long run. For example, if you cannot e-mail a file larger than 10MB, then you can simply break your .txt file in half and e-mail separately - using a macro which loads the text into Excel locally.

Very simple CustomXMLPart example:
Sub CustomTextTester()
Dim cxp1 As CustomXMLPart, cxp2 As CustomXMLPart
Dim txt As String
'read file content
txt = CreateObject("scripting.filesystemobject").opentextfile( _
"C:\_Stuff\test.txt").readall()
'Add a custom XML part with that content
Set cxp1 = ThisWorkbook.CustomXMLParts.Add("<myXMLPart><content><![CDATA[" & txt _
& "]]></content></myXMLPart>")
Debug.Print cxp1.SelectSingleNode("myXMLPart/content").FirstChild.NodeValue
End Sub

Consider the method shown below. It uses Caption property of Label object located on a worksheet for data storage. So you can create a number of such containers with different names.
Sub Test()
Dim sText
' create special hidden sheet for data storage
If Not IsSheetExists("storage") Then
With ThisWorkbook.Worksheets.Add()
.Name = "storage"
.Visible = xlVeryHidden
End With
End If
' create new OLE object TypeForms.Label type as container
AddContainer "test_container_"
' read text from file
sText = ReadTextFile("C:\Users\DELL\Desktop\tmp\tmp.txt", 0)
' put text into container
PutContent "test_container_", sText
' retrieve text from container
sText = GetContent("test_container_")
' show length
MsgBox Len(sText)
' remove container
RemoveContainer "test_container_"
End Sub
Function IsSheetExists(sSheetName)
Dim oSheet
For Each oSheet In ThisWorkbook.Sheets
If oSheet.Name = sSheetName Then
IsSheetExists = True
Exit Function
End If
Next
IsSheetExists = False
End Function
Sub AddContainer(sName)
With ThisWorkbook.Sheets("storage").OLEObjects.Add(ClassType:="Forms.Label.1")
.Visible = False
.Name = sName
End With
End Sub
Sub RemoveContainer(sName)
ThisWorkbook.Sheets("storage").OLEObjects.Item(sName).Delete
End Sub
Sub PutContent(sName, sContent)
ThisWorkbook.Sheets("storage").OLEObjects.Item(sName).Object.Caption = sContent
End Sub
Function GetContent(sName)
GetContent = ThisWorkbook.Sheets("storage").OLEObjects.Item(sName).Object.Caption
End Function
Function ReadTextFile(sPath, iFormat)
With CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath, 1, False, iFormat)
ReadTextFile = ""
If Not .AtEndOfStream Then ReadTextFile = .ReadAll
.Close
End With
End Function

Related

Insert RichText (From RichTextBox, RTF File, OR Clipboard) into Word Document (Bookmarks or Find/Replace)

To summarize what I'm attempting to do, I work for a non-profit organization that sends out acknowledgement letters when someone donates money to us (a thank you, basically). We have multiple different letters that are written every month and sent to IS to "process". I would like to make this as efficient and use as little time as possible for IS, so I've created a program in VB.NET that takes content and pastes it into a template using Word bookmarks, updates a table in SQL so that the letter can be tested with live data, and sends an e-mail to the Production department letting them know to test the letter. It works fully, except...
I cannot for the life of me figure out how to retain RTF (RichText) when I insert the content into the letter template.
I've tried saving the content of the RichTextBox as an RTF file, but I can't figure out how to insert the RTF file contents into my document template and replace the bookmark.
I've tried using the Clipboard.SetText, odoc......Paste method, but it's unreliable as I can't accurately state where I'd like the text to paste. The find/replace function isn't very helpful because all of the bookmarks I'm trying to replace are within text boxes.
I'd show some code, but most of it has been deleted out of frustration for not working. Either way, here's some code I've been working with:
Private Sub testing()
strTemplateLocation = "\\SERVER\AcknowledgementLetters\TEST\TEMPLATE.dot"
Dim Selection As Word.Selection
Dim goWord As Word.Application
Dim odoc As Word.Document
goWord = CreateObject("Word.Application")
goWord.Visible = True
odoc = goWord.Documents.Add(strTemplateLocation)
Clipboard.Clear()
Clipboard.SetText(txtPreD.Rtf, TextDataFormat.Rtf)
odoc.Content.Find.Execute(FindText:="<fp>", ReplaceWith:=My.Computer.Clipboard.GetText)
'Code for looping through all MS Word Textboxes, but didn't produce desired results
For Each oCtl As Shape In odoc.Shapes
If oCtl.Type = Microsoft.Office.Core.MsoShapeType.msoTextBox Then
oCtl.TextFrame.TextRange.Text.Replace("<fp>", "Test")
goWord.Selection.Paste()
End If
Next
'Clipboard.Clear()
'Clipboard.SetText(txtPostD.Rtf, TextDataFormat.Rtf)
'odoc.Content.Find.Execute(FindText:="<bp>", ReplaceWith:="")
'goWord.Selection.Paste()
MsgBox("Click Ok when finished checking.")
odoc.SaveAs2("\\SERVER\AcknowledgementLetters\TEST\TEST.docx")
odoc = Nothing
goWord.Quit(False)
odoc = Nothing
goWord = Nothing
End Sub
...and here is the default code for setting bookmarks. This works perfectly as long as formatting is not required:
Private Sub SetBookmark(odoc As Object, strBookmark As String, strValue As String)
Dim bookMarkRange As Object
If odoc.Bookmarks.Exists(strBookmark) = False Then
Exit Sub
End If
bookMarkRange = odoc.Bookmarks(strBookmark).Range
If ((Err.Number = 0) And (Not (bookMarkRange Is Nothing))) Then
bookMarkRange.text = strValue
odoc.Bookmarks.Add(strBookmark, bookMarkRange)
bookMarkRange = Nothing
End If
End Sub
TL;DR - Need formatted text (Example: "TEST") to be inserted into a Word document either as a bookmark or as a replacement text.
Expected results: Replace "fp" (front page) bookmark with "TEST" including bold formatting.
Actual results: "fp" is not replaced (when using clipboard and find/replace method), or is replaced as "TEST" with no formatting.
I figured it out! I had to do it a weird way, but it works.
The following code saves the RichTextBox as an .rtf file:
RichTextBoxName.SaveFile("temp .rtf file location")
I then used the following code to insert the .rtf file into the bookmark:
goWord.ActiveDocument.Bookmarks("BookmarkName").Select()
goWord.Selection.InsertFile(FileName:="temp .rtf file location")
I then deleted the temp files:
If My.Computer.FileSystem.FileExists("temp .rtf file location") Then
My.Computer.FileSystem.DeleteFile("\temp .rtf file location")
End If

Remove all macros from a visio 2013 file

I have a Viso 2013 .vstm file that launches a VBA macro on document creation (template instanciation when a user opens the template manually). This macro populates the created drawing from a datasource. When finished, I would like to save programatically (from VBA) the drawing that has been generated as a .vsdx file, i.e. with all VBA macros that were used to populate the drawing being removed.
My questions are:
Is it possible to remove all macros programatically from a VBA macro (Visio 2013) which is in the .vstm file itself without causing the VBA Macro to fail and if yes, how can I do it ?
If 1. is not possible, how can I force programatically Visio to save to .vsdx a drawing that has macros (i.e. save ignoring all macros)
If 2. is not possible, how can I copy current drawing (everything except macros) to a new Drawing which should then be savable to .vsdx?
I have tried the following:
Deleting all lines with VBProject.VBComponents.Item(index).CodeModule.DeleteLines causes the macro to fail with "End Function is missing" (I have checked and there is no missing End Function anywhere, my guess is that the macro probably deletes the code that hasn't been executed yet, which in turn causes this error)
Save and SaveEX do not work either, I get a "VBProjects cannot be saved in macro-free files" error/message, even if I add a Application.AlertResponse = IDOK prior to the call to Save / SaveEx.
Here follows a sample code.
Private Sub RemoveVBACode()
' If document is a drawing remove all VBA code
' Works fine however execution fails as all code has been deleted (issue 1)
If ActiveDocument.Type = visTypeDrawing Then
Dim i As Integer
With ActiveDocument.VBProject
For i = .VBComponents.Count To 1 Step -1
.VBComponents.Item(i).CodeModule.DeleteLines 1, .VBComponents.Item(i).CodeModule.CountOfLines
Next i
End With
On Error GoTo 0
End If
End Sub
Private Sub SaveAsVSDX(strDataFilePath As String)
RemoveVBACode
Application.AlertResponse = IDOK
' Next line fails at runtime (issue 2), the same occurs when using Save
ThisDocument.SaveAsEx strDataFilePath, visSaveAsWS + visSaveAsListInMRU
Application.AlertResponse = 0
End Sub
The code that starts the execution of the Macro is the following event:
' This procedure runs when a Visio document is
' created. I.e., when the template (.vstm) is opened.
Private Sub Document_DocumentCreated(ByVal Doc As IVDocument)
' ...
SaveAsVSDX (strDataFilePath)
' ...
End Sub
I finally found a way to achieve what I wanted : generate a macro-less visio drawing, from a macro-enabled drawing.
What IS NOT possible from my understanding :
Have vba code that removes modules / class modules that is launched through an event such as Document_DocumentCreated. The best I could achieve is to remove the content of ThisDocument vba visio object, but all code in modules / class modules were not removable (note that if the macro is called manually, everything works like a charm, but this was not what I wanted to achieve).
Saving a a drawing instanciated from a vstm template as a macro-less vsdx file.
What IS possible (and is my solution to the third part of the question) :
Instead of loading datasource into the drawing instanciated from the vstm file, have the macro do the following:
select all shapes that appear on the page of the drawing that has been instanciated
group them
copy them
create a new Document
setup the page of the new document (orientation, size, disable snapping and gluing)
paste the group into the first page of the newly created document
center the drawing on the new document
Then load the datasource into the newly created document and link data to existing Shapes
Finaly you can save the new document as vsdx
With lots of shapes (more than 400) this takes some time (around 10 seconds), but it works.
Here is the code of the class module that generates the document.
Option Explicit
'Declare private variables accessible only from within this class
Private m_document As Document
Private m_dataSource As DataSourceFile
Private m_longDataRecordsetID As Long
Public Function Document() As Document
Set Document = m_document
End Function
Private Sub CreateDocument()
' I consider here that the active window is displaying the diagram to
' be copied
ActiveWindow.ViewFit = visFitPage
ActiveWindow.SelectAll
Dim activeGroup As Shape
Set activeGroup = ActiveWindow.Selection.Group
activeGroup.Copy
ActiveWindow.DeselectAll
Set m_document = Application.Documents.Add("")
' I need an A4 document
m_document.Pages(1).PageSheet.CellsSRC(visSectionObject, visRowPage, visPageWidth).FormulaU = "297 mm"
m_document.Pages(1).PageSheet.CellsSRC(visSectionObject, visRowPage, visPageHeight).FormulaU = "210 mm"
m_document.Pages(1).PageSheet.CellsSRC(visSectionObject, visRowPrintProperties, visPrintPropertiesPageOrientation).FormulaForceU = "2"
m_document.Pages(1).PageSheet.CellsSRC(visSectionObject, visRowPrintProperties, visPrintPropertiesPaperKind).FormulaForceU = "9"
m_document.SnapEnabled = False
m_document.GlueEnabled = False
m_document.Pages(1).Paste
m_document.Pages(1).CenterDrawing
End Sub
Private Sub LoadDataSource()
Dim strConnection As String
Dim strCommand As String
Dim vsoDataRecordset As Visio.DataRecordset
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "User ID=Admin;" _
& "Data Source=" + m_dataSource.DataSourcePath + ";" _
& "Mode=Read;" _
& "Extended Properties=""HDR=YES;IMEX=1;MaxScanRows=0;Excel 12.0;"";" _
& "Jet OLEDB:Engine Type=34;"
strCommand = "SELECT * FROM [Data$]"
Set vsoDataRecordset = m_document.DataRecordsets.Add(strConnection, strCommand, 0, "Data")
m_longDataRecordsetID = vsoDataRecordset.ID
End Sub
Private Function CheckDataSourceCompatibility() As Boolean
Dim visRecordsets As Visio.DataRecordsets
Dim varRowData As Variant
Set visRecordsets = m_document.DataRecordsets
varRowData = visRecordsets(1).GetRowData(1)
If varRowData(3) = "0.6" Then
CheckDataSourceCompatibility = True
Else
MsgBox "Using invalid DataSource version, aborting. You shoud use data format version 0.6."
CheckDataSourceCompatibility = False
End If
End Function
Private Sub LinkDataToShapes()
Application.ActiveWindow.SelectAll
Dim ColumnNames(1) As String
Dim FieldTypes(1) As Long
Dim FieldNames(1) As String
Dim IDsofLinkedShapes() As Long
ColumnNames(0) = "ID"
FieldTypes(0) = Visio.VisAutoLinkFieldTypes.visAutoLinkCustPropsLabel
FieldNames(0) = "ID"
Application.ActiveWindow.Selection.AutomaticLink m_longDataRecordsetID, ColumnNames, FieldTypes, FieldNames, 10, IDsofLinkedShapes
Application.ActiveWindow.DeselectAll
End Sub
Public Function GenerateFrom(dataSource As DataSourceFile) As Boolean
Set m_dataSource = dataSource
'Store diagram services
Dim DiagramServices As Integer
DiagramServices = ActiveDocument.DiagramServicesEnabled
ActiveDocument.DiagramServicesEnabled = visServiceVersion140
' Create a new document that contains only shapes
CreateDocument
' Load datasource
LoadDataSource
' Check datasource conformity
If CheckDataSourceCompatibility Then
' Link data recordset to Visio shapes
LinkDataToShapes
GenerateFrom = True
Else
GenerateFrom = False
End If
'Restore diagram services
ActiveDocument.DiagramServicesEnabled = DiagramServices
End Function
Hope this helps.

VBA Edit 3rd line of a Text File

I currently have a text file (c:\temp\temp.txt) and I want to be able to use VBA to edit the file and and wipe out the 3rd row of string data (it's variable so I don't know what it will say) but keep the rest of the rows of text intact.
I've been trying to figure it out, it seems like I have to open the file, save the entire file as a string, then close and reopen the file and edit the string and save?
Any help would be much appreciated!
Your pseudocode is pretty much what you need to do. I'd personally split on a newline and write individual lines back:
Private Sub KillLineThree(filepath As String)
With CreateObject("Scripting.FileSystemObject")
Dim lines() As String
With .OpenTextFile(filepath)
lines = Split(.ReadAll, vbCrLf)
.Close
End With
Dim i As Long
With .CreateTextFile(filepath)
For i = LBound(lines) To UBound(lines)
If i <> 2 Then .WriteLine lines(i)
Next
.Close
End With
End With
End Sub
as a shorter a bit overkill version you can use Excel
Workbooks.Open "c:\temp\temp.txt"
Rows(3).Delete
DisplayAlerts = False
ActiveWorkbook.Close True
DisplayAlerts = True

How can I use VBA to lock/unlock all fields in a Microsoft Word 2010 document?

The problem I have got is that my corporate template set uses a SaveDate field in the footer of every word document - which is used to detail when the document was saved, which ties in with our custom document management system.
Subsequently, when users want to make a PDF of an old document, using the Save As PDF function of Office 2010, the Save Date is updated - creating a PDF of the old document, but with today's date. This is wrong. We are just trying to create a true PDF version of whatever the original document has in it.
To get around this, I am writing a macro solution which locks the fields, exports the document as a PDF and then unlocks the fields again.
I have come up against an issue where I can identify and lock all fields in the headers/footers (which is actually what I'm trying to do) but to make it more robust, need to find out a way to lock ALL FIELDS in ALL SECTIONS.
Showing you my code below, how can I identify all fields in all sections? Will this have to be done using the Index facility?
Sub CPE_CustomPDFExport()
'20-02-2013
'The function of this script is to export a PDF of the active document WITHOUT updating the fields.
'This is to create a PDF of the document as it appears - to get around Microsoft Word 2010's native behaviour.
'Route errors to the correct label
'On Error GoTo errHandler
'This sub does the following:
' -1- Locks all fields in the specified ranges of the document.
' -2- Exports the document as a PDF with various arguments.
' -3- Unlocks all fields in the specified ranges again.
' -4- Opens up the PDF file to show the user that the PDF has been generated.
'Lock document fields
Call CPE_LockFields
'Export as PDF and open afterwards
Call CPE_ExportAsPDF
'Unlock document fields
Call CPE_UnlockFields
'errHandler:
' MsgBox "Error" & Str(Err) & ": " &
End Sub
Sub CPE_LockFields()
'Update MS Word status bar
Application.StatusBar = "Saving document as PDF. Please wait..."
'Update MS Word status bar
Application.StatusBar = "Locking fields in all section of the active document..."
'Declare a variable we can use to iterate through sections of the active document
Dim docSec As section
'Loop through all document sections and lock fields in the specified ranges
For Each docSec In ActiveDocument.Sections
docSec.Footers(wdHeaderFooterFirstPage).Range.fields.Locked = True
docSec.Footers(wdHeaderFooterPrimary).Range.fields.Locked = True
docSec.Footers(wdHeaderFooterEvenPages).Range.fields.Locked = True
Next
End Sub
Sub CPE_UnlockFields()
'Update MS Word status bar
Application.StatusBar = "PDF saved to DocMan Temp. Now unlocking fields in active document. Please wait..."
'Declare a variable we can use to iterate through sections of the active document
Dim docSec As section
'Loop through all document sections and unlock fields in the specified ranges
For Each docSec In ActiveDocument.Sections
docSec.Footers(wdHeaderFooterFirstPage).Range.fields.Locked = False
docSec.Footers(wdHeaderFooterPrimary).Range.fields.Locked = False
docSec.Footers(wdHeaderFooterEvenPages).Range.fields.Locked = False
Next
End Sub
Sub CPE_ExportAsPDF()
'Update MS Word status bar
Application.StatusBar = "Saving document as PDF. Please wait..."
'Chop up the filename so that we can remove the file extension (identified by everything right of the first dot)
Dim adFilename As String
adFilename = Left(ActiveDocument.FullName, (InStrRev(ActiveDocument.FullName, ".", -1, vbTextCompare) - 1)) & ".pdf"
'Export to PDF with various arguments (here we specify file name, opening after export and exporting with bookmarks)
With ActiveDocument
.ExportAsFixedFormat outPutFileName:=adFilename, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True, _
OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateWordBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
End With
'Update MS Word status bar
Application.StatusBar = "PDF saved to DocMan Temp."
End Sub
Try something like the following to get to all fields in the document, header, footer, background and main text:
Sub LockAllFieldsInDocument(poDoc As Document, Optional pbLock As Boolean = True)
Dim oRange As Range
If Not poDoc Is Nothing Then
For Each oRange In poDoc.StoryRanges
oRange.Fields.Locked = pbLock
Next
End If
Set oRange = Nothing
End Sub
Here is another way to do it. It'll select the entire document and then lock all fields, before deselecting everything.
Sub SelectUnlink()
ActiveDocument.Range(0, 0).Select
Selection.WholeStory
Selection.Range.Fields.Unlink
Selection.End = Selection.Start
End Sub

Generic Powerpoint Developer Controls Value Saving in VBA

I am looking to create a sort of Quiz using Powerpoint and I would like to save the input given by the user.
For example: If I ask the question: What is your favorite color? When they answer the question and click the next button, I would like to save the value of the textbox and append it to an output file.
I already know how to get the value and write the value to a file.
What I am looking to do is a sort of loop.
Here is the pseudo-code:
foreach(Control c in CurrentSlide.Controls)
{
File.Append(c.Value);
}
This way, no matter what controls are on the form, I want to save the value of each and every control.
Is this possible in VBA? If not, do you have any generic solutions for this situation?
Here's a more generic way of checking for each control on the slide, w/o knowing in advance how many there'll be. This assumes that you've kept the default names assigned to control shapes (TextBox1, CheckBox1 and so on). If you want to change those, you'll need to be sure that each TextBox has a name that includes at least one bit of string that's unique to it and change the code accordingly. Siddarth has already supplied code for writing to files and you said you have that under control so I'm just Debug.Printing the values here to keep the example simple.
Sub TestIt()
' Run this to test the shapes on slide 1
ProcessTheSlide ActivePresentation.Slides(1)
End Sub
Sub ProcessTheSlide(oSl As Slide)
Dim oSh As Shape
For Each oSh In oSl.Shapes
' Is it a control?
If oSh.Type = 12 Then ' msoOLEControlObject
On Error Resume Next
With oSh.OLEFormat.Object
If InStr(.Name, "TextBox") > 0 Then
Debug.Print .Text
End If
If InStr(.Name, "CheckBox") > 0 Then
Debug.Print .Value
End If
End With
End If
Next
End Sub
Is this possible in VBA?
Yes it is :)
On your presentation, Place 1 TextBox and two Command Buttons. Your presentation should look like this.
In the VBA Editor paste this code
Option Explicit
'~~> Save data to file
Private Sub CommandButton1_Click()
Dim filesize As Integer
Dim FlName As String
'~~> text File where you want to save the data
FlName = "C:\Sample.Txt"
'~~> Get a free file handle
filesize = FreeFile()
'~~> Open your file
Open FlName For Append As #filesize
'~~> Export Text
Print #filesize, TextBox1.Text
Close #filesize
TextBox1.Text = ""
End Sub
'~~> Exit Show
Private Sub CommandButton2_Click()
SlideShowWindows(1).View.Exit
End Sub
Now when you run it and click on "Next", the data will automatically be saved in the text file.
And this is how your text file will look...
HTH