View Full Version : BBCode Table
Hi Kris,
VBA to convert excel range to BBCode table syntax and send to the clipboard via API
Option Explicit
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
For Each BB_Cells In BB_Row.Cells
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
v
A
B
C
D
E
F
G
H
1
order
product
qty
1
2
3
10
30
2
1001
orange
3
A
AA
AAA
AAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
3
1002
berry red
1
4
1002
berry red
1
5
1002
berry purple
1
6
1003
apple red
1
7
1003
apple green
2
8
1004
berry red
1
Admin
01-20-2016, 07:30 AM
Thanks. I made it a sticky thread here :)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxhXnQ-mWYhrHWuM354AaABAg.9bepnegjnRu9iMmBDtf4m1 (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxhXnQ-mWYhrHWuM354AaABAg.9bepnegjnRu9iMmBDtf4m1)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxFIZ858qf7w_uA9bd4AaABAg.9dKpEpUk3YT9dVEGnka6 yj (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxFIZ858qf7w_uA9bd4AaABAg.9dKpEpUk3YT9dVEGnka6 yj)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=Ugz8oC8iGd6-SPhpaQZ4AaABAg.9bhRt-kPXri9brzh_99JF9 (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=Ugz8oC8iGd6-SPhpaQZ4AaABAg.9bhRt-kPXri9brzh_99JF9)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=Ugz8oC8iGd6-SPhpaQZ4AaABAg.9bhRt-kPXri9bsrQIgXb3L (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=Ugz8oC8iGd6-SPhpaQZ4AaABAg.9bhRt-kPXri9bsrQIgXb3L)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzFkoI0n_BxwnwVMcZ4AaABAg (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzFkoI0n_BxwnwVMcZ4AaABAg)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxwJDkFskrMW8EpcXt4AaABAg.9bmKMz5-Z1g9bmx0REIz41 (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxwJDkFskrMW8EpcXt4AaABAg.9bmKMz5-Z1g9bmx0REIz41)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxhXnQ-mWYhrHWuM354AaABAg.9bepnegjnRu9bmyko2YUvQ (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxhXnQ-mWYhrHWuM354AaABAg.9bepnegjnRu9bmyko2YUvQ)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxwJDkFskrMW8EpcXt4AaABAg.9bmKMz5-Z1g9bmzpPqfLRD (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxwJDkFskrMW8EpcXt4AaABAg.9bmKMz5-Z1g9bmzpPqfLRD)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzZwbV_Y_7UFzHwNBh4AaABAg.9dKb0Vc7MOB9dVK8si3o nt (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzZwbV_Y_7UFzHwNBh4AaABAg.9dKb0Vc7MOB9dVK8si3o nt)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=Ugx6Ec_r4kb9EYOVgIt4AaABAg.9dOW613fb8V9dVIJECZI dC (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=Ugx6Ec_r4kb9EYOVgIt4AaABAg.9dOW613fb8V9dVIJECZI dC)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgwBho9tBLQ4nPVdYqd4AaABAg.9fWvoBWY3Da9g9cLjhPi az (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgwBho9tBLQ4nPVdYqd4AaABAg.9fWvoBWY3Da9g9cLjhPi az)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzZy1NAMBx5Uv4U2cJ4AaABAg.9f0XX-_JaGp9g9bYLMZiIy (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzZy1NAMBx5Uv4U2cJ4AaABAg.9f0XX-_JaGp9g9bYLMZiIy)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgyL-xp8IiiahmQ12kJ4AaABAg.9f7xHCpAEx29g9asFhVFfT (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgyL-xp8IiiahmQ12kJ4AaABAg.9f7xHCpAEx29g9asFhVFfT)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxRxyFNNp3WHTzuiJJ4AaABAg.9fFR6ECmXk69g9afNBcS 4Z (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxRxyFNNp3WHTzuiJJ4AaABAg.9fFR6ECmXk69g9afNBcS 4Z)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgwsdMh0FGDfvA249_B4AaABAg.9fLR6FHCIVI9g9aLlUyz og (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgwsdMh0FGDfvA249_B4AaABAg.9fLR6FHCIVI9g9aLlUyz og)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgwBho9tBLQ4nPVdYqd4AaABAg.9fWvoBWY3Da9g9_4422N zK (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgwBho9tBLQ4nPVdYqd4AaABAg.9fWvoBWY3Da9g9_4422N zK)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=Ugwyy8JXr56HJ8m_od94AaABAg.9gSFgqqJQNV9gTXco41b 5l (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=Ugwyy8JXr56HJ8m_od94AaABAg.9gSFgqqJQNV9gTXco41b 5l)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgyS8stMz5B9NrpPrbR4AaABAg.9gOjiS0rs8l9gTYl6Rld pA (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgyS8stMz5B9NrpPrbR4AaABAg.9gOjiS0rs8l9gTYl6Rld pA)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgyS8stMz5B9NrpPrbR4AaABAg.9gOjiS0rs8l9gTfhAWU9 ju (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgyS8stMz5B9NrpPrbR4AaABAg.9gOjiS0rs8l9gTfhAWU9 ju)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgyS8stMz5B9NrpPrbR4AaABAg.9gOjiS0rs8l9gTfuYQGm Ua (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgyS8stMz5B9NrpPrbR4AaABAg.9gOjiS0rs8l9gTfuYQGm Ua)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgyS8stMz5B9NrpPrbR4AaABAg.9gOjiS0rs8l9gTg3AmMP Uc (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgyS8stMz5B9NrpPrbR4AaABAg.9gOjiS0rs8l9gTg3AmMP Uc)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgyS8stMz5B9NrpPrbR4AaABAg.9gOjiS0rs8l9gTgEqh5w do (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgyS8stMz5B9NrpPrbR4AaABAg.9gOjiS0rs8l9gTgEqh5w do)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxmUK0S_aZVZWz8-gt4AaABAg.9gLc3DfWfHl9gTZ3y6fL1H (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgxmUK0S_aZVZWz8-gt4AaABAg.9gLc3DfWfHl9gTZ3y6fL1H)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzZloYeY2wQr7-xTOh4AaABAg.9gB2bbbs9mB9gTZUkNYI8e (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzZloYeY2wQr7-xTOh4AaABAg.9gB2bbbs9mB9gTZUkNYI8e)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzlM96nGEhW9J1Gpgd4AaABAg.9fmOFVcXZh49gT_8CYeQ gz (https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzlM96nGEhW9J1Gpgd4AaABAg.9fmOFVcXZh49gT_8CYeQ gz)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
Admin
01-20-2016, 10:21 AM
This seems to be working on Conditional Formatting as well.
Option Explicit
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
For Each BB_Cells In BB_Row.Cells
If BB_Cells.FormatConditions.Count Then
strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
Else
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
End If
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
Admin
01-20-2016, 10:22 AM
v
F
G
H
I
J
K
L
M
10
87
24
62
97
12
47
33
77
11
48
90
44
10
91
51
18
65
12
65
61
69
96
84
54
13
92
13
72
94
96
83
71
47
22
25
14
27
94
74
21
13
31
27
76
15
25
46
52
14
95
32
90
92
16
54
29
53
17
45
20
10
81
17
84
11
74
28
33
45
52
10
18
76
55
56
91
88
76
49
26
19
10
69
20
51
11
74
37
73
20
46
25
94
94
53
68
57
19
21
90
93
89
41
26
11
25
99
22
94
61
24
29
54
85
81
20
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
DocAElstein
01-20-2016, 08:24 PM
I have a File with working versions of this code, and some other BB Code Generator Alternatives.
File is “MollyBBCodes.xlsm”
https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
http://www.excelforum.com/attachments/development-testing-forum/441618d1453300597-forum-tools-test-no-reply-needed-mollybbcodes.xlsm
Some typical results shown Here:
http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9635
I have tried to tidy the File up a bit, such that all these codes work independently as “stand alone” codes.. ( But I may have missed a shared function or two!! )
Alan
Using Excel 2007
<tbody>
Row\Col
J
K
L
5
Test
ying
"PikeFoxRick"
6
Note
does
not
7
have
The
XL2007
8
Cell
Text
Color
9
problem
that
some
10
similar
codes
have
</tbody>
<tbody>
Sheet: Molly
</tbody>
_.......................................
Using Excel 2007
Row\Col
D
E
F
G
H
I
J
K63
87
24
62
97
12
47
33
77
64
48
90
44
10
91
51
18
65
65
65
61
69
96
84
54
13
92
66
72
94
96
83
71
47
22
25
67
27
94
74
21
13
31
27
76
68
25
46
52
14
95
32
90
92
69
54
29
53
17
45
20
10
81
70
84
11
74
28
33
45
52
10
71
76
55
56
91
88
76
49
26
72
10
69
20
51
11
74
37
73
73
46
25
94
94
53
68
57
19
74
90
93
89
41
26
11
25
99
75
94
61
24
29
54
85
81
20
Sheet: Molly
Admin
01-21-2016, 06:23 PM
Using Excel 2013 on Win 10 64 bit
v
E
F
G
H
I
J
K
L
M
4
39
99
63
45
15
81
67
9
92
5
97
29
96
55
1
23
40
70
99
6
55
55
50
71
28
4
79
48
53
7
5
84
31
28
70
33
92
97
67
8
84
88
66
76
83
75
79
14
83
9
32
90
35
45
45
5
92
41
18
10
52
90
24
63
84
59
64
75
26
11
72
23
40
26
70
100
88
88
64
12
3
91
93
39
21
5
97
84
80
13
86
39
82
49
50
73
13
97
7
14
8
22
99
48
8
38
24
64
100
15
27
1
99
58
89
40
54
31
75
16
63
85
93
23
5
99
93
92
33
17
70
57
78
75
33
51
90
41
19
DocAElstein
01-21-2016, 07:32 PM
@Admin
How do you get your code to look “normal” in a php Window .. when I try my code, I get something like this:
http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9634
Thanks
Alan
P.s. ( I realize you use php instead of BB Code Window to stop the square brackets in strings in the code causing problems )
P.P.s when I copy your code and put it in a php window it looks OK…
Here a bit of my code:
Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String 'Const csHEADER_COLOR As String = """#FFFFFF""" Const csHEADER_COLOR As String = "black" 'Const csHEADER_BACK As String = "#888888" Const csHEADER_BACK As String = "powderblue" Const csROW_BACK As String = "#FFFFFF" Set BB_Range = Selection BB_Code = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version BB_Code = BB_Code & "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine 'BB_Code = BB_Code & "[tr]v" & vbNewLine BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0) 'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row Next BB_Cells
_................................
Here a bit of your code from Post #3 ( Note copied here directly from the Thread Post #3 and then pasted into a php Window in this post )
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
BB_Code = BB_Code & "[tr]v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
_........................
But , the same code bit of yours copied first to my the VB Editor, and then back to a php window it does not work again….
Sub BB_Table_Clipboard() Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String Set BB_Range = Selection BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine BB_Code = BB_Code & "[tr]v" & vbNewLine For Each BB_Cells In BB_Range.Rows(1).Cells strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0) BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine Next BB_Cells
DocAElstein
01-21-2016, 10:39 PM
......
How do you get your code to look “normal” in a php Window .........
So I have a "manual" Work around…( Workaround 1 ) … ( which I do not understand.. ) … to get a code with strings containing BB Code to come up ( in a php Window ) which can then be copied to a VB Editor Code Window. ( Normal copying to between BB Code Tags ( as well as simple copying to between php BB Code Tags ) does not work … (… for me… Poo! ) )
_1 ) I copy a few lines from any code from a php Window that does appear to look normal……
_2 ) I paste that code bit into a spare WORD document. ( I have WORD 2007 )
_2a ) I notice that the text appears to be nested in a light grey background….
_3 ) Somewhere in the middle of that code I hit ENTER to get a few empty lines
_4 ) I copy my code from the VB Editor into the WORD document at the point of the spare lines I made
_4a) I notice that my code also appears to be nested in a light grey background.
_5 ) I now copy that into a php Window in a Thread post ( To do that I either; hit the php icon in the symbol in the Forum Editor and paste my code into the php BB Code Tag pair which appears; or paste in my code, highlight it and hit the hit the php icon in above in the symbol ribbon in the Forum Editor. )
Codes ( all to go in one module ) ( for my version of the code from Pike, Kris and Rick )
http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642
http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643
http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=vSjTzhoJFdk&lc=UgzTC8V4jCzDHbmfCHF4AaABAg.9zaUSUoUUYs9zciSZa95 9d (https://www.youtube.com/watch?v=vSjTzhoJFdk&lc=UgzTC8V4jCzDHbmfCHF4AaABAg.9zaUSUoUUYs9zciSZa95 9d)
https://www.youtube.com/watch?v=vSjTzhoJFdk&lc=UgzTC8V4jCzDHbmfCHF4AaABAg.9zaUSUoUUYs9zckCo1tv PO (https://www.youtube.com/watch?v=vSjTzhoJFdk&lc=UgzTC8V4jCzDHbmfCHF4AaABAg.9zaUSUoUUYs9zckCo1tv PO)
https://www.youtube.com/watch?v=vSjTzhoJFdk&lc=UgwMsgdKKlhr2YPpxXl4AaABAg (https://www.youtube.com/watch?v=vSjTzhoJFdk&lc=UgwMsgdKKlhr2YPpxXl4AaABAg)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwTUdEgR4bdt6crKXF4AaABAg.9xmkXGSciKJ9xonTti2s Ix (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwTUdEgR4bdt6crKXF4AaABAg.9xmkXGSciKJ9xonTti2s Ix)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwWw16qBFX39JCRRm54AaABAg.9xnskBhPnmb9xoq3mGxu _b (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwWw16qBFX39JCRRm54AaABAg.9xnskBhPnmb9xoq3mGxu _b)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9xon1p2ImxO (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9xon1p2ImxO)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgybZfNJd3l4FokX3cV4AaABAg.9xm_ufqOILb9xooIlv5P LY (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgybZfNJd3l4FokX3cV4AaABAg.9xm_ufqOILb9xooIlv5P LY)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9y38bzbSqaG (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9y38bzbSqaG)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgyWm8nL7syjhiHtpBF4AaABAg.9xmt8i0IsEr9y3FT9Y9F eM (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgyWm8nL7syjhiHtpBF4AaABAg.9xmt8i0IsEr9y3FT9Y9F eM)
https://www.youtube.com/watch?v=bRd4mJglWiM&lc=UgxRmh2gFhpmHNnPemR4AaABAg.A0opm95t2XEA0q3Kshmu uY (https://www.youtube.com/watch?v=bRd4mJglWiM&lc=UgxRmh2gFhpmHNnPemR4AaABAg.A0opm95t2XEA0q3Kshmu uY)
https://www.youtube.com/watch?v=bRd4mJglWiM&lc=UgxRmh2gFhpmHNnPemR4AaABAg (https://www.youtube.com/watch?v=bRd4mJglWiM&lc=UgxRmh2gFhpmHNnPemR4AaABAg)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837)
https://www.eileenslounge.com/viewtopic.php?f=21&t=40701&p=314836#p314836 (https://www.eileenslounge.com/viewtopic.php?f=21&t=40701&p=314836#p314836)
https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314621#p314621 (https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314621#p314621)
https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314619#p314619 (https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314619#p314619)
https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314600#p314600 (https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314600#p314600)
https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314599#p314599 (https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314599#p314599)
https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314274#p314274 (https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314274#p314274)
https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314229#p314229 (https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314229#p314229)
https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314195#p314195 (https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314195#p314195)
https://www.eileenslounge.com/viewtopic.php?f=36&t=39706&p=314110#p314110 (https://www.eileenslounge.com/viewtopic.php?f=36&t=39706&p=314110#p314110)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
DocAElstein
03-09-2016, 09:19 PM
Just some further Testing, as I may have another solution to the problem of codes pasted into a HTML ( or PHP ) Window "Loosing" a carriage return"
To remind ( me! ) of what i am testing out here: Sometimes it is better to use A HTML ( or PHP ) Code window rather than a BB Code Window to paste in a Forum Post. This can be the case, for example, when a Code itself contains text strings which may have BB Code Tags in. ( The Code tags usually are recognised as just that giving some peculiar results. )
This Code for example, shown here excactly as I want it, would get messed up in a code Window
Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
1 'Line 1
2 'Line 2
3 'Line 3
4 Dim strBBCodeTag As String
5 Let strBBCodeTag = "A Text in Forum Post to come out Light Salmon in Color"
End Sub
_................................................. ....
Pasted in a code Window:
Sub CodeLinesInHTMLWindowLoosingCarriageReturns()1 'Line 1
2 'Line 2
3 'Line 3
4 Dim strBBCodeTag As String
5 Let strBBCodeTag = "A Text in Forum Post to come out Light Salmon in Color"
End Sub
You see the BB Code String was evaluated literally as BB Code. - The BB Code string is messed up as I do not want
_.............................................
It is found that pasting in a HTML Code window instead can give you this
Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
1 'Line 1
2 'Line 2
3 'Line 3
4 Dim strBBCodeTag As String
5 Let strBBCodeTag = "A Text in Forum Post to come out Light Salmon in Color"
End Sub
which is again what I wanted
_...............................................
But if you paste directly by copying from the VB Editor ( Ctrl C ) and pasting in the forum Editor in HTML Code tags, then you can get this instead.
Sub CodeLinesInHTMLWindowLoosingCarriageReturns()1 'Line 12 'Line 23 'Line 34 Dim strBBCodeTag As String5 Let strBBCodeTag = "A Text in Forum Post to come out Light Salmon in Color"End Sub
. here the carriage returns have „vanished!!!!“
_................................................. ..................................
_ I noticed and demonstrated that you can get over this sometimes by “doing a stop over “ in between at a a Word Document, that is to say pasting into a Word document first , then re – copying that to the clipboard and pasting that into the Forum Editor.
http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9641
http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9645
_..............................................
OK that was one “workaround”..... _The other Day I had a similar problem (_.......... with a code i did to overcome the problem of the Forum Editor “eating” spaces of greater than two. )
Eileen's Lounge • View topic - Word VBA Replace multiple Spaces in Text with BB Code String (http://www.eileenslounge.com/viewtopic.php?f=26&t=22603&start=20#p176255)
_...............)
_ Some how this “loss of a carriage return crept in when pasted into a Post, ( even though in Word or in a displayed Message Box, the text i wanted to past in seemed OK ).
_ After a bit of experimenting I tried a modification which was basically this code line
= Replace((Text), vbCr, vbCr & vbLf, 1, -1) 'In Text~~,~~~replce a vbCr~~~,~~~with a vbCr & vbLf~~~~,~~~~the returned string should start at position 1 of the original ( so whole string returned )(Note: the number is not just where you start replacing- it is also where the returned String may start-so a number greater than 1 will "chop" bits off returning a string of reduced length compared with the original~~~,~~~-1~~indicates replace all occurrences
Writing a code to do something similar to the text held in the Clipboard appears to do something similar ( Not quite the same .. here what the Message box shows for the “Before” and “after” is different, which was not the case with the modification to the “preventing Forum editor eating spaces more than 2 codes” . Clearly the vbCr and vbLf is a trick one.. )
_.................
So Finally
_ If you wish to use the HTML Code Window rather than the BB Code Window when posting a Code in a Forum Thread.... you
_ Copy the code from the VB Editor, ( Ctrl C )
_ Run this code, ( which works on and modifies the text in the Clipboard.
Sub PutInAvbLfInClipboadText() ' "Replcace vbCr with vbCr & vbLf "
'Get Current Text from Clipboard
Dim objDat As dataobject
Set objDat = New dataobject 'Set to a new Instance ( Blue Print ) of dataobject
'Dim obj As Object
'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDat.GetFromClipboard 'All that is in the Clipboard goes in this Data Object instance of the Class.
Let TxtOut = objDat.GetText() 'retrieve the text in this instance of the Class. ( In this case all I have in it is the text typically I think as it is coming from a Ctrl C Copy from the VB Editor )
Dim originalClipboardText As String: Let originalClipboardText = TxtOut
Dim TextWithExtravbLF As String
Let TextWithExtravbLF = Replace(TxtOut, vbCr, vbCr & vbLf, 1, -1)
'Dump in Clipboard: This second instance of Data Object used to put in Clipboard
Dim objCliS As dataobject '**Early Binding. This is for an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. So I name it CLIpboardSend. But it is a DataObject. It has the Methods I need to send text to the Clipboard
Set objCliS = New dataobject '**Must enable Forms Library: In VB Editor do this: Tools -- References - scroll down to Microsoft Forms 2.0 Object Library -- put checkmark in. Note if you cannot find it try OR IF NOT THERE..you can add that manually: VBA Editor -- Tools -- References -- Browse -- and find FM20.DLL file under C:\WINDOWS\system32 and select it --> Open --> OK.
' ( or instead of those two lines Dim obj As New DataObject ). or next two lines are.....Late Binding equivalent'
'Dim obj As Object' Late Binding equivalent' If you declare a variable as Object, you are late binding it. http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/
'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
objCliS.SetText TextWithExtravbLF 'Make Data object's text equal to a copy of ORefiginalText
objCliS.PutInClipboard 'Place current Data object into the Clipboard
' Get from clipboard. This a Another Object from class to be sure we have the data in the Clipboard
MsgBox prompt:="You dumped in Clipboard originally this " & vbCr & TxtOut & vbCr & "and if you try to get it, you should get" & vbCr & TextWithExtravbLF & ""
' End clean up.
'TheEnd: ' ( Come here always, even on a unpredictable error )
Set objDat = Nothing ' Good practice... maybe....
Set objCliS = Nothing ' ....... http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring.html#post4414065
End Sub
_ Paste into the Forum Thread an enclose in HTML Code Tags..This comes out:
Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
1 'Line 1
2 'Line 2
3 'Line 3
4 Dim strBBCodeTag As String
5 Let strBBCodeTag = "A Text in Forum Post to come out Light Salmon in Color"
End Sub
Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
1 'Line 1
2 'Line 2
3 'Line 3
4 Dim strBBCodeTag As String
5 Let strBBCodeTag = "A Text in Forum Post to come out Light Salmon in Color"
End Sub
Alan
_..................................
DocAElstein
03-27-2016, 08:26 PM
Hi
This Code in a HTML ( or PHP ) Window still catches me out ( due to the “vanishing Carriage return problem ) , sometimes, so I am just checking ( using my Workaround 2 ), on a Code I noticed that seems to have the problem....
So I copy that code from Joe4 in Post #2
Test (http://www.mrexcel.com/forum/test-here/928170-test.html#post4460965)
to a VB Editor Window ( and put it in HTML Code Tags ), as that might be my normal “starting point” ( I just present a part for clarity here, but initially I did the experiment on the whole code and the important results were the same)
I post it into the Editor. It looks Ok initially In the Editor.....
Sub MyMacro()
Dim myRow As Long
Dim myLastRow As Long
Dim myCounter As Long
Dim mySplit As Long
Dim myNewRow As Long
Dim myInsert As Long
Dim myColA As String
Dim myColB As String
Dim myColC As String
Dim myColD As String
Dim myColE As String
' Find last row
_................................................. ..........................
But then comes out like this in the final Post.
Sub MyMacro()
Dim myRow As Long Dim myLastRow As Long Dim myCounter As Long Dim mySplit As Long Dim myNewRow As Long Dim myInsert As Long Dim myColA As String Dim myColB As String Dim myColC As String Dim myColD As String Dim myColE As String ' Find last rowEnd Sub
_................................................. ......................
If I then relook in the editor ( by editing the post ) it no longer looks OK:
Sub MyMacro()
Dim myRow As Long Dim myLastRow As Long Dim myCounter As Long Dim mySplit As Long Dim myNewRow As Long Dim myInsert As Long Dim myColA As String Dim myColB As String Dim myColC As String Dim myColD As String Dim myColE As String ' Find last row
End Sub
_...
Weird!!!!!!!!
_..............
My “Theory” ( probably as naively wrong as all of them.. ) ... back in the early days... a carriage return brought the Printer back to the start at the left
But then you needed...
A Line feed to go to the next line to be printed on.
Somewhere along the line the exact translation to what similarly happens in modern computer world is a bit abstract. So a carriage return ( or Line feed alone ) might work. But maybe doing a carriage return and a Line feed would not do any harm and might occasionally help....
_....................................
So Try this: After copying to the clipboard from the code Window I run this code
' http://www.eileenslounge.com/viewtopic.php?f=26&t=22603&start=20#p176255 http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9687 ( Manual Solution Alternative: http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9645 )
Sub PutInAvbLfInClipboadText() ' "Replcace vbCr with vbCr & vbLf "
'Get Current Text from Clipboard
Dim objDat As dataobject
Set objDat = New dataobject 'Set to a new Instance ( Blue Print ) of dataobject
'Dim obj As Object
'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDat.GetFromClipboard 'All that is in the Clipboard goes in this Data Object instance of the Class.
Let TxtOut = objDat.GetText() 'retrieve the text in this instance of the Class. ( In this case all I have in it is the text typically I think as it is coming from a Ctrl C Copy from the VB Editor )
Dim originalClipboardText As String: Let originalClipboardText = TxtOut
Dim TextWithExtravbLF As String
Let TextWithExtravbLF = Replace(TxtOut, vbCr, vbCr & vbLf, 1, -1)
'Dump in Clipboard: This second instance of Data Object used to put in Clipboard
Dim objCliS As dataobject '**Early Binding. This is for an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. So I name it CLIpboardSend. But it is a DataObject. It has the Methods I need to send text to the Clipboard
Set objCliS = New dataobject '**Must enable Forms Library: In VB Editor do this: Tools -- References - scroll down to Microsoft Forms 2.0 Object Library -- put checkmark in. Note if you cannot find it try OR IF NOT THERE..you can add that manually: VBA Editor -- Tools -- References -- Browse -- and find FM20.DLL file under C:\WINDOWS\system32 and select it --> Open --> OK.
' ( or instead of those two lines Dim obj As New DataObject ). or next two lines are.....Late Binding equivalent'
'Dim obj As Object' Late Binding equivalent' If you declare a variable as Object, you are late binding it. http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/
'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
objCliS.SetText TextWithExtravbLF 'Make Data object's text equal to a copy of ORefiginalText
objCliS.PutInClipboard 'Place current Data object into the Clipboard
' Get from clipboard. This a Another Object from class to be sure we have the data in the Clipboard
MsgBox prompt:="You dumped in Clipboard originally this " & vbCr & TxtOut & vbCr & "and if you try to get it, you should get" & vbCr & TextWithExtravbLF & ""
' End clean up.
'TheEnd: ' ( Come here always, even on a unpredictable error )
Set objDat = Nothing ' Good practice... maybe....
Set objCliS = Nothing ' ....... http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring.html#post4414065
End Sub
_.....
That code simply replaces all
vbCr 's
with a
vbCr & vbLf ( So replaces a carriage return with a carriage return and a Line feed )
Then in the editor initially I get this
Sub MyMacro()
Dim myRow As Long
Dim myLastRow As Long
Dim myCounter As Long
Dim mySplit As Long
Dim myNewRow As Long
Dim myInsert As Long
Dim myColA As String
Dim myColB As String
Dim myColC As String
Dim myColD As String
Dim myColE As String
' Find last row
End Sub
_..........
In the post it now comes out OK:
Sub MyMacro()
Dim myRow As Long
Dim myLastRow As Long
Dim myCounter As Long
Dim mySplit As Long
Dim myNewRow As Long
Dim myInsert As Long
Dim myColA As String
Dim myColB As String
Dim myColC As String
Dim myColD As String
Dim myColE As String
' Find last row
End Sub
_....
But note if i look again in the Editor by editing the post I see this:
Sub MyMacro()
Dim myRow As Long
Dim myLastRow As Long
Dim myCounter As Long
Dim mySplit As Long
Dim myNewRow As Long
Dim myInsert As Long
Dim myColA As String
Dim myColB As String
Dim myColC As String
Dim myColD As String
Dim myColE As String
' Find last row
End Sub
_................................................. ....
I am not sure of exactly what is going on. Either I am giving an extra carriage return to be “eaten” by the Forum editor, but maybe that does not tie up with further editing remaining stable . More likely it wants to see a vbLF to interpret thing correctly. Just an idea from a computer Novice. But anyway the workaround seems to work. :)
Alan
Ref:
Eileen's Lounge • View topic - Word VBA Replace multiple Spaces in Text with BB Code String (http://www.eileenslounge.com/viewtopic.php?f=26&t=22603&start=20#p176255)
P.s. i also have a “manual” solution ( Workaround 1) that seems to work but is a bit more tedious...
http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9645
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
Hi Doc,
I don't totally understand the question and it maybe better to post it in the help forum .. basically the code is VBA not PHP or HTML code.
Only post VBA with Code tags, PHP in the PHP tags and HTML code with HTML tags.
You should post a question on what you want to achieve and not your anticipated solution.
DocAElstein
05-01-2016, 02:25 PM
Hi Pike,
Thanks for the reply,
Only post VBA with Code tags, PHP in the PHP tags and HTML code with HTML tags.
As far as I know that is usually the case, correct. But An exception is the codes we are looking at here which contain strings to build up a BB Code. Those strings will often interfere and cause problems when pasted within BB Code Tags. Hence we usually paste those codes in PHP or HTML ( If you heck out your post #1, you will see that :::.....Last edited by Admin; 01-20-2016 at 04:51 AM. Reason: replaced code tag with php ... . )
I just did another quick demo for you:
First you see in BB Code Tags you get a problem:
http://www.excelforum.com/showthread.php?t=1057943&page=13&p=4376284&highlight=#post4376284
http://www.excelfox.com/forum/f17/test-bb-code-2079/index2.html#post9720
Then the same in HTML Code Tags it is usually OK
http://www.excelforum.com/showthread.php?t=1057943&page=13&p=4376285&highlight=#post4376285
http://www.excelfox.com/forum/f17/test-bb-code-2079/index2.html#post9718
and PHP Tags are also usually OK
http://www.excelfox.com/forum/f17/test-bb-code-2079/index2.html#post9719
http://www.excelforum.com/showthread.php?t=1057943&page=13&p=4376284&highlight=#post4376326
Occaisionally, in some forums, some browsers etc. etc. you get the problem i was on about ....
http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9634
But I note that this Problem is appearing less and less. An update to the Forum Software may have had some effect
_....._________________________
I don't totally understand ...….
You should post a question on what you want to achieve and not your anticipated solution….
I posted a small follow up question some time back, as there were problems with carriage returns vanishing sometimes when trying to copy and share the code further in the HTML Code tags. I had no answer.
I then found a couple of solutions to that problem myself so shared those.
So no Problem, Or rather I have given a couple of solution to a problem that can occur. ( Some people experienced the problem, contacted me and I sent them here to get the solution. In addition at another Forum they did something in their software to prevent the problem coming up ) - If you get the problem ever, then you can refer back to my detailed solutions, or let me know if you need better explanation. There were two general solutions, as I detailed in the previous post and in the referred to posts.
_..............
maybe better to post it in the help forum .
I think that would confuse the issue . The question and solution are directly related to using and, in particular sharing this code, so probably better to be tacked on here as I did. I realise that there should be no questions asked in this Sub Forum. But in this case I thought it was appropriate. .......... particularly as I gave then the solution.....
Anyone wanting the code will probably go straight to the first few posts here to get what they want. Then if they do experience the problems I detailed, then theymay come back here and they may see my reference to those problems and the given solutions. I do not think there is an "About the Board" Type Sub Forum here at ExcelFox. TheHelp Forums are for Excel Word, etc....
_..........................
I don't totally understand
I do not want to labor the point again as I have tried to explain it in detail. But very briefly.
_1) For these particular type of VBA Codes you do need to use HTML or PHP Code Tags when Posting them
_2) When you copy such a code into such Tags and post, you can sometimes get strange results as I indicated with carriage returns vanishing. I gave a couple of solutions to get over that.
Hope that clears it up a bit. Thanks for popping in here…. BTW.**
Alan
_..............................................
P.s. BTW**… How are you accessing ExcelFox just Now. Using Google Chrome I get blocked and am given a warning of a viruses , similar to those which plagued ExcelForum a few Months back. I would be carefuls how you access ExcelFox just now. I drop my Email to you per PM now as I am a bit nervous to use the Forum just now. I have informed Admin and Rick ( Rothstein )
_..
This is what I get when trying to Access ExcelFox using Google Chrome
: http://i1065.photobucket.com/albums/u400/DocAElstein/ExcelFoxUnderAttack_zps4xga2vdi.jpg (http://s1065.photobucket.com/user/DocAElstein/media/ExcelFoxUnderAttack_zps4xga2vdi.jpg.html)
For further examples see Links in first post here
http://www.excelforum.com/the-water-cooler/1129773-so-who-is-still-here-or-back.html
Hello,
The PHP code is executed by the Web server when a web page is accessed and the resulting output is written as HTML within the Web page.
I just tried different PHPBB table properties to find which ones also worked with BBcode as the is little written about all there methods and properties.
Your question is about excel cell string which split string with carriage return[s] and converting to BBcode via VBA.
BBCode or Bulletin Board Code is a basic markup language used to format posts boards which is complied by HTML to covert to a basic table ect...
The VBA BBcode generator does not account for carriage returns in a cell .. work around .. .do not use carriage return and then size the columns and rows height and width to the desired look. Converting excel cell height and width to BBcode table (Height and Width) is a best fit as different fonts have different character heights and widths. basic algorithm for fifteen or so character (few Spaces) is RoundUp(BB_Cells.ColumnWidth * 7.5, 0) you will never get an exact conversion match. It is linear but also needs a count of different character sizes. a x potential algorithm could be better guess for 15 to 25 chars
Set BB_Range = Selection
BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
Also not all excel font styles are available in BBcode so I never tried added them into the routine .. but you could do it and if the font is not available use a default. you will notice in the code above the Windings font does not always get complied from a v to an asterisk
It just a basic table and never a complete worksheet representation , if you have more a complex work upload a workbook.
hope that helps
DocAElstein
05-01-2016, 04:44 PM
Hi Pike, :confused:
I really do appreciate you taking the time to reply and give all of that info. It sounds very intersting. Thanks :) . Sadly , I am a computer novice, and do not really understand. I get only the general point. It certainly sounds like the code snippet you gave could come in handy to further improve your great BB Code Genarator Code. Sadly I lack the ability to incorporate that in your code. I lack the basic understanding. I do not really understand what you are talking about.......
.......
Your question is about excel cell string which split string with carriage return[s] and converting to BBcode via VBA.
............ No That was not anything like my question ( i think :confused: ). You have given some fantasic answers but have completely missed my point. Sorry if i have explained so badly.....
I try again:
I did some more tests for you, just now to try to get accross what I am talking about. Once again: It is all to do with how to share your code in a Forum - that is to say what Code Tags to use. Your BB Code Genarator Code is a VBA Code, so normally we would use the normal BB Code Tags ( from icon # above ).....
But....
..........
......But An exception .... codes ... which contain strings to build up a BB Code. Those strings will often interfere and cause problems when pasted within BB Code Tags. Hence we usually paste those codes in PHP or HTML ( If you check out your post #1, you will see that :::.....Last edited by Admin; 01-20-2016 at 04:51 AM. Reason: replaced code tag with php ... . )
I just did another quick demo for you:
First you see in BB Code Tags you get a problem:
Excel Help Forum (http://www.excelforum.com/showthread.php?t=1057943&page=13&p=4376284&highlight=#post4376284)
http://www.excelfox.com/forum/f17/test-bb-code-2079/index2.html#post9720
Then the same in HTML Code Tags it is usually OK
Excel Help Forum (http://www.excelforum.com/showthread.php?t=1057943&page=13&p=4376285&highlight=#post4376285)
http://www.excelfox.com/forum/f17/test-bb-code-2079/index2.html#post9718
and PHP Tags are also usually OK
http://www.excelfox.com/forum/f17/test-bb-code-2079/index2.html#post9719
http://www.excelforum.com/showthread.php?t=1057943&page=13&p=4376284&highlight=#post4376326
Occaisionally, in some forums, some browsers etc. etc. you get the problem I was on about ....
http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9634
But I note that this Problem is appearing less and less. An update to the Forum Software may have had some effect
_....._________________________
Basically the point is this:
-1) Your BB Code Genarator Code which is the point of this Thread ( and which is a VBA Code ) , will **usually not come out properly in a BB Code Window. So we use a HTML or PHP Code Window as an exception for this type of VBA Code, - that is to say a VBA Code where there are strings inside it with BB Code bits in it ( the square bracket stuff)
(_.. -2) Very occaisionally, ( and not often anymore ), there were also some additional problems when using a HTML window to post your BB Code Genarator Code. I gave a couple of work arounds to that. (Note that this post is from a few Month's ago and there were some updates in Forum Software in the maentime, effecting Code Windows, such as the scroll bar which suddenly appeared in many Forums that did not have it:
http://www.excelfox.com/forum/f17/code-tag-test-with-long-comments-1976/#post9664
from Post # 50 http://www.mrexcel.com/forum/about-board/830361-board-wish-list-5.html
_.....)
What you are talkng about does sound very interseting and useful. But it is something completely different. ( i think:confused: )
If you check out those tests I just did for you, then I think it should be obvious what I was getting at...
I am so very greatful that you take the time to give me such great ( unfortunately above my head partly ) info. So sorry it is not relavent to what I was trying to get across. Hope those extra tests will help.
Alan
_.........
**P.s. I note that in some of your referrences, for example
Convert Excel range to BBCode Table - Page 2 (http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613)
then in the code window you are using there, "VB:" , you do not experience the problems that I have been referring to. But as I have endeavoured to explain, you will get problems at MrExcel, ExcelFox, and ExcelForum if you attempt to post your VBA BBcode generator in normal BB Code Tags. It would appear that at Ozgrid your "normal" Code Window is different to that at MrExcel ExcelForum and ExcelFox. I have no account at, or experience with, Ozgrid Forum
_.....
P.P.s
Since the last time we spoke last January generally about BB Code Generators, the Theme came up a bit in some Threads.. may be just of passing interest...
How to post a range - headers and data? [SOLVED] - Page 17 (http://www.excelforum.com/suggestions-for-improvement/949916-how-to-post-a-range-headers-and-data-17.html)
Tags for Coloring Table cells for EXCELFORUM [SOLVED] (http://www.excelforum.com/showthread.php?t=1127943&p=4324451#post4324451)
I updated the File I gave you, to include some of the new Codes presented.
https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
I have posted the table on all the above forum with no problems.. attach the workbook with the offending strings
DocAElstein
05-02-2016, 02:06 PM
I think I am going mad...:confused:
I have posted the table on all the above forum with no problems.. attach the workbook with the offending strings
It has nothing to do with Tables. A Workbook can be no help what so ever here.
Maybe you have not had time to read all the last few Posts I did for you?
Once again. I am talking about posting your code, ( or similar codes which within the code lines have BB Code Strings in them ) into a Forum Post.
I will repeat again what I have done for you all over the place in the links I gave in the last few posts above:
I will take a version of your code.
In the next post I will paste it in normal Code Tags.
Then in the Post after that I will post it again in HTML Code Tags
Then in the Post after that I will post it again in php Code Tags
These experiments i have done already for you in different Forums as linked in my las few replies
If you look carefully at the resulting codes you will see I think that in the Normal Code Tags there is some rubish in because the parts of the code with BB Code Tags strings in have interfered badly.
In the HTML and php Code windows the codes look fine.
The same I have found in other Forums. As I also mentioned it appears your normal code Tags are different at Ozgrid. You appear to not have this problem there. I cannot check that.
So .. experiments once again in next posts
EDIT And just for fun I dropped in a last one showing the other problem that only occasionally happens which is when carriage returns get lost
Maybe strangely you do not get the problem??
Why not try copying your code to the clipboard
Then paste it here in normal code Tags and see how it looks
DocAElstein
05-02-2016, 02:08 PM
Normal Code Tags
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613' http://www.excelfox.com/forum/f13/bbcode-table-2077/
' '//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
' No User Form. Run Main Code Sub BB_Table_Clipboard_PikeFoxAlan()
Option Explicit
' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
'
'Main Code http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643
Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
'Const csHEADER_COLOR As String = """#FFFFFF"""
Const csHEADER_COLOR As String = "black"
'Const csHEADER_BACK As String = "#888888"
Const csHEADER_BACK As String = "powderblue"
Const csROW_BACK As String = "#FFFFFF"
Set BB_Range = Selection
BB_Code = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "" & vbNewLine
'BB_Code = BB_Code & "v" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & ""
'BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
For Each BB_Cells In BB_Row.Cells
If BB_Cells.FormatConditions.Count Then
strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
Else
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
End If
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
'End of main table
BB_Code = BB_Code & "Sheet: " & BB_Range.Parent.Name & "" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
'
'Some required functions. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
'
Private Function ExcelVersion() As String
Dim temp As String
'On Error Resume Next
#If Mac Then
Select Case Val(Application.Version)
Case 11: temp = "Excel 2004"
Case 12: temp = "Excel 2008" ' this should NEVER happen!
Case 14: temp = "Excel 2011"
Case 15: temp = "vNext"
Case Else: temp = "Unknown"
End Select
#Else
Select Case Val(Application.Version)
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
Case Else: temp = "Unknown"
End Select
#End If
ExcelVersion = temp
End Function
'
'
Private Function ColLtr(ByVal iCol As Long) As String
' shg 2012 Alan 2016 http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html
' Good for any positive Long
If iCol > 0 Then
ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
Else
End If
End Function
DocAElstein
05-02-2016, 02:08 PM
HTML Code Tags
Option ExplicitDeclare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
For Each BB_Cells In BB_Row.Cells
If BB_Cells.FormatConditions.Count Then
strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
Else
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
End If
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
Goto OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
DocAElstein
05-02-2016, 02:10 PM
Option ExplicitDeclare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
For Each BB_Cells In BB_Row.Cells
If BB_Cells.FormatConditions.Count Then
strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
Else
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
End If
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
Goto OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor End Function
DocAElstein
05-02-2016, 02:12 PM
And just for fun the other problem that occaisionally occurs.. the loss of carriage returns
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613' http://www.excelfox.com/forum/f13/bbcode-table-2077/' '//Original code is written by Rick Rothstein '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/' No User Form. Run Main Code Sub BB_Table_Clipboard_PikeFoxAlan()Option Explicit' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongDeclare Function CloseClipboard Lib "User32" () As LongDeclare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As LongDeclare Function EmptyClipboard Lib "User32" () As LongDeclare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongDeclare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As LongPrivate Const GHND = &H42Private Const CF_TEXT = 1Private Const MAXSIZE = 4096''Main Code http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613 Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String 'Const csHEADER_COLOR As String = """#FFFFFF""" Const csHEADER_COLOR As String = "black" 'Const csHEADER_BACK As String = "#888888" Const csHEADER_BACK As String = "powderblue" Const csROW_BACK As String = "#FFFFFF" Set BB_Range = Selection BB_Code = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version BB_Code = BB_Code & "" & vbNewLine 'BB_Code = BB_Code & "v" & vbNewLine BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0) 'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row Next BB_Cells BB_Code = BB_Code & "" For Each BB_Row In BB_Range.Rows 'Row Numbers BB_Code = BB_Code & "" 'BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine For Each BB_Cells In BB_Row.Cells If BB_Cells.FormatConditions.Count Then strFontColour = objColour(DisplayedColor(BB_Cells, False, False)) strBackColour = objColour(DisplayedColor(BB_Cells, True, False)) Else strFontColour = objColour(BB_Cells.Font.Color) strBackColour = objColour(BB_Cells.Interior.Color) End If strAlign = FontAlignment(BB_Cells) BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine Next BB_Cells BB_Code = BB_Code & "" & vbNewLine Next BB_Row BB_Code = BB_Code & "" 'End of main table BB_Code = BB_Code & "Sheet: " & BB_Range.Parent.Name & "" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name. ClipBoard_SetData (BB_Code) Set BB_Range = NothingEnd Sub''Some required functions. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644Private Function objColour(strCell As String) As String objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)End Function Private Function FontAlignment(ByVal objCell As Object) As String With objCell Select Case .HorizontalAlignment Case xlLeft FontAlignment = "LEFT" Case xlRight FontAlignment = "RIGHT" Case xlCenter FontAlignment = "CENTER" Case Else Select Case VarType(.Value2) Case 8 FontAlignment = "LEFT" Case 10, 11 FontAlignment = "CENTER" Case Else FontAlignment = "RIGHT" End Select End Select End WithEnd Function Private Function ClipBoard_SetData(MyString As String) Dim hGlobalMemory As Long, lpGlobalMemory As Long Dim hClipMemory As Long, X As Long hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) lpGlobalMemory = GlobalLock(hGlobalMemory) lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Could not unlock memory location. Copy aborted." GoTo OutOfHere2 End If If OpenClipboard(0&) = 0 Then MsgBox "Could not open the Clipboard. Copy aborted." Exit Function End If X = EmptyClipboard() hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Could not close Clipboard." End IfEnd Function Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _ Optional ReturnColorIndex As Long = True) As Long Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant Dim F As String, R As Range '//Original code is written by Rick Rothstein '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/ If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument." CurrentCell = ActiveCell.Address(0, 0) For X = 1 To Cell.FormatConditions.Count With Cell.FormatConditions(X) If .Type = xlCellValue Then Select Case .Operator Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2) Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2) Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value Case xlGreater: Test = Cell.Value > Evaluate(.Formula1) Case xlLess: Test = Cell.Value < Evaluate(.Formula1) Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1) Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1) End Select ElseIf .Type = xlExpression Then Application.ScreenUpdating = False 'Cell.Select F = Replace(.Formula1, "$", vbNullString) F = Replace(F, CurrentCell, Cell.Address(0, 0)) 'Test = Evaluate(.Formula1) Test = Evaluate(F) 'Range(CurrentCell).Select Application.ScreenUpdating = True End If If Test Then If CellInterior Then dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color) If IsNull(dColor) Then dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color) End If Else dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color) If IsNull(dColor) Then dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color) End If End If DisplayedColor = dColor Exit Function End If End With Next If CellInterior Then dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color) Else dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color) End If DisplayedColor = dColor End Function'Private Function ExcelVersion() As String Dim temp As String
'On Error Resume Next#If Mac Then Select Case Val(Application.Version) Case 11: temp = "Excel 2004" Case 12: temp = "Excel 2008" ' this should NEVER happen! Case 14: temp = "Excel 2011" Case 15: temp = "vNext" Case Else: temp = "Unknown" End Select#Else Select Case Val(Application.Version) Case 9: temp = "Excel 2000" Case 10: temp = "Excel 2002" Case 11: temp = "Excel 2003" Case 12: temp = "Excel 2007" Case 14: temp = "Excel 2010" Case 15: temp = "Excel 2013" Case Else: temp = "Unknown" End Select#End If ExcelVersion = tempEnd Function''Private Function ColLtr(ByVal iCol As Long) As String' shg 2012 Alan 2016 http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html' Good for any positive Long If iCol > 0 Then ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26) Else End IfEnd Function
Sadly , I am a computer novice, and do not really understand.
Just post the workbook with the code and I will copy it to see what I get .. other wise no one can help
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
DocAElstein
05-02-2016, 02:39 PM
Just post the workbook with the code and I will copy it to see what I get .. other wise no one can help
Any Code will do that has strings in it containing BB Code Tag Strings in it
In the Workbook I gave you before you could pick any codes...
https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
I do not really need any help. I was just pointing out problems and solutions.
I do not need help.
I have been giving help.
As long as you use HTML or PHP Code Tags for such codes then there is usually no problem. ( Only very occaisionally you get the loss of carriage return problem, and I gave solutions for that too )
For example..
Codes from Module PikeCode
In Code Tags I ( and most people who asked me for help ) get:
Option Explicit' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html
'Pike http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
'Copy the syntax in the "VB:" window below to a standard Module
'Select the range in the worksheet to be converted
'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "
<tbody>
v
" & Split(BB_Cells.Address, "$")(1) & "
" & BB_Row.Row & "
" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "
</tbody>
"
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
DocAElstein
05-02-2016, 02:47 PM
In HTML Tags initially
Option Explicit' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html'Pike http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370'Copy the syntax in the "VB:" window below to a standard Module'Select the range in the worksheet to be converted'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongDeclare Function CloseClipboard Lib "User32" () As LongDeclare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As LongDeclare Function EmptyClipboard Lib "User32" () As LongDeclare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongDeclare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As LongPrivate Const GHND = &H42Private Const CF_TEXT = 1Private Const MAXSIZE = 4096
Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370 Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection BB_Code = "" & vbNewLine BB_Code = BB_Code & "v" & vbNewLine For Each BB_Cells In BB_Range.Rows(1).Cells strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0) BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine Next BB_Cells BB_Code = BB_Code & "" For Each BB_Row In BB_Range.Rows BB_Code = BB_Code & "" BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine For Each BB_Cells In BB_Row.Cells strFontColour = objColour(BB_Cells.Font.Color) strBackColour = objColour(BB_Cells.Interior.Color) strAlign = FontAlignment(BB_Cells) BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine Next BB_Cells BB_Code = BB_Code & "" & vbNewLine Next BB_Row BB_Code = BB_Code & "" ClipBoard_SetData (BB_Code) Set BB_Range = NothingEnd Sub
Private Function objColour(strCell As String) As String objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)End Function
Private Function FontAlignment(ByVal objCell As Object) As String With objCell Select Case .HorizontalAlignment Case xlLeft FontAlignment = "LEFT" Case xlRight FontAlignment = "RIGHT" Case xlCenter FontAlignment = "CENTER" Case Else Select Case VarType(.Value2) Case 8 FontAlignment = "LEFT" Case 10, 11 FontAlignment = "CENTER" Case Else FontAlignment = "RIGHT" End Select End Select End WithEnd Function
Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this Dim hGlobalMemory As Long, lpGlobalMemory As Long Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) lpGlobalMemory = GlobalLock(hGlobalMemory) lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Could not unlock memory location. Copy aborted." GoTo OutOfHere2 End If If OpenClipboard(0&) = 0 Then MsgBox "Could not open the Clipboard. Copy aborted." Exit Function End If X = EmptyClipboard() hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Could not close Clipboard." End IfEnd Function
DocAElstein
05-02-2016, 02:49 PM
In HTML Tags after running my code from Post #10 to solve the missing carriage return problem that occaisonally occurs
Option Explicit
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html
'Pike http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
'Copy the syntax in the "VB:" window below to a standard Module
'Select the range in the worksheet to be converted
'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
For Each BB_Cells In BB_Row.Cells
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
DocAElstein
05-02-2016, 02:50 PM
in php code tags initially
Option Explicit' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html'Pike http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370'Copy the syntax in the "VB:" window below to a standard Module'Select the range in the worksheet to be converted'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongDeclare Function CloseClipboard Lib "User32" () As LongDeclare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As LongDeclare Function EmptyClipboard Lib "User32" () As LongDeclare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongDeclare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As LongPrivate Const GHND = &H42Private Const CF_TEXT = 1Private Const MAXSIZE = 4096
Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370 Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection BB_Code = "" & vbNewLine BB_Code = BB_Code & "v" & vbNewLine For Each BB_Cells In BB_Range.Rows(1).Cells strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0) BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine Next BB_Cells BB_Code = BB_Code & "" For Each BB_Row In BB_Range.Rows BB_Code = BB_Code & "" BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine For Each BB_Cells In BB_Row.Cells strFontColour = objColour(BB_Cells.Font.Color) strBackColour = objColour(BB_Cells.Interior.Color) strAlign = FontAlignment(BB_Cells) BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine Next BB_Cells BB_Code = BB_Code & "" & vbNewLine Next BB_Row BB_Code = BB_Code & "" ClipBoard_SetData (BB_Code) Set BB_Range = NothingEnd Sub
Private Function objColour(strCell As String) As String objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)End Function
Private Function FontAlignment(ByVal objCell As Object) As String With objCell Select Case .HorizontalAlignment Case xlLeft FontAlignment = "LEFT" Case xlRight FontAlignment = "RIGHT" Case xlCenter FontAlignment = "CENTER" Case Else Select Case VarType(.Value2) Case 8 FontAlignment = "LEFT" Case 10, 11 FontAlignment = "CENTER" Case Else FontAlignment = "RIGHT" End Select End Select End WithEnd Function
Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this Dim hGlobalMemory As Long, lpGlobalMemory As Long Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) lpGlobalMemory = GlobalLock(hGlobalMemory) lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Could not unlock memory location. Copy aborted." GoTo OutOfHere2 End If If OpenClipboard(0&) = 0 Then MsgBox "Could not open the Clipboard. Copy aborted." Exit Function End If X = EmptyClipboard() hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Could not close Clipboard." End IfEnd Function
DocAElstein
05-02-2016, 02:51 PM
in php tags after running my code from post #10
Option Explicit
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html
'Pike http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
'Copy the syntax in the "VB:" window below to a standard Module
'Select the range in the worksheet to be converted
'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
For Each BB_Cells In BB_Row.Cells
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Option Explicit
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html
'Pike http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
'Copy the syntax in the "VB:" window below to a standard Module
'Select the range in the worksheet to be converted
'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
For Each BB_Cells In BB_Row.Cells
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Option Explicit
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html
'Pike http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
'Copy the syntax in the "VB:" window below to a standard Module
'Select the range in the worksheet to be converted
'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
For Each BB_Cells In BB_Row.Cells
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
After [code] I added [noparse] and it stops the complier reading the code and making a table/scroll within the vba.
Post #27 with missing noparse tags and compiled scroll in window .then post #28 with noparse tags just syntax.
I have gone back and changed the post #1 from php to code tags .. that was an oversight using php
DocAElstein
05-02-2016, 03:37 PM
After code I added noparse and it stops the complier reading the code and making a table/scroll within the vba.
Post #27 with missing noparse tags and compiled scroll in window .then post #28 with noparse tags........
|code||noparse|BB Code Tag Table Generator VBA Code Here|/noparse||/code| ( just using | for square brackets as demo here of what to do )
Nice alternative solution. Thanks :)
( So how did it work for you before without the extra noparse bits in a normal code window ??)
just unlucky that code was in the correct order that the complier read this bit (with noparse tags)
" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
For Each BB_Cells In BB_Row.Cells
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & "
as (without noparse tags)
" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
For Each BB_Cells In BB_Row.Cells
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & "
notice the table tag at the beginning and end of syntax .. perfect storm .. always add noparse tags when displaying VBA syntax with code tags to stop them complying within the code tags
DocAElstein
05-02-2016, 04:03 PM
I sometimes previously posted such a code in normal code tags and never noticed that it did not come out right due to the problems we have been discussing.
Maybe you too?
I still do not see how you could have got your code to come out right in normal code tags without the extra no parse bit.
But a nice alternative solution you got there, :)
P.s. I just cleatred some space in my In Box for you - you tried to contact me, but my In Box was full
just lucky that the table tags did not a-line in the syntax to make a table .. but if I noticed I would have added the tags ..
noparse tags are in the bbcode tags list for this very reason.. no need to change the code to suit the complier just add noparse tags
BB code is a set of tags based on the HTML language that you may already be familiar with. They allow you to add formatting to your messages in the same way as HTML does, but have a simpler syntax and will never break the layout of the pages you are viewing. The ability to use BB code is set on a forum-by-forum basis by the administrator, so you should check the forum rules when you post a new message.
DocAElstein
05-02-2016, 04:56 PM
just lucky that the table tags did not a-line in the syntax to make a table .....
Strange.. in all the code versions of your code i have they do interfere to produce things like Tables....
where are the error post?
or do you mean when you copy and repost the code in other forums?
DocAElstein
05-03-2016, 01:19 PM
where are the error post?
or do you mean when you copy and repost the code in other forums?
Pike,
.....
:confused: We have it all sorted. :)
Once again,
Almost all codes with strings in them containing BB Code Tags will cause errors when posted in normal Code Tags ( At least at MrExcel, ExcelForum and ExcelFox - At Ozgrid it would appear different, but I have little experience there. )
So in the past, the solution was to use HTML or php Code Tags. That is what most people do, and what I do.
But since yesterday there is a new solutiom which you found!! :)
I posted loads of example along the way of what happens, all referrenced in this Thread.
No offence Pike, but I seem to have been repeating myself time and time again in this Thread. :confused:
You saw yourself yesterday what happens if you do not use the noparse. Until yesterday no one I know knew of that trick. ( I am not talking about noparse BB Code Tags generally here. I and lots of people know about that. But I had not seen them applied to solve this problem) - If you ask me what problem again I will go mad. lol
Alan
No offence Pike, but I seem to have been repeating myself time and time again in this Thread. none taken .. Its no secret about noparse and i am positive many know and regularly use them. Mods use the all the time for displaying the use of code tags ..eg
syntax here between tags
becomes
syntax here between tags
it was a hard question to follow
have you seen this link Excelfox BBcode tags (http://www.excelfox.com/forum/misc.php?do=bbcode)
DocAElstein
05-03-2016, 01:48 PM
Pike: Post 37
.. Its no secret about noparse ....
Alan Post #36
....... I am not talking about noparse BB Code Tags generally here. I and lots of people know about that. .......
_.........:rolleyes:
.........
it was a hard question to follow
_..............:rolleyes:You do not seem to have been following it , so i have been having to repeat myself over and over.:)
Your Post In box is full. I cannot answer your PM's :)
Yes hard question to follow as you gave a anticipated solution .. not the problem until post 12 .. guess I just confused the issue by initially using phpBB code.
Should have been code tags with noparse
DocAElstein
05-04-2016, 02:57 PM
Morning Pike! :)
The Daily ( Morning ) dose of ExcelFox!,,....
Yes hard question to follow as you gave a anticipated solution .. not the problem until post 12 .. guess I just confused the issue by initially using phpBB code.
Should have been code tags with noparse
_.......
_1 ) You came in at post #11. This was a long time after the Thread was, to all intents and purposes, Solved and finished**!. At the end of the Day I am very glad you did. :) - I now see an alternative solution to posting a VBA code containing BB Code Tag strings into a Forum Thread Post. :). I am not sure if you yourself knew of, or had used, that solution until Yesterday? I did not. As far as I know not many people do. In any case I have never seen that solution. Everyone appears to use the alternative solutions of using for such codes ( codes with BB Code Strings in it ) a php or HTML Code Window. So how things developed here is one argument may be for not** having the ability to mark a Thread as solved
_2 )
you gave a anticipated solution .. not the problem until post 12 .......
Sorry Pike, but that is totally wrong. This problem ( Posting a VBA code with BB Code Strings in it ) was never the issue until you came in.
At the very start, when I came in, I addressed the actual problem, and emphasised that Posting a VBA code with BB Code Strings in it was not the issue. .......
@Admin
How do you get your code to look “normal” in a php Window .. when I try my code, I get something like this:
http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9634
Thanks
Alan
P.s. ( I realize you use php instead of BB Code Window to stop the square brackets in strings in the code causing problems )
.........
I explained the problem there that I was addressing. When I had no reply I later gave a couple of solutions which I had found myself sometime later. They were not anticipated solutions. They were, and still are, final solutions to that problem. To re iterate ( repeat myself ) ..That problem was something else. That Problem is that if you chose to use HTML or php Code windows, then occaisionally carriage returns vanish.
_3) I think again, and really no disrespect intended, - you simply did not read the Thread through. That's fine. We are all here voluntarily, so we read, answer, as we choose. :)......At the end of the Day I have now an alternive solution to Posting a VBA code with BB Code Strings in it which is great. I will likely pass that on because, as I mentioned, not many people have twigged to that. :) I will certainly referrence you and this Thread when I pass the solution on! :)
Thanks
Alan
P.s
Orange : The problem I brought up, and finally solved myself
Blue: The Problem ( or rather issue as it was not a problem ) which you brought up ( maybe unintentionally as you had not read through and did not realise that I had brought a different problem up and then later soved it ) to which finally you gave a nice alternative solution:) (- code tags with noparse)
_.........................
P.P.s
BTW. Do you not get virus warnings when accessing this site. Seems a few people have noticed it now
ExcelFox Warning (http://www.excelforum.com/excel-programming-vba-macros/1137702-excelfox-warning.html)
- It is very difficult ( and risky ) for me to post here. I use an old computer that may be scraped soon so as to minimise the damage should i get infected!!
_...............................
P.P.P.s
In the unlikely event that anyone other than Me or Pike ever comes here:
If you wish to post a VBA Code that contains BB Code Strings in it into a Forum Post , there are three solutions I know about now (normal code tags with noparse ; HTML Code Tags ; php Code Tags )
_1 ) Use a normal Code Window, but include a noparse BB Code tag after the first code BB Code Tag at the start, and include an end /noparse BB Code Tag just before the Last end code BB Code Tag as follows ( Note: I using a HTML window to prevent the BB Code Tags "working"** ( which is normally what you can also use noparse BB Code Tags for - using noparse BB Code Tags would mess up in this particular example in trying to demo noparse BB Code Tags themselves!.)..)
Your code goes here
_2) Use either a php or HTML Code Window ( As this prevents the BB Code Tags "working"** ).
_2a) Should you choose to use this _2) solution you may occasionally experience the vanishing carriage return problem. This was discussed from post #7 and solutions were given. The simplist is probably that of the code given in post #9 and #10. To use that you simply run that code ( which works from either VBA Word or VBA Excel, andprobably some other way i do not know!! ) just before pasting your code in. It works on what you have in the Clipboard and seems to may be "put something in" which overcomes the problem -( I am not sure what .. may be it just adds an extra cariage return which allows the editor to satisfy its desire to eat one, whilst allowing one to remain !! I found that solution by trial and error ! )
Hi Doc
Oh man...
P.s. ( I realize you use php instead of BB Code Window to stop the square brackets in strings in the code causing problems )
No I just misused php tags and it should have been code tags including noparse; which lead to the confusion.
Using php or html is misguided to the intent of posting vba with BBcode tags.
and emphasised that Posting a VBA code with BB Code Strings in it was not the issue
It really was the issue and corrected with noparse. It is the correct way to use vba and code tags and highly recommend (Most forums direction) only use php code with phpBB and Html code with HTMLBB.
The bit about
I am not sure if you yourself knew of, or had used, that solution until Yesterday? I did not. As far as I know not many people do was that really really necessary (deeply disappointed in you Doc) .. for examples just search on moderation posts at excel forum.
just kidding but ..needless to say you will have to ditch the guys who were amazed noparse existed and hang around me more!
any way .. if you can attach a workbook with a sample of the VBA syntax, that when copied with copy/paste in to the forum BBcode truncates .. have observed that problem from time to time .. but never been able to replicate it the result.
DocAElstein
05-04-2016, 05:20 PM
Hi Pike :)
.....
The bit about was that really really necessary (deeply disappointed in you Doc) .. for examples just search on moderation posts at excel forum.
just kidding but ..needless to say you will have to ditch the guys who were amazed noparse existed and hang around me more!
.....
The problem with a written media like the internet is that as you do not see the person writing, ( or know them ), So you "speak" them in your head when you read and build up an ( often false) impression about them or how they intend the message to come across. ( Also the Human brain can be a bit unkind here - It often builds a first impression which unfortuntely lasts. ( That is why i got banned from MrExcel. By bad luck a few Mods got totally the wrong idea about me from the start and made it their ambition to get rid of me. So amazing actually, I was there for so long. Most OPs and many very prominant Excel people loved me there. So it is there loss. But that is a seperate Theme )
As I think you may have guessed , what I said there was just a very "in passing" comment of no significance, and no disrespect intended, - I am not ever at Ozgrid, so I never would have known one way or the other if you already knew about it - so I was not making any judgement what so ever about you there! :)
I have no where near the experience of someone like you around Forums, but from my experience I would suggest that hardly anyone at MrExcel or ExcelForum has ever done anything other than using HTML or PHP for VBA codes containion BB Code Strings. ( you accepted may be ) . At least one Admin and several Mods I know ( or highly expect ) had not thought of it. ( Once again I am not talking about noparse generally, I am just here talikng about how to get over the problem of VBA codes with BB Code tags in them interferring when posted in normal Code Tags ). They probably might of had thought of it, but I think possibly that most people I think went straight to the HTML or php Window solution for VBA codes with BB Code tags in them , and just did not twig then about using Normal Code tags with no parse
..... for examples just search on moderation posts at excel forum....I have missed the point there- you are not a moderator at Excel Forum? I have no idea what you are referring to as "moderation posts" . I am not sure I feel like trying to do such a search. I have no idea how to do such a moderation posts search. Sometime the vBulletin Search can be diffficult to navigate through and understand.
_.............
...
It really was the issue and corrected with noparse. .....It was your issue, not mine. But that is fine. :) Glad you brought it up. :) ( It might be that had you originaly used the noparse with normal Code Windows, that I may not have brought my problem up here in this particular Thread. But I would have brought it up somewhere. So I suppose looking at in that very round about abstract sort of a way that it was the issue, sort of , but not really :rolleyes: :confused: :)
_....................
.... if you can attach a workbook with a sample of the VBA syntax, that when copied with copy/paste in to the forum BBcode truncates .. have observed that problem from time to time .. but never been able to replicate it the result.
I do not think it is very practical to take that further
because
_ 1 ) I am sitting on a sack of cement in a cold shed to use an old disregarded computer for the reasons mentioned before. ( Virus warnings )
_ 2 ) We may not be talking about the same things. I am not sure what you mean by Truncates. I am talking about carriage returns ( line breaks ) vanishing on either pasting in or subsequently when posting a Forum Post.
Also my Problem was specific to pasting into php or HTML Code Tag Windows. I have never experienced the problem when pasting into or subsequently posting using Normal BB Code Tag Windows.
It is not to do with a specific VBA syntax. I suspect it is to do with differnt forms of carriage return and linefeeds along with how different Forum Editors deal with that. If you look again from Post #7, I think you can see what I was getting at. I did, and referencced, lots of Posts for you as examples as well as repeating the experiment in this Thread.
I do not get the same results at different forums. And it changes from time to time. Recently it stopped ever happening at MrExcel where it had often happened previously. I tried to take that further there, to clarify what was going in, or what changes had been made , but unfortunately most Mods had already put me on there ignore list then.
If you use for example any codes in the Workbook I gave you it will sometimes give and sometime not give the problem. As will any code what so ever. So again what I am talking about is nothing to do with VBA syntax.
If you have time, if you read agáin from my post #7 in this Thread, then you can follow through and maybe try to repeat the experiments I did. I was still getting the problem here yesterday as I demoed in post #20 for you, as well in the other "Duplicte" posts I did for you and referrenced with a Link.
I think to solve this problem we would need to be working in the same room together for a few days , firstly to make sure we were talking about the same problem. !! :) I suspect we are not talking about the same problem here.
Alan
Yes I was a moderator at excel forum .. Mate your post are hard to follow .. of course noparse is commonly known at MrExcel and other forums.
I do not think it is very practical to take that further
DocAElstein
05-05-2016, 01:20 PM
Hi Pike
.. .. Mate your post are hard to follow ......
Sorry, - was just trying to help and Clarify. :(
Thanks for all your help and info.
:cheers:
Alan
:)
Doc
No it is me who must apologise as
Mate your post are hard to follow I was pulling your chain big time to get a reaction .. I'm a compulsive stirrer and would poke a sleeping tiger with a pointy stick if I ever had the opportunity.
No need to be sorry ... A question never asked is a question answer never known .. if it wasn't for your persistence with the tags thing, it would have never been definitively solved.
Remember the sensibility check that forums are all about excel banter, be pragmatic that its just excel and there are many souls in the world fighting day to day just to live.
JackSht_1
05-05-2016, 03:03 PM
.... I was pulling your chain .. to get a reaction...Lol.. Lol... he said in a PM to you he thought you was trolling
You certainly got a reaction. He had to keeep going back and forth refinding Posts to re referrence for you Lol. The excersize did him good.
_..........
.... would poke a sleeping tiger with a pointy stick if I ever had the opportunity....
And we thought you loved Animals going by your signatures And Avatars!. Clearly the "love" is as with another Excel Promi I will mention:
"I need a macro that is so simple it could be written with the macro recorder...." (http://www.excelforum.com/the-water-cooler/1097141-i-need-a-macro-that-is-so-simple-it-could-be-written-with-the-macro-recorder.html#post4154171) Lol ( Really just Kidding there, Ford is a nice bloke, usually...mostly... )
Now I know what you meant by Rabbiting on, Rabbit Rabbit. Poor Bunny! Lol... Lol..
_..........
...... if it wasn't for your persistence with the tags thing, it would have never been definitively solved.....
His persistance and some very detailed Threads only occaisionaly get rewarded. Or / but occaisionally reveals some intersting things. Lucky no one else is watching here.. Or you would be banned now, or maybe reported, .. by / to, the RSPCA. Lol.
_..........
... and there are many souls in the world fighting day to day just to live.
Yep, that's us. Learning computers from scratch since a couple of years was just to help try speeding up part of how he was trying to do that.
Excel got to be a combination of a distraction from that fight and a bit of a plain Addiction. Instead of asking a Dozen questions he ended up answering several Thousand, mostly in his "Detailed" Style!!!!
But that should/ must all change now
_.......
.....
Remember the sensibility check that forums are all about excel banter, be pragmatic that its just excel.......??? Clearly some peolpe take it all a bit too seriuosly, a few quirky mods IMHO around just recently, like at MrExcel IMHO. But they do all do an amazingly great job, all voluntarily, at helping with Excel. Pitty they do not just stick to that.. but who cares, got / must do other things now
_........
Thanks for letting us know, the Daily ( Morning) Dose of ExcelFox was a bit fun....
Bye
Jacky and Alan
P.Ss
Last night he was just going to reply with
"Is you jealous?" Lol Löl. I "Moderated" him ! Lol-...:)
... and would poke a sleeping tiger with a pointy stick if I ever had the opportunity.
I'd pay money to see that :)
cool send me your bank details and I'll arrange it
xladept
05-16-2016, 01:22 AM
Hi Guys,
You two "junior" members haven't got your avatars up - I never know what's going on- What's BB code? And Hello Trevor, Jac, Doc and Pike:)
v
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R
S
T
52
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
53
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
54
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
55
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
56
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
W
57
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
How you know it me?
I can have an Avatar? Who knew!? I'd forgotten I even had a login on this forum. Only here 'cos someone said it was broke.
@Pike: I pay YOU. Send me YOUR Bank Details ... PayPal would work :)
xladept
05-16-2016, 02:38 AM
Yeah, me too - I came over 'cause Doc steered me over. TMS is rather recognizable. What does BB stand for??
Intrigued ... only 8500 members, and only about 740 with any posts.
DocAElstein
05-16-2016, 03:29 AM
Testing Avatar
There you, go, I forgot about my Avatar as well.
My Wife got his up straight away, bless him :rolleyes:
EDIT: Worked.
I tell you what, they have the newest vbullitin softwäre here. hardly ever have any softwäre problems, everything works, and after getting "Hit", they cleared up the virus things in a few days, rather than a few months.. like somewhere else !
Edit:
P.s.
I Welcome you two "newbies" to Excel Fox
@Doc: see post #54. Not gonna be so much to fix, I would guess.
Only thing left to add is the font name ..but different forums have different default and available fonts ..
By adding the font name is get away form the main idea of BBcode generators being a quick and easy way to show your basic worksheet layout in a table
xladept
05-16-2016, 04:03 AM
I'm feeling unfulfilled here:)
DocAElstein
05-16-2016, 04:08 AM
never mind :)
Good Night, Gentlemen.
there you go font name added .. but will default if the worksheet font name is not avalibale in the forum BBcode font list
Option Explicit
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Dim strFontName As String
Set BB_Range = Selection
BB_Code = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
For Each BB_Cells In BB_Row.Cells
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
strAlign = FontAlignment(BB_Cells)
strFontName = BB_Cells.Font.Name
BB_Code = BB_Code & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Function objColour(strColour As String) As String
objColour = "#" & Right(Right("000000" & Hex(strColour), 6), 2) & Mid(Right("000000" & Hex(strColour), 6), 3, 2) & Left(Right("000000" & Hex(strColour), 6), 2)
End Function
Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
you could add font size if you wanted to
DocAElstein
05-16-2016, 02:04 PM
Hi Pike...
there you go font name added .. but will default if the worksheet font name is not avalibale in the forum BBcode font list.....
Thanks pike, another one for the collection :)
Using Excel 2007
Row\Col
F
G14
PikeCalibri
Fooaarrnst Arial Narrow
15
Verdana
Batang
Sheet: Molly
Full Version for your Code which allows one to paste a screenshot of a Spreadsheet range, in a form that can be copyied to a Spreadsheet is here:
http://www.excelfox.com/forum/showthread.php/2079-test-BB-Code?p=9804#post9804
File with this code and many others:
https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
_.......................
Alan
_......
|Size = 2| below ( |size = 0| above ), maybe most prefer - I need small to get all my errlabberations in !
Using Excel 2007
Row\Col
F
G14
PikeCalibri
Fooaarrnst Arial Narrow
15
Verdana
Batang
Sheet: Molly
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.