I would like to clean an auto-generated Word document.
This document contains several tables and there are many blank lines between each of them. I would like to develop a macro that only keeps one blank line between each table.
I don't know if it can be done. Now I'm stuck with:
Dim i As Integer
Dim tTable As Table
For i = 0 To ActiveDocument.Tables.Count
Set tTable = ActiveDocument.Tables.Item(i)
' ???
Next
Any idea?
I found how to do that:
Dim ParagraphToTrim As Range
Dim tTable As Table
Dim aTables() As Table
Set aTables = ActiveDocument.Tables
For Each tTable In aTables
' Supply a Start and End value for the Range.
Set ParagraphToTrim = ActiveDocument.Range(tTable.Range.Next(Unit:=wdParagraph).Start, tTable.Range.Next(Unit:=wdTable).Start)
' Keep at least a paragraph between each table
If ParagraphToTrim.Paragraphs.Count > 1 Then
With ParagraphToTrim
' Change the start of the range
.MoveStart Unit:=wdParagraph
.Delete
End With
End If
Next
Related
This is a follow on from a question I asked here > Converting an HTML table to JSON to pass to an AJAX call for downloading as a CSV
I have a report page that outputs a number of recordsets as graphs and tables but also buttons to "download as a CSV file" I have a generic function that will take any number of recordsets (as the stored proc returns multiple recordsets) and outputs a CSV so thats fine.
The issue is I want to set the output of my stored proc into a Session("DATA") variable and then create a "copy" of the data in memory so that whenever the "download" button is pressed I can just look for a Session("DATA") variable and output it if it exists.
The problem is that when I set a recordset object to point at the Session it is referential so that once it has looped through all the recordsets outputting them on the page the Session is then empty (or at the end of all the recordsets - so it's an object with no data in it)
How can I Create a "copy" of the recordset instead of a pointer so that the Session always has the full recordset in it e.g
Set Session("DATA") = objCon.Execute(strSQL) '* returns multiple recordsets
Set objRS = Session("DATA")
Do While Not objRS.EOF......
'* BUT now when I want to access Session("DATA") it is at the start of all the recordsets and not a spent, EOF of the last recordset due to me looping through objRS
I could have a function that loops through the recordsets and makes a duplicate but then that seems like a lot of effort and performance and I thought there must be a way to copy the recordsets for the session somehow without looping through it multiple times.
If I have to create a "Copy" object function then I suppose I will have to but is there not an easier way in ASP CLASSIC to create a copy of an object and not a reference pointer?
You can read the entire recordset into an array, using GetRows:
'GetDataSet
' Returns a table of data based on the supplied SQL statement and connection string.
'Parameters:
' sqlString (string) - The SQL string to be sent. This can be either a valid SQL string or an Application setting
' specified using the '#' prefix (e.g. #GET_USERNAME)
' connString (string) - The database connection string. Either a valid connection string, an Application setting
' (using the '#' prefix, e.g. #CONN_STRING) or an AMC (AppModeConnection string).
'Usage:
' dataSet = GetDataSet(sqlString, connString)
'Description:
' This function generates a table of information in a 2 dimensional array. The first dimension represents the columns
' and the second the rows. If an error occurs while the routine is executing the array and the base index (0,0) is set
' to C_ERROR, (0,1) to the VBScript error index, and (0,2) to the VBScript error description.
'Notes:
' Updated this function to take advantage of the AppModeConnection feature.
'Revisions:
' 30/09/2015 1.1 Added facility to allow recovery of Application settings as Query and connection strings using
' '#', (e.g.: ds = GetDataSet("#GET_USER_DETAIL", "#CONN_DATABASE")
' 25/09/2015 1.0 Added AMC support for Classic ASP. The system will test to see if there is a valid connection
' string based on the current application mode and the connection string provided (e.g. if the
' connection string is 'CONN_DATABASE' and the application mode is 'DEV' then the final connection
' string will be 'CONN_DATABASE_DEV'. A connection string should be present to cover this.
' < 25/09/2015 0.1 Bug ironed out that prevented closing of the database.
' < 25/09/2015 0.0 Initial version.
function GetDataSet(ByVal sqlString, ByVal connString)
'Test to see if there's an application connection string first...
If Left(connString, 1) = "#" Then
connString = Application(Mid(connString, 2))
Else
Dim amc
amc = AppModeConnection(connString)
If amc <> "" then connString = amc
End If
'Test the SQL string to see if it's stored as an Application setting...
If Left(sqlString, 1) = "#" Then sqlString = Application(Mid(sqlString, 2))
'Define the initial output...
dim rV, rs
If (Application("APP_MODE") = Application("MODE_DEV") And Application("DEV_TRAP_ERRORS")) Or _
(Application("APP_MODE") <> Application("MODE_DEV")) Then On Error Resume Next
'Define and open the recordset object...
set rs = Server.CreateObject("ADODB.RecordSet")
rs.Open sqlString, connString, 0, 1, 1
'Initialise an empty value for the containing array...
redim rV(0,0)
rV(0,0) = C_NO_DATA
'Deal with any errors...
if not rs.EOF and not rs.BOF then
'Store the data...
rV = rs.GetRows()
'Tidy up...
rs.close
set rs = nothing
select case err.number
case 3021 'No data returned
'Do nothing as the initial value will still exist (C_NO_DATA)
case 0 'No error
'Do nothing as data has been returned
case else
redim rV(4,0)
rV(C_COL_IDENTIFIER,0) = C_ERROR
rV(C_COL_ERROR_ID,0) = err.number
rV(C_COL_ERROR_MESSAGE,0) = err.description
rV(C_COL_SQL,0) = sqlString
rV(C_COL_CONNECTION,0) = "Withheld"
end select
end if
on error goto 0
'Return the array...
GetDataSet = rV
end function
This is my own in depth version which does some funky stuff with connection strings etc, so feel free to use it, but note that you'll have to set-up the handling for the connection strings etc. Within the code, though, is the core element - the GetRows, that you require.
You shouldn't need to set any Session variables, simply process all in the same page, as per marekful's answer to your post. You can do this using a simple For...Next loop using an array.
To use the function above simply declare your SQL and call it like so...
Dim ds, sql
sql = "EXEC prc_get_report_data "
ds = GetDataSet(sql, "#my_conn")
(Note: read the code comments about the connection strings).
The array returned from this is obviously two dimensional zero based, where x = columns, y = rows:
ds(x, y)
What I tend to do is define constants to cover the column names, matching them to the equivalents in the database...
Const COL_ID = 0 'Column 0 is the ID field (note zero based)
Const COL_TITLE = 1 'Title field
Const COL_DESCRIPTION = 2 'Description field
...and so on.
Then you can reference them eaasily:
If ds(COL_ID, row) = 14 Then
Use the UBound function to get the extents of the array...
Dim row, rows
For rows = 0 To UBound(ds, 2) '2 is the second dimension of the array (note not zero based
If ds(COL_ID, row) = avalue Then
You get the idea.
Say I've got your standard MSFlexGrid. I have an image in a cell that already has a tooltip.
What I want to do is store a string about the image in the cell that's associated with the cell but is not displayed to the end user.
I've been looking at the properties on the MSDN website but I didn't see anything that would work.
Is this possible? Has anyone done something similar before? I'm not opposed to using properties that were not necessarily designed for data storage in this sense provided they're not being used already, but obviously this is not desirable.
So here's what I did for those who may be looking to do the same. It's not elegant, it's not pretty, but it works.
Private m_colImageInfo As Collection ' dictionary to store image name Key="Index^m_Tracker Row^Column" Value=IconKey
Private m_colImageInfoSorted As Collection ' Dictionary to store image name Key="Index^FG Row^Column" Value=IconKey
Private m_colSortRowInfo As ACCollection ' How the row changes
I have a function, called DoDisplay() that gets called everytime the grid is refreshed or initially displayed.
In it, I clear the m_colSortRowInfo Collection (ACCollection is just a wrapper we've built).
Call m_colSortRowInfo.Clear ' Note ACCollection allows the use of Clear
Now in do display we're grabbing data from the model, and get the actual image with the first DoAction call, and then get the image key (unique identifier about the image) with the second call.
Set oImage = m_Tracker2.DoAction(TS_ACTION_GET_COL_ICON, lRow, lColumn, False) 'Retrieve the icon image ' get the image
sString = m_Tracker2.DoAction(TS_ACTION_GET_COL_ICON, lRow, lColumn, True)
If Len(sString) > 0 Then
On Error Resume Next
Call m_colSortRowInfo.Add(CStr(.Index & "^" & lRow & "^" & .Col)) ' lets store the old key as a value for later access
Call m_colImageInfo.Add(sString, CStr(.Index & "^" & lRow & "^" & .Col))
On Error GoTo 0
End If
Then I add the icon key to m_colImageInfo as the Collection's "item" and the key being the grid Index^m_TrackerRow^Column.
To the m_colSortRowInfo I set the the same value (Index^m_TrackerRow^Column) as the item and then the key is just a simple iterative index.
Now the problem I was encountering was that these images exist in the grid, but I don't know anything about them besides that the cell contains, or doesn't contain an image / text. I need to associate the icon key with the image for reasons irrelevant to this post.
So now, we've gotten the grid, row and column of the model that the image is in, but we don't know where it actually lies in the grid. The column stays the same, but based on how the user has sorted the grid, the rows can change. This is the key challenge.
We have a way to map the model grid row to a specific MSFlexGrid row. I use that in the method below to populate m_colImageInfoSorted, which is the actual representation of each image in the grid.
'------------------------------------------------------------------
' NAME: SortImageCollection (PRIVATE)
' DESCRIPTION: When we first create the flex grid we pull the images from
' the image provider service and scale them up unfortunately there is
' no reference to the image that gets back. So what we do is create a
' collection to keep track of the image location and then send it to
' the printing class. If the grid has been sorted however, we need to
' identify where that picture moved too. This sub serves that purpose.
' KEYWORDS: sort, icon, collection, image
' CALLED BY: DoDisplay
' PARAMETERS:
' Index (I,REQ) - FlexGrid index
' RETURNS: nothing
' ASSUMES:
' SIDE EFFECTS: populates m_colImageInfoSorted with image keys in the fg grid
' with index passed to the function
'------------------------------------------------------------------
Private Sub SortImageCollection(Index As Integer)
Dim lCnt As Long
Dim lNumImages As Long
Dim lColumn As Long
Dim lRow As Long
Dim lOldRow As Long
Dim lCurGrid As Long
Dim sTempIconStr As String
Dim sOldKey As String
Dim sNewKey As String
Set m_colImageInfoSorted = Nothing
Set m_colImageInfoSorted = New Collection
With fgFlexGrid(Index)
For lNumImages = 1 To m_colSortRowInfo.Count ' we will loop over all the images
lCurGrid = CLng(Piece(m_colSortRowInfo.ItemVar(lNumImages), "^", 1, False)) ' if the grid is the grid we we asked for, then continue
If (lCurGrid = Index) Then ' we are just sorting images for this grid
For lCnt = 1 To m_lPatientRows(Index)
On Error Resume Next
lOldRow = CLng(Piece(m_colSortRowInfo.ItemVar(lNumImages), "^", 2, False)) ' get the m_tracker row we stored earlier
lRow = getRowFromFlexGrid(Index, lCnt) '
sOldKey = m_colSortRowInfo.ItemVar(lNumImages) ' get the old key
lColumn = Piece(sOldKey, "^", 3, False)
sTempIconStr = m_colImageInfo.Item(CStr(Index & "^" & lRow & "^" & lColumn)) '
sNewKey = CStr(.Index & "^" & lCnt & "^" & lColumn) ' get the column, add to new key
If (Len(sTempIconStr)) > 0 Then ' if we have an image (didn't already remove it)
Call m_colImageInfoSorted.Add(sTempIconStr, sNewKey) ' Add the new image location
End If
On Error GoTo 0
Next lCnt
End If
Next lNumImages
End With
End Sub
And wahlah, the call to the sub is all it takes:
Call SortImageCollection(Index)
I know that the SortImageCollection() sub is not the most efficient. If there is a better way to do this mapping, let me know, I'm interested in the response, but this is working well, and has no apparent slow down from an end user perspective so I'm happy with it.
I am trying to remove duplicates from array using for loop and conditional statement.But I am unable to create new array without any duplicates.There is xls having country name with duplicates,i am aiming to remove duplicates and create a new array with unique country names.
For e.g
strFilePath="D:\Country.xls"
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible=True
Set objWorkbook = objExcel.Workbooks.Open (strFilePath)
Set objSheet=objExcel.Sheets("Country")
objExcel.DisplayAlerts = False
objExcel.AskToUpdateLinks = False
objExcel.AlertBeforeOverwriting = False
Dim A(100)
Dim B(100)
For i = 2 To 6 Step 1
k = i-2
A(k)=objSheet.Cells(i,1).Value
Next
B(0)=A(0)
For j = 0 To 4 Step 1
strIt=A(j)
For m = 1 To 4 Step 1
reslt = StrComp(A(m),strIt,1)
If(reslt = 1 Or reslt = -1) Then
c=1
B(c)=A(m)
c=c+1
End if
m=m+1
Next
Next
Two options, depending on your needs:
Try using a hash table of the country names. When entering values in to the hash table you could do a simultaneous check to see whether you encounter an identical value. If it finds one it will abort entering the new value and continue with the next one, otherwise it will be entered in to the table. At the end of it you will have your list of unique country names.
Sort the list of countries and then do a second pass that removes duplicate countries (since duplicates will now be grouped together)
Problems with both of these methods is that they dont preserve original order unless you keep some sort of "original index" value and then sort based on that value once you remove duplicates.
Here's how I usually do it:
Dim uniqueentries()
ReDim uniqueentries(-1)
' Here you could go through your existing array and
' call "GetUniqueEntries" sub on each entry, e.g.
For Each i In oldarray
GetUniqueEntries i
Next
Sub GetUniqueEntries(newentry)
Dim entry
If UBound(uniqueentries) >= 0 Then ' Only check if uniqieentries contains any entries
For Each entry In uniqueentries
If newentry = entry Then Exit Sub ' If the entry you're testing already exists in array then exit sub
Next
End If
ReDim Preserve uniqueentries(UBound(uniqueentries) + 1) ' Increase new array size
uniqueentries(UBound(uniqueentries)) = newentry ' Add unique entry to new array
End Sub
This could be done more simpler way by using Split command. Please check the below solution, if any clarification let me know.
Dim aDupl
Dim aNew, strNew
aDupl = Array("A", "B", "A", "D", "C", "D")
strNew = ""
For iCnt= 0 To UBound(aDupl)
If InStr(strNew,aDupl(iCnt) ) = 0 Then
strNew =strNew&aDupl(iCnt)&","
End If
Next
aNew = Split(strNew, ",")
For iCnt=0 To UBound(aNew)
WScript.Echo aNew(iCnt)
Next
I need to place three objects on my .doc in this order:
One Picutre;
Some Text;
One Table;
I recently learned how to place the image where I want (top of the doc).
But now, the table is getting in the middle of the text, how may I set the text with something like Position Absolute and then the Table below the text ?!
My Currently code:
Private Sub Command1_Click()
Dim Word_App As Word.Application
Dim Word_Doc As Word.Document
Dim Word_Table As Word.Table
Dim Word_Range As Word.Range
Dim iCount As Integer
'Insert the image
Word_App.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Word_App.Selection.InlineShapes.AddPicture FileName:="C:\p\53.jpg", SaveWithDocument:=True
Word_App.Selection.TypeParagraph
With Word_App
'Here I place some text
End With
'Insert Table
Set Word_Table = Word_Doc.Tables.Add(Range:=Word_Doc.Range(Start:=20, End:=20), NumRows:=3, NumColumns:=4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed)
Word_Doc.SaveAs FileName:="C:\p\TestandoPicture"
Set Word_Table = Nothing
Set Word_App = Nothing
Set Word_Doc = Nothing
End Sub
Here is an example of the result:
Notice that: In my code, I typed the position for my table Start:=20, End:=20 and it's in the 20th position of character... But i'd like to place it below the text... Wich is the best way to do so ?
Highlight the text, do a word count on the highlighted text, then use the character count from that to position your table. Crude but effective.
I am not sure if this is possible or not. I am not even sure where to begin. I have a couple thousand files where the file names are named as so:
nnnnnnnnnnnnnnnn.yyyyddmm.pdf (n = number, yyyy = year, dd = day, and mm = month).
Within these thousands of files, there are batches of alike files that have the same nnnnnnnnnnnnnnnnnn part of the filename but the .yyyyddmm is different in order to represent the date of the file. (These batches of alike files will be merged together at a later point but that is not important to this scenario).
My question is, Is there a way to compare the yyyyddmm part of the alike files and have the most recent date files get copied to a different folder? I need the file that has the most recent date of the alike files on the filename get copied to a different folder.
The reason that I am having issues with this is because I am not sure if it is possible to compare parts of the filename to see which one is in fact the file that has the most recent date. I know that there is a way that this can be done through looking at the date modified date but this will not always give me the alike file with the most recent date.
Any thoughts?? Please let me know if I could provide more information.
Trying to understand your problem/specs. Assume a loop over the files of your .pdf folder results in:
Looking at "0000000000012345.20120402.pdf"
Looking at "0000000000012345.20120502.pdf"
Looking at "0000000000012348.20121702.pdf"
Looking at "0000000000012346.20120802.pdf"
Looking at "0000000000012347.20121002.pdf"
Looking at "0000000000012348.20121602.pdf"
Looking at "0000000000012347.20121302.pdf"
Looking at "0000000000012347.20121202.pdf"
Looking at "0000000000012345.20120202.pdf"
Looking at "0000000000012348.20121502.pdf"
Looking at "0000000000012346.20120602.pdf"
Looking at "0000000000012346.20120902.pdf"
Looking at "0000000000012348.20121402.pdf"
Looking at "0000000000012346.20120702.pdf"
Looking at "0000000000012347.20121102.pdf"
Looking at "0000000000012345.20120302.pdf"
Would
Last file for 0000000000012345 is 0000000000012345.20120502.pdf
Last file for 0000000000012348 is 0000000000012348.20121702.pdf
Last file for 0000000000012346 is 0000000000012346.20120902.pdf
Last file for 0000000000012347 is 0000000000012347.20121302.pdf
identify the files to copy correctly? If yes, say so and I will post the code here.
First, you need a class to obtain and store the info put into the file names:
' cut & store info about file(names) like "0000000000012347.20121202.pdf"
Class cCut
Private m_sN ' complete file name
Private m_sG ' group/number prefix part
Private m_dtF ' date part; converted to ease comparisons
Public Function cut(reCut, sFiNa)
Set cut = Me ' return self/this from function
Dim oMTS : Set oMTS = reCut.Execute(sFiNa)
If 1 = oMTS.Count Then
m_sN = sFiNa
Dim oSM : Set oSM = oMTS(0).SubMatches
m_sG = oSM(0)
m_dtF = DateSerial(oSM(1), oSM(3), oSM(2))
Else
' Err.Raise
End If
End Function ' cut
Public Property Get G() : G = m_sG : End Property ' G
Public Property Get D() : D = m_dtF : End Property ' D
Public Property Get N() : N = m_sN : End Property ' N
End Class ' cCut
Then just loop over the .Files and check the date parts for each group stored in a dictionary (number prefix part used as key):
' The one and only .pdf folder - no recursion into subfolders!
Dim sTDir : sTDir = "..\data\test"
' dictionary to store the last/most recently used file for each group
Dim dicG : Set dicG = CreateObject("Scripting.Dictionary")
' RegExp to cut/parse file names like "0000000000012345.20120402.pdf"
Dim reCut : Set reCut = New RegExp
reCut.Pattern = "^(\d{16})\.(\d{4})(\d{2})(\d{2})\.pdf$"
Dim oFile
For Each oFile In goFS.GetFolder(sTDir).Files
WScript.Echo "Looking at", qq(oFile.Name)
' an oCut object for each file name
Dim oCut : Set oCut = New cCut.cut(reCut, oFile.Name)
If Not dicG.Exists(oCut.G) Then
' new group, first file, assume this is the latest
Set dicG(oCut.G) = oCut
Else
' found a better one for this group?
If dicG(oCut.G).D < oCut.D Then Set dicG(oCut.G) = oCut
End If
Next
WScript.Echo "-----------------------"
Dim sG
For Each sG In dicG.Keys
WScript.Echo "Last file for", sG, "is", dicG(sG).N
Next
WRT comments:
All my (ad hoc/proof of concept) scripts start with
Option Explicit
Dim goFS : Set goFS = CreateObject( "Scripting.FileSystemObject" )
and contain some functions dealing with different aspects/stragegies for a solution to a common problem/topic. When I post code here, I copy/paste working/tested code out of the middle of a function frame like
' ============================================================================
goXPLLib.Add _
"useDic02", "use a dictionary (Mark II)"
' ----------------------------------------------------------------------------
' ============================================================================
Function useDic02()
useDic02 = 1 ' assume error
' The one and only .pdf folder - no recursion into subfolders!
...
Next
useDic02 = 0 ' success
End Function ' useDic02
(yes, there is a first attempt function "useDic()" that was guilty of storing all the oCuts for each group to be processed in a second loop; yes, there is a function "createTestData()" I needed to set up/fill my TDir). Sometimes I'm sloppy and forget about goFS, please accept my apologies.
The variable names are part of an experiment. I used to advocate type-prefixed long variable names upto and including
Dim nIdx
For nIdx = 0 To UBound(aNames)
aNames(nIdx) = ...
Next
Other people argued that nIdx-alikes variables just add some letters to mistype but no additional meaning over i, and that aNames-alikes can't be understood without the context and if you have that, aN would be a just as good remainder for "The first names of the kings of persia from the currently processed file to be compared to the names in the database".
So I thought: Given that there are 3 interesting aspects of a file name (full name to copy, number prefix to group, date part to compare/decide) and that there is half a screen between
Private m_sN ' complete file name
and
Public Property Get N() : N = m_sN : End Property ' N
and given that you need just those 3 properties of the Cut object to use it in
Dim oCut : Set oCut = New cCut.cut(reCut, oFile.Name)
If Not dicG.Exists(oCut.G) Then
' new group, first file, assume this is the latest
Set dicG(oCut.G) = oCut
Else
' found a better one for this group?
If dicG(oCut.G).D < oCut.D Then Set dicG(oCut.G) = oCut
will the average short time memory cope with oCut.D?
Obviously not.
To copy the selected files:
Assuming you want the files copied to an existing folder "..\data\latest", use
goFS.CopyFile goFS.BuildPath(sTDir, dicG(sG).N), "..\data\latest\", True
instead of/in addition to the line
WScript.Echo "Last file for", sG, "is", dicG(sG).N
I did not anticipate that .CopyFile chokes on relative source pathes; so consider replacing the *N*ame property of the cCut class with a *P*ath property.
Trying to use
dicG(sG).Copy "..\data\latest\", True
results in:
Microsoft VBScript runtime error: Object doesn't support this property or method: 'dicG(...).Copy'
because the objects stored aren't files (which have a .Copy method), but cCuts (which don't).
How I would handle it:
I would make a dictionary with for each unique number part a separate key. The value will be an array with all file names sharing that key (and thus sharing the unique number part)
For each key in the dictionary, I will loop through the items in the array, searching for the most recent date.
Approach:
Get a file
Extract number part
See if a key for that number part exist. If not create a key for that number with an empty array as value
Add the filename as a new item to the array
Loop to 1. until all files are handled
Get a key
Get the first file in the attached array. Remember the date and the arrayindex
Get the next file, if the date is higher than the remembered date, update the date to this date and the arrayindex to this array index
Loop to 8. until the end of the array is reached
Store the file with the arrayindex as the most recent file for that unique number
loop to 6. until all keys are handled