Drawing letters in excel - vba

Is there a plugin that helps generate letters (A-Z) in excel as seen below? Or can we write some sort of VBA script to do this?

Stackoverflow is not a code-for-me service. Anyhow, the task looked interesting, and I have decided to code something about it:
Option Explicit
Public Sub WriteLetterA()
Dim varLetterA(8) As Variant
Dim lngColCounter As Long
Dim lngRowCounter As Long
Dim blnReverse As Boolean
Dim rngCell As Range
blnReverse = True
varLetterA(0) = Array(1, 1, 1, 0, 0, 1, 1, 1)
varLetterA(1) = Array(1, 0, 0, 0, 0, 0, 0, 1)
varLetterA(2) = Array(1, 0, 0, 1, 1, 0, 0, 1)
varLetterA(3) = Array(1, 0, 0, 1, 1, 0, 0, 1)
varLetterA(4) = Array(0, 0, 0, 1, 1, 0, 0, 0)
varLetterA(5) = Array(0, 0, 0, 0, 0, 0, 0, 0)
varLetterA(6) = Array(0, 0, 0, 0, 0, 0, 0, 0)
varLetterA(7) = Array(0, 0, 1, 1, 1, 1, 0, 0)
varLetterA(8) = Array(0, 0, 1, 1, 1, 1, 0, 0)
Cells(1, 1).Select
For lngRowCounter = 0 To UBound(varLetterA)
For lngColCounter = 0 To UBound(varLetterA(lngRowCounter))
Set rngCell = Cells(lngRowCounter + 1, lngColCounter + 1)
If varLetterA(lngRowCounter)(lngColCounter) Then
rngCell.Interior.Color = IIf(blnReverse, vbBlack, vbWhite)
Else
rngCell.Interior.Color = IIf(blnReverse, vbWhite, vbBlack)
End If
Next lngColCounter
Next lngRowCounter
End Sub
' Points for improvement - varLetterA in a separate class
' Refer to the sheet, do not assume it
' Pass the first cell as a reference
This is what you get:
blnReverse = False
blnReverse = True
Take a look at the points for improvement - they can be useful, if you decide to build the rest of the alphabet. Good luck.

Related

Changes the color of a part using vba macro in solidworks api

I'm trying to change the appearance of a part using the VBA code.
I found a code already on the forum that changes the color for each face individually, but that's a complicated code to use for a simple part.
I tried to record a macro while changing the color but nothing was captured in the macro for some reason.
I tried also to look into the help documentation and all I found was this one: https://help.solidworks.com/2017/english/api/sldworksapi/solidworks.interop.sldworks~solidworks.interop.sldworks.iappearancesetting~color.html
And that's my code along with color commands.
Dim swModel As ModelDoc2
Dim boolstatus As Boolean
Dim swApp As SldWorks
Private x, X1, Y1, X2, Y2 As Integer
swModel = swApp.NewPart()
swModel = swApp.ActiveDoc
'Drawing 2D Sketch
boolstatus = swModel.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
Dim swSketch As SketchManager
swSketch = swModel.SketchManager
swSketch.InsertSketch(True)
X1 = 2
Y1 = 2
X2 = 2
Y2 = 2
Dim skSegment As Object
skSegment = swModel.SketchManager.CreateLine(0, 0, 0#, 2, 0, 0#)
skSegment = swModel.SketchManager.CreateLine(2, 0, 0#, 2, 2, 0#)
skSegment = swModel.SketchManager.CreateLine(2, 2, 0#, 0, 2, 0#)
skSegment = swModel.SketchManager.CreateLine(0, 2, 0#, 0, 0, 0#)
swModel.SketchManager.InsertSketch(True)
swModel.ClearSelection2(True)
swModel.ViewZoomtofit()
' Extrude
Dim CreateExtrude As Feature
boolstatus = swModel.Extension.SelectByID2("Sketch1", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
CreateExtrude = swModel.FeatureManager.FeatureExtrusion2(True, False, False, 0, 0, 3, 0.01, False, False, False, False, 0, 0, False, False, False, False, True, True, True, 0, 0, False)
'''''''''''' COLOR Changing based on the link above '''''''''''''''
Dim Part_color As IAppearanceSetting
Dim value As Integer = 0
value = Math.Max(Math.Min(120, 255), 0) + Math.Max(Math.Min(120, 255), 0) * 16 * 16 + Math.Max(Math.Min(120, 255), 0) * 16 * 16 * 16 * 16
Part_color.Color = value
''''''''''''''
The part was created successfully but the color changing didn't work.
Any thoughts?
I got the answer from the SolidWorks forum (Thanks to Mr. Willie Roelofs)
I just kept the post in case someone is a super beginner in API like me and looking for the same thing.
If it's not useful, just delete it :)
Option Explicit
Sub main()
Dim boolStatus As Boolean
Dim swApp As SldWorks.SldWorks
Set swApp = Application.SldWorks
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
Call Draw2DSketch(swModel)
Call ExtrudeSketch(swModel)
Call ColorPart(swModel)
End Sub
Function Draw2DSketch(swModel As SldWorks.ModelDoc2)
'Drawing 2D Sketch
Dim boolStatus As Boolean
boolStatus = swModel.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
Dim swSketch As SketchManager
Set swSketch = swModel.SketchManager
swSketch.InsertSketch True
swModel.ClearSelection2 True
Dim skSegment As Object
Set skSegment = swModel.SketchManager.CreateLine(0, 0, 0#, 2, 0, 0#)
Set skSegment = swModel.SketchManager.CreateLine(2, 0, 0#, 2, 2, 0#)
Set skSegment = swModel.SketchManager.CreateLine(2, 2, 0#, 0, 2, 0#)
Set skSegment = swModel.SketchManager.CreateLine(0, 2, 0#, 0, 0, 0#)
swModel.SketchManager.InsertSketch (True)
swModel.ClearSelection2 (True)
swModel.ViewZoomtofit
End Function
Function ExtrudeSketch(swModel As SldWorks.ModelDoc2)
Dim boolStatus As Boolean
boolStatus = swModel.Extension.SelectByID2("Sketch1", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
Dim CreateExtrude As Feature
On Error Resume Next
CreateExtrude = swModel.FeatureManager.FeatureExtrusion2(True, False, False, 0, 0, 3, 0.01, False, False, False, False, 0, 0, False, False, False, False, True, True, True, 0, 0, False)
On Error GoTo 0
End Function
Function ColorPart(swModel As SldWorks.ModelDoc2)
Dim vMatProps
vMatProps = swModel.MaterialPropertyValues
'Define the RGB values (1 = RGB value 255)
vMatProps(0) = 154 / 255 'R
vMatProps(1) = 155 / 255 'G
vMatProps(2) = 156 / 255 'B
swModel.MaterialPropertyValues = vMatProps
swModel.GraphicsRedraw2
End Function

How to get CATPart number and name into text editor in drawing using macro?

I'm trying to create a macro in CATIA. The macro should use a UserForm with the button. After clicking on the button, it will automatically fill in the text field with data (Part Name + Part Number).
I am a total novice in VBA.
Private Sub CommandButton1_Click()
Dim DrwDocument As DrawingDocument
Set DrwDocument = CATIA.ActiveDocument
Set DrwSheets = DrwDocument.Sheets
Set Selection = DrwDocument.Selection
Set DrwSheet = DrwSheets.ActiveSheet
Set DrwView = DrwSheet.Views.ActiveView
Set DrwTexts = CATIA.ActiveDocument.Sheets.ActiveSheet.Views.ActiveView.Texts
Dim parameters4 As Parameters
Set parameters4 = DrwDocument.Parameters
Dim realParam4 As Parameter
Set realParam4 = parameters4.Item("Sheet.1\ViewMakeUp.3\Scale")
DrwView.Activate
Set Projekt = DrwTexts.Add(tbProjekt.Text, (288), (45.5))
Projekt.AnchorPosition = catMiddleLeft
Projekt.SetFontName 0, 0, "Monospac821 BT"
Projekt.SetFontSize 0, 0, 3
Set PocetKs = DrwTexts.Add(tbPocetKs.Text + "x", (36), (78))
PocetKs.AnchorPosition = catMiddleLeft
PocetKs.SetFontName 0, 0, "Monospac821 BT"
PocetKs.SetFontSize 0, 0, 3
If OptionZrk = True Then
Set PocetKsZrk = DrwTexts.Add(tbPocetKs.Text + "x", (36),(70))
PocetKsZrk.AnchorPosition = catMiddleLeft
PocetKsZrk.SetFontName 0, 0, "Monospac821 BT"
PocetKsZrk.SetFontSize 0, 0, 3
Set ZrkText = DrwTexts.Add("Zrkadlový", (102), (80))
ZrkText.AnchorPosition = catMiddleLeft
ZrkText.SetFontName 0, 0, "Monospac821 BT"
ZrkText.SetFontSize 0, 0, 3
End If
Set Material = DrwTexts.Add(cbMaterial.Text, (288), (37.5))
Material.AnchorPosition = catMiddleLeft
Material.SetFontName 0, 0, "Monospac821 BT"
Material.SetFontSize 0, 0, 3
Set Mierka = DrwTexts.Add(realParam4.ValueAsString, (238), (40))
Mierka.AnchorPosition = catMiddleLeft
Mierka.SetFontName 0, 0, "Monospac821 BT"
Mierka.SetFontSize 0, 0, 3
Set DatumUpravy = DrwTexts.Add(tbDatum.Text, (355), (38))
DatumUpravy.AnchorPosition = catMiddleLeft
DatumUpravy.SetFontName 0, 0, "Monospac821 BT"
DatumUpravy.SetFontSize 0, 0, 3
End Sub
Via the GenerativeBehavior of a view you get the shown product.
dim oProduct as Product
Set oProduct = DrwView.GenerativeBehavior.Document
MsgBox CStr(oProduct.PartNumber)
MsgBox CStr(oProduct.Nomenclature)
Make shure that the view has a link to a geometry/product

How to sort multidimensional arrays through a function

I'm having some trouble in vb.net 2012 with sorting multidimensional arrays, I tried to make a custom sorting algorithm to sort the coordinates via the z axis, so that a four sided polygon can be drawn. This is so that the shape can be drawn in order like a z index in css
(also how do you add a thing to the array so that you can define the polygon colour)
'there's nothing here in the x and y sections right now
Dim G_ObjList(,,) As Double = {
{{0, 0, 1}, {0, 0, 0.75}, {0, 0, 0.75}, {0, 0, 0.95}},
{{0, 0, 1}, {0, 0, 0.75}, {0, 0, 0.75}, {0, 0, 0.95}},
{{0, 0, 1}, {0, 0, 0.75}, {0, 0, 0.75}, {0, 0, 0.95}},
{{0, 0, 1}, {0, 0, 0.75}, {0, 0, 0.75}, {0, 0, 0.95}},
{{0, 0, 0.75}, {0, 0, 0.75}, {0, 0, 0.75}, {0, 0, 0.75}}
}
Function p3DOrder(ByVal a(,,) As Double, ByVal p As Point)
'0 is point
'1 is depth
'2 is distance to p after being translated to p3d (probably only to be used here, but just in case for anyother use)
'a(depth/point, infopoint
'create new jagged array (not jagged array anymore)
Dim avDP(2, a.GetLength(0) - 1)
'sorts data into new jagged array
For i = 0 To (a.GetLength(0) - 1)
'calculate averages and set array
avDP(2, i) = (Math.Sqrt((a(i, 0, 0) - p.X) ^ 2 + (a(i, 0, 1) - p.Y) ^ 2) + Math.Sqrt((a(i, 1, 0) - p.X) ^ 2 + (a(i, 1, 1) - p.Y) ^ 2) + Math.Sqrt((a(i, 2, 0) - p.X) ^ 2 + (a(i, 2, 1) - p.Y) ^ 2) + Math.Sqrt((a(i, 3, 0) - p.X) ^ 2 + (a(i, 3, 1) - p.Y) ^ 2)) / 4 'calculate distance to main perspective point
avDP(1, i) = (a(i, 0, 2) + a(i, 1, 2) + a(i, 2, 2) + a(i, 3, 2)) / 4 'set depth side by side with distance calculated
avDP(0, i) = {New Point(a(i, 0, 0), a(i, 0, 1)), New Point(a(i, 1, 0), a(i, 1, 1)), New Point(a(i, 2, 0), a(i, 2, 1)), New Point(a(i, 3, 0), a(i, 3, 1))}
'have to keep the varibles in this way to prevent separation between data pairs
'sort jagged array
If i <= a.GetLength(0) - 2 Then
If (avDP(1, i) > avDP(1, i + 1)) Then
'test switch program
Dim _tm0() = {avDP(0, i), avDP(1, i), avDP(2, i)} 'temporary stores data to switch
Dim _tm1() = {avDP(0, i + 1), avDP(1, i + 1), avDP(2, i + 1)}
avDP(0, i) = _tm1(0) 'switch around array data
avDP(1, i) = _tm1(1)
avDP(2, i) = _tm1(2)
avDP(0, i + 1) = _tm0(0)
avDP(1, i + 1) = _tm0(1)
avDP(2, i + 1) = _tm0(2)
Dim _tmbStep As Integer = 0
Do While (avDP(1, i - _tmbStep) > avDP(1, i + 1 - _tmbStep)) 'step back if true
Dim _tm2() = {avDP(0, i - _tmbStep), avDP(1, i - _tmbStep), avDP(2, i - _tmbStep)} 'temporary stores data to switch
Dim _tm3() = {avDP(0, i + 1 - _tmbStep), avDP(1, i + 1 - _tmbStep), avDP(2, i + 1 - _tmbStep)}
avDP(0, i - _tmbStep) = _tm3(0) 'switch around array data
avDP(1, i - _tmbStep) = _tm3(1)
avDP(2, i - _tmbStep) = _tm3(2)
avDP(0, i + 1 - _tmbStep) = _tm2(0)
avDP(1, i + 1 - _tmbStep) = _tm2(1)
avDP(2, i + 1 - _tmbStep) = _tm2(2)
_tmbStep += 1 ' continue step back
If (i - _tmbStep < 0) Then 'stops error
Exit Do
End If
Loop
End If
End If
Next
'return resorted array
Return avDP
End Function
Me.Canvas.Image = New Bitmap(Me.Canvas.Width, Me.Canvas.Height, System.Drawing.Imaging.PixelFormat.Format24bppRgb)
Using g As Graphics = Graphics.FromImage(Me.Canvas.Image)
Dim mainPP = New Point(Me.Canvas.ClientRectangle.Width / 2, Me.Canvas.ClientRectangle.Height / 2)
For i = 0 To (G_ObjList.GetLength(0) - 1)
Dim _tmpy() As Point = {
p3d(G_ObjList(i, 0, 0), G_ObjList(i, 0, 1), G_ObjList(i, 0, 2), mainPP),
p3d(G_ObjList(i, 1, 0), G_ObjList(i, 1, 1), G_ObjList(i, 1, 2), mainPP),
p3d(G_ObjList(i, 2, 0), G_ObjList(i, 2, 1), G_ObjList(i, 2, 2), mainPP),
p3d(G_ObjList(i, 3, 0), G_ObjList(i, 3, 1), G_ObjList(i, 3, 2), mainPP)
}
Dim br As New SolidBrush(Color.FromArgb(255, G_ObjList(i, 0, 0) * 0.3, G_ObjList(i, 0, 0) * 0.3, G_ObjList(i, 0, 0) * 0.3))
g.FillPolygon(br, _tmpy)
Next
end using
'be aware that this isn't all the code

Extract from multidimensional array

I have an array dat that shows Type = Variant/Variant(0 to 500, 0 to 0, 0 to 1)
There is a "column" of dates:
dat(0, 0, 0) = #1/1/2013#
dat(1, 0, 0) = #1/2/2013#
I want to extract this set of dates. I tried:
Dim dat As Variant
Dim dt As Variant
'stuff gets dat in the format described above
dt = Application.Index(dat, 0, 1, 1)
Unfortunately this gives me an Error 13 Type Mismatch. What am I doing wrong?
Use a Loop
Sub dural()
Dim dat(0 To 500, 0 To 1, 0 To 1) As Variant
dat(0, 0, 0) = #1/1/2013#
dat(1, 0, 0) = #1/2/2013#
Dim dt(0 To 500) As Variant
For i = 0 To 500
dt(i) = dat(i, 0, 0)
Next i
End Sub

Sendmessage wm_paste textbox

I am trying to copy text from another window then use SendMessage to paste the text in a textbox. I have tried using:
textBox1.Paste()
and
textBox1.text = Clipboard.GetText()
but it seems these paste functions are called before the sendmessage api, hence why I want a sendmessage api to paste to the textbox so it goes in the event order needed.
SendMessage(1508866, WM_COPY, 0, 0)
SendMessage(textBox1.handle, WM_PASTE, 0, 0) ' Does not paste anything in textbox.
EDIT:
Here is my code. Note, the clipboard method fires BEFORE sendmessage.
AppActivate("Hyperspace")
SetCursorPos(2271,214) ' Request
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
SetCursorPos(2726,111) ' Properties
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
SetCursorPos(2681,792) ' Get EOW
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
SetCursorPos(2853,525) ' Highlight EOW
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
SendMessage(1508866, WM_COPY, 0, 0)
textBox2.Text = Clipboard.GetText()
SetCursorPos(2983,719) ' Close
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
SetCursorPos(2967,783) ' Accept
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
SendMessage() is synchronous. It does not return until the message has been processed by the receiving window:
SendMessage(1508866, WM_COPY, 0, 0)
TextBox1.Text = Clipboard.GetText()
But why are you involving the clipboard at all? If you have the HWND of the external window, you could just use WM_GETTEXT to retrieve its text and then assign it to the Text property of your TextBox. No clipboard needed.