Outlook Record Of Conversation (Select meeting in calendar and run)

This allows you to select a meeting in Outlook, run the macro and create a pre-formatted Record Of Conversation (ROC:[SUBJECT]) message with keys for identifying Projects,





















Then you can start filling in content as the meeting progresses for a quick start and a consistent format. The HTML sections in the back hard code in the header information for the body text to start.



Attribute VB_Name = "Outlook_ROC" Option Explicit Private Const PR_SENT_REPRESENTING_ENTRYID As String = "http://schemas.microsoft.com/mapi/proptag/0x00410102" ''stripped character index tables '''''''''''''''''''0'''''''''1'''''''''2'''''''''3' '''''''''''''''''''0123456789x123456789x123456789x1 Const b32_5_bit = "()+.ABCDEFGHIJKLMNOPQRSTUVWXYZ_" '' basic text only naming '''''''''''''''''''0'''''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6''' '''''''''''''''''''0123456789x123456789x123456789x123456789x123456789x123456789x123 Const b64_6_bit = ".0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz" ''Text and numbers naming '''''''''''''''''''0'''---''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6'''''''''7'''''''''8'''''''''9'''''''''0'''''''''1'''''''''2 '''''''''''''''''''0123---456789x123456789x123456789x123456789x123456789x123456789x123456789x123459789x123456789x12345978 Const b128_7_bit = " !""""#$%&'()*+,-./0123456789:;<=>?@ABCEDFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcedfghijklmnopqrstufwxyz{|}~" ''Full printable characters for naming ''And more space....  
 
Public Sub Meeting_MAIL_ROC()
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim oMail As Outlook.MailItem
    Dim oAppt As Outlook.AppointmentItem
    Dim oPA As Outlook.PropertyAccessor
    Dim strSenderID As String
   
    Dim mAppItm As AppointmentItem
    '''Dim mySender                       ''&lt&lt Broken
    Dim rep As SubMatches
    Dim mRecipient As Recipient
    'Dim objOutlookRecip As Recipient
    Dim boolKeepRecip As Boolean
    Dim ostr As String
   
    Dim objRecipients As Recipients
    Dim objRecip As Recipient
   
    Dim mBody As String
    Dim mDateUTC As Date
    Dim mDateZONE As Date
    Dim mDateZONEstr As String
   
    Dim objMail As MailItem
    Dim preHTML As String
    Dim postHTML As String
   
    Dim Re As New REGEXP
   
    Dim boolHomeOnly As Boolean
    Dim strHOme As String ''home domain
   
    Dim GeneratePrefixTextTxt As String
    Dim x As Integer
    Dim J As Integer
   
    GeneratePrefixTextTxt = "Senders of selected items:"  ''&lt&lt&ltNeed to add code to look for messaged open in the foreground....!
    Set myOlExp = Application.ActiveExplorer
    Set myOlSel = myOlExp.Selection
    For x = 1 To myOlSel.Count
      If myOlSel.Item(x).Class = OlObjectClass.olMail Then
         ' For mail item, use the SenderName property.
         Set oMail = myOlSel.Item(x)
         Set objRecipients = oMail.Recipients
         Set mAppItm = oMail.sender
         oMail.BodyFormat = olFormatHTML
         mBody = oMail.HTMLBody
         mDateUTC = oMail.Sent
         ''mDateZONE = oMail.zo
         ''mDateZONEstr = oAppt.StartTimeZone
      ElseIf myOlSel.Item(x).Class = OlObjectClass.olAppointment Then
         ' For appointment item, use the Organizer property.
         Set oAppt = myOlSel.Item(x)
         ''get sender adn all users
         ''remove meeting rooms
       
         Set mAppItm = oAppt
         ''https://social.msdn.microsoft.com/Forums/sqlserver/en-US/e2fb4e2d-9e27-452e-a50a-7e5c0dac1af5/cant-get-vba-code-to-use-replyall-on-existing-meetings?forum=outlookdev
     
         Set objMail = oAppt.Actions.Item("Reply to All").Execute
        
         'For Each mRecipient In objMail.Recipients
         '   objRecipients.Add (mRecipient)
         '   mRecipient.Delete
         'Next mRecipient ''&lt&ltREMOVE RECIPIENTS
         Set objRecipients = objMail.Recipients
         objMail.BodyFormat = olFormatHTML
        
         mBody = objMail.HTMLBody
         ''replayall and get message'''
         mDateUTC = oAppt.StartUTC
         mDateZONE = oAppt.StartInStartTimeZone
         mDateZONEstr = oAppt.StartTimeZone
         '''GeneratePrefixTextTxt = GeneratePrefixTextTxt & oAppt.Organizer & ";"
      ''Else
         ' For other items, use the property accessor to get sender ID,
         ' then get the address entry to display the sender name.
         'Set oPA = myOlSel.Item(x).PropertyAccessor
         'strSenderID = oPA.GetProperty(PR_SENT_REPRESENTING_ENTRYID)
         'Set mySender = Application.Session.GetAddressEntryFromID(strSenderID)
         '''GeneratePrefixTextTxt = GeneratePrefixTextTxt & mySender.Name & ";"
      End If
     
      ''&gt&gt&gt&gt&gt&gt&gt&gt&gt&gt&gt&gt&gt&gt&gtCLEANUP msg&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt
      With Re ''REGEXP
         .Pattern = "([\s\S]*)(&ltBODY[\s\S]{0,}?&gt)([\s\S]*)(&lt/BODY&gt)([\s\S]*)"
         .MultiLine = False
         .IgnoreCase = True
     
         If .Test(mBody) = True Then
             Set rep = .Execute(mBody).Item(0).SubMatches   ''hard-coded matches based on regex and typical HTML
             preHTML = rep.Item(0) & rep.Item(1)
             postHTML = rep.Item(2) & rep.Item(3) & rep.Item(4)
         Else ''no html formatting EXISTS - JUST IN CASE...
             preHTML = "&lt!DOCTYPE HTML PUBLIC """"-//W3C//DTD HTML 3.2//EN""""&gt&ltHTML&gt&ltHEAD&gt&ltMETA NAME=""""Generator"""" CONTENT=""""MS Exchange Server version 16.0.11328.20390""""&gt&ltTITLE&gt&lt/TITLE&gt&lt/HEAD&gt"
             postHTML = mBody & "&lt/BODY&gt&lt/HTML&gt"
         End If
      End With ''RE REGEXP
       
      ''''''''''''''''''''''''''''''''''''''''''''''''''''
      ''Isolate current domain only for replies?
      strHOme = LCase(Split(getMyEmalAddress, "@")(1))
      ''Home domain report only?
      boolHomeOnly = (MsgBox("Strip non @" & strHOme & " Domain recipients from message?", vbYesNo, "Isolate domain addresses") = vbYes) ''home only
      ''For Each mRecipient In objRecipients
      For J = objRecipients.Count To 1 Step -1
         boolKeepRecip = True         ''reset check
        
         Set mRecipient = Nothing
         Set mRecipient = objRecipients(J)
       
         ostr = "": ostr = LCase(Split(GetSMTP(mRecipient), "@")(1))
        
         If IsRoom(mRecipient) Then ''remove rooms
            boolKeepRecip = False
         ElseIf StripLocalrecipientList(mRecipient) Then
            boolKeepRecip = False
         ElseIf boolHomeOnly And ostr &lt&gt strHOme Then ''force drop non-domain
            boolKeepRecip = False ''objRecipients.Remove (J)
         Else ''if passes 1st 2 then see if they responded
            Select Case mRecipient.MeetingResponseStatus
               ''https://docs.microsoft.com/en-us/office/vba/api/outlook.olresponsestatus
               Case olResponseAccepted      '' Meeting accepted
                  boolKeepRecip = True
               Case olResponseTentative     '' Meeting tentatively accepted
                  boolKeepRecip = True
               Case olResponseNone          '' The appointment is a simple appointment and does not require a response.
                  boolKeepRecip = True
               Case olResponseNotResponded  '' Recipient has not responded.
                  boolKeepRecip = True
               Case olResponseOrganized     '' The AppointmentItem is on the Organizer's calendar or the recipient is the Organizer of the meeting.
                  boolKeepRecip = True
               Case olResponseDeclined      '' Meeting Declined
                  boolKeepRecip = False
            End Select
         End If
        
         If boolKeepRecip = False Then objMail.Recipients.Remove (J)
         
      Next J ''mRecipient

    ''GENERATE MESSAGE if not generated by replayall
    If objMail Is Nothing Then Set objMail = Application.CreateItem(olMailItem)
    With objMail
        .BodyFormat = olFormatHTML

        objMail.HTMLBody = preHTML & StrHead & postHTML
       
        'Set objOutlookRecip = objRecipients    ''Add with items add for multiple listings split on ; or ,
        'objOutlookRecip.Type = olTo
        '.Subject = Format(Date + Time(), "YYYY-MM-DD-hh.mmap") & " Report summary as attached file"  ''&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt
        '.Body = "Please See Attached"
        '.Attachments.Add fn

       'For J = .Recipients.Count To 1 Step -1
       '    Set mRecipient = .Recipients(J)
       '    mRecipient.Resolve
       '    ostr = ""
       '    If InStr(1, GetSMTP(mRecipient), "@", vbTextCompare) &gt 0 Then
       '        ostr = LCase(Split(GetSMTP(mRecipient), "@")(1))
       '    End If
       '
       '    If boolHomeOnly Then
       '        If ostr &lt&gt strHOme Then .Recipients.Remove (J)
       '     End If
       'Next
       ''.DeferredDeliveryTime = (Weekday(Date, 6) - 1) + Date + 22 / 24 ''set delivery at 10pm friday end of week in case changes come up
        Do While Left(.Subject, 4) Like "RE: "
             .Subject = Right(.Subject, Len(.Subject) - 4)
        Loop
       
        .Subject = "ROC:" & .Subject & "-" & Format(mDateZONE, "YYYY-MM-DD")
        .Save
        .Display
        Exit Sub ''''''''''''''''''&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&ltEXIT BREAK&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt
    End With
   
    Set objMail = Nothing
   
    Next x
    'Debug.Print GeneratePrefixTextTxt
End Sub

Function StripLocalrecipientList(objRecipient As Recipient) As Boolean
    'Jim Kunst &ltJKunst@ktgy.com&gt
    Dim x()
    x = Array("JKunst@ktgy.com")
    Dim i
    For i = 0 To UBound(x)
        If LCase(Trim(objRecipient.Address)) = LCase(Trim(x(i))) Then
            StripLocalrecipientList = True
            Exit Function
        End If
    Next i
End Function
Function GetSMTP(objRecip As Recipient) As String
''https://stackoverflow.com/questions/31081960/vba-excel-how-to-find-an-email-address-from-an-exchange-user-in-outlook
Dim olNS As NameSpace
Dim olAddrEntry As AddressEntry
Dim olCont As ContactItem
Dim olExchUser As ExchangeUser
   
    Set olNS = Outlook.GetNamespace("MAPI")
    'Set olRecip = olNS.CreateRecipient("Dmitry Streblechenko")
    objRecip.Resolve
    Set olAddrEntry = objRecip.AddressEntry
    On Error Resume Next
    Set olCont = olAddrEntry.GetContact
    If olCont Is Nothing Then
      Set olExchUser = olAddrEntry.GetExchangeUser
        If olExchUser Is Nothing Then
          GetSMTP = olAddrEntry.Address
          ''NOTIHNG TO DO
        Else
          'olExchUser is ExchangeUser object
          GetSMTP = olExchUser.PrimarySmtpAddress
          If GetSMTP = "" Then
            GetSMTP = olAddrEntry.name
            If GetSMTP &gt "" Then GetSMTP = GetSMTP & "@unresolved.com"
          End If
        End If
    Else
      'this is a contact
      'olCont is ContactItem object
      MsgBox olCont.FullName
    End If
   
    If GetSMTP = "" Then
        GetSMTP = "UNRESOLVED@UNRESOLVED.COM"          '''&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lttEMPORARY HACK FOR UNRESOLVED EMAIL ADDRESSES IN THE SYSTEM
            MsgBox "FOR USER: " & vbCr & vbCr & objRecip.AddressEntry, vbInformation + vbCritical, "Unable to resolve email address." & vbCr & vbCr & "Proceeding..."
        ''GetSMTP = objRecip.Address
    End If
   
    On Error GoTo 0
End Function

Private Function getMyEmalAddress() As String
''https://stackoverflow.com/questions/26519325/how-to-get-the-email-address-of-the-current-logged-in-user
Dim olNS As Outlook.NameSpace
Dim olFol As Outlook.Folder

Set olNS = Outlook.GetNamespace("MAPI")
Set olFol = olNS.GetDefaultFolder(olFolderInbox)

getMyEmalAddress = olFol.Parent.name '~~&gt most cases contains the email address

'MsgBox olNS.Accounts.Item(1).DisplayName '~~&gt usually email address
'MsgBox olNS.Accounts.Item(1).SmtpAddress '~~&gt email address
'MsgBox olNS.Accounts.Item(1).UserName '~~&gt displays the user name

End Function

Function IsRoom(objRecipient As Recipient) As Boolean
''https://docs.microsoft.com/en-us/office/vba/api/outlook.recipient.type
   IsRoom = False
   On Error GoTo IsRoomErr
  
   IsRoom = objRecipient.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39050003") = 1073741831 _
            Or InStr(1, "room", objRecipient.name) &gt 0
   
  
IsRoomErr:
End Function

Private Function StrHead() As String
''formatting for body of message in HTML format
StrHead = _
      "&ltdiv class=WordSection1&gt" & vbCr _
    & "&ltb&gtIf anything appears to be incorrect- please reply with different color inline comments for corrections.&lt/b&gt" & vbCr _
    & "&lt/p&gt" & vbCr _
    & "&ltp class=MsoNormal&gt&ltspan style='mso-fareast-font-family:""""Times New Roman""""'&gt" & vbCr _
    & "|&ltspan style='background:yellow;mso-highlight:yellow'&gtQuestion/Unanswered issue&lt/span&gt" & vbCr _
    & "|&ltspan style='background:lime;mso-highlight:lime'&gtKey Point/Answer&lt/span&gt" & vbCr _
    & "|&ltspan style='background:aqua;mso-highlight:aqua'&gtProject&lt/span&gt" & vbCr _
    & "|&ltb&gt&ltspan style='color:yellow;background:red;mso-highlight:red'&gtCritical Issue&lt/span&gt&lt/b&gt" & vbCr _
    & "|&ltspan style='background:silver;mso-highlight:silver'&gtAfter/Unaddressed&lt/span&gt" & vbCr _
    & "|&lto:p&gt&lt/o:p&gt&lt/span&gt&lt/p&gt"

    StrHead = StrHead _
    & "&ltb&gt&ltspan style='font-size:16.0pt'&gtSUMMARY--------------------&lto:p&gt&lt/o:p&gt&lt/span&gt&lt/b&gt&lt/p&gt" & vbCr _
    & "&ltp class=MsoNormal&gt&ltspan style='mso-fareast-font-family:""""Times New Roman""""'&gt&lto:p&gt &lt/o:p&gt&lt/span&gt&lt/p&gt" & vbCr _
    & "&ltp class=MsoNormal&gt&ltb&gt&ltspan style='font-size:16.0pt'&gt" & vbCr _
    & "&ltp class=MsoNormal&gt&ltb&gt&ltspan style='font-size:16.0pt'&gtROC-----------------------------&lto:p&gt&lt/o:p&gt&lt/span&gt&lt/b&gt&lt/p&gt" & vbCr

    StrHead = StrHead _
    & "&ltp class=MsoNormal&gt&lto:p&gt &lt/o:p&gt&lt/p&gt" & vbCr _
    & "&ltp class=MsoNormal&gt&lto:p&gt &lt/o:p&gt&lt/p&gt" & vbCr _
    & "&lt/div&gt" & vbCr _
    & "&lt/body&gt" & vbCr _
    & "&lt/html&gt"

End Function



Sub ExportWithDateTime() ''export selecte items with prefixed date-time ''Microsoft Schema for extracting properties Const PR_SENT_REPRESENTING_ENTRYID As String = _ "http://schemas.microsoft.com/mapi/proptag/0x00410102" '' Dim myOlExp As Outlook.Explorer ''outlook browser explorer API Dim myOlSel As Outlook.Selection ''current selection Dim mySender As Outlook.AddressEntry ''Address Dim oMail As Outlook.MailItem ''Mail Dim oAppt As Outlook.AppointmentItem 'Appointment Dim oPA As Outlook.PropertyAccessor 'propoerty accessor for getting inforation from interface Dim strSenderID As String ''sender ID Dim MsgTxt As String ''gathereing message for end Dim FP As String ''file folder path to save from browse Dim X As Long ''generic counter Dim fn As String ''file name Dim strDT As String ''date time ''Dim FSO As FileSystemObject ''File system object for looking at files/folders, creteing folders, etc. ''Set FSO = CreateObject("Scripting.FileSystemObject") Set myOlExp = Application.ActiveExplorer Set myOlSel = myOlExp.Selection If myOlSel.Count = 0 Then MsgBox "Please select multiple messages to export.", vbInformation + vbOKOnly Exit Sub End If ''continue if selected FP = "D:\Users\Ron.Allen\Documents\KTGY(Personal)\_ROCs" '' BrowseForFolder.SelectFolder For X = 1 To myOlSel.Count If myOlSel.Item(X).Class = OlObjectClass.olMail Then ' For mail item, use the SenderName property. Set oMail = myOlSel.Item(X) strDT = "" strDT = Format(oMail.SentOn, "YYYY-MM-DDtHHmm") fn = "" fn = Left(strDT & Format(oMail.SentOn, "ap") & "-" & CleanNAME(oMail.Subject), 64) 'Stop '<<<<<<<<<<<<<<<<<<<<< <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< If VBA.FileSystem.Dir(FP & fn & ".*") > "" Then Select Case MsgBox(FP & fn, vbCritical + vbYesNoCancel, "File exists - overwrite?") Case vbYes MsgTxt = MsgTxt & " SAVED:" ''continue thorugh to write Case vbNo MsgTxt = MsgTxt & "EXISTED:" GoTo SkipSave Case vbCancel MsgBox "Cancelled", vbCritical Exit Sub End Select End If ''save as message intact ''oMail.SaveAs FP & fn & ".msg", olMSG ''Save as MSG file ''save as olDoc oMail.SaveAs FP & fn & ".doc", olDoc ''Save as DOC SkipSave: MsgTxt = MsgTxt & oMail.SenderName & ";" ElseIf myOlSel.Item(X).Class = OlObjectClass.olAppointment Then ' For appointment item, use the Organizer property. Set oAppt = myOlSel.Item(X) MsgTxt = MsgTxt & oAppt.Organizer & ";" Else ' For other items, use the property accessor to get sender ID, ' then get the address entry to display the sender name. 'Set oPA = myOlSel.Item(X).PropertyAccessor 'strSenderID = oPA.GetProperty(PR_SENT_REPRESENTING_ENTRYID) 'Set mySender = Application.Session.GetAddressEntryFromID(strSenderID) 'MsgTxt = MsgTxt & mySender.name & ";" End If Next X ''MsgBox MsgTxt MsgBox "Done exporting " & myOlSel.Count & " Messages." End Sub Function CleanNAME(strSource As String) As String Dim objRegex As REGEXP ''Regular exporession Dim strTemp As String ''temp string storage Set objRegex = CreateObject("VBScript.RegExp") ''initialize Regexp ''pares illegal characters and repeates to "-" objRegex.Pattern = "[^a-zA-Z0-9\-\+\.]{1,}" ''a-z upper or lower, numbers + - and . are aceptable objRegex.Global = True objRegex.IgnoreCase = True strTemp = objRegex.Replace(strSource, "-") ''replace illegal chars with "-" ''parse dots to underscoires objRegex.Pattern = "\." strTemp = objRegex.Replace(strTemp, "_") ''Parse combinations of -_ to - objRegex.Pattern = "[-_$]{1,}" strTemp = objRegex.Replace(strTemp, "-") ''remove trailing -_ objRegex.Pattern = "[-_]{1,}$" strTemp = objRegex.Replace(strTemp, "") CleanNAME = strTemp End Function Function CleanFN(strSource As String, Optional strPatt As String = "[^a-zA-Z0-9\-+]", Optional strRepl As String = "-") As String Dim objRegex As REGEXP ''Regular exporession Const strREP_FN_FEXT = "(.*)(\..*$)" ''file extension extractor for regexp Dim objMC As MatchCollection ''match collection from top regex Dim objSM As SubMatches ''Submatches in collection(s) Dim strFext As String ''string to store File Extension Set objRegex = CreateObject("VBScript.RegExp") ''initialize Regexp objRegex.Pattern = "(^.*[\/\\]){0,1}(.*)(\..*){0,1}$" objRegex.Global = True objRegex.IgnoreCase = True Set objMC = objRegex.Execute(strSource) Set objSM = objMC.Item(0).SubMatches strFext = objSM.Item(2) strSource = objSM.Item(1) Stop objRegex.Pattern = strPatt objRegex.Global = True objRegex.IgnoreCase = True CleanFN = objRegex.Replace(strSource, "-")
End Function
'-------------------------------------------------------------------
Attribute VB_Name = "BrowseForFolder"

Option Explicit

' For Outlook 2010.

#If VBA7 Then

    ' The window handle of Outlook.

    Private lHwnd As LongPtr



    ' /* API declarations. */

    Private Declare PtrSafe Function FindWindow Lib "user32" _

            Alias "FindWindowA" (ByVal lpClassName As String, _

                                 ByVal lpWindowName As String) As LongPtr



' For the previous version of Outlook 2010.

#Else

    ' The window handle of Outlook.

    Private lHwnd As Long



    ' /* API declarations. */

    Private Declare PtrSafe Function FindWindow Lib "user32" _

            Alias "FindWindowA" (ByVal lpClassName As String, _

                                 ByVal lpWindowName As String) As Long

#End If

'

' Windows desktop -

' the virtual folder that is the root of the namespace.

Private Const CSIDL_DESKTOP = &H0



' Only return file system directories.

' If user selects folders that are not part of the file system,

' then OK button is grayed.

Private Const BIF_RETURNONLYFSDIRS = &H1



' Do not include network folders below

' the domain level in the dialog box's tree view control.

Private Const BIF_DONTGOBELOWDOMAIN = &H2



Public Function SelectFolder() As String

    Dim objFSO As Object

    Dim objShell As Object

    Dim objFolder As Object

    Dim strFolderPath As String

    Dim blnIsEnd As Boolean



    blnIsEnd = False



    Set objShell = CreateObject("Shell.Application")

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    Set objFolder = objShell.BrowseForFolder( _

                lHwnd, "Please Select Folder to:", _

                BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)



    If objFolder Is Nothing Then

        SelectFolder = ""

        blnIsEnd = True

        GoTo PROC_EXIT

    Else

        SelectFolder = CGPath(objFolder.Self.Path)

    End If



PROC_EXIT:

    Set objFSO = Nothing

    If blnIsEnd Then End

End Function



Public Function CGPath(ByVal Path As String) As String

    If Right(Path, 1) &lt&gt "\" Then Path = Path & "\"

    CGPath = Path

End Function




Comments

Post a Comment

Popular posts from this blog

Powerpoint countdown and current time in slides VBA

Add text fields- this VBA searches through the objects in the first frame until it finds " " in the text some where, truncates everything from and to the right and replaces it with an active countdown timer or current time in the box. Refreshes every 500ms with a prtsafe call so it doesn't bog down the CPU. Add a slide advance to start the next slide and begin automated slide advancement. Attribute VB_Name = "Countdown" Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long Public Sub Wait ( Seconds As Double ) ''non cpu-intensive wait timer '' https://stackoverflow.com/questions/57268161/sleep-wait-timer-in-powerpoint-vba-thats-not-cpu-intensive Dim endtime As Double endtime = DateTime.Timer + Seconds Do WaitMessage DoEvents Loop While DateTime.Timer < endtime End Sub Sub Countdown_from_Start () Dim Time As Date Dim Count As ...
Read more

Revit area plans adding new types and references (Gross and rentable)

Image
Note to self: Add additional (duplicate) gross area and net area schemed under Area Plans And Area schemes... Really counter-intuitive place to put this instead of say...  Area Plans> New Type> Edit Type (ADD) or Create an area plan, then Go to Properties, Edit Type and Duplicate... Always seem to forget this one! 2015-10-16-And for the calculation type... To update: this also applies to Revit as well as LT- The gross calculations cannot be overridden, however the 'rentable' comes in various flavors... From AD Revit help: Applies to Revit LT 2015 Rules are determined by one type of space bordering another space. The following table shows area measurement rules. To find the appropriate measurement rule, find the selected Area Type and the corresponding Bordering Area Type. Gross Building Area Scheme Types Gross Building Area Scheme Types Area Type Selected Bordering Area Type Measurement Rule Gross Building Area Gross Buil...
Read more