I am extending the capability of the Word report writing from VSTO to consider different languages. Therefore, instead of using the headings like "Heading 1" etc, I have used wdStyleHeading1 etc. I have built a function to assign the style to the heading. The problem is that the line 1 and line 2 below are overwriting each other. If I call the function first, I loose list number and If I call function second, I loose the format. Can you please explain where I am going wrong?
I have imported the necessary references.
Call HeadingListLevel(wrdApp, 1)
wrdApp.Selection.ParagraphFormat.Style = Word.WdBuiltinStyle.wdStyleHeading1
Below is the sub function
Sub HeadingListLevel(wrdApp As Object, HeadingLvl As Integer)
'Dim wrdHeading As String
Dim wrdHeadingNr As String
Dim i As Integer
Dim ListTemp As Word.ListTemplate
wrdHeadingNr = "%" & 1
ListTemp = wrdApp.ListGalleries(Word.WdListGalleryType.wdOutlineNumberGallery).ListTemplates(1)
For i = 1 To HeadingLvl
If i > 1 Then
wrdHeadingNr = wrdHeadingNr & "." & "%" & i
End If
Next i
'wrdHeading = "Heading " & HeadingLvl
With ListTemp.ListLevels(1)
Select Case HeadingLvl
Case 1
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading1
Case 2
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading2
Case 3
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading3
Case 4
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading4
Case 5
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading5
Case 6
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading6
Case 7
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading7
End Select
.NumberFormat = wrdHeadingNr
.NumberStyle = Word.WdListNumberStyle.wdListNumberStyleArabic
End With
wrdApp.Selection.Range.ListFormat.ApplyListTemplate(ListTemplate:=ListTemp)
ListTemp = Nothing
End Sub
I discovered the answer myself. Below is the changes to the sub function. It worked well for me.
Sub HeadingListLevel(wrdApp As Object, HeadingLvl As Integer)
'Dim wrdHeading As String
Dim wrdHeadingNr As String
Dim i As Integer
Dim ListTemp As Word.ListTemplate
wrdHeadingNr = "%" & 1
ListTemp = wrdApp.ListGalleries(Word.WdListGalleryType.wdOutlineNumberGallery).ListTemplates(5)
For i = 1 To HeadingLvl
If i > 1 Then
wrdHeadingNr = wrdHeadingNr & "." & "%" & 1
End If
Next i
'wrdHeading = "Heading " & HeadingLvl
With ListTemp.ListLevels(HeadingLvl)
Select Case HeadingLvl
Case 1
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading1).NameLocal
Case 2
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading2).NameLocal
Case 3
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading3).NameLocal
Case 4
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading4).NameLocal
Case 5
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading5).NameLocal
Case 6
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading6).NameLocal
Case 7
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading7).NameLocal
End Select
'.LinkedStyle = wrdHeading
.NumberFormat = wrdHeadingNr
.NumberStyle = Word.WdListNumberStyle.wdListNumberStyleArabic
'.StartAt = 1
'.ResetOnHigher = False
End With
wrdApp.Selection.Range.ListFormat.ApplyListTemplate(ListTemplate:=ListTemp)
ListTemp = Nothing
End Sub
Related
I have a userform created via VBA that is supposed to populate rows on an Excel sheet. It does, but they're one off:
Name | Race | Agency
Black
Joe Asian B
White
Joanne C
Joe's races are black and Asian, at agency B; Joanne's is white, and she's at agency C. Somehow, the entries are staggered.
Name is a textbox, race and agency are listboxes, with race as a multiselect and agency as a single select.
Here's my code:
Private Sub CommandButton1_Click()
Dim j As Long
Dim i As Integer
With ListBox2
ReDim arr(.ListCount - 1)
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
.Selected(i) = False
arr(j) = .List(i)
j = j + i
End If
Next i
End With
ReDim Preserve arr(j)
With ActiveSheet
.Range("B" & .Rows.Count).End(xlUp). _
Offset(1, 0).Resize(j + 1, 1).Value = Application.Transpose(arr)
End With
i = 1
While ThisWorkbook.Worksheets("Sheet1").Range("B" & i).Value <> ""
i = i + 1
Wend
ThisWorkbook.Worksheets("Sheet1").Range("A" & i).Value = TextBox1.Value
ThisWorkbook.Worksheets("Sheet1").Range("C" & i).Value = ListBox1.Value
End Sub
Private Sub CommandButton2_Click()
Dim ctl As MSForms.Control
For Each ctl In Me.Controls
Select Case TypeName(ctl)
Case "TextBox"
ctl.Text = ""
Case "CheckBox", "OptionButton", "ToggleButton"
ctl.Value = False
Case "ComboBox", "ListBox"
ctl.ListIndex = -1
End Select
Next ctl
End Sub
Sub UserForm_Initialize()
ListBox1.List = Array("A", "B", "C")
With ListBox2
.Clear
.AddItem "White"
.AddItem "Black"
.AddItem "Asian"
.AddItem "Am Indian/Al Native"
.AddItem "Native Hawaiian/Pac Islander"
.AddItem "Other"
End With
End Sub
I would love any ideas ya'll have on how to fix that! Ideally, it would come out in one of the following ways:
Name | Race | Agency
Joe Black B
Asian B
Joanne White C
or
Name | Race | Agency
Joe Black, Asian B
Joanne White C
or
Name | Race | Agency
Joe Black B
Joe Asian B
Joanne White C
(I prefer the second, but any would work.)
If I understand the code appropriately, the refactored CommandButton1_Click procedure below should produce the preferred result for you.
Private Sub CommandButton1_Click()
Dim j As Long
Dim i As Integer
'load races into array
With ListBox2
ReDim arr(.ListCount - 1)
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
.Selected(i) = False
arr(j) = .List(i)
j = j + i
End If
Next i
End With
ReDim Preserve arr(j)
'build "," separated string of races
For i = LBound(arr) To UBound(arr)
Dim sRace As String
sRace = sRace & "," & arr(i)
Next
sRace = Mid(sRace, 2) 'to remove first comma
'place info on next available line in sheet.
With ThisWorkbook.Worksheets("Sheet1")
Dim lRow As Long
lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1).Row
.Range("A" & lRow).Value = TextBox1.Value
.Range("B" & lRow).Value = sRace
.Range("C" & lRow).Value = ListBox1.Value
End With
End Sub
I searched but couldn't find what I'm looking for.
How do I convert a normal Date() in ASP Classic to a string in the format dd-monthname-YYYY?
Here is an example:
Old date (mm/dd/YYYY) : 5/7/2013
New date (dd-monthname-YYYY) : 7-May-2013
Dim Dt
Dt = CDate("5/7/2013")
Response.Write Day(Dt) & "-" & MonthName(Month(Dt)) & "-" & Year(Dt)
' yields 7-May-2013
' or if you actually want dd-monthname-YYYY instead of d-monthname-YYYY
Function PadLeft(Value, Digits)
PadLeft = CStr(Value)
If Len(PadLeft) < Digits Then
PadLeft = Right(String(Digits, "0") & PadLeft, Digits)
End If
End Function
Response.Write PadLeft(Day(Dt), 2) & "-" & MonthName(Month(Dt)) & "-" & Year(Dt)
'yields 07-May-2013
I wrote an ASP Classic date handling object a while back that might be of use to you. It has a .Format() method that lets you pass in format specifiers just like the Format() function from VB/VBA. If there are any parts missing, I apologize--but this should be a giant leap forward toward natural date formatting.
Private pMillisecondMatch
Function RemoveMillisecondsFromDateString(DateString) ' Handle string dates from SQL Server that have milliseconds attached
If IsEmpty(pMillisecondMatch) Then
Set pMillisecondMatch = New RegExp
pMillisecondMatch.Pattern = "\.\d\d\d$"
pMillisecondMatch.Global = False
End If
RemoveMillisecondsFromDateString = pMillisecondMatch.Replace(DateString, "")
End Function
Function DateConvert(DateValue, ValueIfError)
On Error Resume Next
If IsDate(DateValue) Then
DateConvert = CDate(DateValue)
Exit Function
ElseIf TypeName(DateValue) = "String" Then
DateValue = RemoveMillisecondsFromDateString(DateValue)
If IsDate(DateValue) Then
DateConvert = CDate(DateValue)
Exit Function
End If
End If
DateConvert = ValueIfError
End Function
Class AspDate
Private pValue
Public Default Property Get Value()
Value = pValue
End Property
Public Property Set Value(DateValue)
If TypeName(DateValue) = "AspDate" Then
pValue = DateValue.Value
Else
Err.Raise 60020, "Class AspDate: Invalid object type " & TypeName(DateValue) & " passed to Value property."
End If
End Property
Public Property Let Value(DateValue)
pValue = DateConvert(DateValue, Empty)
End Property
Public Property Get FormattedDate()
FormattedDate = Format("yyyy-mm-dd hh:nn:ss")
End Property
Public Function Format(Specifier)
Dim Char, Code, Pos, MonthFlag
Format = "": Code = ""
If IsEmpty(Value) Then
Format = "(Empty)"
End If
Pos = 0
MonthFlag = False
For Pos = 1 To Len(Specifier) + 1
Char = Mid(Specifier, Pos, 1)
If Char = Left(Code, 1) Or Code = "" Then
Code = Code & Char
Else
Format = Format & Part(Code, MonthFlag)
Code = Char
End If
Next
End Function
Private Function Part(Interval, MonthFlag)
Select Case LCase(Left(Interval, 1))
Case "y"
Select Case Len(Interval)
Case 1, 2
Part = Right(CStr(Year(Value)), 2)
Case 3, 4
Part = Right(CStr(Year(Value)), 4)
Case Else
Part = Right(CStr(Year(Value)), 4)
End Select
Case "m"
If Not MonthFlag Then ' this is a month calculation
MonthFlag = True
Select Case Len(Interval)
Case 1
Part = CStr(Month(Value))
Case 2
Part = Right("0" & CStr(Month(Value)), 2)
Case 3
Part = MonthName(Month(Value), True)
Case 4
Part = MonthName(Month(Value))
Case Else
Part = MonthName(Month(Value))
End Select
Else ' otherwise it's a minute calculation
Part = Right("0" & Minute(Value), 2)
End If
Case "n"
Part = Right("0" & Minute(Value), 2)
Case "d"
Part = CStr(Day(Value))
If Len(Part) < Len(Interval) Then
Part = Right("0" & Part, Len(Interval))
End If
Case "h"
MonthFlag = True
Part = CStr(Hour(Value))
If Len(Part) < Len(Interval) Then
Part = Right("0" & Part, Len(Interval))
End If
Case "s"
Part = Right("0" & Second(Value), 2)
Case Else ' The item is not a recognized date interval, just return the value
Part = Interval
End Select
End Function
End Class
Function NewDate(Value)
Set NewDate = New AspDate
NewDate.Value = Value
End Function
Function NewDateWithDefault(Value, DefaultValue)
Set NewDateWithDefault = New AspDate
If Value = Empty Then
NewDateWithDefault.Value = DefaultValue
Else
NewDateWithDefault.Value = Value
End If
End Function
Here's example code using the above class:
<%=NewDate(Checkin.Parameters.Item("#DOB").Value).Format("mm/dd/yyyy")%>
To get the format you've noted above, you would do:
.Format("d-mmmm-yyyy")
I am trying to use a string from textbox1 and look for the 3rd 'e' and tell the index of it
for example, if somebody typed in cheese, then the index of it
so far, i have
Dim word As String = TextBox2.Text
Dim x As String
Dim counter As Integer
Dim Letter As String
Dim word1 As String
x = 0
word1 = word.ToLower()
Do
If word1.Substring(x, 1) = "e" Then counter = counter + 1 And x = x + 1
Loop Until counter = 3 Or counter <> 3
If counter <> 3 Then MsgBox("There are only " & counter & "e's in the inputted string") Else ListBox2.Items.Add(Letter)
I have a select distinct query that works find on selected fields from a listbox. However I would like it to be a count distinct and I can't seem to get the code right. Below is my working code for select distinct. Thanks in advance for any assistance I've searched for count distinct questions but I don't see any specific to listbox selections.
Private Sub CmdDistinctVal_Click()
Dim cn1 As ADODB.Connection
Dim rs1 As New ADODB.Recordset
Dim cmd1 As New ADODB.Command
Dim varItem As Variant
Dim aFields() As aArray
Dim NumRows As Integer
Dim NumFields As Integer
Dim colcount As Integer
Dim colwidths As String
Dim strRow As String
Dim cnt1 As Integer
Dim cnt2 As Integer
'On Error GoTo Err_ CmdDistinctVal_Click
'cmd1.ActiveConnection = CurrentProject.Connection
Me.DistinctResultsFldVal.RowSource = ""
ReDim aFields(50)
For cnt1 = 1 To 50
ReDim aFields(cnt1).fValue(6000)
Next
NumRows = 0
colcount = 0
For Each varItem In Me!ResultsFieldList.ItemsSelected
colcount = colcount + 1
aFields(colcount).fName = Me!ResultsFieldList.ItemData(varItem)
NumFields = 0
rs1.Open "SELECT DISTINCT " & Me!ResultsFieldList.ItemData(varItem) & "
FROM [Results Report]", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
If rs1.RecordCount > NumRows Then NumRows = rs1.RecordCount
strRow = strRow & Me!ResultsFieldList.ItemData(varItem) & ";"
While Not rs1.EOF
NumFields = NumFields + 1
If NumFields > NumRows Then
NumRows = NumFields
End If
aFields(colcount).fValue(NumFields) = rs1(0) & ""
rs1.MoveNext
Wend
rs1.Close
Next varItem
strRow = Left(strRow, Len(strRow) - 1)
Me.DistinctResultsFldVal.ColumnCount = colcount
Me.DistinctResultsFldVal.ColumnWidths = Mid(colwidths, 2)
Me.DistinctResultsFldVal.AddItem (strRow)
For cnt1 = 1 To NumRows
strRow = ""
For cnt2 = 1 To colcount
If aFields(cnt2).fValue(cnt1) = "" Then
strRow = strRow & ";"
Else
strRow = strRow & aFields(cnt2).fValue(cnt1) & ";"
End If
Next
strRow = Left(strRow, Len(strRow) - 1)
Me.DistinctResultsFldVal.AddItem (strRow)
Next
'Err_ CmdDistinctVal_Click:
'MsgBox "All null values were found in one or more of your selected fields"
End Sub
I'm trying to copy and paste a range, to create a 28 by 28 grid of numbers "rotating" the values so that each time the range is pasted into the next column, the range is moves down by one row and the last value "overflows" back to the top of the next row, I've got this far but am stumped on the overflow part (i' relative newbie to VBA)
Sub Test()
Dim oRange As Range
Set oRange = ActiveSheet.Range("A1:A28")
Dim i As Integer
For i = 1 To 28
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Next i
End Sub
Also I need to copy and paste values and formatting of the cells
Hope you guys can help
Thanks
Dan
Sub Test()
Dim oRange As Range
Dim startColumn As String
Dim rangeStart As Integer
Dim rangeEnd As Integer
Dim cellCount As Integer
Dim i As Integer
startColumn = "A"
rangeStart = 1
rangeEnd = 28
cellCount = rangeEnd - rangeStart + 1
For i = 1 To cellCount - 1
Set oRange = ActiveSheet.Range(startColumn & rangeStart & _
":" & startColumn & (rangeEnd - i))
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Set oRange = ActiveSheet.Range(startColumn & (rangeEnd - i + 1) & _
":" & startColumn & rangeEnd)
oRange.Copy
oRange.Offset((-1 * cellCount) + i, i).PasteSpecial xlPasteAll
Next i
End Sub
EDIT:
to insert a blanck row at index 'i':
Rows(i & ":" & i).Select
Selection.Insert Shift:=xlDown
to insert 5 rows at the top of the worksheet insert a row 5 times at index 1:
For i = 1 To 5
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Next