vbamania.pl
login:
hasło:
 
  *Rejestracja *Zapomniane hasło
 Dziś jest wtorek, 16 kwietnia 2024 roku.
Ustaw jako stronę startową Ulubione Napisz
Porada 6 marca 2020
Wykorzystanie pliku XML do przechowywania danych konfiguracyjnych.

Poniższy program prezentuje wykorzystanie biblioteki XML Dom do odczytywania danych zawartych w pliku XML.
Sub GetConfiguration(strFile As String, ByRef Data() As String, ByRef Number As Long)

Dim oXML As MSXML2.DOMDocument
Dim oList As MSXML2.IXMLDOMNode
Dim i As Long

Set oXML = New MSXML2.DOMDocument
oXML.async = True
oXML.Load strFile

For Each oList In oXML.getElementsByTagName("List")
    Data(i, 1) = oList.Attributes.getNamedItem("Name").nodeTypedValue
    Data(i, 2) = oList.SelectSingleNode("Size").nodeTypedValue
    Data(i, 3) = oList.SelectSingleNode("Price").nodeTypedValue
    i = i + 1
Next oList

Numer = oXML.SelectSingleNode("//Config/Number").nodeTypedValue

Set oXML = Nothing

End Sub

'-------------------------------------------------------------------
Sub Test()

Dim Data(0 To 1, 1 To 3) As String
Dim Number As Long

GetConfiguration "config.xml", Data, Number

MsgBox "Name: " & vbTab & Data(0, 1) & vbCrLf & _
        "Size: " & vbTab & Data(0, 2) & vbCrLf & _
        "Price: " & vbTab & Data(0, 3) & vbCrLf & _
        "Number: " & vbTab & Numer

End Sub


poniżej listing pliku config.xml:
<?xml version="1.0" encoding="utf-8"?>
<Config>

<List Name="Pierwszy">
<Size>S</Size>
<Price>100</Price>
</List>

<List Name="Drugi">
<Size>XXL</Size>
<Price>105</Price>
</List>

    <Number>2</Number>

</Config>


zamieścił: admin


Porada 3 marca 2020
Usuwanie krótkich segmentów w krzywych w CorelDraw.
Sub RemoveSmallSegments()

Dim sShape As Shape
If ActiveShape Is Nothing Then Exit Sub Else Set sShape = ActiveShape

Dim oShapeRange As ShapeRange
Dim dDist As Double
Dim X As Double, Y As Double, W As Double, H As Double, i As Long
Dim lDirection As cdrContourDirection

sShape.GetBoundingBox X, Y, W, H

'set offset as 0.02 (2%) of heigth of the selected shape
dDist = H * 0.02

For i = 1 To 4
    If i = 1 Or i = 4 Then lDirection = cdrContourOutside Else lDirection = cdrContourInside
    sShape.CreateContour lDirection, dDist, 1, cdrDirectFountainFillBlend, , , , 0, 0, cdrContourSquareCap, cdrContourCornerMiteredOffsetBevel, 0
    sShape.ConvertToCurves
    Set oShapeRange = sShape.Effects(1).Separate
    Set sShape = oShapeRange(1)
    oShapeRange(2).Delete
Next i

sShape.Selected = True
Set oShapeRange = Nothing

End Sub


zamieścił: admin


19 kwietnia 2019

Nowy skrypt VBS w dziale Skrypty VBS, służący do instalacji dodatków Worda.

zamieścił: admin


9 kwietnia 2019

Nowy link, pod ktorym mozna znalezc kontrolke kalendarza, dzialajaca w 64-bitowym Office.

zamieścił: admin


5 kwietnia 2019

Nowe makro w dziale Excel.
Makro służy do zamiany liczb na postać słowną.

zamieścił: admin


16 marca 2019

Nowe makro w dziale Excel.

zamieścił: admin


Porada 25 marca 2018
W czasie pracy nad makrem do CorelDraw szukałem sposobu, by odczytać z poziomu VBA informacje o rozdzielczości i wymiarach pliku *.png.

Oto przykładowe rozwiązanie:

Sub ImageInfos()

Dim objImage

Set objImage = CreateObject("WIA.ImageFile")
objImage.LoadFile ścieżka_do_pliku

MsgBox "Szerokość: " & objImage.Width & vbCrLf & _
          "Wysokość: " & objImage.Height & vbCrLf & _
          "Rozdz. pozioma: " & objImage.Horizontalresolution & vbCrLf & _
          "Rozdz. pionowa: " & objImage.Verticalresolution

Set objImage = Nothing

End Sub


zamieścił: admin


29 listopada 2017

Nowe makro w dziale Excel, demonstrujące w jaki sposób zapisywać na stale dane wpisywane do kontrolki Combobox.

zamieścił: admin


Porada 16 września 2017
Jak stworzyć w Excelu listę plików z wybranego folderu.

Option Explicit

Function GetFolder(sTitle As String, Optional sButtonName As String = vbNullString, Optional strPath As String = vbNullString) As String

Dim fldr As FileDialog
Dim sItem As String

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

With fldr
    .Title = sTitle
    .AllowMultiSelect = False
    .ButtonName = sButtonName
    .InitialFileName = strPath
    If .Show = -1 Then GetFolder = .SelectedItems(1) Else GetFolder = vbNullString
End With

Set fldr = Nothing

End Function

Sub GetFilelist()

Dim sPath As String
sPath = GetFolder("Wybierz folder z plikami", "Wybierz")
If sPath = vbNullString Then Exit Sub

Dim oFS, oFolder, oFile
Dim i As Long: i = 2

Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFS.GetFolder(sPath)

If oFolder.Files.Count = 0 Then
    MsgBox "W wybranym katalogu nie ma plików.", vbInformation
    Set oFolder = Nothing
    Set oFS = Nothing
    Exit Sub
End If

Dim lWKCount As Long
Dim oWBK As Workbook

lWKCount = Application.SheetsInNewWorkbook

Application.SheetsInNewWorkbook = 1
Set oWBK = Application.Workbooks.Add

Application.SheetsInNewWorkbook = lWKCount

oWBK.Worksheets(1).Range("A1").Value = "nazwa pliku"
oWBK.Worksheets(1).Range("B1").Value = "rozmiar"
oWBK.Worksheets(1).Range("C1").Value = "data utworzenia"
oWBK.Worksheets(1).Range("A1").Font.Italic = True
oWBK.Worksheets(1).Range("B1").Font.Italic = True
oWBK.Worksheets(1).Range("C1").Font.Italic = True

For Each oFile In oFolder.Files

    oWBK.Worksheets(1).Range("A" & i).Value = oFile.Name
    
    Select Case oFile.Size
        Case 0 To 1023
            oWBK.Worksheets(1).Range("B" & i).Value = Format(oFile.Size, "0") & " B"
        Case 1024 To 1048575
            oWBK.Worksheets(1).Range("B" & i).Value = Format(oFile.Size / 1024, "0") & " KB"
        Case 1048576 To 1073741823
            oWBK.Worksheets(1).Range("B" & i).Value = Format(oFile.Size / 1048576, "0") & " MB"
        Case 1073741824 To 1.11111111111074E+20
            oWBK.Worksheets(1).Range("B" & i).Value = Format(oFile.Size / 1073741823, "0.00") & " GB"
    End Select
    
    oWBK.Worksheets(1).Range("B" & i).HorizontalAlignment = xlRight
    
    oWBK.Worksheets(1).Range("C" & i).Value = oFile.DateCreated
    
    i = i + 1
    
Next oFile

oWBK.Worksheets(1).Columns("A:C").AutoFit
    
Set oWBK = Nothing
Set oFolder = Nothing
Set oFS = Nothing

End Sub


zamieścił: admin


16 września 2017

Zapraszam na stronę Makra.VBA na Facebooku.

zamieścił: admin




<-wstecz  1 2 3 4 5 6 7 8 9 10  dalej->
wszystkich stron: 13