Right now i can copy from excel and paste in solidwork a html table
i know this is the reverse solution of what you search for
but you might be able ot use this macro in solidwork to copy a selection of a material bill in windows clipboard, then paste it where you want it as a html table
in the code snippet, chek the last sub, its what you should execute with a "copy" button
Sub sel_to_htmcli()
(excel selection to html format windows clipboard)
Option Explicit
'=== 2008-03-11 9:35 SEF
' --------------------------------------------------------------------
Private Const sMODULE_NAME As String = "clsClipboard"
' --------------------------------------------------------------------
' VBA doesn't provide any method to get or set data in the Windows
' Clipboard. This class provides some basic methods for Clipboard
' operation.
' --------------------------------------------------------------------
' Notice:
' This example code is provided as-is by LA Solutions Ltd with no
' warranty of fitness for purpose and with no support. This
' example is derived from published information found at this URL:
' http://vb.mvps.org/articles/ap200106.asp
'
' You are free to use and adapt this code for personal or commercial use
' provided that this notice is retained in full
' End of notice
' --------------------------------------------------------------------
' Clipboard Manager Functions
' --------------------------------------------------------------------
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetPriorityClipboardFormat Lib "user32" (lpPriorityList As Long, ByVal nCount As Long) As Long
' --------------------------------------------------------------------
' Other useful APIs
' --------------------------------------------------------------------
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
' --------------------------------------------------------------------
Private Const GMEM_FIXED As Long = &H0
' --------------------------------------------------------------------
' Predefined Clipboard Formats
' --------------------------------------------------------------------
Private Const CF_TEXT As Long = 1
Private Const CF_BITMAP As Long = 2
Private Const CF_METAFILEPICT As Long = 3
Private Const CF_SYLK As Long = 4
Private Const CF_DIF As Long = 5
Private Const CF_TIFF As Long = 6
Private Const CF_OEMTEXT As Long = 7
Private Const CF_DIB As Long = 8
Private Const CF_PALETTE As Long = 9
Private Const CF_PENDATA As Long = 10
Private Const CF_RIFF As Long = 11
Private Const CF_WAVE As Long = 12
Private Const CF_UNICODETEXT As Long = 13
Private Const CF_ENHMETAFILE As Long = 14
Private Const CF_HDROP As Long = 15
Private Const CF_LOCALE As Long = 16
Private Const CF_MAX As Long = 17
Private Const CF_OWNERDISPLAY As Long = &H80
Private Const CF_DSPTEXT As Long = &H81
Private Const CF_DSPBITMAP As Long = &H82
Private Const CF_DSPMETAFILEPICT As Long = &H83
Private Const CF_DSPENHMETAFILE As Long = &H8E
Const RegHtml As String = "HTML Format"
'=== end clipboard stuff
' --------------------------------------------------------------------
' Public Methods
' --------------------------------------------------------------------
Public Function GetFormat(ByVal Format As Long) As Boolean
' Check if the requested format is available
' on the clipboard. (Same behavior as standard
' VB Clipboard object)
If OpenClipboard(0&) Then
If IsClipboardFormatAvailable(Format) Then
GetFormat = True
End If
Call CloseClipboard
End If
End Function
' --------------------------------------------------------------------
Public Function GetPriorityFormat(ParamArray Formats()) As Long
Dim Fmts() As Long
Dim i As Long
Dim nFmt As Long
' Bail, if no formats were requested
If UBound(Formats) < 0 Then Exit Function
' Transfer desired formats into a non-variant array
ReDim Fmts(0 To UBound(Formats)) As Long
For i = 0 To UBound(Formats)
' Double conversion, to be safer.
' Could error trap, but that'd mean the
' user was a hoser, and we wouldn't want
' to insinuate *that*, would we?
Fmts(i) = CLng(Val(Formats(i)))
Next i
' Try opening clipboard...
If OpenClipboard(0&) Then
' Check to see which format is highest in list
nFmt = GetPriorityClipboardFormat(Fmts(0), UBound(Fmts) + 1)
Call CloseClipboard
Else
' Clipboard may already be open by another
' routine in same process, try anyway to see
' if we can get a successful result. Not
' clean, but worth a shot
nFmt = GetPriorityClipboardFormat(Fmts(0), UBound(Fmts) + 1)
End If
' Return results
GetPriorityFormat = nFmt
End Function
' --------------------------------------------------------------------
Public Function GetText() As String
Dim nFmt As Long
Dim hData As Long
Dim lpData As Long
' Check for desired format
'nFmt = Me.GetPriorityFormat(CF_TEXT, CF_OEMTEXT, CF_DSPTEXT)
nFmt = GetPriorityFormat(CF_TEXT, CF_OEMTEXT, CF_DSPTEXT)
' -1=None requested, 0=Empty
If nFmt > 0 Then
' Grab text from clipboard, if available
If OpenClipboard(0&) Then
hData = GetClipboardData(nFmt)
' Slurp characters from global memory
If hData Then
lpData = GlobalLock(hData)
GetText = PointerToStringA(lpData)
Call GlobalUnlock(hData)
End If
Call CloseClipboard
End If
End If
End Function
' --------------------------------------------------------------------
Public Function SetText(ByVal NewVal As String) As Boolean
Dim hData As Long
Dim lpData As Long
Dim Buffer() As Byte
'=== Try to set text onto clipboard
If OpenClipboard(0&) Then
Call EmptyClipboard
'=== Convert data to ANSI byte array
Buffer = StrConv(NewVal & vbNullChar, vbFromUnicode)
'=== Allocate enough memory for buffer
hData = GlobalAlloc(GMEM_FIXED, UBound(Buffer) + 1)
If hData Then
'=== Copy data to alloc'd memory
lpData = GlobalLock(hData)
Call CopyMemory(ByVal lpData, Buffer(0), UBound(Buffer) + 1)
Call GlobalUnlock(hData)
'=== Hand data off to clipboard
SetText = CBool(SetClipboardData(CF_TEXT, hData))
End If
Call CloseClipboard
End If
End Function
Public Function SetHtml(ByVal NewVal As String) As Boolean
Dim hData As Long
Dim lpData As Long
Dim Buffer() As Byte
Dim CF_HTML As Long
Dim n As String
Dim o As Variant
Dim p As Variant
Dim q As Variant
Dim r As String
Dim i As Integer
Dim s As String
'=== replace all special caracters 128+ ascii with a code for html code
i = 1
While i < Len(NewVal)
s = Mid(NewVal, i, 1)
r = Asc(s)
If r > 128 Then
NewVal = Replace(NewVal, s, "&#" & Trim(CStr(r)) & ";")
i = i + 3 + Len(Trim(CStr(r)))
Else
i = i + 1
End If
Wend
'=== build html structure for clipboard
n = "Version:0.9" & vbCrLf
n = n & "StartHTML:00000000" & vbCrLf
n = n & "EndHTML:00000000" & vbCrLf
n = n & "StartFragment:00000000" & vbCrLf
n = n & "EndFragment:00000000" & vbCrLf
n = n & "StartSelection:00000000" & vbCrLf
n = n & "EndSelection:00000000" & vbCrLf
n = n & "<html><body>" & vbCrLf
n = n & "<!--StartFragment-->" & vbCrLf
n = n & NewVal & vbCrLf
n = n & "<!--EndFragment-->" & vbCrLf
n = n & "</BODY></HTML>" & vbCrLf
'Version: vv version number of the clipboard. Starting version is 0.9.
'StartHTML: bytecount from the beginning of the clipboard to the start of the context, or -1 if no context.
'EndHTML: bytecount from the beginning of the clipboard to the end of the context, or -1 if no context.
'StartFragment: bytecount from the beginning of the clipboard to the start of the fragment.
'EndFragment: bytecount from the beginning of the clipboard to the end of the fragment.
'StartSelection: bytecount from the beginning of the clipboard to the start of the selection.
'EndSelection: bytecount from the beginning of the clipboard to the end of the selection.
'=== once the string is done, we can chek where are the chekpoints
'=== then write it in the string itself, padding with "0"
q = "<html>"
p = Trim(CStr(InStr(LCase(n), q) - 1))
o = String(8 - Len(p), "0") & p
n = Replace(n, "StartHTML:00000000", "StartHTML:" & o, 1, 1)
q = ""
p = Trim(CStr(Len(n)))
o = String(8 - Len(p), "0") & p
n = Replace(n, "EndHTML:00000000", "EndHTML:" & o, 1, 1)
q = "<!--startfragment-->"
p = Trim(CStr(InStr(LCase(n), q) + Len(q) - 1))
o = String(8 - Len(p), "0") & p
n = Replace(n, "StartFragment:00000000", "StartFragment:" & o, 1, 1)
q = "<!--endfragment-->"
p = Trim(CStr(InStr(LCase(n), q) - 1))
o = String(8 - Len(p), "0") & p
n = Replace(n, "EndFragment:00000000", "EndFragment:" & o, 1, 1)
'=== Try to set text onto clipboard
If OpenClipboard(0&) Then
Call EmptyClipboard
'=== Convert data to ANSI byte array
Buffer = StrConv(n & vbNullChar, vbFromUnicode)
'=== Allocate enough memory for buffer
hData = GlobalAlloc(GMEM_FIXED, UBound(Buffer) + 1)
If hData Then
'=== Copy data to alloc'd memory
lpData = GlobalLock(hData)
Call CopyMemory(ByVal lpData, Buffer(0), UBound(Buffer) + 1)
Call GlobalUnlock(hData)
'=== Hand data off to clipboard
CF_HTML = RegisterClipboardFormat(RegHtml)
'MsgBox (CF_HTML)
SetHtml = CBool(SetClipboardData(CF_HTML, hData))
End If
Call CloseClipboard
End If
End Function
' --------------------------------------------------------------------
' Private Methods
' --------------------------------------------------------------------
Private Function PointerToStringA(ByVal lpStringA As Long) As String
Dim Buffer() As Byte
Dim nLen As Long
If lpStringA Then
nLen = lstrlenA(ByVal lpStringA)
If nLen Then
ReDim Buffer(0 To (nLen - 1)) As Byte
CopyMemory Buffer(0), ByVal lpStringA, nLen
PointerToStringA = StrConv(Buffer, vbUnicode)
End If
End If
End Function
Function RangeToHTM(myrange As Range)
' This macro will convert an Excel range to a HTML Table.
'
' Copywrite 1996 - 2000 by Charles Balch, mailto:charlie@balch.edu
' Original Source is at http://balch.org/charlie/hdoc
'
' Care Ware! The code is yours to use and adapt for free as long as
' you do something nice for anyone (that includes you).
' Please send me Email describing how you use this code and any
' adjustments that you have made. Redistribute at will.
' Please leave my name and the original source in the comments.
'
' MyRange is an Excel range you wish to convert.
' DocDestination is the FileName and Path to send the document to.
'
Dim CalcState, RowStart, ColStart
Dim ColCount, RowCount, RowEnd, ColEnd
Dim StatusBarState
Dim MyTitle, Row, HzA, MV, strcc
Dim DocDestination, col, intp, cellv, strTemp
Dim cella, cc, SFC1, sfc2, fc, ColSpan, sametitle
Dim bgc
Application.StatusBar = "Selection to HTM, converting..."
CalcState = Application.Calculation
StatusBarState = Application.DisplayStatusBar
Application.Calculation = xlManual
Calculate
RowStart = myrange.Row
ColStart = myrange.Column
ColCount = myrange.Columns.Count
RowCount = myrange.Rows.Count
RowEnd = RowStart + RowCount - 1
ColEnd = ColStart + ColCount - 1
'=== string that will contain all html code - short name for convenience
Dim s As String
'create Code
s = "<HTML>" & Chr$(13)
s = s & "<HEAD>" & Chr$(13)
'Establish Font in all areas
s = s & "<STYLE TYPE=""text/css"">" & Chr$(13)
s = s & "<!-- " & Chr$(13)
s = s & "BODY, TD, TR, P, H1, H2, H3 { font-family: arial, helvetica, sans-serif; COLOR=""#00008B""; font-size: 100% }" & Chr$(13)
s = s & "A { COLOR=""0000FF"" }" & Chr$(13)
s = s & "A:hover { Color: #8F0000}" & Chr$(13)
s = s & " -->" & Chr$(13)
s = s & "</STYLE>" & Chr$(13)
MyTitle = Cells(RowStart, ColStart) ' Use first cell as title
s = s & "<TITLE>" & MyTitle & "</TITLE>" & Chr$(13)
s = s & "</HEAD>" & Chr$(13)
s = s & "<BODY bgcolor=" & Chr(34) & "#9F9F9F" & Chr(34) & " >" & Chr$(13)
s = s & "<FONT FACE=""arial, helvetica, sans-serif"">" & Chr$(13)
s = s & "<CENTER><TABLE bgcolor=" & Chr(34) & "#FFFFFF" & Chr(34) & " Border=2>" & Chr$(13)
's = s & "<Caption><B><Font Size=+2>" & MyTitle & "<Font Size=-2></B></caption>" & Chr$(13)
While Row < RowCount
Row = Row + 1
DoEvents
Application.StatusBar = DocDestination & ": " & Str$(Int((Row / RowCount) * 100)) & "% Completed"
If (Not myrange.Rows(Row).Hidden) Then
MV = ""
col = 0
While col < ColCount
col = col + 1
cellv = ""
If (Not myrange.Columns(col).Hidden) Then
strTemp = myrange.Cells(Row, col).Text
For intp = 1 To Len(strTemp)
strcc = Mid(strTemp, intp, 1)
If Asc(strcc) = 10 Then strcc = "<BR>"
cellv = cellv & strcc
Next intp
If cellv = "" Then cellv = "<BR>"
HzA = myrange.Cells(Row, col).HorizontalAlignment
cella = " Align=Right "
If HzA = -4108 Then cella = " Align=Center "
If HzA = -4131 Then cella = " Align=Left "
If HzA = -4152 Then cella = " Align=Right "
If myrange.Cells(Row, col).Font.Bold Then cellv = "<B>" & cellv & "</B>"
If myrange.Cells(Row, col).Font.Italic Then cellv = "<I>" & cellv & "</I>"
If HzA = 7 Or myrange.Cells(Row, col).MergeCells Then
ColSpan = 0
sametitle = True
While (myrange.Cells(Row, col).HorizontalAlignment = 7 Or myrange.Cells(Row, col).MergeCells) And sametitle
' The following code must be changed for versions of Excel earlier than 97
If Not myrange.Columns(col).Hidden Then ColSpan = ColSpan + 1
col = col + 1
If (Len(myrange.Cells(Row, col).Text) > 1 Or myrange.Cells(Row, col).MergeCells = False) Then sametitle = False: col = col - 1
Wend
cella = cella & " ColSpan=" & ColSpan
End If
'find cell interior color
cc = myrange.Cells(Row, col).Interior.ColorIndex
bgc = ""
If cc = 1 Then bgc = "#000000" 'black"
If cc = 3 Or cc = 22 Then bgc = "#FFD0D0" 'Red"
If cc = 4 Or cc = 35 Then bgc = "#CCFFCC" 'green"
If cc = 6 Or cc = 19 Then bgc = "#FFFFCC" 'yellow"
If cc = 8 Or cc = 41 Or cc = 34 Or cc = 20 Then bgc = "#CCFFFF" 'blue
If cc = 9 Then bgc = "#8A0045" 'burgandy
If cc = 15 Or cc = 40 Then bgc = "#DFDED0" 'grey"
If cc = 39 Or cc = 24 Or cc = 39 Then bgc = "#FFCCFF" 'Purple
If Len(bgc) > 2 Then bgc = " bgcolor=" & Chr(34) & bgc & Chr(34)
'find cell font color
fc = myrange.Cells(Row, col).Font.ColorIndex
SFC1 = ""
sfc2 = ""
If fc = 3 Then
SFC1 = "<FONT COLOR=""#FF0000"">"
ElseIf fc = 2 Then
SFC1 = "<FONT COLOR=""#FFFFFF"">"
End If
If Len(SFC1) > 2 Then sfc2 = "</FONT>"
'Replace chr(13) with <BR>
'Range(MyRange).Cells(Row, Col).Replace
MV = MV & "<TD" & cella & bgc & ">" & SFC1 & cellv & sfc2 & "</TD>"
End If
Wend
s = s & "<TR>" & MV & "</TR>" & Chr$(13)
End If
Wend
s = s & "</TABLE></CENTER></BODY>" & Chr$(13)
s = s & "<P>" & Chr$(13)
' s = s & "This table was created by a free Excel macro written by <A HREF =" & Chr(34) & "MAILTO:charlie@balch.org" & Chr(34) & ">Charles Balch</A>.<BR>" & Chr$(13)
' s = s & "Here's the <A HREF = " & Chr(34) & "http://charlie.balch.org/hdoc/exceltohtml.html" & Chr(34) & ">code</A>. It is care ware - it's yours for free if do something nice for anyone (anyone includes you)."
s = s & "</HTML>" & Chr$(13)
Close
DoEvents
Application.Calculation = CalcState
Application.StatusBar = ""
Application.DisplayStatusBar = StatusBarState
RangeToHTM = s
End Function
Sub sel_to_htmcli()
'=== take excel selection and make a html table with it
'=== and put it in windows clipboard
Dim table As String
If TypeName(Selection) <> "Range" Then
MsgBox "Select the range to be copied. A multiple selection is allowed."
Exit Sub
End If
table = RangeToHTM(Selection)
'===put the table in windows clipboard in html format
Call SetHtml(table)
End Sub
1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135: 136: 137: 138: 139: 140: 141: 142: 143: 144: 145: 146: 147: 148: 149: 150: 151: 152: 153: 154: 155: 156: 157: 158: 159: 160: 161: 162: 163: 164: 165: 166: 167: 168: 169: 170: 171: 172: 173: 174: 175: 176: 177: 178: 179: 180: 181: 182: 183: 184: 185: 186: 187: 188: 189: 190: 191: 192: 193: 194: 195: 196: 197: 198: 199: 200: 201: 202: 203: 204: 205: 206: 207: 208: 209: 210: 211: 212: 213: 214: 215: 216: 217: 218: 219: 220: 221: 222: 223: 224: 225: 226: 227: 228: 229: 230: 231: 232: 233: 234: 235: 236: 237: 238: 239: 240: 241: 242: 243: 244: 245: 246: 247: 248: 249: 250: 251: 252: 253: 254: 255: 256: 257: 258: 259: 260: 261: 262: 263: 264: 265: 266: 267: 268: 269: 270: 271: 272: 273: 274: 275: 276: 277: 278: 279: 280: 281: 282: 283: 284: 285: 286: 287: 288: 289: 290: 291: 292: 293: 294: 295: 296: 297: 298: 299: 300: 301: 302: 303: 304: 305: 306: 307: 308: 309: 310: 311: 312: 313: 314: 315: 316: 317: 318: 319: 320: 321: 322: 323: 324: 325: 326: 327: 328: 329: 330: 331: 332: 333: 334: 335: 336: 337: 338: 339: 340: 341: 342: 343: 344: 345: 346: 347: 348: 349: 350: 351: 352: 353: 354: 355: 356: 357: 358: 359: 360: 361: 362: 363: 364: 365: 366: 367: 368: 369: 370: 371: 372: 373: 374: 375: 376: 377: 378: 379: 380: 381: 382: 383: 384: 385: 386: 387: 388: 389: 390: 391: 392: 393: 394: 395: 396: 397: 398: 399: 400: 401: 402: 403: 404: 405: 406: 407: 408: 409: 410: 411: 412: 413: 414: 415: 416: 417: 418: 419: 420: 421: 422: 423: 424: 425: 426: 427: 428: 429: 430: 431: 432: 433: 434: 435: 436: 437: 438: 439:
by: wildboy85Posted on 2008-04-08 at 10:39:43ID: 21307647
If you can't select the bill of material in solidwork, this wont be of any use to you
but in our case the bill of material have to be on the drawing (i think it's the case for everyone)
here is my plan about this kind of data transfert: (excel to solidwork)
part 1: generate a HTML table with excel selection (in your case solidwork selection)
(not done yet)
part 2: put the table in windows clipboard in html format
part 3: past it in solidwork (in your case in something else) as a clean cool html table
only part 2 is done for me right now
but if you are interested in the copy past method i will post my futur code here
it will be reversed, (excel to solidwork) but your skill being advanced, i think you can reverse it back to solidwork selection to clipboard html table
i am coding this stuff right now, so it should be 2or 3 days before i post the whole copy past as html table if you are interested
Select allOpen in new window