I have Outlook VBA code which runs when a recurring event is added to a calendar. I need to convert the event.GetRecurrencePattern.DaysOfWeekMask to a valid Rrule string.
I am creating a weekly recurring event which occurs every Sunday, Tuesday, and Friday for 10 occurrences.
When the event is added, this code gets executed:
If Item.IsRecurring = True Then
Set ItemRecurrPatt = Item.GetRecurrencePattern
RRuleFrequency = ConvertFrequency(ItemRecurrPatt.RecurrenceType)
RRuleByDay = ConvertDaysOfTheWeek(ItemRecurrPatt.DayOfWeekMask)
End If
ConvertFrequency is correctly returning "Weekly" so I don't have a problem with that function.
This is the code for ConvertDaysOfTheWeek:
Function ConvertDaysOfTheWeek(ByVal DayMask As Integer) As String
Dim sDaysOfTheWeek As String
sDaysOfTheWeek = ""
If (DayMask & OlDaysOfWeek.olSunday) Then
sDaysOfTheWeek = ",SU"
End If
If (DayMask & OlDaysOfWeek.olMonday) Then
sDaysOfTheWeek = sDaysOfTheWeek + ",MO"
End If
If (DayMask & OlDaysOfWeek.olTuesday) Then
sDaysOfTheWeek = sDaysOfTheWeek + ",TU"
End If
If (DayMask & OlDaysOfWeek.olWednesday) Then
sDaysOfTheWeek = sDaysOfTheWeek + ",WE"
End If
If (DayMask & OlDaysOfWeek.olThursday) Then
sDaysOfTheWeek = sDaysOfTheWeek + ",TH"
End If
If (DayMask & OlDaysOfWeek.olFriday) Then
sDaysOfTheWeek = sDaysOfTheWeek + ",FR"
End If
If (DayMask & OlDaysOfWeek.olSaturday) Then
sDaysOfTheWeek = sDaysOfTheWeek + ",SA"
End If
If Len(sDaysOfTheWeek) > 1 Then
sDaysOfTheWeek = Right(sDaysOfTheWeek, Len(sDaysOfTheWeek) - 1)
End If
ConvertDaysOfTheWeek = sDaysOfTheWeek
End Function
When I step through the function in debug, I can see that the value passed into the function is 37. Then, as I step through the code, I see that every If condition ends up true so at the end of the function, the string that gets returned is "SU,MO,TU,WE,TH,FR,SA".
Obviously, I am not interrogating the passed value properly.
& is a string concatenation operator in VB, so 37 & olSaturday will be "3764".
You need to use the And operator instead.
The & Operator is for string concatenation in VBA. For the RecurrencePattern.DayOfWeekMask property you need to use boolean operators like AND, OR and etc. In the following case the appointment is displayed with the pattern: "Occurs every Monday, Tuesday, Wednesday, Thursday, and Friday
.DayOfWeekMask = olMonday Or olTuesday Or olWednesday Or olThursday Or olFriday
So, to check whether it happens on a specific day of week you can use the AND operator:
Function ConvertDaysOfTheWeek(ByVal DayMask As Integer) As String
Dim sDaysOfTheWeek As String
sDaysOfTheWeek = ""
If (DayMask AND OlDaysOfWeek.olSunday) Then
sDaysOfTheWeek = ",SU"
End If
If (DayMask AND OlDaysOfWeek.olMonday) Then
sDaysOfTheWeek = sDaysOfTheWeek + ",MO"
End If
If (DayMask AND OlDaysOfWeek.olTuesday) Then
sDaysOfTheWeek = sDaysOfTheWeek + ",TU"
End If
If (DayMask AND OlDaysOfWeek.olWednesday) Then
sDaysOfTheWeek = sDaysOfTheWeek + ",WE"
End If
If (DayMask AND OlDaysOfWeek.olThursday) Then
sDaysOfTheWeek = sDaysOfTheWeek + ",TH"
End If
If (DayMask AND OlDaysOfWeek.olFriday) Then
sDaysOfTheWeek = sDaysOfTheWeek + ",FR"
End If
If (DayMask AND OlDaysOfWeek.olSaturday) Then
sDaysOfTheWeek = sDaysOfTheWeek + ",SA"
End If
If Len(sDaysOfTheWeek) > 1 Then
sDaysOfTheWeek = Right(sDaysOfTheWeek, Len(sDaysOfTheWeek) - 1)
End If
ConvertDaysOfTheWeek = sDaysOfTheWeek
End Function
See And Operator for more information.
Related
If I try to change it, its size is too limited
ActiveDocument.Tables(2).Cell(3, 2).Range = text + " " + String(200,".")
For example:
Sub Demo()
Const Txt As String = "abcdefghijklmnopqrstuvwxyz"
With ActiveDocument.Tables(2).Cell(3, 2)
.Range.Text = Txt + " " + String(200, ".")
.Range.FitTextWidth = .Width
End With
End Sub
In my document I must add footnotes to every formula i used. For example, I have some text with added Bibliography source
(something like "some very smart text [WrittenBySb]")
and I have formula
(for examle : E = mc2)
And after that formula I must add footnote contains source. I decided to write a macro that add footnote to formula with selected bibliography source:
Sub addFootnoteFromSelection()
Selection.MoveRight Unit:=wdCell 'my formula is in table - first row
'is null. second is actual formula and
'third contains actual formula's number
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
With Selection 'i want footnote mark to be in current
'formula's number
With .FootnoteOptions
.Location = wdBottomOfPage
.NumberingRule = wdRestartContinuous
.StartingNumber = 1
.NumberStyle = wdNoteNumberStyleArabic
End With
.Footnotes.Add Range:=Selection.Range, Reference:=""
End With
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.Style = ActiveDocument.Styles("Numer wzoru")
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
End Sub
And that works, but I want to have full source name (like in bibliography field), not a citation mark.
I write a function in vba that returns proper looking and formatted string from Source field:
Function stringFromSource(curField As Source) As String
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.LoadXML curField.XML
authors = "": title = "": publish = "": city = "": year = "": periodic =
""
'authors
Set surname = xmlDoc.getElementsByTagName("b:Last")
Set name = xmlDoc.getElementsByTagName("b:First")
Dim l As Integer
l = 0
For Each el In surname
If el.Text = "" Then Exit For
authors = authors + (el.Text & " " & name(l).Text & " ")
l = l + 1
Next el
'title
Set titlex = xmlDoc.getElementsByTagName("b:Title")
For Each el In titlex
If el.Text = "" Then Exit For
title = title + (el.Text & " ")
Next el
'publisher
Set pubx = xmlDoc.getElementsByTagName("b:Publisher")
For Each el In pubx
publish = publish + (el.Text & " ")
Next el
'city
Set cityx = xmlDoc.getElementsByTagName("b:City")
If cityx.Length = 0 Then city = city + ("(brak miasta)" & " ")
For Each el In cityx
city = city + (el.Text & " ")
Next el
'year
Set yearx = xmlDoc.getElementsByTagName("b:Year")
If yearx.Length = 0 Then year = year + ("(brak roku wydania)" & " ")
For Each el In yearx
year = year + (el.Text & " ")
Next el
'periodical title
Set periodx = xmlDoc.getElementsByTagName("b:PeriodicalTitle")
For Each el In period
periodic = periodic + (el.Text & " ")
Next el
Dim outputString As String
outputString = author & "- " & title & ", " & publish & periodic & ", " &
year
stringFromSource = outputString
End Function
This function works as expected. But I want to loop through all footnotes and convert it to string using my function:
Sub convertAllFootnotes()
Dim ftn As Footnote
Dim oRng As Range
For Each ftn In ActiveDocument.Footnotes
Set oRng = Selection.Range
oRng.Start = oRng.Start - 1
oRng.End = oRng.End + 1
oRng.Select
oRng.Text = stringFromSource(ftn) 'i don't know how to get source object
'from footnote
Next ftn
End Sub
And that is my problem. I don't know how to get Source object from footnote (that has Source object in it, this is not a static string but copied proper Source field)
I got the error related to the code below. The weird part is, I am able to access and write to the cells.formula property just find in immediate, and I was able to run the formula just fine as well in immediate. The error is "Application-defined or object-defined error". Since I have no clue what is causing the issue, I pasted the entire code here to see if anyone see something that may be causing it. It's weird....
' This function adds a column to an existing table if the table does not already has the function, or updates the table with the new values as needed
Public Function AddAssocStds(objSheet As Worksheet) As Boolean
Dim i As Integer
Dim rowHeader As Integer
Dim CombDes As Integer
Dim AssocStd As Integer
Dim SAP As Variant
Dim Stockcode As Variant
Dim Mincom As Variant
Dim WriteAssocStd As String
' Defines my header row
rowHeader = 1
' A specific row to look up in an existing table
CombDes = -1
' This is the write row
AssocStd = -1
i = 1
' Speeding up the run, speed play
Application.ScreenUpdating = False
' Registers the columns in the sheet correctly first
For i = 1 To objSheet.Cells(rowHeader, objSheet.Columns.Count).End(xlToLeft).Column
Select Case Cells(rowHeader, i).value
Case "CombinedDescription"
CombDes = i
Case "AssocStds"
AssocStd = i
Case "SAP"
SAP = objSheet.Range(objSheet.Cells(rowHeader + 1, i), objSheet.Cells(objSheet.UsedRange.Count, i)).value
Case "Stockcode"
Stockcode = objSheet.Range(objSheet.Cells(rowHeader + 1, i), objSheet.Cells(objSheet.UsedRange.Count, i)).value
Case "Mincom"
Mincom = objSheet.Range(objSheet.Cells(rowHeader + 1, i), objSheet.Cells(objSheet.UsedRange.Count, i)).value
End Select
Next
' Determines which column to write to - either inserts after combdes column or make a new column
If AssocStd = -1 Then
If CombDes = -1 Then
AssocStd = objSheet.Cells(rowHeader, objSheet.Columns.Count).End(xlToLeft).Column + 1
Else
objSheet.Range(Cells(1, CombDes + 1), Cells(1, CombDes + 1)).EntireColumn.Insert
AssocStd = CombDes + 1
End If
End If
' Writes the header for the new column
objSheet.Cells(rowHeader, AssocStd).value = "AssocStds"
' Resets the counter
i = 1
' Loops throught the entire column
For i = 1 To objSheet.UsedRange.Count - rowHeader
If NotNull(CStr(SAP(i, 1))) Then
WriteAssocStd = AssocStdsGen(CStr(SAP(i, 1)))
Else
WriteAssocStd = "-1"
End If
If WriteAssocStd = "-1" And NotNull(CStr(Stockcode(i, 1))) Then
WriteAssocStd = AssocStdsGen(CStr(Stockcode(i, 1)))
Else
WriteAssocStd = "-1"
End If
If WriteAssocStd = "-1" And NotNull(CStr(Mincom(i, 1))) Then
WriteAssocStd = AssocStdsGen(CStr(Mincom(i, 1)))
Else
WriteAssocStd = "-1"
End If
' This is where the problem happens, when writing as a formula, it doesn't work...
If WriteAssocStd = "-1" Then
objSheet.Cells(i + rowHeader, AssocStd).Formula = "=IF(UPPER([#Standard RR]) <> " & Chr(34) & "NON-STD" & Chr(34) & ", [#Standard RR] &" & Chr(34) & "-" & Chr(34) & "&[#PlanNo] & " & Chr(34) & "." & Chr(34) & "& TEXT([#SheetNo], " & Chr(34) & "00" & Chr(34) & "), [#Standard RR])"
Else
objSheet.Cells(i + rowHeader, AssocStd).value = WriteAssocStd
End If
Next
AddAssocStds = True
Application.ScreenUpdating = True
End Function
Additional note:
The formula does work in excel by itself as evidenced by the rows that did not prompt the error
The error seems to only occur at the last row. I have a weird feeing it may be related
Hi i have this code and it give me error:
Type of value has a mismatch with column typeCouldn't store <10/1/2012
3:43:30 PM> in time_in_am Column. Expected type is MySqlDateTime.
my mySQL data type for "time_in_am" is DateTime.
dataRow = dataSet.Tables(0).NewRow()
dataRow("time_in_am") = DateTime.Now
dataSet.Tables(0).Rows.Add(dataRow)
I believe MySQL's accepted DateTime format is yyyy-mm-dd hh:mm:ss
So, alter the 2nd row of your code to:
dataRow("time_in_am") = DateTime.Now.ToString("yyyy-MM-dd HH:mm:ss")
For what each of the format 'magic strings' mean, see here
If you find yourself using this often (which is probable) you can create an extension:
Imports System.Runtime.CompilerServices
Public Module MyExtensions
<Extension()>
Public Function ToMySql(d As Date) As String
Return d.ToString("yyyy-MM-dd HH:mm:ss")
End Function
End Module
Now you can use this in your code as follows:
dataRow("time_in_am") = DateTime.Now.ToMySql()
Return d.toString("yyyy-MM-dd HH:mm:ss")
will solve it.. :)
I think another shortest way to do it is using Format()
dataRow("time_in_am") = Format(DateTime.Now, "yyyy-MM-dd HH:mm:ss")
i was looking a way to convert this vb6 date conversion to mysql accepted value to vb.net;
'convert date to mysql format
Public Function convToYMD(strDate)
strYear = CStr(Year(strDate))
strmonth = CStr(Month(strDate))
strday = CStr(Day(strDate))
strhour = CStr(Hour(strDate))
strminute = CStr(Minute(strDate))
strsecond = CStr(Second(strDate))
If Len(strhour) = 1 Then
strhour = "0" & strhour
ElseIf Len(strhour) = 0 Then
strhour = "00"
End If
If Len(strminute) = 1 Then
strminute = "0" & strminute
ElseIf Len(strminute) = 0 Then
strminute = "00"
End If
If Len(strsecond) = 1 Then
strsecond = "0" & strsecond
ElseIf Len(strsecond) = 0 Then
strsecond = "00"
End If
If Len(strday) = 1 Then
strday = "0" + strday
ElseIf Len(strday) = 0 Then
strday = "00"
End If
If Len(strmonth) = 1 Then
strmonth = "0" & strmonth
ElseIf Len(strmonth) = 0 Then
strmonth = "00"
End If
convToYMD = strYear + "-" + strmonth + "-" + strday + " " + strhour + ":" + strminute + ":" + strsecond
end function
found this code and solves my problem!
i just added inside the module
If DateFormat.ShortDate Then
Return d.ToString("yyyy-MM-dd")
ElseIf DateFormat.LongDate Then
Return d.ToString("yyyy-MM-dd HH:mm:ss")
End If
many, many thanks!
I have some code which will return true if a user is in a specific group that I pass in, however if the user is in another group that is part of the goroup I'm passing in, the function will return false. I need to be able to iterate through the groups to see if the user may be a member of a group that is in the group I'm interested in.
So as an example, if a user is in GroupA and all members of Group_A are in Group_B and I need to know if the user is in Group_B, which they are by being in Group_A.
Here is what I have now:
****EDIT added function GetCurrentUser used in IsUserInRole()
Public Function GetCurrentUser() As String
GetCurrentUser = Environ("USERNAME")
End Function
Public Function IsUserInRole(role) As Boolean
Dim UserObj As Object
Dim GroupObj As Object
Dim strObjectString As String
strObjectString = "WinNT://my domain/" & GetCurrentUser() & ""
Set UserObj = GetObject(strObjectString)
For Each GroupObj In UserObj.Groups
Debug.Print GroupObj.Name
If GroupObj.Name = role Then
IsUserInRole = True
Exit Function
End If
Next
End Function
Ok, I got a solution to this through MS. I have some code on the Access Form that passes a Group name into a function that lives in a Module. The function iterates through all the Groups the user is a member of and itereates through any Groups within the Group passed in. It returns true if the user is a member of the Group or is a member of a Group that is a member of the passed in Group.
Code on Form:
strGroup = "_System Admin"
If IsCurrentUserInGroup(strGroup) = True Then
MsgBox "In System Admin"
End If
Declared Public variables at top of Module:
Public strOut As String
Public objGroupList, objUser
IsCurrentUserInGroup Code:
Function IsCurrentUserInGroup(ByVal strGroup) As Boolean
Dim objSysInfo As Object
Dim strDN As String
'Get currentlly logged in users info
Set objSysInfo = CreateObject("ADSystemInfo")
strDN = objSysInfo.UserName
On Error Resume Next
Set objUser = GetObject("LDAP://" & strDN)
If (Err.Number <> 0) Then
On Error GoTo 0
MsgBox "User not found" & vbCrLf & strDN
End If
On Error GoTo 0
' Bind to dictionary object.
Set objGroupList = CreateObject("Scripting.Dictionary")
' Enumerate group memberships.
If EnumGroups(objUser, "", strGroup) = True Then
IsCurrentUserInGroup = True
Else
IsCurrentUserInGroup = False
End If
End Function
EnumGroups Code:
Public Function EnumGroups(ByVal objADObject, ByVal strOffset, ByVal strGroup) As Boolean
' Recursive subroutine to enumerate user group memberships.
' Includes nested group memberships.
Dim colstrGroups, objGroup, j
objGroupList.CompareMode = vbTextCompare
colstrGroups = objADObject.memberOf
If (IsEmpty(colstrGroups) = True) Then
Exit Function
End If
If (TypeName(colstrGroups) = "String") Then
' Escape any forward slash characters, "/", with the backslash
' escape character. All other characters that should be escaped are.
colstrGroups = Replace(colstrGroups, "/", "\/")
Set objGroup = GetObject("LDAP://" & colstrGroups)
If (objGroupList.Exists(objGroup.sAMAccountName) = False) Then
objGroupList.Add objGroup.sAMAccountName, True
strOut = strOut + strOffset & objGroup.distinguishedName + Chr(13) + Chr(10)
Call EnumGroups(objGroup, strOffset & "--", "")
Else
strOut = strOut + strOffset + strOffset & objGroup.distinguishedName & " (Duplicate)" + Chr(13) + Chr(10)
End If
Exit Function
End If
For j = 0 To UBound(colstrGroups)
' Escape any forward slash characters, "/", with the backslash
' escape character. All other characters that should be escaped are.
colstrGroups(j) = Replace(colstrGroups(j), "/", "\/")
Set objGroup = GetObject("LDAP://" & colstrGroups(j))
If (objGroupList.Exists(objGroup.sAMAccountName) = False) Then
If objGroup.sAMAccountName = strGroup Then
EnumGroups = True
End If
objGroupList.Add objGroup.sAMAccountName, True
strOut = strOut + strOffset & objGroup.distinguishedName + Chr(13) + Chr(10)
Call EnumGroups(objGroup, strOffset & "--", "")
Else
strOut = strOut + strOffset & objGroup.distinguishedName & " (Duplicate)" + Chr(13) + Chr(10)
End If
Next
End Function