Friday, February 10, 2017

Need macro to split large word doc by headings - Page 2

Attribute VB_Name = "SPLIT_BY_HEADINGS" Option Explicit Const levels = 2 ''Levels to consider in parsing Dim level() As Integer ''Level counter- reset lower levels at each turn of a higher level Sub SplitByPara() Dim I As Integer ''counter variable Dim Para As Paragraph ''loop para Dim ParaLast As Paragraph ''last paragraph the caught flac Dim paraPriev As Paragraph ''paragraph from previous loop Dim aDoc As Document ''active document Dim FP As String ''File Path Set aDoc = ActiveDocument ''abbreviated active document FP = aDoc.Path & "\" & StrFormat(aDoc.Name) NewFolder FP ''Call to new folder- open folder or bring focus to front ReDim level(1 To levels) Set ParaLast = aDoc.Paragraphs.First ''prime paragraphs for loop Set paraPriev = aDoc.Paragraphs.First ''prime paragraphs for loop '''Iterate through paragraphs in current document''' For I = 2 To aDoc.Paragraphs.Count ''paras from next-to-last to first Set Para = aDoc.Paragraphs(I) 'If aDoc.Paragraphs.Count = 1 Or _ ' (Parastyles(Para, Array("Heading 1*", "Heading 2*", "*Appendix*")) _ ' And Para.Range.Text > "") _ ' Then If (Parastyles(Para, Array("Heading 1*", "Heading 2*", "*Appendix*")) _ And Para.Range.Text > "") _ Then '''copy form para2 to para ParasWriteOut FP, I, ParaLast, paraPriev Set ParaLast = Para ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Set ref to last flag point End If Set paraPriev = Para ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Set previous paragraph Next I ParasWriteOut FP, I, ParaLast, paraPriev '''''''''''''''''''''''''''''''''''''''''''''writeout last para End Sub Sub ParasWriteOut(FP As String, I As Integer, Parastart As Paragraph, ParaEnd As Paragraph) Dim fn As String ''File name Dim bDoc As Document ''writeout document per piece Dim rng As Range ''Range to write out Dim x Dim J As Integer fn = format(I, "0000") & "-" If Not Parastart.Range.ListFormat.List Is Nothing Then ''use numbers from list to write out x = Split(PadParanums(Parastart.Range.ListFormat.ListString, 2), "-") For J = 1 To levels level(J) = Val(x(J - 1)) Next J ElseIf Parastart.OutlineLevel <= levels Then ''use level formatting level(Parastart.OutlineLevel) = level(Parastart.OutlineLevel) + 1 ''increment levels ''fn = fn & PadParanums(Parastart.OutlineLevel, levels) & "-" End If For J = Parastart.OutlineLevel + 1 To levels level(J) = 0 ''reset levels Next J fn = fn & PadParanums(level(1) & "-" & level(2), levels) & "-" fn = Left(Trim(fn & Parastart.Range.Text), 64) fn = StrFormat(fn) Set rng = ActiveDocument.Range(Parastart.Range.Start, ParaEnd.Range.End) Set bDoc = Documents.Add(Visible:=False) bDoc.Content.FormattedText = rng '''reset colors to automatic bDoc.Content.Font.Color = wdColorAutomatic On Error Resume Next VBA.Kill FP & fn bDoc.SaveAs FP & fn, fileformat:=Word.wdFormatDocument, addtorecentfiles:=False, allowsubstitutions:=False ''allow substitutions allows word to substitutie characters with similar looking characters (ie © with (C)) On Error GoTo 0 bDoc.Close False Set bDoc = Nothing End Sub Private Function PadParanums(strString As String, Optional levels As Integer) As String '' add 0's in numbered formats Dim x Dim I, xI strString = StrFormat(strString) x = Split(strString, "-") Const format = "000" xI = -1 On Error Resume Next xI = UBound(x) On Error GoTo 0 For I = 0 To xI If x(I) Like "*#*" Then PadParanums = PadParanums & Right(format & x(I), 3) & "-" End If Next I For I = UBound(Split(PadParanums, "-")) To levels - 1 ''use padparanums to determine number of levels defined then add padded 000- for remining PadParanums = PadParanums & format & "-" Next I PadParanums = StrFormat(PadParanums) End Function Private Function Parastyles(Para As Paragraph, strStyles) As Boolean Dim I As Integer Dim K As Integer I = -1 On Error Resume Next I = UBound(strStyles) On Error GoTo 0 For K = 0 To I If Para.Style Like strStyles(K) Then Parastyles = True Exit Function End If Next K End Function Function StrFormat(strString As String) As String Dim regex As New regexp With regex .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "[^a-zA-Z0-9\-]" End With StrFormat = regex.Replace(strString, "-") With regex .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "\-{1,}" End With StrFormat = regex.Replace(StrFormat, "-") '''Remove trailing dashes With regex .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "\-{1,}(?=\s|$)" End With StrFormat = regex.Replace(StrFormat, "") End Function Sub NewFolder(FP As String, Optional DoNotOpen As Boolean) Dim OpenFold As Variant Dim oShell As Object Dim Wnd As Object ''Dim strFolder ''OpenFold = "mysubfolder" ''strFolder = "U:\myfolder\" & OpenFold Set oShell = CreateObject("Shell.Application") ''Wnd.LocationName ''Cread subfolder for paragraphs On Error Resume Next VBA.MkDir (FP) FP = FP & "\" On Error GoTo 0 For Each Wnd In oShell.Windows Debug.Print Wnd.Document.Folder.Self.Path '' If Wnd.LocationName = "Windows Explorer" Then If LCase(Wnd.Document.Folder.Self.Path & "\") = LCase(FP) Then Wnd.Visible = True Exit Sub End If ''End If Next Wnd If Not DoNotOpen Then Shell "C:\WINDOWS\explorer.exe """ & FP & "", vbNormalFocus End Sub

Access VBA to get e-mail address from Outlook 2003 and 2010

Access VBA to get e-mail address from Outlook 2003 and 2010: "Function GetSMTPAddress(ByVal strAddress As String)
' As supplied by Vikas Verma ... see
' http://blogs.msdn.com/vikas/archive/2007/10/24/oom-getting-primary-smtp-address-from-x400-x500-sip-ccmail-etc.aspx
Dim olApp As Object
Dim oCon As Object
Dim strKey As String
Dim oRec As Object
Dim strRet As String
Dim fldr As Object
'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS
On Error Resume Next
Set olApp = Application
Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).folders.Item("Random")
If fldr Is Nothing Then
olApp.GetNamespace("MAPI").GetDefaultFolder(10).folders.Add "Random"
Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).folders.Item("Random")
End If
On Error GoTo 0
If CInt(Left(olApp.Version, 2)) >= 12 Then
Set oRec = olApp.Session.CreateRecipient(strAddress)
If oRec.Resolve Then
strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
End If
If Not strRet = "" Then GoTo ReturnValue
'IF OUTLOOK VERSION IS < 2007 THEN USES LITTLE HACK
'How it works
'============
'1) It will create a new contact item
'2) Set it's email address to the value passed by you, it could be X500,X400 or any type of email address stored in the AD
'3) We will assign a random key to this contact item and save it in its Fullname to search it later
'4) Next we will save it to local contacts folder
'5) Outlook will try to resolve the email address & make AD call if required else take the Primary SMTP address from its cache and append it to Display name
'6) The display name will be something like this " ( email.address@server.com )"
'7) Now we need to parse the Display name and delete the contact from contacts folder
'8) Once the contact is deleted it will go to Deleted Items folder, after searching the contact using the unique random key generated in step 3
'9) We then need to delete it from Deleted Items folder as well, to clean all the traces
Set oCon = fldr.items.Add(2)
oCon.Email1Address = strAddress
strKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
oCon.FullName = strKey
oCon.Save
strRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), strKey, ""))
oCon.Delete
Set oCon = Nothing
Set oCon = olApp.Session.GetDefaultFolder(3).items.Find("[Subject]=" & strKey)
If Not oCon Is Nothing Then oCon.Delete
ReturnValue:
GetSMTPAddress = strRet
End Function

"



'via Blog this'

The Top 20 Augmented Reality Announcements at CES 2016 | Kudan

The Top 20 Augmented Reality Announcements at CES 2016 | Kudan: "Top 20 Augmented Reality Announcements at CES 2016"

Monday, February 6, 2017

213 foot rise in seas if all the ice melted.

http://www.nationalgeographic.com/magazine/2013/09/rising-seas-ice-melt-new-shoreline-maps/

Lync 2013 installation breaks Office 2010 interoperability | Chris Barnes

Bluebeam reporting it cannot print - failes on interop unregistered error:

Error : 13:46:29 : Distillery.GenerateDistilleryDocOperation.RunWithProgress -   Unable to cast COM object of type 'Microsoft.Office.Interop.Word.ApplicationClass' to interface type 'Microsoft.Office.Interop.Word._Application'. This operation failed because the QueryInterface call on the COM component for the interface with IID '{00020970-0000-0000-C000-000000000046}' failed due to the following error: Library not registered. (Exception from HRESULT: 0x8002801D (TYPE_E_LIBNOTREGISTERED)).

solved here:
Lync 2013 installation breaks Office 2010 interoperability | Chris Barnes:

By removing these latent LYNC 2013 keys:
Windows Registry Editor Version 5.00
[-HKEY_CLASSES_ROOT\TypeLib\{00062FFF-0000-0000-C000-000000000046}\9.5]
[-HKEY_CLASSES_ROOT\TypeLib\{00020905-0000-0000-C000-000000000046}\8.6]
[-HKEY_CLASSES_ROOT\TypeLib\{00020813-0000-0000-C000-000000000046}\1.8]

'via Blog this'

Saturday, February 4, 2017