|
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
zamieścił: admin
Porada 24 lutego 2017
Instalator dodatków Excela.
Poniższy kod VBS służy do instalacji dodatków Excela (plikow *.xlam).
Plik VBS z poniższym kodem musi się znajdować w katalogu, w którym znajduje się plik *.xlam. Wraz z plikiem *.xlam zostaną skopiowane do katalogu dodatków także wszystkie inne pliki (na przykład pliki pomocy), które się w tym katalogu znajdują, oprócz pliku VBS.
Const sInstalator = "Instalator"
Dim oExcel
On Error Resume Next
Set oExcel = GetObject(,"Excel.Application")
If Err.Number = 0 Then
MsgBox "Um die Installation weiter durchfüren zu können, schließen Sie Excel.", vbCritical, sInstalator
Else
Err.Clear
Const sExt = "xlam"
Dim oFS, oInstallFolder, sTitle, N, cAddonCol
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oInstallFolder = oFS.GetFile(WScript.ScriptFullName).ParentFolder
Set cAddonCol = CreateObject("Scripting.Dictionary")
N=0
For Each oFileItem In oInstallFolder.Files
If oFS.GetExtensionName(oFileItem.Name) = sExt Then sTitle = GetName(oInstallFolder.Path, oFileItem.Name): sFile=oFileItem.Name: cAddonCol.Add N, oFileItem.Name : N=N+1
Next
If N=1 Then
Dim OF
Set oExcel= CreateObject("Excel.Application")
If Err.Number <> 0 Then
Msgbox Err.Description, vbCritical, sInstalator & " " & sTitle
Err.Clear
Else
Dim oFile
For Each oF in oInstallFolder.Files
If oFS.FileExists(oF) And oF.Name <> oFS.GetFilename(WScript.ScriptFullName) Then oFS.CopyFile OF, oExcel.UserLibraryPath , True
Next
If Err.Number <> 0 Then
oExcel.Quit
Set oExcel = Nothing
Msgbox Err.Description, vbCritical, sInstalator & " " & sTitle
Err.Clear
Else
Dim oWbk
Set oWbk = oExcel.Workbooks.add
oExcel.AddIns.Add (oFS.BuildPath(oExcel.UserLibraryPath, sFile)).Installed=true
If Err.Number <> 0 Then
oWbk.Close False
oExcel.Quit
Msgbox Err.Description, vbCritical, sInstalator & " " & sTitle
Err.Clear
Else
oWbk.Close False
oExcel.Quit
Msgbox "Installation vom Addin '" & sTitle & "' erfolgreich abgeschlossen.", vbInformation, sInstalator & " " & sTitle
End If
Set oWbk = Nothing
End If
Set oExcel = Nothing
End If
ElseIf N=0
MsgBox "Keine Addin-Datei in diesem Folder.", vbCritical, sInstalator & " " & sTitle
Else
Dim key, sLista
For Each key In cAddonCol.keys
sLista = sLista & cAddonCol.Item(key) & vbcrlf
Next
MsgBox "Es gibt " & N & " Addin-Dateien in diesem Folder:" & vbcrlf & vbcrlf & Trim(sLista) & vbcrlf & _
"Es darf nur eine Addin-Datei im Folder sein.", vbCritical, sInstalator
End If
Set oFS = Nothing
Set oInstallFolder = Nothing
Set cAddonCol = Nothing
End If
Function GetName(sFolder, SFile)
Dim objShell, objFolder, objFolderItem
Set objShell = CreateObject("Shell.application")
Set objFolder = objShell.Namespace(sFolder)
Set objFolderItem = objFolder.ParseName(sFile)
GetName = objFolder.GetDetailsOf(objFolderItem, 21)
Set objFolderItem = Nothing
Set objFolder = Nothing
Set objShell = Nothing
End Function
zamieścił: admin
wszystkich stron: 12
|
|