• 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

Manipulating shapes with VBA

Excel Version
  1. 2016
Here is a description of this application:


Canvas sheet - shows your current work.

Problem sheet - presents the original problem and also some examples that can be pasted on Dat page.

Dat sheet - There are stored triangles vertices generated by the program. Alternatively, you can insert your own data.

Do not leave any blank cells in the middle of your data range. Each line represents the three vertices of a triangle.

Be sure to start on the third row.

The x axis runs from left to right, and the y axis from top to bottom, meaning the origin is at the upper left corner.


Controls sheet - this is the main page, consisting of the following elements:

Canvas color block - allows you to change the background color by dragging the three scroll bars.

When satisfied, click the Apply button.

Big thumbnail - shows how the Canvas page is looking like. At the lower right corner is the directory to be used, in case you decide to save a wallpaper (see below).

3D button - toggles 3D effect on every triangle.

Gradient button - applies this effect on triangles.

Shadow button - toggles this effect on/off.

Texture button - puts this effect on all triangles.

Pattern button - applies this appearance on every triangle.

#Triangles button - clicking it will generate a number of new triangles defined in cell F29.

Intersection button - will eliminate intersecting triangles.

Table button - clicking this will draw a set of triangles based on the existing table, instead of generating a new one.

Wallpaper button - saves current canvas and sets it as your desktop wallpaper. If there is no directory defined to store the file, you will be prompted to choose one. Pick a folder where Windows allows recording of user files.

Triangles_v1.2.xlsm

trisat.PNG


VBA Code:
Option Explicit
Option Base 1

Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
' Declare a UDT to store a GUID for the IPicture OLE Interface
Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Public Type uPicDesc    ' Declare a UDT to store the bitmap information
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
Public Const CF_BITMAP = 2, PICTYPE_BITMAP = 1
Const SPI_SETDESKWALLPAPER = 20

Public Declare Function SystemParametersInfo Lib "user32" _
Alias "SystemParametersInfoA" (ByVal uAction As Long, _
ByVal uParam As Long, ByVal lpvParam As Any, _
ByVal fuWinIni As Long) As Long
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Public Type triangle
    x(3) As Single
    y(3) As Single
    t_area As Double
    npar As Integer
    out As Boolean
    gc As Integer
End Type
Public tri() As triangle, i%, j%, n%, m%, svar, miss As Boolean
Dim dv%, p%, rv%, ws As Worksheet, wdir$, estr$

Sub TMaker(x!(), y!())
    Dim ta!(4, 2)
    ta(1, 1) = x(1)
    ta(1, 2) = y(1)
    ta(2, 1) = x(2)
    ta(2, 2) = y(2)
    ta(3, 1) = x(3)
    ta(3, 2) = y(3)
    ta(4, 1) = x(1)
    ta(4, 2) = y(1)
    Worksheets("Canvas").Shapes.AddPolyline ta
End Sub

Sub Gen(need As Boolean)
Dim tpg%, comp%, xstep%, ystep%, st$
miss = False
tpg = n \ 5                 ' triangles per group
comp = n Mod 5              ' remainder joins fifth and last group
xstep = 50
ystep = 30
If need Then
    Eraser
    Sheets("Dat").Range("c3:h104").ClearContents
    For i = 1 To 5
        Gb 3 + (i - 1) * tpg, 2 + (i - 1) * tpg + tpg, 1300 - i * xstep, 600 - i * ystep, _
        i * xstep, i * ystep
    Next
    Gb 3 + 5 * tpg, 2 + 5 * tpg + comp, 1300 - 5 * xstep, 600 - 5 * ystep, 5 * xstep, 5 * ystep
End If
st = "c3:h" & LastRow
If WorksheetFunction.CountBlank(Range(st)) > 0 Then
    MsgBox "Missing data at Dat page", vbCritical
    miss = True
    Exit Sub
End If
For i = 3 To n + 2
    For j = 3 To 5
        tri(i - 2).x(j - 2) = Sheets("Dat").Cells(i, j).Value
    Next j
Next i
For i = 3 To n + 2
    For j = 6 To 8
        tri(i - 2).y(j - 5) = Sheets("Dat").Cells(i, j).Value
    Next j
Next i
End Sub

Sub Gb(start%, endrow%, xi%, yi%, xs%, ys%)
Dim xseed!, yseed!, c%
Randomize
For c = start To endrow                     ' rows
    xseed = xi * Rnd
    yseed = yi * Rnd
    For j = 3 To 5                          ' columns
        Sheets("Dat").Cells(c, j).Value = xseed + xs * Rnd
    Next
    For j = 6 To 8                          ' columns
        Sheets("Dat").Cells(c, j).Value = yseed + ys * Rnd
    Next
Next
End Sub

Sub WhoStays()
Dim k%, m%, ni%, a(), B()
a() = Array(1, 1, 2)
B() = Array(2, 3, 3)
For k = 1 To n - 1
    For m = k + 1 To n
        For i = 1 To 3
            For j = 1 To 3
                If lines_si(tri(k).x(a(i)), tri(k).y(a(i)), tri(k).x(B(i)), tri(k).y(B(i)), _
                tri(m).x(a(j)), tri(m).y(a(j)), tri(m).x(B(j)), tri(m).y(B(j))) Then
                    If tri(k).t_area > tri(m).t_area Then tri(m).out = True
                    If tri(k).t_area < tri(m).t_area Then tri(k).out = True
                End If
            Next
        Next
    Next
Next
ni = 0
For i = 1 To n
    If tri(i).out Then ni = ni + 1
Next

End Sub

Sub AreaCalc()
For i = 1 To n
    tri(i).t_area = TriArea(tri(i).x, tri(i).y)
Next
End Sub

Sub Opening(gv As Boolean)
If gv Then n = Sheets("Controls").Cells(29, 6).Value
If Not gv Then n = LastRow - 2
If n < 1 Then
    MsgBox "Data table is empty!", vbExclamation
    Exit Sub
End If
ReDim tri(n)
For i = 1 To n
    tri(i).out = False
    tri(i).npar = 0
    tri(i).t_area = 0
Next
Gen gv
AreaCalc
If Not miss Then WhoStays
svar = 1
End Sub

Sub Main(gv As Boolean)
Dim k%, m%, nlev%, step!(3), est$
If svar = Empty Or svar = 0 Then Opening gv
If n < 1 Then Exit Sub
If miss Then Exit Sub
Sheets("Canvas").Activate
For i = 1 To n - 1                          ' base
    If Not tri(i).out Then
        For j = i + 1 To n                      ' others to the right
            If Not tri(j).out Then DefPar
        Next
    End If
Next
Sheets("Aux").Range("d1:f100").ClearContents
For i = 1 To n
    Sheets("Aux").Cells(i, 4) = tri(i).t_area
    Sheets("Aux").Cells(i, 5) = i
    Sheets("Aux").Cells(i, 6) = tri(i).out
Next
SortAreas
For i = 1 To n                      ' draw bigger ones first
    j = Sheets("Aux").Cells(i, 5).Value
    TMaker tri(j).x, tri(j).y
Next
nlev = tri(1).npar
For i = 2 To n
    If tri(i).npar > nlev Then nlev = tri(i).npar
Next
step(1) = (0.9 * Range("RedV")) / (nlev + 1)
step(2) = (0.9 * Range("GreenV")) / (nlev + 1)
step(3) = (0.9 * Range("BlueV")) / (nlev + 1)
For i = 1 To n
    j = Sheets("Aux").Cells(i, 5).Value
    ActiveSheet.Shapes(i).Fill.ForeColor.RGB = RGB(Range("RedV") - (tri(j).npar + 1) * step(1), _
    Range("GreenV") - (tri(j).npar + 1) * step(2), Range("BlueV") - (tri(j).npar + 1) * step(3))
Next
est = " "
For i = 1 To n
    est = est & tri(i).npar & "  "
Next
End Sub

Sub DefPar()
Dim xa!(3), ya!(3), ind%, k%, bv As Boolean
bv = tri(i).t_area > tri(j).t_area
Select Case bv
    Case True
        ind = 0
        CClock tri(i).x, tri(i).y, xa, ya
        For k = 1 To 3
            If Inside(xa, ya, tri(j).x(k), tri(j).y(k)) Then ind = ind + 1
        Next
        If ind = 3 Then tri(j).npar = tri(j).npar + 1
    Case False
        ind = 0
        CClock tri(j).x, tri(j).y, xa, ya
        For k = 1 To 3
            If Inside(xa, ya, tri(i).x(k), tri(i).y(k)) Then ind = ind + 1
        Next
        If ind = 3 Then tri(i).npar = tri(i).npar + 1
End Select
End Sub

Sub SortAreas()
Dim es$
If n < 1 Then Exit Sub
ActiveWorkbook.Worksheets("Aux").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Aux").Sort.SortFields.Add Key:=Range("d1"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
es = "d1:f" & n
With ActiveWorkbook.Worksheets("Aux").Sort
    .SetRange Range(es)
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub

Public Function LastRow() As Long
    Sheets("Dat").Activate
    If WorksheetFunction.CountA(Cells) = 0 Then
        LastRow = 0
        Exit Function
    End If
    LastRow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row
End Function
Sub Invisibles()
Application.ScreenUpdating = False

If svar = Empty Or svar = 0 Then Opening False
n = Sheets("Canvas").Shapes.Count
For i = 1 To n
    j = Sheets("Aux").Cells(i, 5).Value
    If tri(j).out Then Sheets("Canvas").Shapes(i).Visible = False
Next
CCopy
Application.ScreenUpdating = True

End Sub

Sub Eraser()
Dim esh As Shape
For Each esh In Sheets("Canvas").Shapes
    esh.Delete
Next
svar = 0
End Sub

Sub ChangeColorSwatch()
    ActiveSheet.Range("RedSwatch").Interior.Color = RGB(Range("RedV"), 0, 0)
    ActiveSheet.Range("GreenSwatch").Interior.Color = RGB(0, Range("GreenV"), 0)
    ActiveSheet.Range("BlueSwatch").Interior.Color = RGB(0, 0, Range("BlueV"))
    ActiveSheet.Range("CombinedColor").Interior.Color = RGB(Range("RedV"), _
    Range("GreenV"), Range("BlueV"))
End Sub

Sub TriTexture()
Sheets("Canvas").Activate
n = ActiveSheet.Shapes.Count
Randomize
For i = 1 To n
    ActiveSheet.Shapes(i).Fill.PresetTextured PresetTexture:=1 + Round(20 * Rnd, 0)
Next
End Sub

Sub TogShadow()
Set ws = Sheets("Canvas")
n = ws.Shapes.Count
If n = 0 Then Exit Sub

For i = 1 To n
    ws.Shapes(i).Shadow.Visible = Not ws.Shapes(i).Shadow.Visible
Next
If ws.Shapes(1).Shadow.Visible Then
    For i = 1 To n
        With ws.Shapes(i).Shadow
            .Transparency = 0.8
            .OffsetX = 30
            .OffsetY = 30
            .Blur = 12
        End With
    Next
End If
End Sub

Sub Tog3D()
Set ws = Sheets("Canvas")
If svar = Empty Or svar = 0 Then Opening False
For i = 1 To n
    ws.Shapes(i).ThreeD.Visible = Not ws.Shapes(i).ThreeD.Visible
Next
If ws.Shapes(1).ThreeD.Visible Then
    For i = 1 To n
        dv = Round(0.002 * tri(i).t_area, 0) + 1
        If dv > 50 Then dv = 50
        With ws.Shapes(i).ThreeD
            .Depth = dv
            .BevelTopDepth = 8
            .RotationY = 10
        End With
    Next
End If
End Sub

Sub TriGrad()
n = Sheets("Canvas").Shapes.Count
Randomize
For i = 1 To n
        
    With Sheets("Canvas").Shapes(i).Fill
        .TwoColorGradient Style:=1 + Round(4 * Rnd, 0), Variant:=2
        .ForeColor.RGB = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
        .BackColor.ObjectThemeColor = 1 + Round(15 * Rnd, 0)
    End With
Next
End Sub

Sub TriPatt()
n = Sheets("Canvas").Shapes.Count
Randomize
For i = 1 To n
    With Sheets("Canvas").Shapes(i).Fill
        .Patterned Pattern:=1 + Round(49 * Rnd, 0)
        .ForeColor.RGB = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
        .BackColor.RGB = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
    End With
Next
End Sub

Sub CCopy()
Dim p As Object, q As Object, t!, L!, w!, h!
Application.ScreenUpdating = False
For Each p In Sheets("Controls").Pictures
    If p.Width > 200 Then p.Delete          ' protect command buttons
Next
Sheets("Canvas").Range("a1:ad43").CopyPicture Appearance:=xlScreen, Format:=xlPicture
Sheets("Controls").Paste
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
For Each p In Sheets("Controls").Pictures
    If p.Width > 200 Then Set q = p
Next
With Sheets("Controls").Range("j2:v21")
        t = .Top
        L = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
End With
q.ShapeRange.LockAspectRatio = msoFalse
q.Placement = xlMoveAndSize
q.Top = t
q.Left = L
q.Width = w
q.Height = h
Set q = Nothing
Sheets("Canvas").Activate
Application.ScreenUpdating = True
End Sub

Sub CImage()
Sheets("Canvas").Range("a1:ad43").CopyPicture
Sheets("Controls").Paste Destination:=Worksheets("Controls").Range("j2:t21")
End Sub
Function TriArea(x!(), y!())
TriArea = 0.5 * Abs((x(1) * (y(2) - y(3)) + x(2) * (y(3) - y(1)) + x(3) * (y(1) - y(2))))
End Function

Sub CClock(x!(), y!(), fx!(), fy!())       ' arranges vertices in counter clockwise order
Dim r%, S%, L%
If x(1) >= x(2) And x(1) >= x(3) Then
    r = 1                       ' first
    If y(2) >= y(3) Then
        S = 2                   ' second
        L = 3                   ' last
    Else
        S = 3
        L = 2
    End If
ElseIf x(2) >= x(1) And x(2) >= x(3) Then
    r = 2
    If y(1) >= y(3) Then
        S = 1
        L = 3
    Else
        S = 3
        L = 1
    End If
ElseIf x(3) >= x(1) And x(3) >= x(2) Then
    r = 3
    If y(1) >= y(2) Then
        S = 1
        L = 2
    Else
        S = 2
        L = 1
    End If
End If
fx(1) = x(r)
fx(2) = x(S)
fx(3) = x(L)
fy(1) = y(r)
fy(2) = y(S)
fy(3) = y(L)
End Sub

Function Inside(x!(), y!(), px!, py!)   ' must receive vertices in counter clockwise order
Inside = False
If ((px - x(1)) * (y(2) - y(1)) - (py - y(1)) * (x(2) - x(1))) > 0 Then Exit Function
If ((px - x(2)) * (y(3) - y(2)) - (py - y(2)) * (x(3) - x(2))) > 0 Then Exit Function
If ((px - x(3)) * (y(1) - y(3)) - (py - y(3)) * (x(1) - x(3))) > 0 Then Exit Function
Inside = True
End Function

Function lines_si(x1!, y1!, x2!, y2!, x3!, y3!, x4!, y4!) As Boolean
Dim x5!, y5!, ival%, u!, v!     ' computes the intersection of two lines
x5 = 0
y5 = 0
Lines_exp_int x1, y1, x2, y2, x3, y3, x4, y4, ival, x5, y5
If ival = 0 Then
    lines_si = False
    Exit Function
End If
Line_seg_contains_point x1, y1, x2, y2, x5, y5, u, v
If u < 0 Or 1 < u Or v > 0.001 Then
    lines_si = False
    Exit Function
End If
Line_seg_contains_point x3, y3, x4, y4, x5, y5, u, v
If u < 0 Or 1 < u Or v > 0.001 Then
    lines_si = False
    Exit Function
End If
lines_si = True
End Function

Sub Lines_exp_int(x1!, y1!, x2!, y2!, x3!, y3!, x4!, y4!, ival%, x!, y!)
Dim point1 As Boolean, point2 As Boolean, a1!, b1!, c1!, a2!, b2!, c2!
ival = 0        ' finds where two explicit lines intersect
x = 0
y = 0
If x1 = x2 And y1 = y2 Then
    point1 = True
Else
    point1 = False
End If
If x3 = x4 And y3 = y4 Then
    point2 = True
Else
    point2 = False
End If
If Not point1 Then line_exp2imp x1, y1, x2, y2, a1, b1, c1
If Not point2 Then line_exp2imp x3, y3, x4, y4, a2, b2, c2
If point1 And point2 Then
    If x1 = x3 And y1 = y3 Then
        ival = 1
        x = x1
        y = y1
    End If
ElseIf point1 Then
    If (a2 * x1 + b2 * y1) = c2 Then
        ival = 1
        x = x1
        y = y1
    End If
ElseIf point2 Then
    If (a1 * x3 + b1 * y3) = c1 Then
        ival = 1
        x = x3
        y = y3
    End If
Else
    lines_imp_int a1, b1, c1, a2, b2, c2, ival, x, y
End If
End Sub

Sub Line_seg_contains_point(x1!, y1!, x2!, y2!, x3!, y3!, u!, v!)
Dim unit!
unit = Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2)
If unit = 0 Then
    If x3 = x1 And y3 = y1 Then
        u = 0.5
        v = 0
    Else
        u = 0.5
        v = 1E+20
    End If
Else
    u = ((x3 - x1) * (x2 - x1) + (y3 - y1) * (y2 - y1)) / (unit * unit)
    v = Sqr(((u - 1) * x1 - u * x2 + x3) ^ 2 + ((u - 1) * y1 - u * y2 + y3) ^ 2) / unit
End If
End Sub

Sub line_exp2imp(x1!, y1!, x2!, y2!, a!, B!, c!)
If x1 = x2 And y1 = y2 Then         ' explicit to implicit form
    MsgBox "Fatal error"
    Exit Sub
End If
a = y2 - y1
B = x1 - x2
c = x2 * y1 - x1 * y2
End Sub

Sub lines_imp_int(a1!, b1!, c1!, a2!, b2!, c2!, ival%, x!, y!)
Dim a!(2, 2), B!(2, 2), det!        ' where two implicit lines intersect
x = 0
y = 0
If a1 = 0 And b1 = 0 Then
    ival = -1
    Exit Sub
ElseIf a2 = 0 And b2 = 0 Then
    ival = -2
    Exit Sub
End If
a(1, 1) = a1
a(1, 2) = b1
a(2, 1) = a2
a(2, 2) = b2
Rmat2_inv a, B, det
If det <> 0 Then
    ival = 1
    x = -B(1, 1) * c1 - B(1, 2) * c2
    y = -B(2, 1) * c1 - B(2, 2) * c2
Else
    ival = 0
    If a1 = 0 Then
        If b2 * c1 = c2 * b1 Then ival = 2
    Else
        If a2 * c1 = c2 * a1 Then ival = 2
    End If
End If
End Sub

Sub Rmat2_inv(a, B, det!)       ' inverts a matrix
det = a(1, 1) * a(2, 2) - a(1, 2) * a(2, 1)
If det = 0 Then
    B(1, 1) = 0
    B(1, 2) = 0
    B(2, 1) = 0
    B(2, 2) = 0
    Exit Sub
End If
B(1, 1) = a(2, 2) / det
B(1, 2) = -a(1, 2) / det
B(2, 1) = -a(2, 1) / det
B(2, 2) = a(1, 1) / det
End Sub

Sub hide()
Sheets("Aux").Visible = xlSheetVeryHidden
End Sub
Function DECIMAL2RGB(ColorVal) As Variant
'   Converts a color value to an RGB triplet
'   Returns a 3-element variant array
    DECIMAL2RGB = Array(ColorVal \ 256 ^ 0 And 255, ColorVal \ 256 ^ 1 And 255, ColorVal \ 256 ^ 2 And 255)
End Function

Function RGB2DECIMAL(r, G, B)
    RGB2DECIMAL = RGB(r, G, B)
End Function

Function Round(alpha, beta) As Long
   Round = WorksheetFunction.Round(alpha, beta)
End Function

Sub WriteDir()
    Dim Msg$, f$, r&
    Msg = "Select a location to store the file."
    If Cells(42, 5).Value Then
        wdir = GetDirectory(Msg)
        If wdir = "" Then Exit Sub
        If Right(wdir, 1) <> "\" Then wdir = wdir & "\"
        Sheets("Controls").Cells(22, 22).Value = wdir
    Else
        wdir = Sheets("Controls").Cells(22, 22).Value
    End If
End Sub

Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO, path$, r&, x&, pos%
' Root folder = Desktop
    bInfo.pidlRoot = 0&
' Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
  End If
' Type of directory to return
    bInfo.ulFlags = &H1
' Display the dialog
    x = SHBrowseForFolder(bInfo)
' Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
  End If
End Function

Private Sub SaveRangePic(SourceRange As Range, FilePathName$)
    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc
    Dim IPic As IPicture, hPtr&
    On Error Resume Next
    SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    CloseClipboard
    With IID_IDispatch          ' Create the interface GUID for the picture
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPtr ' Handle to image.
        .hPal = 0 ' Handle to palette (if bitmap).
    End With
   ' Create the Range Picture Object
    OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
    stdole.SavePicture IPic, FilePathName
    If Err.Number <> 0 Then
        MsgBox "Directory not valid.", vbCritical
        Sheets("Controls").Cells(22, 22).Value = " "
    End If
End Sub

Sub SaveImage()
estr = Time
estr = WorksheetFunction.Substitute(estr, ":", "0")
estr = wdir & "wp" & estr & ".bmp"
SaveRangePic Sheets("Canvas").Range("A1:ab41"), estr
End Sub

Public Sub SetWallpaper(ByVal FileName$)
Dim ret&
ret = SystemParametersInfo(20, 0&, FileName, &H2 Or &H1)
End Sub

Sub NewWall()
WriteDir
SaveImage
If Err.Number = 0 Then SetWallpaper (estr)
End Sub
Author
Worf
Views
4,576
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