' 0_Fix_Chart_20130109_Rev.A.bas
=================================================
Attribute VB_Name = "Module1"
Public Sub TEST_BELOW()
' 20130109 - fixed the font size on y-axis label
' 20130109 - fixed legend top
ZIM = "CHART5"
Call CHART_SELECT(ZIM, 1) '<=INPUT
End Sub
Public Sub CHART_SELECT(TIKO, ncollections)
ActiveChart.Name = "" & TIKO & ""
ActiveChart.ApplyLayout (1)
x$ = "##0."
y$ = "##0."
Dim tcol()
GXMIN = -180 '<=INPUT
GXMAX = 180 '<=INPUT
GYMIN = -180 '<=INPUT
GYMAX = 180 '<=INPUT
ZTITLE = "Array Factor phase" '<=INPUT
XLABEL = "Angle[deg]" '<=INPUT
YLABEL = "Gain[dB]" '<=INPUT
CX0 = 70
CY0 = 80
CW = 900
CH = 400
CT = CH + 100
'=================
ReDim tcol(ncollections)
For i = 1 To ncollections
tcol(i) = Sheet2.Cells(1, i + 1).Value '<=INPUT
Next i
ActiveChart.ChartTitle.Characters.Text = ZTITLE
ActiveChart.Axes(xlCategory, xlPrimary).HasTitle = True
ActiveChart.Axes(xlCategory).AxisTitle.Select
Selection.Format.TextFrame2.TextRange.Font.Size = 18
ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = XLABEL
ActiveChart.Axes(xlValue, xlPrimary).HasTitle = True
Selection.Format.TextFrame2.TextRange.Font.Size = 18
ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = YLABEL
ActiveChart.Axes(xlCategory).Select
ActiveChart.SeriesCollection(1).MarkerStyle = -4142
ActiveChart.Axes(xlCategory).Select
ActiveChart.Axes(xlCategory).MajorUnit = 30
For i = 1 To ncollections
ActiveChart.SeriesCollection(1).Name = tcol(i)
Next i
With ActiveChart.Axes(xlCategory) ' x-axis
.MinimumScale = GXMIN
.MaximumScale = GXMAX
.Crosses = xlCustom
.CrossesAt = GXMIN
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
.HasMajorGridlines = True
.HasMinorGridlines = False
End With
ActiveChart.Axes (xlValue) ' y-axis
With ActiveChart.Axes(xlValue)
.MinimumScale = GYMIN
.MaximumScale = GYMAX
.Crosses = xlCustom
.CrossesAt = GYMIN
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
.HasMajorGridlines = True
.HasMinorGridlines = False
End With
ActiveChart.ChartArea.Select
ActiveChart.HasLegend = True
ActiveChart.Legend.Select
Selection.Position = xlTop
ActiveChart.PlotArea.Select
With Selection.Border
.ColorIndex = 16
.Weight = xlThin
.LineStyle = xlContinuous
End With
Selection.Interior.ColorIndex = xlNone
ActiveChart.ChartArea.Select
ActiveChart.PlotArea.Select
Selection.Width = 1200
Selection.Left = 120
Selection.Height = 800
Selection.Top = 20
ActiveChart.ChartArea.Select
ActiveChart.ChartArea.Copy
'=================
ActiveChart.ChartArea.Select
ActiveChart.ChartTitle.Select 'CHART TITLE
Selection.Format.TextFrame2.TextRange.Font.Size = 24
ActiveChart.ChartTitle.Text = ZTITLE
ActiveChart.Legend.Select
With Selection.Format.TextFrame2.TextRange.Font
.BaselineOffset = 0
.Size = 12 'legend font size
.Name = "Arial"
End With
'================
ActiveChart.Axes(xlValue).Select
Selection.TickLabels.NumberFormat = x$
Selection.TickLabels.Font.Size = 16 'y-axis font size
Selection.TickLabels.Font.Name = "Arial"
Selection.TickLabels.Font.Bold = msoTrue
ActiveChart.Axes(xlCategory).Select
Selection.TickLabels.NumberFormat = y$
Selection.TickLabels.Font.Size = 16 'x-axis font size
Selection.TickLabels.Font.Name = "Arial"
Selection.TickLabels.Font.Bold = msoTrue
'======================
ActiveChart.PlotArea.Select
Selection.Left = CX0 '60
Selection.Top = CY0 ' 60
Selection.Width = CW '1000
Selection.Height = CH '700
ActiveChart.Axes(xlCategory).AxisTitle.Select
Selection.Top = CT
'=================
ActiveChart.Legend.Select
ActiveChart.ApplyLayout (1)
ActiveChart.Axes(xlCategory).Select
ActiveChart.Axes(xlCategory).HasMinorGridlines = True
ActiveChart.Axes(xlValue).Select
ActiveChart.Axes(xlValue).HasMinorGridlines = True
ActiveChart.Axes(xlValue).AxisTitle.Select
Selection.Format.TextFrame2.TextRange.Font.Size = 18
ActiveChart.ChartArea.Select
ActiveChart.Legend.Select
ActiveChart.Legend.Select
Selection.Position = xlTop
End Sub
' 0_Hyperlink_Excel_20131211_0959_WORKS.bas
=================================================
Attribute VB_Name = "Module1"
Private Declare Function GetComputerName Lib "kernel32" _
Alias "GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Sub fixitall()
'
' 20130311 - Added Computer Name and date
'
Call AddHyperlinksToRange
Call titles
Call Cols
AKO = Now()
AKO = Replace(AKO, "/", "_")
AKO = Replace(AKO, " ", "_")
AKO = Replace(AKO, ":", "_")
Sheet1.Cells(1, 9).Value = AKO
Sheet1.Cells(2, 9) = ReturnComputerName
Range("I1:I2").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Font.Bold = True
Selection.ColumnWidth = 25
MsgBox "The job is done !"
End Sub
Sub AddHyperlinksToRange()
'Find the last used row in a Column: column A in this example
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Row_max = LastRow
Dim rngCell As Range
i = 0
With ActiveSheet
'For Each rngCell In .Range("B1:B80000")
For Each rngCell In .Range(Cells(1, 2), Cells(Row_max, 2))
i = i + 1
If Not IsEmpty(rngCell) Then
ival = Check_Cell_Validity(rngCell.Value)
If ival > 0 Then
t$ = rngCell.Value
Mid(t$, 1, 3) = "C:\"
End If
.Hyperlinks.Add Anchor:=rngCell, _
Address:=rngCell.Value, _
TextToDisplay:=rngCell.Value
End If
Next
End With
i = 0
With ActiveSheet
'For Each rngCell In .Range("A1:A80000")
For Each rngCell In .Range(Cells(1, 1), Cells(Row_max, 1))
i = i + 1
B$ = Cells(i, 2).Value
C$ = Cells(i, 1).Value
a$ = B$ + "\" + C$ '<==
On Error Resume Next
If Not IsEmpty(rngCell) Then
ival = Check_Cell_Validity(rngCell.Value)
If ival > 0 Then
t$ = rngCell.Value
Mid(t$, 1, 3) = "C:\"
End If
If Not IsEmpty(rngCell) Then
.Hyperlinks.Add Anchor:=rngCell, _
Address:=a$, TextToDisplay:=rngCell.Value
End If
End If
Next
End With
End Sub
Sub linkcells()
Application.ScreenUpdating = False
AR = ActiveCell.Row
ac = ActiveCell.Column
lr = Cells(Rows.Count, ac).End(xlUp).Row
For a = AR To lr
Cells(a, ac).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
ActiveCell.Address, TextToDisplay:=ActiveCell.Text
Next a
ActiveWorkbook.Save
End Sub
Sub titles()
'
' titles Macro
' Macro recorded 1/31/2011 by tuli
'
'
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "File Name"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Directory"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Size"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Creation Date"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Last Modification Date"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Last Access Date"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Ext"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Type"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Attributes"
Range("A1:H1").Select
Range("H1").Activate
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.ColorIndex = 1
.Pattern = xlSolid
End With
Selection.Interior.ColorIndex = 6
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
End Sub
Sub Cols()
'
' Macro2 Macro
' Macro recorded 1/31/2011 by tuli
'
'
Columns("A:A").Select
Selection.ColumnWidth = 50
Columns("B:B").Select
Selection.ColumnWidth = 100
Columns("D:F").Select
Selection.ColumnWidth = 20
Columns("G:G").Select
Selection.ColumnWidth = 5
Columns("H:H").Select
Selection.ColumnWidth = 10
Selection.ColumnWidth = 8
Columns("H:H").Select
Selection.ColumnWidth = 9
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
Columns("C:C").Select
Selection.ColumnWidth = 9
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("D:H").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
Function Check_Cell_Validity(a$)
f$ = Mid(a$, 1, 1)
Check_Cell_Validity = 0
For i = 1 To 26
c1 = Chr$(i + 64)
c2 = Chr$(i + 64 + 32)
If f$ = c1 Or f$ = c2 Then
Check_Cell_Validity = Check_Cell_Validity + 1
End If
Next i
End Function
Function ReturnComputerName() As String
Dim rString As String * 255, sLen As Long, tString As String
tString = ""
On Error Resume Next
sLen = GetComputerName(rString, 255)
sLen = InStr(1, rString, Chr(0))
If sLen > 0 Then
tString = Left(rString, sLen - 1)
Else
tString = rString
End If
On Error GoTo 0
ReturnComputerName = UCase(Trim(tString))
End Function
Function getdrivename(a$)
Dim fso As New FileSystemObject
Dim flds As Folders
Dim strText As String
Dim i As Integer
j = 23
Set flds = fso.GetFolder(a$).SubFolders
i = 2
m = 0
For Each f In flds
m = m + 1
'strText = f.Path & " - " & f.Size
strText = f.path & " "
Worksheets("Sheet1").Cells(1, j) = f.Drive.VolumeName
Worksheets("Sheet1").Cells(i, j) = strText
i = i + 1
Next
End Function
Public Sub copyallsources()
Dim fSource, fDestination
Set filesys = CreateObject("Scripting.FileSystemObject")
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Row_max = LastRow
Dim rngCell As Range
i = 1
With ActiveSheet
For Each rngCell In .Range(Cells(1, 2), Cells(Row_max, 2))
i = i + 1
If Not IsEmpty(rngCell) Then
ival = Check_Cell_Validity(rngCell.Value)
If ival > 0 Then
fSource = Sheet1.Cells(i, 2).Value + Sheet1.Cells(i, 1).Value
fDestination = "\\10.10.8.141\bernstein\HFSS Sources Backup\" + Sheet1.Cells(i,
1).Value
FileCopy fSource, fDestination
End If
End If
Next
End With
End Sub
Public Sub test_copyallsources()
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 99 To LastRow
fSource = Sheet1.Cells(i, 2).Value + Sheet1.Cells(i, 1).Value
fDestination = "P:\Sources Backup\CST\" + Sheet1.Cells(i, 1).Value
FileCopy fSource, fDestination
Debug.Print i
Next
End Sub
Sub FixCols()
'
' Macro2 Macro
' Macro recorded 1/31/2011 by tuli
'
Sheet3.Select
'
Columns("A:A").Select
Selection.ColumnWidth = 50
Columns("B:B").Select
Selection.ColumnWidth = 100
Columns("D:F").Select
Selection.ColumnWidth = 20
Columns("G:G").Select
Selection.ColumnWidth = 5
Columns("H:H").Select
Selection.ColumnWidth = 10
Selection.ColumnWidth = 8
Columns("H:H").Select
Selection.ColumnWidth = 9
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
Columns("C:C").Select
Selection.ColumnWidth = 9
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("D:H").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
' Add_Hyperlink.bas =================================================
Public Sub test_Hyperlink()
'S$ = "sheet1"
'W$ = "www.msn.com"
'L$ = "Zorba"
Call Add_HYPERLINK(S$, W$, L$)
End Sub
Public Sub Add_Hyperlink(S$, W$, L$)
Sheets(S$).Select
Range(Cells(1, 1), Cells(1, 1)).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=W$, _
TextToDisplay:=L$
End Sub
' Add_Now_to_Chart.bas =================================================
Sub Add_Now_to_Chart()
'
' Macro8 Macro
'
Chart3.Select
ActiveChart.ChartArea.Select
ActiveChart.Shapes.AddLabel(msoTextOrientationHorizontal, 600, 30, 80,
80).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Now()
End Sub
' add_sheets_one_by_one.bas =================================================
Attribute VB_Name = "Module1"
'Public get_CST_Materials
'open "C:\Program Files (x86)\CST STUDIO SUITE 2013\Library\Materials'
Sub FindTextFiles()
Dim i As Integer
spath = "C:\Program Files (x86)\CST STUDIO SUITE 2013\Library\Materials\"
i = 0
sdir = Dir$(spath & "*.mtd", vbNormal)
Do Until LenB(sdir) = 0
k = 0
'Set oWB = Workbooks.Open(spath & sDir)
i = i + 1
'Sheet1.Cells(i, 1).Value = sDir
Open spath & sdir For Input As 1
iko = ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets.Add after:=Worksheets(iko)
Sheets(iko + 1).Select
B$ = Mid(sdir, 1, Len(sdir) - 4)
B$ = Replace(B$, " ", "_")
ActiveSheet.Name = Mid(B$, 1, 301)
While EOF(1) = False
k = k + 1
Line Input #1, t$
t$ = Replace(t$, ",", Chr$(34))
tt = Split(t$, Chr$(34))
lt = UBound(tt)
For m = 0 To lt
Sheets(ActiveSheet.Name).Cells(k, m + 1).Value = tt(m)
Next m
Wend
Close 1
sdir = Dir$
If i > 407 Then
End
End If
Loop
End Sub
' AddExcelLine.bas =================================================
Sub AddExcelLine(l1, l2, r1, r2)
With ActiveSheet.Shapes.AddLine(l1, l2, r1, r2).line
.ForeColor.RGB = RGB(255, 0, 0)
End With
End Sub
' AddExcelRectangle.bas =================================================
Sub AddExcelRectangle(A, B, C, D)
'START_X,START_Y,LENGTH_WIDTH,LENGTH_HEIGHT
S = 10
AA = S * (A + 40)
BB = S * (B + 40)
CC = S * C
DD = S * D
Sheet1.Select
ActiveSheet.Shapes.AddShape(msoShapeRectangle, AA, BB, CC, DD).Select
End Sub
' AKO.BAS =================================================
Public Sub MyAko(tiko)
AKO = Now()
AKO = Replace(AKO, "/", "_")
AKO = Replace(AKO, " ", "_")
tiko = "_" + Replace(AKO, ":", "_") + "_"
End Sub
' ARRAY_CALCS.bas =================================================
Private Sub miki()
Dim X(), Amp(), phase(), pt(), THETA(), af(), pt0()
Dim Tops(), Bots(), ITOPS(), IBOTS()
Sheet24.Select
NP = Sheet24.Cells(2, 5).Value
Tmin = Cells(4, 5).Value
Tmax = Cells(6, 5).Value
dt = Cells(8, 5).Value
NT = Int((Tmax - Tmin) / dt) + 1
ReDim X(NP), Amp(NP), phase(NP), pt(NT), pt0(NT), THETA(NT), af(NT)
piko = 4 * Atn(1)
rad = piko / 180
For I = 2 To NP + 1
X(I - 1) = Cells(I, 2).Value
Amp(I - 1) = Cells(I, 3).Value
phase(I - 1) = Cells(I, 4).Value
Next I
FREQ = Cells(10, 5).Value
wl = 30 / FREQ
KK = 2 * piko / wl
ptmax = -100000000
k = 1
For t = Tmin To Tmax Step dt
cos_sum = 0
sin_sum = 0
For I = 1 To NP
cos_sum = cos_sum + Amp(I) * Cos(KK * X(I) * Sin(t * rad) + phase(I) * rad)
sin_sum = sin_sum + Amp(I) * Sin(KK * X(I) * Sin(t * rad) + phase(I) * rad)
Next I
THETA(k) = t
pt(k) = 10 * Log(cos_sum ^ 2 + sin_sum ^ 2) / Log(10)
If ptmax < pt(k) Then
ptmax = pt(k)
End If
k = k + 1
Cells(k, 6).Value = t
Cells(k, 7).Value = pt
Next t
For k = 1 To NT
Cells(k, 6).Value = THETA(k)
pt0(k) = pt(k) - ptmax
Cells(k, 7).Value = pt0(k)
Next k
Call FINDSLL(THETA, pt0, Tops, Bots, ITOPS, IBOTS, NT, NTOPS, NBOTS, MAXSLL,
ANG_MAXSLL, BEAMWIDTH)
Cells(14, 5).Value = BEAMWIDTH
Cells(16, 5).Value = MAXSLL
Cells(18, 5).Value = ANG_MAXSLL
End Sub
Public Sub FINDSLL(THETA, ARR, Tops, Bots, ITOPS, IBOTS, NMAX, NTOPS, NBOTS,
MAXSLL, ANG_MAXSLL, BEAMWIDTH)
Dim KK As Integer
ReDim EXTREMA(1000), Tops(1000), Bots(1000)
ReDim ITOPS(1000), IBOTS(1000)
ReDim GRAD(3000), Index(1000)
G$ = "@@@"
piko = 4 * Atn(1#)
' ReDim THETA(NMAX), ARR(NMAX)
For I = 2 To NMAX
If (ARR(I) - ARR(I - 1) > 0#) Then
GRAD(I) = -1#
Else
GRAD(I) = 1#
End If
Next I
Open "C:\TeMP\MAXIMA1.TXT" For Output As 1
k = 0
For I = 2 To NMAX - 1
If ((GRAD(I) * GRAD(I - 1)) < 0#) Then
k = k + 1
EXTREMA(k) = ARR(I - 1)
Index(k) = I - 1
Print #1, FPR(k), FPR(THETA(Index(k))), FPR(EXTREMA(k))
End If
Next I
kmax = k
If (EXTREMA(1) > EXTREMA(2)) Then
Tops(1) = EXTREMA(1)
Bots(1) = EXTREMA(2)
M = 0
N = 0
For k = 3 To kmax
KK = k / 2
XK = k - 2 * KK
If (XK = 0#) Then
M = M + 1
Bots(M) = EXTREMA(k)
IBOTS(M) = Index(k)
Else
N = N + 1
Tops(N) = EXTREMA(k)
ITOPS(N) = Index(k)
End If
Next k
Else
Tops(1) = EXTREMA(2)
Bots(1) = EXTREMA(1)
M = 0
N = 0
For k = 3 To kmax
KK = k / 2
XK = k - 2 * KK
If (XK = 0#) Then
M = M + 1
Tops(M) = EXTREMA(k)
ITOPS(M) = Index(k)
Else
N = N + 1
Bots(N) = EXTREMA(k)
IBOTS(N) = Index(k)
End If
Next k
End If
NTOPS = M
Print #1, "================================================ TOPS "
For IL = 1 To M
Print #1, FPR(ITOPS(IL)), FPR(THETA(ITOPS(IL))), FPR(Tops(IL))
Next IL
Print #1, "================================================ BOTS"
NBOTS = M
For IL = 1 To M
Print #1, FPR(IBOTS(IL)), FPR(THETA(IBOTS(IL))), FPR(Bots(IL))
Next IL
Print #1, "================================================ "
MAXSLL = -10000000000#
For IL = 1 To NTOPS
If MAXSLL < Tops(IL) Then
MAXSLL = Tops(IL)
IKA = IL
ANG_MAXSLL = THETA(ITOPS(IKA))
End If
Next IL
MAXSLL = -10000000000#
Tops(IKA) = -1000000#
For IL = 1 To NTOPS
If MAXSLL < Tops(IL) Then
MAXSLL = Tops(IL)
IKA = IL
ANG_MAXSLL = THETA(ITOPS(IKA))
End If
Next IL
'======================================FIND HPBW=====================
BEAMWIDTH = HPBW(ARR, THETA, NMAX)
Close (1)
End Sub
Public Function FPR(X) As String
If X > 0 Then
FPR = Format(X, Space(1) + "###0.0000")
Else
FPR = Format(X, "###0.0000")
End If
End Function
Public Sub MATMU(NN, CM1, CM2, CR)
' ReDim CM1(NN, NN), CM2(NN, NN), CR(NN, NN) As Double
For I = 1 To NN
For j = 1 To NN
CR(I, j) = 0#
For k = 1 To NN
CR(I, j) = CR(I, j) + CM1(I, k) * CM2(k, j)
Next k
Next j
Next I
End Sub
Public Function HPBW(ARR, ANG, N) As Double
' Dim ARR(N), ANG(N)
Dim A3(8)
Dim M As Integer
Dim I As Integer
' IMAXAR SUB NEEDED
' SGN SUB NEEDED
VMAX = ARR(IMAXAR(ARR, N))
V3 = VMAX - 3#
M = 0
For I = 1 To N - 1
I1 = Sgn(ARR(I) - V3)
I2 = Sgn(ARR(I + 1) - V3)
If I1 <> I2 Then
X1 = ANG(I)
X2 = ANG(I + 1)
Y1 = ARR(I)
Y2 = ARR(I + 1)
M = M + 1
A3(M) = (V3 - Y1) * (X2 - X1) / (Y2 - Y1) + X1
End If
Next I
If (M = 2) Then
HPBW = A3(2) - A3(1)
Else
If (M = 1) Then
HPBW = 2# * A3(1)
Else
'PRINT*,'RIPPLE'
End If
End If
End Function
Public Function IMAXAR(ARR, N) As Double
' Dim ARR(N) As Double
XXMAXAR = -1E+33
STOR = 0#
For I = 1 To N
STOR = AMAX1(ARR(I), XXMAXAR)
If (STOR <> XXMAXAR) Then
k = I
XXMAXAR = ARR(I)
End If
Next I
IMAXAR = k
End Function
Public Function XMAXAR(ARR, N) As Double
XMAXAR = -1E+30
STOR = 0#
For I = 1 To N
STOR = AMAX1(ARR(I), XMAXAR)
If (STOR <> XMAXAR) Then
k = I
XMAXAR = ARR(I)
End If
Next I
End Function
Public Function AMAX1(X, Y)
If X >= Y Then
AMAX1 = X
Else
AMAX1 = Y
End If
End Function
' Assign_Hyperlink.bas =================================================
Public sub test_hyper()
Call assign_hyperlink("sheet1", 1, 1)
End sub
Sub assign_hyperlink(bb, ir, ic)
Aa = sheet1.cells(ir, ic).value
Sheets(bb).cells(ir, ic).select
With selection
.hyperlinks.add anchor:=selection, address:=aa, texttodisplay:=aa
End with
End sub
' AxialRatio.bas =================================================
Public Sub AR(Exa, Exp, Eya, Eyp, ARdB, Tau)
Pi = 4 * Atn(1#)
rad = Pi / 180
del_phase_rad = rad * Abs(Exp - Eyp)
T = (Exa ^ 4 + Eya ^ 4 + 2 * Exa ^ 2 * Eya ^ 2 * Cos(2 * del_phase_rad)) ^ 0.5
OA = Sqr(0.5 * (Exa ^ 2 + Eya ^ 2 + T))
OB = Sqr(0.5 * (Exa ^ 2 + Eya ^ 2 - T))
AxialRatio = OA / OB
ARdB = 10 * Log(AxialRatio)
arg = 2 * Exa * Eya * Cos(del_phase_rad) / (Exa ^ 2 - Eya ^ 2)
Tau = Pi / 2 - 0.5 * Atn(arg)
End Sub
Public Sub test_AR()
Dim Exp As Double
Exa = 1
Eya = 1.01
Exp = 0
Eyp = 90
Call AR(Exa, Exp, Eya, Eyp, ARdB, Tau)
Debug.Print ARdB, Tau
End Sub
' AxialRatio.txt =================================================
Public Sub AR(Exa, Exp, Eya, Eyp, ARdB, Tau)
Pi = 4 * Atn(1#)
rad = Pi / 180
del_phase_rad = rad * Abs(Exp - Eyp)
T = (Exa ^ 4 + Eya ^ 4 + 2 * Exa ^ 2 * Eya ^ 2 * Cos(2 * del_phase_rad)) ^ 0.5
OA = Sqr(0.5 * (Exa ^ 2 + Eya ^ 2 + T))
OB = Sqr(0.5 * (Exa ^ 2 + Eya ^ 2 - T))
AxialRatio = OA / OB
ARdB = 10 * Log(AxialRatio)
arg = 2 * Exa * Eya * Cos(del_phase_rad) / (Exa ^ 2 - Eya ^ 2)
Tau = Pi / 2 - 0.5 * Atn(arg)
End Sub
Public Sub test_AR()
Dim Exp As Double
Exa = 1
Eya = 1.01
Exp = 0
Eyp = 90
Call AR(Exa, Exp, Eya, Eyp, ARdB, Tau)
Debug.Print ARdB, Tau
End Sub
' Calc_bandwidth.bas =================================================
Public Sub band()
f1_x = 1
f1_y = 2
f2_x = 1
f2_y = 142
ic = 2
m = 0
di = 12
For i = f1_y To f2_y
If Sheet3.Cells(i, f1_x + di).Value < -9.54 And m = 0 Then
fmin = Sheet3.Cells(i, f1_x + di - 1).Value
m = 1
Else
If Sheet3.Cells(i, f1_x + di).Value < -9.54 Then
fmax = Sheet3.Cells(i, f1_x + di - 1).Value
End If
End If
Next i
Sheet3.Cells(2, f1_x + di + 1) = fmax
Sheet3.Cells(3, f1_x + di + 1) = fmin
Sheet3.Cells(4, f1_x + di + 1) = 100 * (fmax / fmin - 1)
End Sub
' cmdDriveinfo.bas =================================================
Sub cmdDriveInfo_Click()
Dim myFileSystemObject As FileSystemObject, aDrive As Drive
Set myFileSystemObject = New FileSystemObject
Set aDrive = myFileSystemObject.GetDrive("C:\")
With aDrive
Debug.Print "Volume Name: " & .VolumeName & vbCrLf
Debug.Print "Free Space: " & Format(.FreeSpace / 1000000000#, "#0.00") & "GB" &
vbCrLf
Debug.Print "Total Size: " & Format(.TotalSize / 1000000000#, "#0.00") & "GB" &
vbCrLf
Debug.Print "Ready: " & .IsReady
End With
Set myFileSystemObject = Nothing
Set aDrive = Nothing
End Sub
' copyallsources.bas =================================================
Public Sub test_copyallsources()
Sheet1.Select
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
fSource = Sheet1.Cells(i, 2).Value + Sheet1.Cells(i, 1).Value
fDestination = "P:\Sources Backup\CST\" + Sheet1.Cells(i, 1).Value
FileCopy fSource, fDestination
Debug.Print i
End Sub
' CopyFiles.bas =================================================
Public Sub CopyFiles()
Dim filesys, filetxt, getname, path
Set filesys = CreateObject("Scripting.FileSystemObject")
d$ = "N:\CENTRAL - SATS\SAT LIB\"
For i = 1179 To 6433
On Error Resume Next
s$ = Sheet1.Cells(i, 2).Value + Sheet1.Cells(i, 1).Value
Debug.Print i, Len(s$)
t$ = d$ + Sheet1.Cells(i, 1).Value
filesys.CopyFile s$, t$, True
Next i
End Sub
' Create_Chart_20121128_1559.bas
=================================================
Public Sub Create_patterns()
' ----------------------------------------------
' Script Recorded by Ansoft HFSS Version 14.0.0
' 2:06:17 PM Aug 28, 2012
' ----------------------------------------------
Dim oAnsoftApp
Dim oDesktop
Dim oProject
Dim oDesign
Dim oEditor
Dim oModule
Set oAnsoftApp = CreateObject("AnsoftHfss.HfssScriptInterface")
Set oDesktop = oAnsoftApp.GetAppDesktop()
oDesktop.RestoreWindow
Set oProject = oDesktop.SetActiveProject("V3.1")
Set oDesign = oProject.SetActiveDesign("HFSSDesign1")
Set oModule = oDesign.GetModule("RadField")
oModule.InsertFarFieldSphereSetup Array("NAME:Infinite Sphere1",
"UseCustomRadiationSurface:=", _
False, "ThetaStart:=", "0deg", "ThetaStop:=", "360deg", "ThetaStep:=", "1deg",
"PhiStart:=", _
"0deg", "PhiStop:=", "360deg", "PhiStep:=", "1deg", "UseLocalCS:=", False)
Set oModule = oDesign.GetModule("ReportSetup")
oModule.CreateReport "XY Plot 5", "Far Fields", "Rectangular Plot", _
"Setup1 : Sweep1", Array("Context:=", "Infinite Sphere1"), Array("Freq:=",
Array( _
"All"), "Phi:=", Array("0deg"), "Theta:=", Array("0deg"), "zp:=", Array( _
"Nominal"), "XA:=", Array("Nominal"), "YA:=", Array("Nominal"), "XB:=", Array( _
"Nominal"), "YB:=", Array("Nominal"), "XC:=", Array("Nominal"), "YC:=", Array( _
"Nominal"), "XD:=", Array("Nominal"), "YD:=", Array("Nominal"), "XE:=", Array( _
"Nominal"), "YE:=", Array("Nominal"), "XF:=", Array("Nominal"), "YF:=", Array( _
"Nominal"), "XN:=", Array("Nominal"), "YN:=", Array("Nominal"), "XM:=", Array( _
"Nominal"), "YM:=", Array("Nominal"), "XP:=", Array("Nominal"), "YP:=", Array( _
"Nominal"), "z0:=", Array("Nominal"), "$EPS:=", Array("Nominal")), Array("X
Component:=", _
"Freq", "Y Component:=", Array("dB(GainTotal)")), Array()
oModule.AddTraces "XY Plot 5", "Setup1 : Sweep1", Array("Context:=", _
"Infinite Sphere1"), Array("Freq:=", Array("All"), "Phi:=", Array("0deg"),
"Theta:=", Array( _
"0deg"), "zp:=", Array("Nominal"), "XA:=", Array("Nominal"), "YA:=", Array( _
"Nominal"), "XB:=", Array("Nominal"), "YB:=", Array("Nominal"), "XC:=", Array( _
"Nominal"), "YC:=", Array("Nominal"), "XD:=", Array("Nominal"), "YD:=", Array( _
"Nominal"), "XE:=", Array("Nominal"), "YE:=", Array("Nominal"), "XF:=", Array( _
"Nominal"), "YF:=", Array("Nominal"), "XN:=", Array("Nominal"), "YN:=", Array( _
"Nominal"), "XM:=", Array("Nominal"), "YM:=", Array("Nominal"), "XP:=", Array( _
"Nominal"), "YP:=", Array("Nominal"), "z0:=", Array("Nominal"), "$EPS:=", Array(
_
"Nominal")), Array("X Component:=", "Freq", "Y Component:=", Array( _
"dB(DirTotal)")), Array()
oModule.AddTraces "XY Plot 5", "Setup1 : Sweep1", Array("Context:=", _
"Infinite Sphere1"), Array("Freq:=", Array("All"), "Phi:=", Array("0deg"),
"Theta:=", Array( _
"0deg"), "zp:=", Array("Nominal"), "XA:=", Array("Nominal"), "YA:=", Array( _
"Nominal"), "XB:=", Array("Nominal"), "YB:=", Array("Nominal"), "XC:=", Array( _
"Nominal"), "YC:=", Array("Nominal"), "XD:=", Array("Nominal"), "YD:=", Array( _
"Nominal"), "XE:=", Array("Nominal"), "YE:=", Array("Nominal"), "XF:=", Array( _
"Nominal"), "YF:=", Array("Nominal"), "XN:=", Array("Nominal"), "YN:=", Array( _
"Nominal"), "XM:=", Array("Nominal"), "YM:=", Array("Nominal"), "XP:=", Array( _
"Nominal"), "YP:=", Array("Nominal"), "z0:=", Array("Nominal"), "$EPS:=", Array(
_
"Nominal")), Array("X Component:=", "Freq", "Y Component:=", Array( _
"dB(RealizedGainTotal)")), Array()
oProject.Save
oModule.ChangeProperty Array("NAME:AllTabs", Array("NAME:Attributes",
Array("NAME:PropServers", _
"XY Plot 5:dB(DirTotal):Phi=" & Chr(39) & "0deg" & Chr(39) & " Theta=" & Chr(39)
& "" & _
"0deg" & Chr(39) & " [Curve1]"), Array("NAME:ChangedProps", Array("NAME:Line
Width", "MustBeInt:=", _
True, "Value:=", "2"))))
oModule.ChangeProperty Array("NAME:AllTabs", Array("NAME:Attributes",
Array("NAME:PropServers", _
"XY Plot 5:dB(GainTotal):Phi=" & Chr(39) & "0deg" & Chr(39) & " Theta=" &
Chr(39) & "" & _
"0deg" & Chr(39) & " [Curve1]"), Array("NAME:ChangedProps", Array("NAME:Line
Width", "MustBeInt:=", _
True, "Value:=", "2"))))
oModule.ChangeProperty Array("NAME:AllTabs", Array("NAME:Attributes",
Array("NAME:PropServers", _
"XY Plot 5:dB(RealizedGainTotal):Phi=" & Chr(39) & "0deg" & Chr(39) & " Theta="
& Chr(39) & "" & _
"0deg" & Chr(39) & " [Curve1]"), Array("NAME:ChangedProps", Array("NAME:Line
Width", "MustBeInt:=", _
True, "Value:=", "2"))))
oProject.Save
oModule.CreateReport "Radiation Pattern 1", "Far Fields", "Radiation Pattern", _
"Setup1 : Sweep1", Array("Context:=", "Infinite Sphere1"), Array("Theta:=",
Array( _
"All"), "Phi:=", Array("0deg"), "Freq:=", Array("30GHz"), "zp:=", Array( _
"Nominal"), "XA:=", Array("Nominal"), "YA:=", Array("Nominal"), "XB:=", Array( _
"Nominal"), "YB:=", Array("Nominal"), "XC:=", Array("Nominal"), "YC:=", Array( _
"Nominal"), "XD:=", Array("Nominal"), "YD:=", Array("Nominal"), "XE:=", Array( _
"Nominal"), "YE:=", Array("Nominal"), "XF:=", Array("Nominal"), "YF:=", Array( _
"Nominal"), "XN:=", Array("Nominal"), "YN:=", Array("Nominal"), "XM:=", Array( _
"Nominal"), "YM:=", Array("Nominal"), "XP:=", Array("Nominal"), "YP:=", Array( _
"Nominal"), "z0:=", Array("Nominal"), "$EPS:=", Array("Nominal")), Array("Ang
Component:=", _
"Theta", "Mag Component:=", Array("GainTotal")), Array()
oModule.UpdateTraces "Radiation Pattern 1", Array("GainTotal"), _
"Setup1 : Sweep1", Array("Context:=", "Infinite Sphere1"), Array("Theta:=",
Array( _
"All"), "Phi:=", Array("0deg"), "Freq:=", Array("30GHz"), "zp:=", Array( _
"Nominal"), "XA:=", Array("Nominal"), "YA:=", Array("Nominal"), "XB:=", Array( _
"Nominal"), "YB:=", Array("Nominal"), "XC:=", Array("Nominal"), "YC:=", Array( _
"Nominal"), "XD:=", Array("Nominal"), "YD:=", Array("Nominal"), "XE:=", Array( _
"Nominal"), "YE:=", Array("Nominal"), "XF:=", Array("Nominal"), "YF:=", Array( _
"Nominal"), "XN:=", Array("Nominal"), "YN:=", Array("Nominal"), "XM:=", Array( _
"Nominal"), "YM:=", Array("Nominal"), "XP:=", Array("Nominal"), "YP:=", Array( _
"Nominal"), "z0:=", Array("Nominal"), "$EPS:=", Array("Nominal")), Array("Ang
Component:=", _
"Theta", "Mag Component:=", Array("dB(GainTotal)")), Array()
oModule.UpdateTraces "Radiation Pattern 1", Array("dB(GainTotal)"), _
"Setup1 : Sweep1", Array("Context:=", "Infinite Sphere1"), Array("Theta:=",
Array( _
"All"), "Phi:=", Array("0deg"), "Freq:=", Array("All"), "zp:=",
Array("Nominal"), "XA:=", Array( _
"Nominal"), "YA:=", Array("Nominal"), "XB:=", Array("Nominal"), "YB:=", Array( _
"Nominal"), "XC:=", Array("Nominal"), "YC:=", Array("Nominal"), "XD:=", Array( _
"Nominal"), "YD:=", Array("Nominal"), "XE:=", Array("Nominal"), "YE:=", Array( _
"Nominal"), "XF:=", Array("Nominal"), "YF:=", Array("Nominal"), "XN:=", Array( _
"Nominal"), "YN:=", Array("Nominal"), "XM:=", Array("Nominal"), "YM:=", Array( _
"Nominal"), "XP:=", Array("Nominal"), "YP:=", Array("Nominal"), "z0:=", Array( _
"Nominal"), "$EPS:=", Array("Nominal")), Array("Ang Component:=", "Theta", "Mag
Component:=", Array( _
"dB(GainTotal)")), Array()
End Sub
' create_chart_from_cells.txt =================================================
Public Sub ZAKOPANE()
Set rngChart = ActiveSheet.Range("A1:U26")
Dim srs As Series
Set co = ActiveSheet.Shapes.AddChart(xlXYScatter, 100, 100, 500, 500)
Set cht = co.Chart
Set sc = cht.SeriesCollection
For M = 1 To 3
Set srs = cht.SeriesCollection.NewSeries
With Worksheets("Sheet1")
srs.Name = .Cells(1, M + 1)
srs.XValues = .Range(.Cells(2, 1), .Cells(100, 1))
srs.Values = .Range(.Cells(2, M + 1), .Cells(100, M + 1))
srs.Format.Line.Visible = msoCTrue
srs.MarkerSize = 2
srs.MarkerStyle = xlMarkerStyleNone
End With
Next M
End Sub
' Create_Chart_from_cells_in_ROWS.bas
=================================================
Public Sub ZAKOPANE_ROWS()
Dim I1, I2, I3 As Long
Sheet2.Select
Set rngChart = ActiveSheet.Range("A1:U26")
Dim srs As Series
nseries_start = 2
nseries_stop = 200
xrow = 1: xcolstart = 20: xcolstop = 30
y1: yrowstart = 2: yrowstop = 1081
Set co = ActiveSheet.Shapes.AddChart(xlXYScatter, 100, 100, 500, 500)
Set cht = co.Chart
Set sc = cht.SeriesCollection
For M = nseries_start To nseries_stop
Set srs = cht.SeriesCollection.NewSeries
With ActiveSheet
If .Cells(M, 1).Text = "" Then
a1$ = "0"
Else
a1$ = .Cells(M, 1).Text
End If
If .Cells(M, 2).Text = "" Then
a2$ = "0"
Else: a2$ = .Cells(M, 2).Text
End If
If .Cells(M, 3).Text = "" Then
a3$ = "0"
Else
a3$ = .Cells(M, 3).Text
End If
If .Cells(M, 4).Text = "" Then
a4$ = "0"
Else
a4$ = .Cells(M, 4).Text
End If
a$ = "In" + a1$ + " - out" + a2$ + " - P=" + a3$ + " - T=" + a4$
srs.Name = a$
srs.XValues = .Range(.Cells(xrow, xcolstart), .Cells(xrow, xcolstop))
srs.Values = .Range(.Cells(yrowstart + M, xcolstart), .Cells(yrowstart + M,
xcolstop))
srs.Format.Line.Weight = 2
srs.Format.Line.Visible = msoCTrue
srs.MarkerSize = 2
srs.MarkerStyle = xlMarkerStyleNone
I1 = Abs(Int(200 * Rnd(M - 1)))
I2 = 400 * Rnd(M)
I3 = Abs(Int(500 * Rnd(M + 1)))
srs.Format.Line.ForeColor.RGB = RGB(I1, I2, I3)
End With
Next M
'=======================================================================
co.Select
ActiveChart.ApplyLayout (1)
x$ = "##0."
y$ = "##0."
Dim tcol()
GXMIN = 14.4 '<=INPUT
GXMAX = 15.4 '<=INPUT
GYMIN = -40 '<=INPUT
GYMAX = 0 '<=INPUT
ZTITLE = "Modes S-par" '<=INPUT
XLABEL = "Frequency [GHz]" '<=INPUT
YLABEL = "Spar[dB]" '<=INPUT
CX0 = 70
CY0 = 80
CW = 900
CH = 400
CT = CH + 100
'=================
xlMajorUnit = 0.1
xlMinorUnit = 0.1
legend_font_size = 3
ActiveChart.ChartTitle.Characters.Text = ZTITLE
ActiveChart.Axes(xlCategory, xlPrimary).HasTitle = True
ActiveChart.Axes(xlCategory).AxisTitle.Select
Selection.Format.TextFrame2.TextRange.Font.Size = 18
ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = XLABEL
ActiveChart.Axes(xlValue, xlPrimary).HasTitle = True
Selection.Format.TextFrame2.TextRange.Font.Size = 18
ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = YLABEL
ActiveChart.Axes(xlCategory).Select
ActiveChart.SeriesCollection(1).MarkerStyle = -4142
ActiveChart.Axes(xlCategory).Select
ActiveChart.Axes(xlCategory).MajorUnit = xlMajorUnit
ActiveChart.Axes(xlCategory).MinorUnit = xlMinorUnit
ActiveChart.Axes(xlCategory).TickLabels.NumberFormat = "#,##0.0"
For i = 1 To ncollections
ActiveChart.SeriesCollection(1).Name = tcol(i)
Next i
With ActiveChart.Axes(xlCategory) ' x-axis
.MinimumScale = GXMIN
.MaximumScale = GXMAX
.Crosses = xlCustom
.CrossesAt = GXMIN
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
.HasMajorGridlines = True
.HasMinorGridlines = True
End With
ActiveChart.Axes (xlValue) ' y-axis
With ActiveChart.Axes(xlValue)
.MinimumScale = GYMIN
.MaximumScale = GYMAX
.Crosses = xlCustom
.CrossesAt = GYMIN
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
.HasMajorGridlines = True
.HasMinorGridlines = False
End With
ActiveChart.ChartArea.Select
ActiveChart.HasLegend = True
ActiveChart.Legend.Select
Selection.Position = xlTop
ActiveChart.PlotArea.Select
With Selection.Border
.ColorIndex = 16
.Weight = xlThin
.LineStyle = xlContinuous
End With
Selection.Interior.ColorIndex = xlNone
ActiveChart.ChartArea.Select
ActiveChart.PlotArea.Select
Selection.Width = 1200
Selection.Left = 120
Selection.Height = 800
Selection.Top = 20
ActiveChart.ChartArea.Select
ActiveChart.ChartArea.Copy
'=================
ActiveChart.ChartArea.Select
ActiveChart.ChartTitle.Select 'CHART TITLE
Selection.Format.TextFrame2.TextRange.Font.Size = 24
ActiveChart.ChartTitle.Text = ZTITLE
ActiveChart.Legend.Select
With Selection.Format.TextFrame2.TextRange.Font
.BaselineOffset = 0
.Size = 12 'legend font size
.Name = "Arial"
End With
'================
ActiveChart.Axes(xlValue).Select
Selection.TickLabels.NumberFormat = x$
Selection.TickLabels.Font.Size = 16 'y-axis font size
Selection.TickLabels.Font.Name = "Arial"
Selection.TickLabels.Font.Bold = msoTrue
ActiveChart.Axes(xlCategory).Select
Selection.TickLabels.NumberFormat = y$
Selection.TickLabels.Font.Size = 16 'x-axis font size
Selection.TickLabels.Font.Name = "Arial"
Selection.TickLabels.Font.Bold = msoTrue
'======================
ActiveChart.PlotArea.Select
Selection.Left = CX0 '60
Selection.Top = CY0 ' 60
Selection.Width = CW '1000
Selection.Height = CH '700
ActiveChart.Axes(xlCategory).AxisTitle.Select
Selection.Top = CT
'=================
ActiveChart.Legend.Select
ActiveChart.ApplyLayout (1)
ActiveChart.Axes(xlCategory).Select
ActiveChart.Axes(xlCategory).HasMinorGridlines = True
ActiveChart.Axes(xlValue).Select
ActiveChart.Axes(xlValue).HasMinorGridlines = True
ActiveChart.Axes(xlValue).AxisTitle.Select
Selection.Format.TextFrame2.TextRange.Font.Size = 18
ActiveChart.ChartArea.Select
ActiveChart.Legend.Select
ActiveChart.Legend.Select
Selection.Position = xlTop
ActiveChart.Legend.Select
Selection.Format.TextFrame2.TextRange.Font.Size = legend_font_size
ActiveChart.Location Where:=xlLocationAsNewSheet
End Sub
' Create_Chart_from_cells_in_ROWS.txt
=================================================
Public Sub ZAKOPANE_ROWS()
Sheet2.Select
Set rngChart = ActiveSheet.Range("A1:U26")
Dim srs As Series
nseries_start = 2
nseries_stop = 200
xrow = 1: xcolstart = 20: xcolstop = 30
y1: yrowstart = 2: yrowstop = 1081
Set co = ActiveSheet.Shapes.AddChart(xlXYScatter, 100, 100, 500, 500)
Set cht = co.Chart
Set sc = cht.SeriesCollection
For M = nseries_start To nseries_stop
Set srs = cht.SeriesCollection.NewSeries
With ActiveSheet
If .Cells(M, 1).Text = "" Then
a1$ = "0"
Else
a1$ = .Cells(M, 1).Text
End If
If .Cells(M, 2).Text = "" Then
a2$ = "0"
Else: a2$ = .Cells(M, 2).Text
End If
If .Cells(M, 3).Text = "" Then
a3$ = "0"
Else
a3$ = .Cells(M, 3).Text
End If
If .Cells(M, 4).Text = "" Then
a4$ = "0"
Else
a4$ = .Cells(M, 4).Text
End If
a$ = "In" + a1$ + " - out" + a2$ + " - P=" + a3$ + " - T=" + a4$
srs.Name = a$
srs.XValues = .Range(.Cells(xrow, xcolstart), .Cells(xrow, xcolstop))
srs.Values = .Range(.Cells(yrowstart + M, xcolstart), .Cells(yrowstart + M,
xcolstop))
srs.Format.Line.Weight = 2
srs.Format.Line.Visible = msoCTrue
srs.MarkerSize = 2
srs.MarkerStyle = xlMarkerStyleNone
srs.Format.Line.ForeColor.RGB = RGB(M - 1, 0, M + 1)
End With
Next M
End Sub
' Create_PML_2.bas =================================================
' ----------------------------------------------
'
' Author: Eric Zheng
' Email: eric.zheng@ansys.com
' March 2010
' ----------------------------------------------
Dim oAnsoftApp
Dim oDesktop
Dim oProject
Dim oDesign
Dim oEditor
Dim oModule
Dim oBoundingBox
Dim ABCFaceID(5)
Set oAnsoftApp = CreateObject("AnsoftHfss.HfssScriptInterface")
Set oDesktop = oAnsoftApp.GetAppDesktop()
oDesktop.RestoreWindow
Set oProject = oDesktop.GetActiveProject
Set oDesign = oProject.GetActiveDesign()
Set oEditor = oDesign.SetActiveEditor("3D Modeler")
oEditor.SetModelUnits(ARRAY("NAME:Units
Paramter","Units:=","mm","Rescale:=",false))
Input1 = inputbox("Please input the solution Frequency (in Hz),", "Frequency
Input","10e9",50,50)
f_solution = cDbl(Input1)
Input2 = inputbox("Please input the Minimun Frequency in Freq Band (in Hz),",
"Frequency Input",Input1,50,50)
f_min = cDbl(Input2)
c0 = 3e8
WL0 = c0/f_solution
Unit_mm = "*1mm"
oBoundingBox = oEditor.GetModelBoundingBox()
x_Min = (cDBl(oBoundingBox(0)))
y_Min = (cDBl(oBoundingBox(1)))
z_Min = (cDBl(oBoundingBox(2)))
x_Max = (cDBl(oBoundingBox(3)))
y_Max = (cDBl(oBoundingBox(4)))
z_Max = (cDBl(oBoundingBox(5)))
x_Size = (abs(x_Max-x_min))
y_Size = (abs(y_Max-y_min))
z_Size = (abs(z_Max-z_min))
oDesign.ChangeProperty Array("NAME:AllTabs", Array("NAME:LocalVariableTab",
Array("NAME:PropServers", _
"LocalVariables"), Array("NAME:NewProps", Array("NAME:fr", "PropType:=",
"VariableProp", "UserDef:=", _
true, "Value:=", (f_solution) & "Hz"), Array("NAME:WL", "PropType:=",
"VariableProp", "UserDef:=", _
true, "Value:=", "c0/fr"))))
oEditor.CreateBox Array("NAME:BoxParameters", "XPosition:=", cstr(x_Min) & "mm",
"YPosition:=", _
cstr(y_Min) & "mm", "ZPosition:=", cstr(z_Min)& "mm", "XSize:=", cstr(x_Size) &
"mm", "YSize:=", cstr(y_Size) & "mm", "ZSize:=", _
cstr(z_Size)& "mm"), Array("NAME:Attributes", "Name:=", "Box_Air", "Flags:=",
"", "Color:=", _
"(132 132 193)", "Transparency:=", 0.8, "PartCoordinateSystem:=", _
"Global", "MaterialValue:=", "" & Chr(34) & "vacuum" & Chr(34) & "",
"SolveInside:=", _
true)
oEditor.OffsetFaces Array("NAME:Selections", "Selections:=", "Box_Air",
"NewPartsModelFlag:=", _
"Model"), Array("NAME:OffsetParameters", "OffsetDistance:=", "WL/10")
oBoundingBox = oEditor.GetModelBoundingBox()
x_Min = (cDBl(oBoundingBox(0)))
y_Min = (cDBl(oBoundingBox(1)))
z_Min = (cDBl(oBoundingBox(2)))
x_Max = (cDBl(oBoundingBox(3)))
y_Max = (cDBl(oBoundingBox(4)))
z_Max = (cDBl(oBoundingBox(5)))
x_Center = ((x_Max+x_min)/2.0)
y_Center = ((y_Max+y_min)/2.0)
z_Center = ((z_Max+z_min)/2.0)
ABCFaceID(0) = oEditor.GetFaceByPosition(Array("NAME:FaceParameters", _
"BodyName:=", "Box_Air", "XPosition:=", cstr(x_Center) & Unit_mm, "YPosition:=",
_
cstr(y_Center) & Unit_mm, "ZPosition:=", cstr(z_Min)& Unit_mm))
ABCFaceID(1) = oEditor.GetFaceByPosition(Array("NAME:FaceParameters", _
"BodyName:=", "Box_Air", "XPosition:=", cstr(x_Center)& Unit_mm, "YPosition:=",
_
cstr(y_Center)& Unit_mm, "ZPosition:=", cstr(z_Max)& Unit_mm))
ABCFaceID(2) = oEditor.GetFaceByPosition(Array("NAME:FaceParameters", _
"BodyName:=", "Box_Air", "XPosition:=", cstr(x_Center)& Unit_mm, "YPosition:=",
_
cstr(y_Min)& Unit_mm, "ZPosition:=", cstr(z_Center)& Unit_mm))
ABCFaceID(3) = oEditor.GetFaceByPosition(Array("NAME:FaceParameters", _
"BodyName:=", "Box_Air", "XPosition:=", cstr(x_Center)& Unit_mm, "YPosition:=",
_
cstr(y_Max)& Unit_mm, "ZPosition:=", cstr(z_Center)& Unit_mm))
ABCFaceID(4) = oEditor.GetFaceByPosition(Array("NAME:FaceParameters", _
"BodyName:=", "Box_Air", "XPosition:=", cstr(x_Min)& Unit_mm, "YPosition:=", _
cstr(y_Center)& Unit_mm, "ZPosition:=", cstr(z_Center)& Unit_mm))
ABCFaceID(5) = oEditor.GetFaceByPosition(Array("NAME:FaceParameters", _
"BodyName:=", "Box_Air", "XPosition:=", cstr(x_Max)& Unit_mm, "YPosition:=", _
cstr(y_Center)& Unit_mm, "ZPosition:=", cstr(z_Center)& Unit_mm))
Set oModule=oDesign.GetModule("BoundarySetup")
oModule.CreatePML Array("UserDrawnGroup:=", false,_
"PMLFaces:=",ABCFaceID, "CreateJoiningObjs:=", true,_
"Thickness:=",cstr(WL0/6*1000) & "mm", "RadDist:=", cstr(WL0/4*1000) & "mm",_
"UseFreq:=", true, "MinFreq:=", cstr(f_min) &"Hz")
oEditor.CreateEntityList Array("NAME:GeometryEntityListParameters",
"EntityType:=", _
"Face", "EntityList:=", ABCFaceID), Array("NAME:Attributes", "Name:=", _
"NTF_FaceList")
Set oModule = oDesign.GetModule("RadField")
oModule.InsertFarFieldSphereSetup Array("NAME:3DSphere",
"UseCustomRadiationSurface:=", _
true, "CustomRadiationSurface:=", "NTF_FaceList", "ThetaStart:=", "-180deg",
"ThetaStop:=", _
"180deg", "ThetaStep:=", "10deg", "PhiStart:=", "0deg", "PhiStop:=", "180deg",
"PhiStep:=", _
"10deg", "UseLocalCS:=", false)
MsgBox "Script Executed Successfully",0,"Script Complete"
' DATA2EXCEL.bas =================================================
Attribute VB_Name = "DATA2EXCEL"
Public Sub DATA2EXCEL() '============================================== EXCEL ==
'2345678901234567890123456789012345678901234567890123456789012345678901234567890
'0000000011111111112222222222333333333344444444445555555555666666666677777777778
Dim LB, RT, TRANGE As String
Dim X_RANGE(100), Y_RANGE(100) 'As String
Dim V As Integer
Dim COL_NUM
Dim CELX, CELY1, CELY2 As String
COLX = 0
For K = 1 To NF
If K = 1 Then
COLX = 1
Else
COLX = COLY2 + 1
End If
X_RANGE(K) = "=SHEET1!R1C" + LTrim(Str$(COLX)) + ":R" + LTrim(Str$(NTH)) + "C" +
LTrim(Str$(COLX))
For I = 1 To NPH
If I = 1 Then
COLY1 = COLX + 1
Else
COLY1 = COLY2 + 1
End If
COLY2 = COLY1 + 1
For J = 1 To NTH
CELX = Chr$(64 + COLX) + LTrim(Str$(J))
NashXl.Range(CELX) = THETACUT(K, I, J)
CELY1 = Chr$(64 + COLY1) + LTrim(Str$(J))
NashXl.Range(CELY1) = DBV(K, I, J)
CELY2 = Chr$(64 + COLY2) + LTrim(Str$(J))
NashXl.Range(CELY2) = DBH(K, I, J)
Next J
Next I
Y_RANGE(K) = "=SHEET1!R1C" + LTrim(Str$(COLX + 1)) + ":R" + LTrim(Str$(NTH)) +
"C" + LTrim(Str$(COLY2))
Next K
'With NashXl '=============////////////////////////////////////////////
NashXl.Range("SHEET1!A1:" + CELY2).Select
NashXl.Selection.NumberFormat = "0.00"
NashXl.Selection.Style = "Normal"
NashXl.Charts.Add
NashXl.ActiveChart.ChartType = xlXYScatterLinesNoMarkers
'
Dim RAMBOX, RAMBOY, RAMBOY2 As String
M = 0
For K = 1 To NF
If K = 1 Then
COLX = 1
Else
COLX = COLY2 + 1
End If
RAMBOX = "=SHEET1!R1C" + LTrim(Str$(COLX)) + ":R" + LTrim(Str$(NTH)) + "C" +
LTrim(Str$(COLX))
For I = 1 To NPH
M = M + 1
If I = 1 Then
COLY1 = COLX + 1
Else
COLY1 = COLY2 + 1
End If
NashXl.ActiveChart.SeriesCollection(M).XValues = RAMBOX
RAMBOY1 = "=SHEET1!R1C" + LTrim(Str$(COLY1)) + ":R" + LTrim(Str$(NTH)) + "C" +
LTrim(Str$(COLY1))
NashXl.ActiveChart.SeriesCollection(M).Values = RAMBOY1
NashXl.ActiveChart.SeriesCollection(M).Name = "CO " + LEGEND_TITLE(M)
COLY2 = COLY1 + 1
M = M + 1
NashXl.ActiveChart.SeriesCollection(M).XValues = RAMBOX
RAMBOY2 = "=SHEET1!R1C" + LTrim(Str$(COLY2)) + ":R" + LTrim(Str$(NTH)) + "C" +
LTrim(Str$(COLY2))
NashXl.ActiveChart.SeriesCollection(M).Values = RAMBOY1
NashXl.ActiveChart.SeriesCollection(M).Name = "CX"
Next I
Next K
NashXl.ActiveChart.PlotArea.Select
NashXl.ActiveChart.Location Where:=xlLocationAsNewSheet
With NashXl.ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Title"
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Angle [Deg]"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Pattern [dB]"
End With
NashXl.ActiveChart.Axes(xlCategory).Select
NashXl.ActiveChart.Axes(xlValue).Select
With NashXl.ActiveChart.Axes(xlValue)
.MinimumScale = GYmin
.MaximumScale = GYmax
.MinorUnit = 10
.MajorUnit = 5
.Crosses = xlCustom
.CrossesAt = GYmin
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
With NashXl.ActiveChart.Axes(xlCategory)
.MinimumScale = GXmin
.MaximumScale = GXmax
.MinorUnit = 10
.MajorUnit = 30
.Crosses = xlCustom
.CrossesAt = GXmin
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
NashXl.ActiveChart.ChartArea.Select
NashXl.ActiveChart.HasLegend = True
NashXl.ActiveChart.Legend.Select
NashXl.Selection.Position = xlTop
With NashXl.ActiveChart.Axes(xlCategory)
.HasMajorGridlines = True
.HasMinorGridlines = False
End With
With NashXl.ActiveChart.Axes(xlValue)
.HasMajorGridlines = True
.HasMinorGridlines = False
End With
NashXl.ActiveChart.PlotArea.Select
With NashXl.Selection.Border
.ColorIndex = 16
.Weight = xlThin
.LineStyle = xlContinuous
End With
NashXl.Selection.Interior.ColorIndex = xlNone
NashXl.ActiveChart.ChartArea.Select
NashXl.ActiveChart.PlotArea.Select
NashXl.Selection.Width = 373
NashXl.Selection.Left = 168
NashXl.ActiveChart.ChartArea.Select
NashXl.ActiveChart.ChartArea.Copy
' Form2.Picture1.Picture = Clipboard.GetData(vbCFDIB)
'====================================================== PPT START
Dim ppApp As PowerPoint.Application
Set ppApp = CreateObject("Powerpoint.Application")
' Make it visible.
ppApp.Visible = True
' Add a new presentation.
Dim ppPres As PowerPoint.Presentation
Set ppPres = ppApp.Presentations.Add(msoTrue)
' Add a new slide.
Dim ppSlide1 As PowerPoint.Slide
Set ppSlide1 = ppPres.Slides.Add(1, ppLayoutBlank)
ppSlide1.Shapes.Paste.PictureFormat.CropRight = 20
A$ = Mid(OFLN, 1, Len(OFLN) - 4) + ".ppt"
ppPres.SaveAs Filename:=A$
'====================================================== PPT END
Call TEXTBOX
NashXl.ActiveWorkbook.SaveAs Filename:=XLSFLN, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=True
ActiveWorkbook.Close
ppApp.Quit
End Sub
' Define hyperlink using sheet name and cells methods.bas
=================================================
Define hyperlink using sheet name and cells methods
Sheets("Sheet1").Hyperlinks.Add Anchor:=Sheets("sheet1").Cells(1, 2),
Address:="", SubAddress:= _
Sheet2.Cells(1, 1).Address, TextToDisplay:=txt
' define_range_using_cells.bas =================================================
Sub test()
Dim cell1, cell2, rng As Range
Set cell1 = Cells(1, 2)
Set cell2 = cell1.End(xlDown).End(xlToRight)
Set rng = Range(cell1, cell2)
rng.Select
End Sub
' define_range_using_cells_loop_inwork.bas
=================================================
Attribute VB_Name = "Module1"
Sub Macro1()
Attribute Macro1.VB_ProcData.VB_Invoke_Func = " \n14"
'
' Macro1 Macro
'
'
Dim MyXRange, MyYRange, MyTRange As Range
Dim cell1, cell2, rng As Range
Set cell1 = Cells(2, 1)
Set cell2 = Cells(43, 1)
Set MyXRange = Range(cell1, cell2)
Set cell1 = Cells(2, 2)
Set cell2 = Cells(43, 2)
Set MyYRange = Range(cell1, cell2)
Set cell1 = Cells(1, 1)
Set cell2 = Cells(1, 1)
Set MyTRange = Range(cell1, cell2)
'MyXRange.Select
Range(MyXRange, MyXRange).Select
'Range("C42").Activate
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlXYScatterLinesNoMarkers
ActiveChart.SetSourceData Source:=Range(MyXRange, MyYRange)
ActiveChart.Location Where:=xlLocationAsNewSheet
ActiveChart.ChartArea.Select
ActiveChart.PlotArea.Select
For k = 2 To 50
Set cell1 = Cells(2, 7)
Set cell2 = Cells(43, k)
Set MyYRange = Range(cell1, cell2)
Set cell1 = Cells(1, k)
Set cell2 = Cells(1, k)
Set MyTRange = Range(cell1, cell2)
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(2).Name = MyTRange
ActiveChart.SeriesCollection(2).XValues = MyXRange
ActiveChart.SeriesCollection(2).Values = MyYRange
Next k
End Sub
' Delete multiple sheets in a loop.bas
=================================================
Dim i As Long, ws As Long
ws = ActiveWorkbook.Worksheets.Count
For i = 2 To ws - 1
ActiveWorkbook.Worksheets(i).Delete
Next i
' Delete_All_Sheets_Except.bas =================================================
Public sub Delete_All_But
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name <> "Sheet1" And ws.Name <> "Sheet2" Then ws.Delete
Next
Application.DisplayAlerts = True
end sub
' Delete_Sheets.bas =================================================
Public Sub Delete_Sheets()
Sheet1.Delete
End Sub
' delete_sheets_in_loop.bas =================================================
Attribute VB_Name = "Module2"
Public Sub delsheets()
For i = 10 To 79
a$ = "Sheet" + LTrim(RTrim(Str$(i)))
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(a$).Delete
Next i
End Sub
' DeleteDrawingObjects.bas =================================================
Public Sub DeleteDrawingObjects()
ActiveSheet.DrawingObjects.Delete
End Sub
' Excel_Delete_entire_Column.bas
=================================================
Sheet1.Cells(1, i).Select
ActiveCell.EntireColumn.Delete
' Excel_Get_Path_FullName.bas =================================================
Public Sub Excel_Path_FullName()
Sheet1.Cells(2, 51).Value = Application.ActiveWorkbook.Path
Sheet1.Cells(3, 51).Value = Application.ActiveWorkbook.FullName
End Sub
' excel_insert_picture.bas =================================================
Sub TestInsertPictureInRange()
Sheet3.Select
a$ =
"C:\Users\tuli\Documents\Ansoft\InnercutNew_20111017_1146_6_InsidePinsVacuum_CylCut_SPHERE_8_3\snap1.jpg"
InsertPictureInRange a$, Range("B5:D10")
End Sub
Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCell
t = .Top
l = .Left
If CenterH Then
w = .Offset(0, 1).Left - .Left
l = l + w / 2 - p.Width / 2
If l < 1 Then l = 1
End If
If CenterV Then
h = .Offset(1, 0).Top - .Top
t = t + h / 2 - p.Height / 2
If t < 1 Then t = 1
End If
End With
' position picture
With p
.Top = t
.Left = l
End With
Set p = Nothing
Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub
' excell_AllObjects_AllHyperlinks.bas
=================================================
Attribute VB_Name = "Module1"
Sub DelShp()
Dim sh As Shape
For Each sh In Sheet2.Shapes
sh.Delete
Next sh
End Sub
Sub RemoveHyperlinks()
Dim oField As Field
For Each oField In ActiveDocument.Fields
If oField.Type = wdFieldHyperlink Then
oField.Unlink
End If
Next
Set oField = Nothing
End Sub
Sub RemoveallHyperlinks()
'Remove all hyperlinks from the active sheet
ActiveSheet.Hyperlinks.Delete
End Sub
Sub UnMergeFill()
Dim cell As Range, joinedCells As Range
For Each cell In ThisWorkbook.ActiveSheet.UsedRange
If cell.MergeCells Then
Set joinedCells = cell.MergeArea
cell.MergeCells = False
joinedCells.Value = cell.Value
End If
Next
End Sub
' find_chr_in_string.txt =================================================
Public Sub test_finds()
a$ = Sheet1.Cells(1, 7).Value
Call finds(a$, "T", k)
End Sub
Public Sub finds(a$, b$, j)
la = Len(a$)
For i = 1 To la
Debug.Print i, Mid(a$, i, 1), Asc(Mid(a$, i, 1))
If Mid(a$, i, 1) = b$ Then
j = i
End If
Next i
End Sub
' Find_MaxRow.bas =================================================
Public Sub test_Find_MaxRow()
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Row_max = LastRow
End Sub
' Find_MaxRow_MaxColumn.bas =================================================
Public Sub find_occupancy()
Sheet2.Cells(1, 1).Value = Sheet1.Range("A1").End(xlDown).Row
Sheet2.Cells(1, 2).Value = Sheet1.Range("A1").End(xlToRight).Column
End Sub
' Find_string_and_write_to_Sheet2.bas
=================================================
Attribute VB_Name = "Module3"
Public Sub Copy_all2sheet2()
m = 1
For i = 2 To 5001
a$ = Sheet1.Cells(i, 1).Value
aa = Len(a$)
b$ = "Raven"
For j = 1 To aa - 5
C$ = Mid(a$, j, 5)
If C$ = b$ Then
m = m + 1
For k = 1 To 10
Sheet2.Cells(m, k).Value = Sheet1.Cells(i, k).Value
Next k
End If
Next j
Next i
End Sub
' FindFileExtension.bas =================================================
Public Function FindFileExtension(gln) As String
Dim tt As String
lgln = Len(gln)
For i = 1 To lgln
tt = Mid(gln, i, 1)
Debug.Print tt
If tt = Chr(46) Then
j = i + 1
End If
Next i
FindFileExtension = Mid(gln, j, lgln - j + 1)
End Function
' fix cst exported patterns.bas
=================================================
Sub Macro2()
'
' Macro2 Macro
'
'
ActiveWindow.SmallScroll Down:=12
Range("A183:H362").Select
Selection.Cut
ActiveWindow.ScrollRow = 160
ActiveWindow.ScrollRow = 159
ActiveWindow.ScrollRow = 158
ActiveWindow.ScrollRow = 157
ActiveWindow.ScrollRow = 156
ActiveWindow.ScrollRow = 154
ActiveWindow.ScrollRow = 152
ActiveWindow.ScrollRow = 150
ActiveWindow.ScrollRow = 147
ActiveWindow.ScrollRow = 145
ActiveWindow.ScrollRow = 142
ActiveWindow.ScrollRow = 139
ActiveWindow.ScrollRow = 136
ActiveWindow.ScrollRow = 133
ActiveWindow.ScrollRow = 129
ActiveWindow.ScrollRow = 126
ActiveWindow.ScrollRow = 123
ActiveWindow.ScrollRow = 119
ActiveWindow.ScrollRow = 115
ActiveWindow.ScrollRow = 111
ActiveWindow.ScrollRow = 107
ActiveWindow.ScrollRow = 103
ActiveWindow.ScrollRow = 98
ActiveWindow.ScrollRow = 94
ActiveWindow.ScrollRow = 90
ActiveWindow.ScrollRow = 86
ActiveWindow.ScrollRow = 82
ActiveWindow.ScrollRow = 79
ActiveWindow.ScrollRow = 76
ActiveWindow.ScrollRow = 72
ActiveWindow.ScrollRow = 69
ActiveWindow.ScrollRow = 65
ActiveWindow.ScrollRow = 61
ActiveWindow.ScrollRow = 58
ActiveWindow.ScrollRow = 55
ActiveWindow.ScrollRow = 51
ActiveWindow.ScrollRow = 47
ActiveWindow.ScrollRow = 44
ActiveWindow.ScrollRow = 41
ActiveWindow.ScrollRow = 38
ActiveWindow.ScrollRow = 35
ActiveWindow.ScrollRow = 32
ActiveWindow.ScrollRow = 30
ActiveWindow.ScrollRow = 27
ActiveWindow.ScrollRow = 24
ActiveWindow.ScrollRow = 22
ActiveWindow.ScrollRow = 19
ActiveWindow.ScrollRow = 17
ActiveWindow.ScrollRow = 15
ActiveWindow.ScrollRow = 13
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 1
Range("K3").Select
ActiveSheet.Paste
Range("J3").Select
ActiveCell.FormulaR1C1 = "=-RC[1]"
Range("J3").Select
Selection.Copy
Range("J4:J182").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("J:J").Select
Selection.Copy
Columns("K:K").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("J:J").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A3:H182").Select
Selection.Cut
ActiveWindow.SmallScroll Down:=153
Range("J183").Select
ActiveSheet.Paste
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Range("J2:Q539").Select
Selection.Cut
Range("A2").Select
ActiveSheet.Paste
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Range("B1").Select
ActiveCell.FormulaR1C1 = "Directivity [dBi]"
Range("B2").Select
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A2").Select
ActiveCell.FormulaR1C1 = "=-RC[1]"
Range("A2").Select
Selection.Copy
Range("A3:A361").Select
ActiveSheet.Paste
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Copy
Columns("B:B").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
End Sub
' Fix_columns.bas =================================================
Attribute VB_Name = "Module2"
Sub FixCols()
'
' Macro2 Macro
' Macro recorded 1/31/2011 by tuli
'
Sheet3.Select
'
Columns("A:A").Select
Selection.ColumnWidth = 50
Columns("B:B").Select
Selection.ColumnWidth = 100
Columns("D:F").Select
Selection.ColumnWidth = 20
Columns("G:G").Select
Selection.ColumnWidth = 5
Columns("H:H").Select
Selection.ColumnWidth = 10
Selection.ColumnWidth = 8
Columns("H:H").Select
Selection.ColumnWidth = 9
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
Columns("C:C").Select
Selection.ColumnWidth = 9
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("D:H").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
' fix_smith.bas =================================================
Attribute VB_Name = "Module1"
Sub fix_Smith()
Attribute fix_Smith.VB_ProcData.VB_Invoke_Func = " \n14"
'
' Macro1 Macro
'
npoints = 210
Q$ = Chr$(32)
'
A$ = "=Smith!$C$7:$C$" + LTrim(RTrim(Q$ + Str$(npoints) + Q$))
B$ = "=Smith!$D$7:$D$" + LTrim(RTrim(Q$ + Str$(npoints) + Q$))
Debug.Print A$
Debug.Print B$
ActiveChart.SeriesCollection(1).XValues = A$
ActiveChart.SeriesCollection(1).Values = B$
End Sub
' FIX_THETA.bas =================================================
Attribute VB_Name = "FIX_THETA"
Public Sub FIX_THETA()
Dim TH(), PH(), AMP(), THF(), TMP() As Double
Dim kindex() As Long
NR = 360
ReDim TH(NR), PH(NR), AMP(NR), THF(NR), kindex(NR), TMP(NR)
For i = 0 To NR
TH(i) = Sheet1.Cells(i + 4, 1).Value
PH(i) = Sheet1.Cells(i + 4, 2).Value
AMP(i) = Sheet1.Cells(i + 4, 3).Value
If PH(i) = 180 Then
THF(i) = -TH(i)
Else
THF(i) = TH(i)
End If
TMP(i) = THF(i)
Sheet1.Cells(i + 4, 15).Value = THF(i)
Sheet1.Cells(i + 4, 16).Value = AMP(i)
Next i
'=====================================
QuickSort THF, LBound(THF), UBound(THF) '==== THF IS SORTED NOW ======
For i = 0 To NR
Sheet1.Cells(i + 4, 21).Value = THF(i)
Next i
'find ordered indices
For i = 0 To NR
aa = THF(i)
For j = 0 To NR
bb = TMP(j)
If bb = aa Then
kindex(i) = j
End If
Next j
Next i
For i = 0 To NR
Sheet1.Cells(i + 4, 23).Value = THF(i)
Sheet1.Cells(i + 4, 24).Value = AMP(kindex(i))
Next i
End Sub
Public Sub test_BubbleSort()
'
' arr unsorted array
' brr sorted array
'
Dim arr(), brr() As Double
Dim kindex() As Long
Dim Lo, Hi As Long
NR = 21
ReDim arr(NR), brr(NR), kindex(NR)
For i = 0 To NR
arr(i) = Rnd()
brr(i) = arr(i)
Sheet1.Cells(i + 1, 1).Value = arr(i)
Next i
'BubbleSort arr
QuickSort arr, LBound(arr), UBound(arr)
For i = 0 To NR
Sheet1.Cells(i + 1, 2).Value = arr(i)
Next i
'find ordered indices
For i = 0 To NR
aa = arr(i)
For j = 0 To NR
bb = brr(j)
If bb = aa Then
kindex(i) = j
End If
Next j
Next i
For i = 0 To NR
Sheet1.Cells(i + 1, 5).Value = kindex(i)
Sheet1.Cells(i + 1, 6).Value = brr(kindex(i))
Next i
End Sub
Sub BubbleSort(arr)
'Correct use: BubbleSort arr
Dim strTemp As String
Dim i As Long
Dim j As Long
Dim lngMin As Long
Dim lngMax As Long
lngMin = LBound(arr)
lngMax = UBound(arr)
For i = lngMin To lngMax - 1
For j = i + 1 To lngMax
If arr(i) > arr(j) Then
strTemp = arr(i)
arr(i) = arr(j)
arr(j) = strTemp
End If
Next j
Next i
End Sub
Sub QuickSort(arr, Lo As Long, Hi As Long)
'Correct use: arr, LBound(arr), UBound(arr)
Dim varPivot As Variant
Dim varTmp As Variant
Dim tmpLow As Long
Dim tmpHi As Long
tmpLow = Lo
tmpHi = Hi
varPivot = arr((Lo + Hi) \ 2)
Do While tmpLow <= tmpHi
Do While arr(tmpLow) < varPivot And tmpLow < Hi
tmpLow = tmpLow + 1
Loop
Do While varPivot < arr(tmpHi) And tmpHi > Lo
tmpHi = tmpHi - 1
Loop
If tmpLow <= tmpHi Then
varTmp = arr(tmpLow)
arr(tmpLow) = arr(tmpHi)
arr(tmpHi) = varTmp
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Loop
If Lo < tmpHi Then QuickSort arr, Lo, tmpHi
If tmpLow < Hi Then QuickSort arr, tmpLow, Hi
End Sub
' FolderSize.bas =================================================
Sub FolderSize()
Dim fso As Object, fsoFolder As Object
Const strFolderName As String = "C:\Users\1300617472C\Documents"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fsoFolder = fso.GetFolder(strFolderName)
MsgBox fsoFolder.Size & " bytes"
Set fsoFolder = Nothing
Set fso = Nothing
End Sub
' get_file_created_date.bas =================================================
Attribute VB_Name = "Module3"
Public Sub GETFILEPROPERTIES()
Dim fso, fileSpec, f, s
Set fso = CreateObject("Scripting.FileSystemObject")
fileSpec = "Y:\D\(0)_OFFICE\VB Modules\BAS\ifdriveexists.bas"
Set f = fso.GetFile(fileSpec)
s = f.Path & vbCrLf
s = s & "Created: " & f.DateCreated & vbCrLf
s = s & "Last Accessed: " & f.DateLastAccessed & vbCrLf
s = s & "Last Modified: " & f.DateLastModified
MsgBox s
End Sub
' get_file_properties.bas =================================================
Public Sub GETFILEPROPERTIES()
Dim fso, fileSpec, f, s
Set fso = CreateObject("Scripting.FileSystemObject")
fileSpec = "Y:\D\(0)_OFFICE\VB Modules\BAS\ifdriveexists.bas"
Set f = fso.GetFile(fileSpec)
s = f.Path & vbCrLf
s = s & "Created: " & f.DateCreated & vbCrLf
s = s & "Last Accessed: " & f.DateLastAccessed & vbCrLf
s = s & "Last Modified: " & f.DateLastModified
MsgBox s
End Sub
' get_network_path.bas =================================================
sub get_network_path()
dim fs, fol, netpath
set fs = createobject("Scripting.filesystemobject")
set fol = fs.getfolder("n:\tmp")
netpath = fol.drive.sharename
end sub
' GetDir.bas =================================================
Public Sub GetDir()
Z = RecurseFolderList(Sheet1.Cells(1, 1).Value)
End Sub
Public Function RecurseFolderList(FolderName As String) As Boolean
On Error Resume Next
Dim fso, f, fc, fj, f1
Set fso = CreateObject("Scripting.FileSystemObject")
If Err.Number > 0 Then
RecurseFolderList = False
Exit Function
End If
On Error GoTo 0
If fso.FolderExists(FolderName) Then
Set f = fso.GetFolder(FolderName)
Set fc = f.SubFolders
Set fj = f.Files
'For each subfolder in the Folder
i = 1
For Each f1 In fc
i = i + 1
Sheet1.Cells(i + 1, 1).Value = f1.Name
'Do something with the Folder Name
'Then recurse this function with the sub-folder to get any'
' sub-folders
RecurseFolderList (f1)
Next
'For each folder check for any files
For Each f1 In fj
i = i + 1
a$ = f1.Path
Sheet1.Cells(i, 2).Value = a$
'Debug.Print a$
DoEvents
Next
Set f = Nothing
Set fc = Nothing
Set fj = Nothing
Set f1 = Nothing
Else
RecurseFolderList = False
End If
Set fso = Nothing
End Function
Sub Klean()
Range("b2:AZ65000").Select
Selection.ClearContents
End Sub
' getdrivename.txt =================================================
Function getdrivename(a$)
Dim fso As New FileSystemObject
Dim flds As Folders
Dim strText As String
Dim i As Integer
j = 23
Set flds = fso.GetFolder(a$).SubFolders
i = 2
M = 0
For Each f In flds
M = M + 1
'strText = f.Path & " - " & f.Size
strText = f.Path & " "
Worksheets("Sheet1").Cells(1, j) = f.Drive.VolumeName
Worksheets("Sheet1").Cells(i, j) = strText
i = i + 1
Next
End Function
' GetEmailAttachments2000.bas =================================================
Attribute VB_Name = "GetEmailAttachments"
Option Explicit
'************************** Õ¿Õ- **************************
'*** Code by Martin Green ******** martin@fontstuff.com ***
'******* Office Tips Web Site - www.fontstuff.com *********
'**********************************************************
Sub GetAttachments()
' This Outlook macro checks a the Outlook Inbox for messages
' with attached files (of any type) and saves them to disk.
' NOTE: make sure the specified save folder exists before
' running the macro.
On Error GoTo GetAttachments_err
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
' Check Inbox for messages and exit of none found
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In Inbox.Items
' Save any attachments found
For Each Atmt In Item.Attachments
' This path must exist! Change folder name as necessary.
FileName = "C:\Email Attachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
' Show summary message
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Email Attachments folder." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation,
"Finished!"
End If
' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle errors
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Sales Reports") ' Enter correct subfolder name.
i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "xls" extension
If Right(Atmt.FileName, 3) = "xls" Then
' This path must exist! Change folder name as necessary.
FileName = "C:\Email Attachments\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
' Show summary message
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Email Attachments folder." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation,
"Finished!"
End If
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub
' GetEmailAttachments97.BAS =================================================
Attribute VB_Name = "GetEmailAttachments"
Option Explicit
'************************** Õ¿Õ- **************************
'*** Code by Martin Green ******** martin@fontstuff.com ***
'******* Office Tips Web Site - www.fontstuff.com *********
'**********************************************************
Sub GetAttachments()
' This Outlook macro checks a the Outlook Inbox for messages
' with attached files (of any type) and saves them to disk.
' NOTE: make sure the specified save folder exists before
' running the macro. This code requires a reference to be set
' to the Microsoft Outlook 8.0 Object Model
On Error GoTo GetAttachments_err
' Declare variables
Dim appOl As New Outlook.Application
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String
Dim i As Integer
Set ns = appOl.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
' Check Inbox for messages and exit of none found
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In Inbox.Items
' Save any attachments found
For Each Atmt In Item.Attachments
' This path must exist! Change folder name as necessary.
FileName = "C:\Email Attachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
' Show summary message
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Email Attachments folder." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation,
"Finished!"
End If
' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Set appOl = Nothing
Exit Sub
' Handle errors
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro. This code requires a reference to be set
' to the Microsoft Outlook 8.0 Object Model
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
Dim appOl As New Outlook.Application
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As Variant
Set ns = appOl.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Sales Reports") ' Enter correct subfolder name.
i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "xls" extension
If Right(Atmt.FileName, 3) = "xls" Then
' This path must exist! Change folder name as necessary.
FileName = "C:\Email Attachments\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
' Show summary message
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Email Attachments folder." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation,
"Finished!"
End If
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Set appOl = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub
' if_drive_exists.bas =================================================
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias _
"GetLogicalDriveStringsA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
' Check whether a given drive exist
' Note that this returns True even if the drive isn't currently ready
' (e.g. a diskette isn't in drive A:)
Function DriveExists(ByVal sDrive As String) As Boolean
Dim buffer As String
buffer = Space(64)
' return False if invalid argument
If Len(sDrive) = 0 Then Exit Function
'get the string that contains all drives
GetLogicalDriveStrings Len(buffer), buffer
' check that the letter we're looking for is there
DriveExists = InStr(1, buffer, Left$(sDrive, 1), vbTextCompare)
End Function
' if_file_dir_exists.bas =================================================
Option Explicit
Function FileOrDirExists(PathName As String) As Boolean
'Macro Purpose: Function returns TRUE if the specified file
' or folder exists, false if not.
'PathName : Supports Windows mapped drives or UNC
' : Supports Macintosh paths
'File usage : Provide full file path and extension
'Folder usage : Provide full folder path
' Accepts with/without trailing "\" (Windows)
' Accepts with/without trailing ":" (Macintosh)
Dim iTemp As Integer
'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)
'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select
'Resume error checking
On Error Goto 0
End Function
Sub TestItWithWindows()
'Macro Purpose: To test the FileOrDirExists function with Windows
'Only included to demonstrate the function. NOT required for normal use!
Dim sPath As String
'Change your directory here
sPath = "C:\Test.xls"
'Test if directory or file exists
If FileOrDirExists(sPath) Then
MsgBox sPath & " exists!"
Else
MsgBox sPath & " does not exist."
End If
End Sub
Sub TestItWithMacintosh()
'Macro Purpose: To test the FileOrDirExists function with a Macintosh
'Only included to demonstrate the function. NOT required for normal use!
Dim sPath As String
'Change your directory here
sPath = "HardDriveName:Documents:Test.doc"
'Test if directory or file exists
If FileOrDirExists(sPath) Then
MsgBox sPath & " exists!"
Else
MsgBox sPath & " does not exist."
End If
End Sub
' if_file_exists.BAS =================================================
Function FileOrDirExists(PathName As String) As Boolean
'Macro Purpose: Function returns TRUE if the specified file
' or folder exists, false if not.
'PathName : Supports Windows mapped drives or UNC
' : Supports Macintosh paths
'File usage : Provide full file path and extension
'Folder usage : Provide full folder path
' Accepts with/without trailing "\" (Windows)
' Accepts with/without trailing ":" (Macintosh)
Dim iTemp As Integer
'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)
'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select
'Resume error checking
On Error Goto 0
End Function
Sub TestItWithWindows()
'Macro Purpose: To test the FileOrDirExists function with Windows
'Only included to demonstrate the function. NOT required for normal use!
Dim sPath As String
'Change your directory here
sPath = "C:\Test.xls"
'Test if directory or file exists
If FileOrDirExists(sPath) Then
MsgBox sPath & " exists!"
Else
MsgBox sPath & " does not exist."
End If
End Sub
' ifdriveexists.bas =================================================
Option Explicit
Function FileOrDirExists(PathName As String) As Boolean
'Macro Purpose: Function returns TRUE if the specified file
' or folder exists, false if not.
'PathName : Supports Windows mapped drives or UNC
' : Supports Macintosh paths
'File usage : Provide full file path and extension
'Folder usage : Provide full folder path
' Accepts with/without trailing "\" (Windows)
' Accepts with/without trailing ":" (Macintosh)
Dim iTemp As Integer
'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)
'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select
'Resume error checking
On Error Goto 0
End Function
Sub TestItWithWindows()
'Macro Purpose: To test the FileOrDirExists function with Windows
'Only included to demonstrate the function. NOT required for normal use!
Dim sPath As String
'Change your directory here
sPath = "C:\Test.xls"
'Test if directory or file exists
If FileOrDirExists(sPath) Then
MsgBox sPath & " exists!"
Else
MsgBox sPath & " does not exist."
End If
End Sub
Sub TestItWithMacintosh()
'Macro Purpose: To test the FileOrDirExists function with a Macintosh
'Only included to demonstrate the function. NOT required for normal use!
Dim sPath As String
'Change your directory here
sPath = "HardDriveName:Documents:Test.doc"
'Test if directory or file exists
If FileOrDirExists(sPath) Then
MsgBox sPath & " exists!"
Else
MsgBox sPath & " does not exist."
End If
End Sub
' import_prof.bas =================================================
Public Sub import_prof()
'===================================================
Dim oAnsoftApp
Dim oDesktop
Dim oProject
Dim oDesign
Dim oEditor
Dim oModule
Set oAnsoftApp = CreateObject("AnsoftHfss.HfssScriptInterface")
Set oDesktop = oAnsoftApp.GetAppDesktop()
Set oProject = oDesktop.GetActiveProject
Set oDesign = oProject.GetActiveDesign()
Set oModule = oProject.GetActiveDesign()
Set oModule = oDesign.GetModule("AnalysisSetup")
'===================================================
Dim DesignName, ProjectName, SetupName, ExportFileName, NetworkName,
MeshFileName As String
DesignName = oDesign.getname()
ProjectName = oProject.getname()
ProDir = oDesktop.GetProjectDirectory
setupnames = oModule.GetSetups
Path = oProject.GetPath()
Path = Replace(Path, "/", "\")
SetupName = setupnames(0)
sweepnames = oModule.GetSweeps(SetupName)
SweepName = sweepnames(0)
'===================================================
' EXPORT PROFILE
ExportFileName = Path + "\" + ProjectName + ".prof"
Set oModule = oDesign.GetModule("Solutions")
oDesign.ExportProfile SetupName, "", ExportFileName, overwriteIfExists = False
' IMPORT PROFILR
fln = Path + "\" + ProjectName + ".prof"
i = 0
Set oFS = CreateObject("Scripting.FileSystemObject")
Set fHFSS = oFS.OpenTextFile(fln, 1)
Do Until fHFSS.AtEndOfStream
line = fHFSS.ReadLine
i = i + 1
If i >= 1 And i < 4 Then
If Len(line) <> 0 Then
T1 = Mid(line, 1, 21)
T2 = Mid(line, 22, 50)
Sheet2.Cells(i, 1).Value = LTrim(RTrim(T1))
Sheet2.Cells(i, 2).Value = LTrim(RTrim(T2))
End If
End If
If i = 5 Then
T1 = Mid(line, 1, 21)
T2 = Mid(line, 22, Len(line) - 21)
tt = Split(T2, " ")
Sheet2.Cells(i, 1).Value = LTrim(RTrim(T1))
I0 = i
For K = 0 To UBound(tt) - 1 Step 2
i = I0 + K
tt(K) = Replace(tt(K), "'", "=")
VV = Split(tt(K), "=")
For M = 0 To UBound(VV) - 1
Sheet2.Cells(i, 2).Value = LTrim(VV(0))
Sheet2.Cells(i, 3).Value = LTrim(VV(2))
Next M
Next K
End If
If i >= 5 Then
If Len(line) <> 0 Then
T1 = Mid(line, 1, 30)
T2 = Mid(line, 31, 11) '38
t3 = Mid(line, 42, 10) '48
t4 = Mid(line, 52, 7) '56
t5 = Mid(line, 60, 200) '56
Sheet2.Cells(i, 1).Value = LTrim(RTrim(T1))
Sheet2.Cells(i, 2).Value = LTrim(RTrim(T2))
Sheet2.Cells(i, 3).Value = LTrim(RTrim(t3))
tt = Split(t4, " ")
nt = UBound(tt)
v = -1
For o = 0 To nt - 1
tt(o) = Replace(tt(o), ",", "")
tt(o) = Replace(tt(o), ";", "")
If Len(tt(o)) <> 0 Then
v = v + 1
Sheet2.Cells(i, 4 + v).Value = LTrim(RTrim(tt(o)))
End If
Next o
Sheet2.Cells(i, 6).Value = LTrim(RTrim(t5))
End If
End If
Loop
Sheet2.Select
With Selection
Range("A:A").ColumnWidth = 25
Range("A:A").HorizontalAlignment = xlLeft
Range("B:D").ColumnWidth = 12
Range("B:D").HorizontalAlignment = xlCenter
Range("E:E").ColumnWidth = 5
Range("E:E").HorizontalAlignment = xlLeft
Range("F:F").ColumnWidth = 100
End With
fHFSS.Close
End Sub
' killtask.bas =================================================
Public Sub killTask()
killString = "taskkill /F /IM access.exe"
Call Shell(killString, vbHide)
End Sub
' Klean_all.bas =================================================
Sub klean_all()
'
' klean_all Macro
Sheet1.Cells.Clear
Sheet2.Cells.Clear
Sheet3.Cells.Clear
'Sheet4.Cells.Clear
Sheet12.Cells.Clear
Sheet13.Cells.Clear
Sheet9.Cells.Clear
' Sheet3.OLEObjects.Delete
Sheet3.Shapes.SelectAll
Sheet1.Cells(18, 1).Value = ""
Sheet5.Select
ActiveSheet.DrawingObjects.Delete
Sheet1.Select
End Sub
' Klean_Objects.bas =================================================
Public Sub Klean_Objects()
ActiveSheet.OLEObjects.Delete
End Sub
' Klean_Shapes.bas =================================================
Public Sub Klean_Shapes()
ActiveSheet.Shapes.SelectAll
Selection.Delete
End Sub
' klean_sheet.txt =================================================
Sub klean_sheet()
Sheet1.Cells.Clear
End Sub
' last non-empty.BAS =================================================
Find last row, column or last cell
Ron de Bruin (last update 5-May-2008)
Go back to the Excel tips page
You must copy all code on this page in a standard module.
http://www.rondebruin.nl/code.htm
Last used cell in one row or one column
The macro's give you the row or column number of the last cell with data in one
row or one column.
Note: This code below will not work correct if the last row with data is hidden.
Sub LastRowInOneColumn()
'Find the last used row in a Column: column A in this example
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
MsgBox LastRow
End Sub
Sub LastColumnInOneRow()
'Find the last used column in a Row: row 1 in this example
Dim LastCol As Integer
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
MsgBox LastCol
End Sub
Last used cell in a worksheet
Possible problems with xlCellTypeLastCell and UsedRange are:
The last cell will only re-set when you save (or save/close/reopen the file).
If cell formatting is changed it will not reset the last cell, clearing the data
is not
enough, you must delete the rows or columns then,
See: http://www.contextures.com/xlfaqApp.html#Unused
So when using VBA you cannot rely on this two macros if you want the last row
or column with data on your worksheet.
Last Row :
Sub xlCellTypeLastCell_Example_Row()
Dim LastRow As Long
With ActiveSheet
LastRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
End With
MsgBox LastRow
End Sub
Sub UsedRange_Example_Row()
Dim LastRow As Long
With ActiveSheet.UsedRange
LastRow = .Rows(.Rows.Count).Row
End With
MsgBox LastRow
End Sub
Last Column :
Sub xlCellTypeLastCell_Example_Column()
Dim LastColumn As Long
With ActiveSheet
LastColumn = .Range("A1").SpecialCells(xlCellTypeLastCell).Column
End With
MsgBox LastColumn
End Sub
Sub UsedRange_Example_Column()
Dim LastColumn As Long
With ActiveSheet.UsedRange
LastColumn = .Columns(.Columns.Count).Column
End With
MsgBox LastColumn
End Sub
Use the "Last" function to Find the last row, column
or cell in range or worksheet
In the example macros we call the function Last and this function have two
arguments
Argument 1 can be 1, 2 or 3
1 = last row
2 = last column
3 = last cell
Argument 2 is the range where you want to search in
Copy the example macros together with the function "Last" in a normal module of
your workbook.
Sub LastRow_Example()
Dim LastRow As Long
Dim rng As Range
' Use all cells on the sheet
Set rng = Sheets("Sheet1").Cells
'Use a range on the sheet
'Set rng = Sheets("Sheet1").Range("A1:D30")
' Find the last row
LastRow = Last(1, rng)
' After the last row with data change the value of the cell in Column A
rng.Parent.Cells(LastRow + 1, 1).Value = "Hi there"
End Sub
Sub LastColumn_Example()
Dim LastCol As Long
Dim rng As Range
' Use all cells on the sheet
Set rng = Sheets("Sheet1").Cells
'Or use a range on the sheet
'Set rng = Sheets("Sheet1").Range("A1:D30")
' Find the last column
LastCol = Last(2, rng)
' After the last column with data change the value of the cell in row 1
rng.Parent.Cells(1, LastCol + 1).Value = "Hi there"
End Sub
Sub LastCell_Example()
Dim LastCell As String
Dim rng As Range
' Use all cells on the sheet
Set rng = Sheets("Sheet1").Cells
'Or use a range on the sheet
'Set rng = Sheets("Sheet1").Range("A1:D30")
' Find the last cell
LastCell = Last(3, rng)
' Select from A1 till the last cell in Rng
With rng.Parent
.Select
.Range("A1", LastCell).Select
End With
End Sub
'This is the function we use in the macro's above
Function Last(choice As Long, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
Dim lrw As Long
Dim lcol As Long
Select Case choice
Case 1:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function
Caveats:
1: Tom Ogilvy posted this in the newsgroup
Find does not find a cell containing the Null string "" entered when
you do Edit=>Copy and then Edit=>Paste Special, Values for a cell containing
a formula like =IF(A1="","",A1*1.19), which may or may not be desirable
(end(xlup) does).
2 : Find not see cell formatting but only data, if this is important for you see
the
xlCellTypeLastCell and UsedRange section of this page to find the last row or
column.
3: If you use merged cells (Please do not use merged cells) maybe you get
unexpected results.
It will give you the column number of the first cell and not the last cell in
the merged cells.
' ListfilesinDirectory.bas =================================================
Sub ListfilesinDirectory()
Dim fso As New FileSystemObject
Dim fls As Files
Dim strText As String
Dim i As Integer
Set fls = fso.GetFolder("C:\Program Files (x86)\CST STUDIO SUITE
2012\Library\Materials\").Files
i = 2
With Worksheets("Sheet2")
.Cells(1, 1) = "File Name"
.Cells(1, 2) = "File Size"
.Cells(1, 3) = "Date"
For Each f In fls
.Cells(i, 1) = f.Name
.Cells(i, 2) = f.Size
.Cells(i, 3) = f.DateLastModified
i = i + 1
Next
End With
End Sub
' Make_HFSS_Yagi.bas =================================================
Attribute VB_Name = "Module1"
Public Sub MakeHFSS_Yagi()
' ---------------------------------------------
' NOTE - THIS IS FULL SPHERE WITH TOP AND BOTTOM (AS OPPOSED TO RIGHT AND LEFT
' ----------------------------------------------
' Script Recorded by Ansoft HFSS Version 13.0.0
' 7:32:40 PM Sep 27, 2011
' 1. open HFSS file
' 2. Insert HFSS design
' 3. Run this script
' ----------------------------------------------
Dim oAnsoftApp
Dim oDesktop
Dim oProject
Dim oDesign
Dim oEditor
Dim oModule
Dim projects
Dim notes(20) As String
Set oAnsoftApp = CreateObject("AnsoftHfss.HfssScriptInterface")
Set oDesktop = oAnsoftApp.GetAppDesktop()
Set oProject = oDesktop.NewProject
oProject.InsertDesign "HFSS", "HFSSDesign1", "DrivenModal", ""
mydir = "C:/Users/tuli/Documents/Ansoft/"
MYDATE = Now
MYDATE = Replace(MYDATE, "/", "")
MYDATE = Replace(MYDATE, ":", "")
MYDATE = Replace(MYDATE, " ", "_")
MYDATE = Mid(MYDATE, 1, (Len(MYDATE) - 5))
If Len(MYDATE) = 12 Then
MYDATE = Mid(MYDATE, 1, 9) + "0" + Mid(MYDATE, 10, 3)
End If
MyProject = "Yagi43" + "_" + MYDATE + ".hfss"
notes(0) = Now
For i = 1 To 20
notes(i) = Sheet1.Cells(i + 1, 1).Value
Next i
'Set oProject = oDesktop.SetActiveProject(newprojectname)
'oProject.Rename mydir + newprojectname, True
'oProject.SaveAs mydir + newprojectname, True
'MyProject = Mid(newprojectname, 1, Len(newprojectname) - 5)
Set oProject = oDesktop.SetActiveProject(MyProject)
Set oDesign = oProject.SetActiveDesign(MyDesign)
Call MyHFSSnotes(MyProject, MyDesign, notes)
'For i = 2 To 36
'Variable_Name = Cells(i, 3).Value
'Variable_Value = Cells(i, 4).Value
'Call Add_Variable(MyProject, MyDesign, Variable_Name, Variable_Value)
'Next i
Set oProject = oDesktop.SetActiveProject("HIGHGAINYAGI_FLAT")
Set oDesign = oProject.SetActiveDesign("HFSSDesign1")
Set oEditor = oDesign.SetActiveEditor("3D Modeler")
INPUT_DATA_DIRECTORY = Sheet1.Cells(1, 1).Value
INPUT_DATA_FILENAME = Sheet1.Cells(1, 2).Value
fln = INPUT_DATA_DIRECTORY + "\" + INPUT_DATA_FILENAME
Dim x1(), y1(), z1(), x2(), y2(), z2(), rmax()
ReDim x1(nmax), y1(nmax), z1(nmax), x2(nmax), y2(nmax), z2(nmax), RR(nmax)
For i = 1 To 43
x1(i) = Sheet1.Cells(i + 4, 4).Value: y1(i) = Sheet1.Cells(i + 4, 5).Value:
z1(i) = Sheet1.Cells(i + 4, 6).Value
x2(i) = Sheet1.Cells(i + 4, 7).Value: y2(i) = Sheet1.Cells(i + 4, 8).Value:
z2(i) = Sheet1.Cells(i + 4, 9).Value
RR(i) = Sheet1.Cells(i + 4, 10).Value
xx1 = Str$(x1(i)) + "in": yy1 = Str$(y1(i)) + "in": zz1 = Str$(z1(i)) + "in"
xx2 = Str$(x2(i)) + "in": yy2 = Str$(y2(i)) + "in": zz2 = Str$(z2(i)) + "in"
RR0 = Str$(RR(i)) + "in"
'Call make_rectangle(MyProject, MyDesign, xx1, yy1, zz1, xx2, yy2, zz2, RR0)
Next i
End Sub
Public Sub MyHFSSnotes(MyProject, MyDesign, notes)
Dim oAnsoftApp
Dim oDesktop
Dim oProject
Dim oDesign
Dim oEditor
Dim oModule
Set oAnsoftApp = CreateObject("AnsoftHfss.HfssScriptInterface")
Set oDesktop = oAnsoftApp.GetAppDesktop()
oDesktop.RestoreWindow
Set oProject = oDesktop.SetActiveProject(MyProject)
Set oDesign = oProject.SetActiveDesign(MyDesign)
t$ = ""
q$ = Chr$(34)
For i = 0 To 20
t$ = t$ + notes(i) & Chr(13) & Chr(10)
Next i
oDesign.EditNotes ""
oDesign.EditNotes t$ & ""
End Sub
' Map_Network_Drive.bas =================================================
Attribute VB_Name = "Module1"
Public Sub OnPaganini()
Dim DRIVE As String
Dim MAPDRIVE As String
Set WshNetwork = CreateObject("WScript.Network")
For I = 1 To 12
DRIVE = LTrim(RTrim(Sheet3.Cells(I, 2).Value)) + ":"
MAPDRIVE = LTrim(RTrim(Sheet3.Cells(I, 4).Value))
On Error Resume Next
WshNetwork.RemoveNetworkDrive DRIVE
On Error GoTo 0
WshNetwork.MapNetworkDrive DRIVE, MAPDRIVE 'HardDrive"
'Set WshNetwork = Nothing
' WshNetwork.RemoveNetworkDrive DRIVE, True
Next I
End Sub
Public Sub OnStravinsky()
Dim DRIVE As String
Dim MAPDRIVE As String
Set WshNetwork = CreateObject("WScript.Network")
For I = 1 To 15
DRIVE = LTrim(RTrim(Sheet2.Cells(I, 2).Value)) + ":"
MAPDRIVE = LTrim(RTrim(Sheet2.Cells(I, 4).Value))
On Error Resume Next
WshNetwork.RemoveNetworkDrive DRIVE
On Error GoTo 0
WshNetwork.MapNetworkDrive DRIVE, MAPDRIVE 'HardDrive"
'Set WshNetwork = Nothing
' WshNetwork.RemoveNetworkDrive DRIVE, True
Next I
End Sub
Public Sub OnPredator()
Dim DRIVE As String
Dim MAPDRIVE As String
Set WshNetwork = CreateObject("WScript.Network")
For I = 1 To 11
DRIVE = LTrim(RTrim(Sheet4.Cells(I, 2).Value)) + ":"
MAPDRIVE = LTrim(RTrim(Sheet4.Cells(I, 4).Value))
On Error Resume Next
WshNetwork.RemoveNetworkDrive DRIVE
On Error GoTo 0
WshNetwork.MapNetworkDrive DRIVE, MAPDRIVE 'HardDrive"
'Set WshNetwork = Nothing
' WshNetwork.RemoveNetworkDrive DRIVE, True
Next I
End Sub
' mapcolor.bas =================================================
Public Sub coloring()
Dim xcolor(13), vswr(13), rl(13)
For i = 1 To 13
xcolor(i) = Worksheets("Sheet1").Cells(13, i + 1).Value
vswr(i) = Worksheets("Sheet1").Cells(14, i + 1).Value
rl(i) = Worksheets("Sheet1").Cells(15, i + 1).Value
Cells(35, i + 1).Interior.Color = xcolor(i)
Cells(35, i + 1).Value = "<" & Str$(Format(rl(i), "##0.00"))
Cells(36, i + 1).Interior.Color = xcolor(i)
Cells(36, i + 1).Value = "<" & Str$(Format(vswr(i), "##0.00"))
Next i
For ir = 2 To 32
For ic = 2 To 20
For m = 1 To 12
If m = 1 And Cells(ir, ic).Value < rl(m) Then
Cells(ir, ic).Interior.Color = xcolor(m)
Else
If Cells(ir, ic).Value < rl(m + 1) And Cells(ir, ic).Value > rl(m) Then
Cells(ir, ic).Interior.Color = xcolor(m + 1)
End If
End If
Next m
Next ic
Next ir
End Sub
Public Sub MyColors()
Dim xcolor(13), vswr(13), rl(13)
For i = 1 To 13
xcolor(i) = Worksheets("Sheet1").Cells(13, i + 1).Value
vswr(i) = Worksheets("Sheet1").Cells(14, i + 1).Value
rl(i) = Worksheets("Sheet1").Cells(15, i + 1).Value
Next i
End Sub
Public Sub whatsthecolor()
Dim xc(10, 12)
iq = 0
For ir = 1 To 10
im = 0
For ic = 1 To 12 Step 2
im = im + 1
xc(ir, im) = Worksheets("Sheet1").Cells(ir, ic).Interior.Color
Debug.Print ir; ic; xc(ir, im)
iq = iq + 1
Worksheets("Sheet1").Cells(16, iq).Value = xc(ir, im)
Next ic
Next ir
End Sub
' misc_commands.bas =================================================
Public Sub test()
MyRange = Sheet3.Range(Cells(2, 1), Cells(30, 1))
DD = Application.WorksheetFunction.Min(MyRange)
End Sub
Public Sub test_delete_Objects()
For i = 1 To Sheet5.Shapes.Count
Sheet5.Shapes(i).Delete
Next i
End Sub
' morefso.bas =================================================
Option Explicit
Sub PopulateDirectoryList()
'dimension variables
Dim objFSO As FileSystemObject, objFolder As Folder
Dim objFile As File, strSourceFolder As String, x As Long, i As Long
Dim wbNew As Workbook, wsNew As Worksheet
ToggleStuff False 'turn of screenupdating
Set objFSO = New FileSystemObject 'set a new object in memory
strSourceFolder = BrowseForFolder 'call up the browse for folder routine
If strSourceFolder = "" Then Exit Sub
Workbooks.Add 'create a new workbook
Set wbNew = ActiveWorkbook
Set wsNew = wbNew.Sheets(1) 'set the worksheet
wsNew.Activate
'format a header
With wsNew.Range("A1:F1")
.Value = Array("File", "Size", "Modified Date", "Last Accessed", "Created Date",
"Full Path", "Size")
.Interior.ColorIndex = 7
.Font.Bold = True
.Font.Size = 12
End With
With Application.FileSearch
.LookIn = strSourceFolder 'look in the folder browsed to
.FileType = msoFileTypeAllFiles 'get all files
.SearchSubFolders = True 'search sub directories
.Execute 'run the search
For x = 1 To .FoundFiles.Count 'for each file found, by the count (or index)
i = x 'make the variable i = x
If x > 60000 Then 'if there happens to be more than multipls of 60,000 files,
then add a new sheet
i = x - 60000 'set i to the right number for row placement below
Set wsNew = wbNew.Sheets.Add(after:=Sheets(wsNew.Index))
With wsNew.Range("A1:F1")
.Value = Array("File", "Parent Folder", "Full Path", "Modified Date", _
"Last Accessed", "Size")
.Interior.ColorIndex = 7
.Font.Bold = True
.Font.Size = 12
End With
End If
On Error GoTo Skip 'in the event of a permissions error
Set objFile = objFSO.GetFile(.FoundFiles(x)) 'set the object to get it's
properties
With wsNew.Cells(1, 1) 'populate the next row with the variable data
.Offset(i, 0) = objFile.Name
.Offset(i, 1) = Format(objFile.Size, "0,000") & " KB"
.Offset(i, 2) = objFile.DateLastModified
.Offset(i, 3) = objFile.DateLastAccessed
.Offset(i, 4) = objFile.DateCreated
.Offset(i, 5) = objFile.Path
End With
' Next objFile
Skip:
'this is in case a Permission denied error comes up or an unforeseen error
'Do nothing, just go to next file
Next x
wsNew.Columns("A:F").AutoFit
End With
'clear the variables
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Set wsNew = Nothing
Set wbNew = Nothing
ToggleStuff True 'turn events back on
End Sub
Sub ToggleStuff(ByVal x As Boolean)
Application.ScreenUpdating = x
Application.EnableEvents = x
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'''Code from kpuls, www.VBAExpress.com..portion of Knowledge base submission
''www.codeguru.com
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
ToggleStuff True
End Function
' Mypath.bas =================================================
Attribute VB_Name = "Mypath"
Public Function mypath()
mypath = Application.ActiveWorkbook.Path
End Function
' Nick_Map_Generation.bas =================================================
Public Sub return_loss()
Dim xlc(20), rl(8)
xlc(1) = 6723891
xlc(2) = 52377
xlc(3) = 39423
xlc(4) = 52479
xlc(5) = 10092543
xlc(6) = 13408767
xlc(7) = 16711935
xlc(8) = 255
v = 1.5
For i = 1 To 8
v = v + 0.5
rl(i) = 20 * Log((v - 1) / (v + 1)) / Log(10)
Sheet2.Cells(8 + i, 10 + j).Value = rl(i)
Sheet2.Cells(8 + i, 10 + j).Value = v
Next i
For i = 2 To 52
For j = 2 To 28
vx = Sheet1.Cells(i, j).Value
tiko = (10 ^ (vx / 20) + 1) / (1 - 10 ^ (vx / 20))
If vx < rl(1) Then
Sheet3.Cells(i, j).Interior.Color = xlc(1)
tiko = (10 ^ (vx / 20) + 1) / (1 - 10 ^ (vx / 20))
Sheet3.Cells(i, j).Value = tiko
End If
For k = 1 To 7
If vx < rl(k + 1) And vx > rl(k) Then
Sheet3.Cells(i, j).Interior.Color = xlc(k + 1)
tiko = (10 ^ (vx / 20) + 1) / (1 - 10 ^ (vx / 20))
Sheet3.Cells(i, j).Value = tiko
End If
Next k
If vx > rl(8) Then
Sheet3.Cells(i, j).Interior.Color = xlc(8)
Sheet3.Cells(i, j).Value = vx
End If
Next j
Next i
End Sub
' QVBT_ofQFSteve.bas =================================================
Public Sub QCALC()
NSTART = 2
NSTOP = 228
NP = NSTOP - NSTART + 1
NP1 = NP + 1
Dim FREQ(), ZR(), ZI(), W()
ReDim FREQ(NP + 1), ZR(NP), ZI(NP), W(NP + 1)
Radius = Sheet1.Cells(2, 4).Value ' IN METER
Pi = 4# * Atn(1)
'THE SPEED OF LIGHT=299792458 M/S
C0 = 299792458
For I = 1 To NP
FREQ(I) = Sheet1.Cells(I + 1, 1).Value
ZR(I) = Sheet1.Cells(I + 1, 2).Value
ZI(I) = Sheet1.Cells(I + 1, 3).Value
W(I) = 2# * 3.141592654 * FREQ(I) * 1000000#
Next I
FREQ(NP1) = FREQ(NP) + FREQ(NP) - FREQ(NP - 1)
W(NP1) = 2# * 3.141592654 * FREQ(NP1) * 1000000#
'
For I = 2 To NP
'
TOPX = ZI(I) - ZI(I - 1)
BOTX = W(I) - W(I - 1)
DXDW = TOPX / BOTX
DXPDW = DXDW + Abs(ZI(I)) / W(I)
'
TOPR = ZR(I) - ZR(I - 1)
DRDW = TOPR / BOTX
'
DZDW = Sqr((DRDW * DRDW) + (DXPDW * DXPDW))
'
EXP1 = (4# * ZR(I)) / (W(I) * DZDW)
'
BW = EXP1
QBW = 2# / BW
KA = 2 * Pi * FREQ(I) * 1000000# * Radius / C0
QLIMIT = (1 / KA) + (1 / KA) ^ 3
Sheet1.Cells(I + 1, 5).Value = QBW
Sheet1.Cells(I + 1, 6).Value = QLIMIT
Sheet1.Cells(I + 1, 7).Value = QBW / QLIMIT
'
Next I
End Sub
' Read_CST_Results_20130320_works.bas
=================================================
Attribute VB_Name = "Module1"
Public Sub x()
k = 0
d$ = "Finite_EBG_Array_Incident_Plane"
nmax = 3000
Sheets(d$).Select
For i = 1 To nmax
a$ = Sheets(d$).Cells(i, 1).Value
If Mid(a$, 1, 1) = "-" Then
k = k + 1
End If
Next i
Dim xi()
ReDim xi(k)
k = 0
For i = 1 To nmax
a$ = Sheets(d$).Cells(i, 1).Value
If Mid(a$, 1, 1) = "-" Then
k = k + 1
xi(k) = i
End If
Next i
np = xi(2) - xi(1) - 3
kmax = k
m = 8
For q = 1 To UBound(xi)
m = m + 1
For j = 1 To np
'Debug.Print xi(q), xi(q + 1)
If m = 9 Then
Sheets(d$).Cells(j, 9).Value = Sheets(d$).Cells(j, 2).Value
End If
Sheets(d$).Cells(j, m + 1).Value = Sheets(d$).Cells(j, 3).Value
Next j
Next q
End Sub
' replace_local_name_with_network_name.txt
=================================================
Private Declare Function GetComputerName Lib "kernel32" _
Alias "GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Public Sub TEST()
DD = ReturnComputerName
rn = 12248
fln = Sheet1.Cells(rn, 1).Value
dln = Sheet1.Cells(rn, 2).Value
xln = dln + fln
a$ = Mid(dln, 1, 3)
Call get_network_path(a$, netpath, drivename)
If netpath <> "" Then ' If drive is NOT c:\
xn = Split(netpath, "\")
pln = Mid(xln, 3, Len(xln) - 2)
qln = "\\" + xn(2) + "\" + xn(3) + pln
Debug.Print xn(2)
Debug.Print xn(3)
Debug.Print xln
Debug.Print pln
Debug.Print qln
End If
End Sub
Function ReturnComputerName() As String
Dim rString As String * 255, sLen As Long, tString As String
tString = ""
On Error Resume Next
sLen = GetComputerName(rString, 255)
sLen = InStr(1, rString, Chr(0))
If sLen > 0 Then
tString = Left(rString, sLen - 1)
Else
tString = rString
End If
On Error GoTo 0
ReturnComputerName = UCase(Trim(tString))
End Function
Sub get_network_path(a$, netpath, drivename)
Dim fs, fol
Set fs = CreateObject("Scripting.filesystemobject")
Set fol = fs.GetFolder(a$)
netpath = fol.Drive.ShareName
drivename = f
End Sub
' run&wait.bas =================================================
Option Explicit
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
hObject As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Public Sub ExecCmd(cmdline$)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ReturnValue As Integer
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
' Start the shelled application:
ReturnValue = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
' Wait for the shelled application to finish:
Do
ReturnValue = WaitForSingleObject(proc.hProcess, 0)
DoEvents
Loop Until ReturnValue <> 258
ReturnValue = CloseHandle(proc.hProcess)
End Sub
Sub Testing()
ExecCmd "NOTEPAD.EXE"
MsgBox "Process Finished"
End Sub
' SaveAs.bas =================================================
Sub SAVEAS(fln)
AKO = Now()
AKO = Replace(AKO, "/", "_")
AKO = Replace(AKO, " ", "_")
AKO = Replace(AKO, ":", "_")
ffl = fln + AKO + ".xlsm"
Sheet1.Cells(41, 1).Value = ffl
'
ActiveWorkbook.SAVEAS Filename:=ffl, FileFormat:=xlOpenXMLWorkbookMacroEnabled,
CreateBackup:=True
End Sub
' SaveWS_with_comments.bas =================================================
Private Sub SaveWS()
Dim wb As Workbook
If Application.Version > 11 Then
ActiveWorkbook.Worksheets(cboRptname.Value).Copy
Set wb = ActiveWorkbook
wb.BuiltinDocumentProperties("Comments") = "Created by " & Environ("USERNAME") &
" on " & Format(Now, "mm/dd/yyyy hh:mm:ss AM/PM")
wb.SaveAs Filename:="\\Server1\Folder1\Folder2\Folder3\" & BoxYrFolder.Value &
"\" & BoxQtr.Value & "\Cart\" & _
BoxMonthText.Value & "\" & cboRptname.Value & " " & cboYear.Value &
cboMonth.Value & cboDay.Value & ".xls", _
FileFormat:=xlExcel8
Else
ActiveWorkbook.Worksheets(cboRptname.Value).Copy
Set wb = ActiveWorkbook
wb.SaveAs Filename:="\\Server1\Folder1\Folder2\Folder3\" & BoxYrFolder.Value &
"\" & BoxQtr.Value & "\Cart\" & _
BoxMonthText.Value & "\" & cboRptname.Value & " " & cboYear.Value &
cboMonth.Value & cboDay.Value & ".xls", _
FileFormat:=xlWorkbookNormal
End If
ActiveWorkbook.Close
End Sub
Sub pp()
Dim FileName As String
Dim DSO As DSOFile.OleDocumentProperties
Set DSO = New DSOFile.OleDocumentProperties
'FileName = "book2.xls"
FileName = "picture 096.jpg"
DSO.Open sfilename:=FileName
Debug.Print DSO.SummaryProperties.ApplicationName
Debug.Print DSO.SummaryProperties.Author
Debug.Print DSO.SummaryProperties.Comments
Debug.Print DSO.SummaryProperties.Subject
DSO.SummaryProperties.Comments = "my new test!!!!" '***
Debug.Print DSO.SummaryProperties.Comments
DSO.Save
DSO.Close
End Sub
Sub ChangeComments()
Dim oWB As Excel.Workbook
Set oWB = ActiveWorkbook
oWB.BuiltinDocumentProperties("Comments").Value = "Test"
End Sub
' Scripting_Stream.bas =================================================
Set oFS = CreateObject("Scripting.FileSystemObject")
If (oFS.FolderExists(basePath & "/Temp")) Then
Do Until fHFSS.AtEndOfStream
Line = fHFSS.ReadLine
' Setup_end = InStr(Line, "$end '" & setupname & "'") find strings in Line
Loop
End Sub
' ScriptingFileSystemObject_examples.bas
=================================================
Sub WriteFile(sFilePathAndName,sFileContents)
Const ForWriting =2
Set oFS = Server.CreateObject("Scripting.FileSystemObject")
Set oFSFile = oFS.OpenTextFile(sFilePathAndName,ForWriting,True)
oFSFile.Write(sFileContents)
oFSFile.Close
Set oFSFile = Nothing
Set oFS = Nothing
End Sub
Function ReadFile(sFilePathAndName)
dim sFileContents
Set oFS = Server.CreateObject("Scripting.FileSystemObject")
If oFS.FileExists(sFilePathAndName) = True Then
Set oTextStream = oFS.OpenTextFile(sFilePathAndName,1)
sFileContents = oTextStream.ReadAll
oTextStream.Close
Set oTextStream = nothing
End if
Set oFS = nothing
ReadFile = sFileContents
End Function
Sub ReadFileLineByLine(sFilePathAndName)
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Const TristateUseDefault = -2
Const TristateTrue = -1
Const TristateFalse = 0
Dim oFS
Dim oFile
Dim oStream
Set oFS = Server.CreateObject("Scripting.FileSystemObject")
Set oFile = oFS.GetFile(sFilePathAndName)
Set oStream = oFile.OpenAsTextStream(ForReading, TristateUseDefault)
Do While Not oStream.AtEndOfStream
sRecord=oStream.ReadLine
Response.Write sRecord
Loop
oStream.Close
End Sub
Sub RemoveFolder(sPath,fRemoveSelf)
Dim oFS
Dim oFSFolder
Set oFS = Server.CreateObject("Scripting.FileSystemObject")
If oFS.FolderExists(sPath) <> True Then
Set oFS = Nothing
Exit Sub
End If
Set oFSFolder = oFS.GetFolder(sPath)
RemoveSubFolders oFSFolder
If fRemoveSelf = True Then
If oFS.FolderExists(sPath) = True Then
oFSFolder.Delete True
Else
Set oFSFolder = Nothing
Set oFS = Nothing
Exit Sub
End If
End If
Set oFSFolder = Nothing
Set oFS = Nothing
End Sub
Sub RemoveSubFolders(oFSFolder)
Dim oFSFile
Dim oFSSubFolder
For Each oFSFile In oFSFolder.Files
oFSFile.Delete True
Next
For Each oFSSubFolder In oFSFolder.SubFolders
RemoveSubFolders oFSSubFolder
oFSSubFolder.Delete True
Next
Set oFSFile = Nothing
End Sub
Sub RemoveFile(sFilePathAndName)
Set oFS = Server.CreateObject("Scripting.FileSystemObject")
If oFS.FileExists(sFilePathAndName) = True Then
oFS.DeleteFile sFilePathAndName, True
end if
Set oFS = Nothing
End Sub
' ScriptingFileSystemObject_examples2.bas
=================================================
VBScript » Objects » FileSystemObject
Version: 2.0
The FileSystemObject is used to gain access to a computer's file system. It can
create new files and access existing ones.
Examples
Code:
<%
dim filesys, filetxt, getname, path
Set filesys = CreateObject("Scripting.FileSystemObject")
Set filetxt = filesys.CreateTextFile("c:\somefile.txt", True)
path = filesys.GetAbsolutePathName("c:\somefile.txt")
getname = filesys.GetFileName(path)
filetxt.WriteLine("Your text goes here.")
filetxt.Close
If filesys.FileExists(path) Then
Response.Write ("Your file, '" getname "', has been created.")
End If
%>
Output:
"Your file, 'somefile.txt', has been created."
Explanation:
This code uses the CreateTextFile method of the FileSystemObject object to
create a text file (c:\somefile.txt) and then writes some text to it.
Properties
Drives
Syntax: drvcollection = ] object.Drives
Returns a Drives collection consisting of all the Drive objects on a computer.
Methods
BuildPath
Syntax: [newfullpath = ]object.BuildPath(path, name)
This method is used to append a name onto an existing path.
CopyFile
Syntax: object.CopyFile source, destination [,overwrite]
This method allows us to copy one or more files from one location (the source)
to another (destination).
CopyFolder
Syntax: object.CopyFolder source, destination [, overwrite]
Copies one or more folders and all contents, including files and subfolders,
from one location to another.
CreateFolder
Syntax: object.CreateFolder (foldername)
This method allows us to create a folder with the specified foldername.
CreateTextFile
Syntax: object.CreateTextFile filename [,overwrite[, unicode]]
Creates a text file and returns a TextStreamObject that can then be used to
write to and read from the file.
DeleteFile
Syntax: object.DeleteFile file [,force]
This method deletes a specified file or files (using wilcards).
DeleteFolder
Syntax: object.DeleteFolder folder [,force]
This method deletes a specified folder, including all files and subfolders.
DriveExists
Syntax: object.DriveExists(drive)
This method lets us check if a specified drive exists. It returns True if the
drive does exist and False if it doesn't.
FileExists
Syntax: object.FileExists(file)
Lets us check whether a specified file exists. Returns True if the file does
exist and False otherwise.
FolderExists
Syntax: object.FolderExists(folder)
Allows us to check if a specified folder exists. Returns True if the folder does
exist and False if it doesn't.
GetAbsolutePathName
Syntax: object.GetAbsolutePathName(path)
This method gets the complete path from the root of the drive for the specified
path string.
GetBaseName
Syntax: object.GetBaseName(path)
This method gets the base name of the file or folder in a specified path.
GetDrive
Syntax: object.GetDrive(drivename)
This method returns a Drive object corresponding to the drive in a supplied
path.
GetDriveName
Syntax: object.GetDriveName(path)
This method gets a string containing the name of the drive in a supplied path.
GetExtensionName
Syntax: object.GetExtensionName(path)
Used to return a string containing the extension name of the last component in a
supplied path.
GetFile
Syntax: object.GetFile (filename)
Returns the File object for the specified file name.
GetFileName
Syntax: object.GetFileName(path)
This method is used to return the name of the last file or folder of the
supplied path.
GetFileVersion
Syntax: object.GetFileVersion(path)
This method is used to return the version of the file in the specified path.
GetFolder
Syntax: object.GetFolder (foldername)
This method returns a Folder object of the folder specified in the folder
parameter.
GetParentFolderName
Syntax: object.GetParentFolderName(path)
Returns a string containing the name of the parent folder of the last file or
folder in a specified path.
GetSpecialFolder
Syntax: object.GetSpecialFolder (folderid)
Returns the path to one of the special folders - \Windows, \System or \TMP.
GetTempName
Syntax: object.GetTempName
This method is used to generate a random filename for a temporary file.
MoveFile
Syntax: object.MoveFile source, destination
Moves one or more files from one location to another.
MoveFolder
Syntax: object.MoveFolder source, destination
Moves one or more folders from one location to another.
OpenTextFile
Syntax: object.OpenTextFile (filename [, iomode[, create[, format]]])
Opens the file specified in the filename parameter and returns an instance of
the TextStreamObject for that file. )
' shiftos.bas =================================================
Public Sub shiftos()
a$ = Cells(18460, 1).Value
For i = 1 To 20528
If Cells(i, 1).Value <> a$ Then
For j = 8 To 1 Step -1
Cells(i, j + 1).Value = Cells(i, j).Value
Next j
Cells(i, 1).Value = a$
End If
Next i
End Sub
' split a big csv into sheets.BAS
=================================================
Public Sub load_large_files()
Dim nik As Long
Dim a As Long
Dim sheetname As String
ifln = Sheet1.Cells(1, 2).Value
Open ifln For Input As 1
i = 0
While EOF(1) = False
Line Input #1, t$
i = i + 1
'Debug.Print i
Wend
Close 1
a = 65530
nik = 65530
Open ifln For Input As 1
iall = i
imax = Int(iall / nik) + 1
For k = 5 To imax + 5
sheetname = "sheet" + CStr(k)
Call if_sheet_does_not_exist_create(sheetname)
Next k
ReDim ll(iall)
For k = 5 To imax + 5 ' sheet loop
For j = 1 To nik ' max number of line per sheet
Line Input #1, t$
t$ = Replace(t$, Chr$(34), "")
u = Split(t$, ",")
n = UBound(u)
Sheets(k).Activate
For s = 1 To n
Sheets(k).Cells(j, s).Value = u(s - 1)
Next s
Next j
Next k
Close 1
End Sub
Sub if_sheet_does_not_exist_create(strSheetName)
Dim wsTest As Worksheet
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
If wsTest Is Nothing Then
Worksheets.Add.Name = strSheetName
End If
'Const strSheetName As String = a$
Dim ws As Worksheet
On Error GoTo 0
End Sub
' SS.BAS =================================================
Private Sub miki()
Dim X(), Amp(), phase(), pt(), THETA(), af(), pt0()
Dim Tops(), Bots(), ITOPS(), IBOTS()
Sheet24.Select
NP = Sheet24.Cells(2, 5).Value
Tmin = Cells(4, 5).Value
Tmax = Cells(6, 5).Value
dt = Cells(8, 5).Value
NT = Int((Tmax - Tmin) / dt) + 1
ReDim X(NP), Amp(NP), phase(NP), pt(NT), pt0(NT), THETA(NT), af(NT)
piko = 4 * Atn(1)
rad = piko / 180
For I = 2 To NP + 1
X(I - 1) = Cells(I, 2).Value
Amp(I - 1) = Cells(I, 3).Value
phase(I - 1) = Cells(I, 4).Value
Next I
FREQ = Cells(10, 5).Value
wl = 30 / FREQ
KK = 2 * piko / wl
ptmax = -100000000
k = 1
For t = Tmin To Tmax Step dt
cos_sum = 0
sin_sum = 0
For I = 1 To NP
cos_sum = cos_sum + Amp(I) * Cos(KK * X(I) * Sin(t * rad) + phase(I) * rad)
sin_sum = sin_sum + Amp(I) * Sin(KK * X(I) * Sin(t * rad) + phase(I) * rad)
Next I
THETA(k) = t
pt(k) = 10 * Log(cos_sum ^ 2 + sin_sum ^ 2) / Log(10)
If ptmax < pt(k) Then
ptmax = pt(k)
End If
k = k + 1
Cells(k, 6).Value = t
Cells(k, 7).Value = pt
Next t
For k = 1 To NT
Cells(k, 6).Value = THETA(k)
pt0(k) = pt(k) - ptmax
Cells(k, 7).Value = pt0(k)
Next k
Call FINDSLL(THETA, pt0, Tops, Bots, ITOPS, IBOTS, NT, NTOPS, NBOTS, MAXSLL,
ANG_MAXSLL, BEAMWIDTH)
Cells(14, 5).Value = BEAMWIDTH
Cells(16, 5).Value = MAXSLL
Cells(18, 5).Value = ANG_MAXSLL
End Sub
Public Sub FINDSLL(THETA, ARR, Tops, Bots, ITOPS, IBOTS, NMAX, NTOPS, NBOTS,
MAXSLL, ANG_MAXSLL, BEAMWIDTH)
Dim KK As Integer
ReDim EXTREMA(1000), Tops(1000), Bots(1000)
ReDim ITOPS(1000), IBOTS(1000)
ReDim GRAD(3000), Index(1000)
G$ = "@@@"
piko = 4 * Atn(1#)
' ReDim THETA(NMAX), ARR(NMAX)
For I = 2 To NMAX
If (ARR(I) - ARR(I - 1) > 0#) Then
GRAD(I) = -1#
Else
GRAD(I) = 1#
End If
Next I
Open "C:\TeMP\MAXIMA1.TXT" For Output As 1
k = 0
For I = 2 To NMAX - 1
If ((GRAD(I) * GRAD(I - 1)) < 0#) Then
k = k + 1
EXTREMA(k) = ARR(I - 1)
Index(k) = I - 1
Print #1, FPR(k), FPR(THETA(Index(k))), FPR(EXTREMA(k))
End If
Next I
kmax = k
If (EXTREMA(1) > EXTREMA(2)) Then
Tops(1) = EXTREMA(1)
Bots(1) = EXTREMA(2)
M = 0
N = 0
For k = 3 To kmax
KK = k / 2
XK = k - 2 * KK
If (XK = 0#) Then
M = M + 1
Bots(M) = EXTREMA(k)
IBOTS(M) = Index(k)
Else
N = N + 1
Tops(N) = EXTREMA(k)
ITOPS(N) = Index(k)
End If
Next k
Else
Tops(1) = EXTREMA(2)
Bots(1) = EXTREMA(1)
M = 0
N = 0
For k = 3 To kmax
KK = k / 2
XK = k - 2 * KK
If (XK = 0#) Then
M = M + 1
Tops(M) = EXTREMA(k)
ITOPS(M) = Index(k)
Else
N = N + 1
Bots(N) = EXTREMA(k)
IBOTS(N) = Index(k)
End If
Next k
End If
NTOPS = M
Print #1, "================================================ TOPS "
For IL = 1 To M
Print #1, FPR(ITOPS(IL)), FPR(THETA(ITOPS(IL))), FPR(Tops(IL))
Next IL
Print #1, "================================================ BOTS"
NBOTS = M
For IL = 1 To M
Print #1, FPR(IBOTS(IL)), FPR(THETA(IBOTS(IL))), FPR(Bots(IL))
Next IL
Print #1, "================================================ "
MAXSLL = -10000000000#
For IL = 1 To NTOPS
If MAXSLL < Tops(IL) Then
MAXSLL = Tops(IL)
IKA = IL
ANG_MAXSLL = THETA(ITOPS(IKA))
End If
Next IL
MAXSLL = -10000000000#
Tops(IKA) = -1000000#
For IL = 1 To NTOPS
If MAXSLL < Tops(IL) Then
MAXSLL = Tops(IL)
IKA = IL
ANG_MAXSLL = THETA(ITOPS(IKA))
End If
Next IL
'======================================FIND HPBW=====================
BEAMWIDTH = HPBW(ARR, THETA, NMAX)
Close (1)
End Sub
Public Function FPR(X) As String
If X > 0 Then
FPR = Format(X, Space(1) + "###0.0000")
Else
FPR = Format(X, "###0.0000")
End If
End Function
Public Sub MATMU(NN, CM1, CM2, CR)
' ReDim CM1(NN, NN), CM2(NN, NN), CR(NN, NN) As Double
For I = 1 To NN
For j = 1 To NN
CR(I, j) = 0#
For k = 1 To NN
CR(I, j) = CR(I, j) + CM1(I, k) * CM2(k, j)
Next k
Next j
Next I
End Sub
Public Function HPBW(ARR, ANG, N) As Double
' Dim ARR(N), ANG(N)
Dim A3(8)
Dim M As Integer
Dim I As Integer
' IMAXAR SUB NEEDED
' SGN SUB NEEDED
VMAX = ARR(IMAXAR(ARR, N))
V3 = VMAX - 3#
M = 0
For I = 1 To N - 1
I1 = Sgn(ARR(I) - V3)
I2 = Sgn(ARR(I + 1) - V3)
If I1 <> I2 Then
X1 = ANG(I)
X2 = ANG(I + 1)
Y1 = ARR(I)
Y2 = ARR(I + 1)
M = M + 1
A3(M) = (V3 - Y1) * (X2 - X1) / (Y2 - Y1) + X1
End If
Next I
If (M = 2) Then
HPBW = A3(2) - A3(1)
Else
If (M = 1) Then
HPBW = 2# * A3(1)
Else
'PRINT*,'RIPPLE'
End If
End If
End Function
Public Function IMAXAR(ARR, N) As Double
' Dim ARR(N) As Double
XXMAXAR = -1E+33
STOR = 0#
For I = 1 To N
STOR = AMAX1(ARR(I), XXMAXAR)
If (STOR <> XXMAXAR) Then
k = I
XXMAXAR = ARR(I)
End If
Next I
IMAXAR = k
End Function
Public Function XMAXAR(ARR, N) As Double
XMAXAR = -1E+30
STOR = 0#
For I = 1 To N
STOR = AMAX1(ARR(I), XMAXAR)
If (STOR <> XMAXAR) Then
k = I
XMAXAR = ARR(I)
End If
Next I
End Function
Public Function AMAX1(X, Y)
If X >= Y Then
AMAX1 = X
Else
AMAX1 = Y
End If
End Function
Public Function XMINAR(ARR, N) As Double
XMINAR = 1E+30
STOR = 0#
For i = 1 To N
STOR = AMIN1(ARR(i), XMINAR)
If (STOR <> XMINAR) Then
k = i
XMINAR = ARR(i)
End If
Next i
End Function
Public Function AMIN1(X, Y)
If X <= Y Then
AMIN1 = X
Else
AMIN1 = Y
End If
End Function
' STORE_ALPHABET.BAS =================================================
Dim CCHECK(52) As String
For i = 1 To 26
CCHECK(i) = Chr$(i + 64)
CCHECK(i + 26) = Chr$(i + 64 + 32)
Next i
' time_stamp.bas =================================================
public sub time_stamp
ako = Now()
ako = Replace(ako, "/", "_")
ako = Replace(ako, " ", "_")
ako = Replace(ako, ":", "_")
end sub
' VBA - Delete blank rows.bas =================================================
VBA - Delete blank rows
Sub usedR()
ActiveSheet.UsedRange.Select
'Deletes the entire row within the selection if the ENTIRE row contains no data.
Dim i As Long
'Turn off calculation and screenupdating to speed up the macro.
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
'Work backwards because we are deleting rows.
For i = Selection.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
Selection.Rows(i).EntireRow.Delete
End If
Next i
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
' VBA - delete empty rows in word.bas
=================================================
VBA - delete empty rows in word
Public Sub gagag()
For i = 1 To 1400
Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=i
'Selection.MoveDown Unit:=wdLine, Count:=15
Selection.Expand wdLine
a$ = Selection.Text
la = Len(a$)
If la = 1 Then
'Selection.Delete unit:=wdLine, Count:=1
Selection.Delete
End If
Debug.Print Str$(i) & " ", Str$(la) + " " & Selection.Text & " " & Str$(Len(a$))
Next i
End Sub
' VBA - hyperlink from one sheet to another.bas
=================================================
!VBA - hyperlink from one sheet to another
Sub TOC3()
Dim shtName As String, shtLink As String, rowNum As Long _
, nSht As Worksheet, i As Long
Set nSht = Sheets("INDEX")
nSht.Cells(1, 1).Value = "Table of Contents"
rowNum = 2
For i = 1 To Sheets.Count
If Sheets(i).Name <> nSht.Name Then
shtName = Sheets(i).Name
shtLink = "'" & shtName & "'!" & Sheets(i).Cells(1, 1).Cells(1, 1).Address
nSht.Cells(rowNum, 1).Hyperlinks.Add Anchor:=nSht.Cells(rowNum, 1), Address:="",
SubAddress:= _
shtLink, TextToDisplay:=shtName
'Debug.Print shtLink
rowNum = rowNum + 1
End If
Next i
nSht.Columns(1).AutoFit
End Sub
' vba read text file character by character.BAS
=================================================
PUBLIC SUB READ_CBYC
Do Until EOF(1)
mychar = Input(1, #1) ' Get one character.
If mychar = vbLf Then MsgBox (i)
Debug.Print mychar ' Print to the
i = i + 1
If i = 100 Then Exit Do
Loop
END SUB
' vba_fortran_format.BAS =================================================
Right( Space(10) & Format(NumberToFormat, "0.000"), 10)
' vba_getopenfile.bas =================================================
Sub OpenSingleFile()
Dim Filter As String, Title As String
Dim FilterIndex As Integer
Dim Filename As Variant ' File filters
Filter = "Excel Files (*.xls),*.xls," & _
"Text Files (*.txt),*.txt," & _
"All Files (*.*),*.*"
' Default Filter to *.* FilterIndex = 3
' Set Dialog Caption Title = "Select a File to Open"
' Select Start Drive & Path ChDrive ("E") ChDir ("E:\Chapters\chap14")
With Application
' Set File Name to selected File
Filename = .GetOpenFilename(Filter, FilterIndex, Title)
' Reset Start Drive/Path
ChDrive (Left(.DefaultFilePath, 1))
ChDir (.DefaultFilePath)
Debug.Print Left(.DefaultFilePath, 1)
Debug.Print .DefaultFilePath
End With
' Exit on Cancel If Filename = False Then MsgBox "No file was selected." Exit
Sub End If
' Open File Workbooks.Open Filename MsgBox Filename, vbInformation, "File
Opened"
' This can be removed
End Sub
Public Sub test_GetOpenFilename_1()
FullFileName = Application.GetOpenFilename("Excel files (*.xl*),*.xl*", _
1, "Custom Dialog Title", , False)
Workbooks.Open FullFileName
End Sub
Public Sub test_GetOpenFilename_2()
FullFileName = Application.GetSaveAsFilename("DefaultFilename.xls", _
"Excel files (*.xl*),*.xl*", 1, "Custom Dialog Title")
ActiveWorkbook.SaveAs FullFileName
End Sub
' vba_kill_process.bas =================================================
Sub TerminateProcess()
'---------------------------------------------------------------------------------------
' : Terminates a process. First checking to see if it is running or not.
' : Uses WMI (Windows Management Instrumentation) to query all running processes
' : then terminates ALL instances of the specified process
' : held in the variable strTerminateThis.
' :
' : ***WARNING: This will terminate a specified running process,use with
caution!.
' : ***Terminating certain processes can effect the running of Windows and/or
' : ***running applications.
'---------------------------------------------------------------------------------------
Dim strTerminateThis As String 'The variable to hold the process to terminate
Dim objWMIcimv2 As Object
Dim objProcess As Object
Dim objList As Object
Dim intError As Integer
strTerminateThis = "notepad.exe" 'Process to terminate,
'change notepad.exe to the process you want to terminate
Set objWMIcimv2 = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\.\root\cimv2") 'Connect to CIMV2 Namespace
Set objList = objWMIcimv2.ExecQuery _
("select * from win32_process where name='" & strTerminateThis & "'") 'Find the
process to terminate
If objList.Count = 0 Then 'If 0 then process isn't running
MsgBox strTerminateThis & " is NOT running." & vbCr & vbCr _
& "Exiting procedure.", vbCritical, "Unable to continue"
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Exit Sub
Else
'Ask if OK to continue
Select Case MsgBox("Are you sure you want to terminate this running process?:" _
& vbCrLf & "" _
& vbCrLf & "Process name: " & strTerminateThis _
& vbCrLf & "" _
& vbCrLf & "Note:" _
& vbCrLf & "Terminating certain processes can effect the running of Windows" _
& "and/or running applications. The process will terminate if you OK it, WITHOUT
" _
& "giving you the chance to save any changes in anything that is running in the
specified process above." _
, vbOKCancel Or vbQuestion Or vbSystemModal Or vbDefaultButton1, "WARNING:")
Case vbOK
'OK to continue with terminating the process
For Each objProcess In objList
intError = objProcess.Terminate 'Terminates a process and all of its threads.
'Return value is 0 for success. Any other number is an error.
If intError <> 0 Then
MsgBox "ERROR: Unable to terminate that process.", vbCritical, "Aborting"
Exit Sub
End If
Next
'ALL instances of specified process (strTerminateThis) has been terminated
Call MsgBox("ALL instances of process " & strTerminateThis & " has been
successfully terminated.", _
vbInformation, "Process Terminated")
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Exit Sub
Case vbCancel
'NOT OK to continue with the termination, abort
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Exit Sub
End Select
End If
End Sub
' VBA_Rangebycells.bas =================================================
MyRange = Sheet3.Range(Cells(2, 3), Cells(N + 1, 3))
' vba_scheduler.bas =================================================
Public Const TimerTest = "ActionSub" 'call the sub routine with sheet tab
Dim SheetNo As Integer
Sub TimerStart()
Dim RunTime As Double
RunTime = Now + TimeSerial(0, 0, 10) ' Wait 10 secs
Application.OnTime EarliestTime:=RunTime, Procedure:=TimerTest, Schedule:=True
'Start sub
End Sub
Sub TimerStop()
On Error Resume Next
Application.OnTime EarliestTime:=RunTime, Procedure:=TimerTest, Schedule:=False
'stop sub
End Sub
Sub ActionSub()
'This contains the code to tab sheets
Select Case SheetNo ' Change sheet
Case 0
Sheet2.Activate
SheetNo = 3
Case 1
Sheet1.Activate
SheetNo = 2
Case 2
Sheet2.Activate
SheetNo = 3
Case 3
Sheet3.Activate
SheetNo = 1
Case Else
Sheet1.Activate
SheetNo = 2
End Select
Call TimerStart ' RESTART 10 SEC WAIT
End Sub
' VBS_4Equationbased.bas =================================================
' ----------------------------------------------
' Author: Eric Zheng, Minhong Mi
' Email: ezheng@ansoft.com,mmi@ansoft.com
' HFSS Version: V11.1.3
' Feb 2009
' ----------------------------------------------
Dim oAnsoftApp
Dim oDesktop
Dim oProject
Dim oDesign
Dim oEditor
Dim oModule
Set oAnsoftApp = CreateObject("AnsoftHfss.HfssScriptInterface")
Set oDesktop = oAnsoftApp.GetAppDesktop()
oDesktop.RestoreWindow
Set oProject = oDesktop.GetActiveProject
Set oDesign = oProject.GetActiveDesign()
Set oEditor = oDesign.SetActiveEditor("3D Modeler")
Dim Pi
Dim Nsection,Npoint,n
Dim start_t,end_t
Dim X_t1,Y_t1,Z_t1,X_t2,Y_t2,Z_t2
Dim P1,P2
Pi = 3.1415926
Start_t = 0
End_t = pi*2
Npoint = 128
Nsection = Npoint-1
d_t = (End_t-Start_t)/Nsection
for n = 1 to Nsection
P1 = Start_t+d_t*(n-1)
P2 = P1+d_t
X_t1 = cos(P1*6)
Y_t1 = sin(P1*6)
Z_t1 = P1
X_t2 = cos(P2*6)
Y_t2 = sin(P2*6)
Z_t2 = P2
oEditor.CreatePolyline Array("NAME:PolylineParameters", "CoordinateSystemID:=",
-1, "IsPolylineCovered:=", _
true, "IsPolylineClosed:=", false, Array("NAME:PolylinePoints",
Array("NAME:PLPoint", "X:=", _
"1in*"&cstr(X_t1), "Y:=", "1in*"&cstr(Y_t1), "Z:=", "1in*"&cstr(Z_t1)),
Array("NAME:PLPoint", "X:=", _
"1in*"&cstr(X_t2), "Y:=", "1in*"&cstr(Y_t2), "Z:=", "1in*"&cstr(Z_t2))),
Array("NAME:PolylineSegments", Array("NAME:PLSegment", "SegmentType:=", _
"Line", "StartIndex:=", 0, "NoOfPoints:=", 2))), Array("NAME:Attributes",
"Name:=", _
"Polyline"&Cstr(n), "Flags:=", "", "Color:=", "(132 132 193)", "Transparency:=",
0.5, "PartCoordinateSystem:=", _
"Global", "MaterialName:=", "vacuum", "SolveInside:=", true)
next
' Z2G.bas =================================================
Sub Z2G()
'
' Z2G Macro
' Macro recorded 1/15/2008 by AFRL User
'
'
Sheets("data").Select
Z0 = Cells(2, 4).Value
NP = Cells(4, 4).Value
For I = 1 To NP
Real_Z = Cells(I, 2).Value
Imag_Z = Cells(I, 3).Value
DENO = Z0 ^ 2 + 2 * Real_Z * Z0 + Imag_Z ^ 2 + Real_Z ^ 2
GAMMA_R = -(Z0 ^ 2 - Imag_Z ^ 2 - Real_Z ^ 2) / DENO
GAMMA_I = 2 * Imag_Z * Z0 / DENO
GAMMA_ABS = Sqr(GAMMA_R ^ 2 + GAMMA_I ^ 2)
If GAMMA_ABS <> 0 Then
GAMMA_DB = 20 * Log(GAMMA_ABS) / Log(10)
Else
GAMMA_DB = 0
End If
'Cells(i, 12) = GAMMA_R
'Cells(i, 13) = GAMMA_I
'Cells(i, 14) = DENO
'Cells(i, 15) = GAMMA_ABS
If GAMMA_ABS <> 1 Then
VSWRX = (1 + GAMMA_ABS) / (1 - GAMMA_ABS)
Else
VSWRX = 1000
End If
Cells(I, 11).Value = GAMMA_DB
Cells(I, 12).Value = VSWRX
Next I
Call change_chart_parameters
End Sub