• If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.
  • Excel articles and downloadable files provided in the articles have not been reviewed by MrExcel Publishing. Please apply the provided methods / codes and open the files at your own risk. If you have any questions regarding an article, please use the Article Discussion section.
Worf

Draw the Ukrainian flag with VBA

Excel Version
  1. 2016
The Ukrainian flag is rather easy to draw, and here we will see six distinct ways to do it:

  • 2 user forms without title and borders
  • 2 worksheet cells
  • A Word table
  • A chart
  • 2 shapes
  • 2 text boxes
woch.png

tbuf.png

VBA Code:
Option Explicit
Rem standard module
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
                      
Private Declare PtrSafe Function GetWindowLong Lib "user32" _
    Alias "GetWindowLongA" (ByVal hWnd As Long, _
    ByVal nIndex As Long) As Long

Private Declare PtrSafe Function SetWindowLong Lib "user32" _
    Alias "SetWindowLongA" (ByVal hWnd As Long, _
    ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare PtrSafe Function DrawMenuBar Lib "user32" ( _
    ByVal hWnd As Long) As Long

Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" ( _
                ByVal hWnd As Long, ByVal crKey As Long, _
                ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
#Else
Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
                      
Private Declare Function GetWindowLong Lib "user32" _
    Alias "GetWindowLongA" ( _
    ByVal hWnd As Long, _
    ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong Lib "user32" _
    Alias "SetWindowLongA" ( _
    ByVal hWnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

Private Declare Function DrawMenuBar Lib "user32" ( _
    ByVal hWnd As Long) As Long

Private Declare Function SetLayeredWindowAttributes Lib "user32" ( _
                ByVal hWnd As Long, _
                ByVal crKey As Long, _
                ByVal bAlpha As Byte, _
                ByVal dwFlags As Long) As Long
#End If

Public ftop, fh
Private Const GWL_STYLE As Long = -16
Private Const GWL_EXSTYLE As Long = -20
Private Const WS_CAPTION As Long = &HC00000       'Style for titlebar
Private Const WS_EX_DLGMODALFRAME As Long = &H1

Sub HideTBB(frm As Object)
Dim wd&, fh&
fh = FindWindow(vbNullString, frm.Caption)
SetWindowLong fh, GWL_STYLE, GetWindowLong(fh, GWL_STYLE) And (Not WS_CAPTION)
SetWindowLong fh, GWL_EXSTYLE, GetWindowLong(fh, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
DrawMenuBar fh
End Sub

Sub Run_me()
UserForm1.Show vbModeless
UserForm2.Show vbModeless
End Sub

Sub ColumnW_MM(ColNo&, mmWidth%)
Dim w!
If ColNo < 1 Or ColNo > 255 Then Exit Sub
Application.ScreenUpdating = False
w = Application.CentimetersToPoints(mmWidth / 10)
While Columns(ColNo + 1).Left - Columns(ColNo).Left - 0.1 > w
    Columns(ColNo).ColumnWidth = Columns(ColNo).ColumnWidth - 0.1
Wend
While Columns(ColNo + 1).Left - Columns(ColNo).Left + 0.1 < w
    Columns(ColNo).ColumnWidth = Columns(ColNo).ColumnWidth + 0.1
Wend
End Sub

Sub RowH_MM(RowNo&, mmHg%)
If RowNo < 1 Or RowNo > 65536 Then Exit Sub
Rows(RowNo).RowHeight = Application.CentimetersToPoints(mmHg / 10)
End Sub

Sub Cells2()        ' two cells
ColumnW_MM 3, 120
RowH_MM 3, 40
ColumnW_MM 3, 120
RowH_MM 4, 40
With [c3].Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = RGB(5, 90, 180)
End With
With [c4].Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = RGB(250, 210, 5)
End With
End Sub

Sub Chart2()
Dim ch As Shape, ya As Axis
Set ch = ActiveSheet.Shapes.AddChart _
(Left:=90, Top:=5, Width:=440, Height:=190)
With ch.Chart
    .SeriesCollection.NewSeries
    .SeriesCollection(1).Values = Array(100)
    .SeriesCollection.NewSeries
    With .SeriesCollection(1)
        .XValues = Array("Chart")
        .ChartType = xlColumnStacked
        .AxisGroup = 1
        .Format.Fill.ForeColor.RGB = RGB(250, 210, 5)
    End With
    With .SeriesCollection(2)
        .Values = Array(100)
        .ChartType = xlColumnStacked
        .AxisGroup = 1
        .Format.Fill.ForeColor.RGB = RGB(5, 90, 180)
    End With
    .HasTitle = 0
    Set ya = .Axes(xlValue)
    ya.Delete
    .ChartArea.Font.Color = vbWhite
    .ChartArea.Interior.ColorIndex = 1
    .HasLegend = False
    .Axes(xlCategory).MajorGridlines.Delete
    .Axes(xlCategory).TickLabels.Font.Size = 20
    .ChartGroups(1).GapWidth = 150
End With
End Sub

Sub Two_Shapes()
Dim s(2) As Shape
Const uni = 90
Set s(1) = ActiveSheet.Shapes.AddShape _
(msoShapeRectangle, 170, 285, uni * 3, uni)
With s(1).Fill
    .Visible = msoTrue
    .ForeColor.RGB = RGB(5, 90, 180)
    .Transparency = 0
    .Solid
End With
With s(1).Line
    .Visible = msoTrue
    .ForeColor.RGB = RGB(5, 90, 180)
    .Transparency = 0
End With
Set s(2) = ActiveSheet.Shapes.AddShape _
(msoShapeRectangle, 170, 285 + s(1).Height, uni * 3, uni)
With s(2).Fill
    .Visible = msoTrue
    .ForeColor.RGB = RGB(250, 210, 5)
    .Transparency = 0
    .Solid
End With
With s(2).Line
    .Visible = msoTrue
    .ForeColor.RGB = RGB(250, 210, 5)
    .Transparency = 0
End With
End Sub

Sub ole()
Dim tb(2) As OLEObject
Const uni = 100
Set tb(1) = ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", Link:=False, _
DisplayAsIcon:=False, Left:=300, Top:=600, Width:=uni * 3, Height:=uni)
tb(1).Object.BackColor = RGB(5, 90, 180)
Set tb(2) = ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", Link:=False, _
DisplayAsIcon:=False, Left:=300, Top:=600 + uni - 7, Width:=uni * 3 - 2, Height:=uni)
tb(2).Object.BackColor = RGB(250, 210, 5)
tb(2).Object.BorderColor = RGB(250, 210, 5)
tb(2).Object.SpecialEffect = fmSpecialEffectFlat
End Sub

Sub Word_table()
Dim t As Word.Table, wap As Object
Set wap = CreateObject("Word.Application")
wap.Visible = True
wap.documents.Add template:="Normal", newtemplate:=False, documenttype:=0
Set t = wap.ActiveDocument.Tables.Add(Range:=wap.Selection.Range, NumRows:=2, NumColumns:= _
1, DefaultTableBehavior:=1, AutoFitBehavior:=wdAutoFitFixed)
t.PreferredWidthType = wdPreferredWidthPoints
t.PreferredWidth = InchesToPoints(6)
t.Rows(1).Shading.BackgroundPatternColor = RGB(5, 90, 180)
t.Rows(2).Shading.BackgroundPatternColor = RGB(250, 210, 5)
t.Borders.Enable = 0
t.Rows.SetHeight InchesToPoints(2), wdRowHeightExactly
wap.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
wap.Selection.Font.Size = 26
wap.Selection.TypeText Text:="Word table"
wap.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

VBA Code:
Rem UserForm1 module
Private Sub UserForm_Initialize()
HideTBB Me
Me.Width = 200
Me.Height = Me.Width * 0.333
Me.StartUpPosition = 0
ftop = (Application.Height - Me.Height) / 2
Me.Top = ftop
Me.Left = (Application.Width - Me.Width - 50)
fh = Me.Height
Me.BackColor = RGB(5, 90, 180)
End Sub

Private Sub UserForm_Click()
Unload Me
End Sub

Rem UserForm2 module
Private Sub UserForm_Click()
Unload Me
End Sub

Private Sub UserForm_Initialize()
HideTBB Me
Me.Width = 200
Me.Height = Me.Width * 0.333
Me.StartUpPosition = 0
Me.Top = ftop + fh - 5
Me.Left = (Application.Width - Me.Width - 50)
Me.BackColor = RGB(250, 210, 5)
End Sub
  • Like
Reactions: Dan_W
Author
Worf
Views
1,468
First release
Last update

Ratings

0.00 star(s) 0 ratings

More Excel articles from Worf

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top