Sample
VBA code
2. ตัวอย่าง MS visio export ข้อความทั้งหมดใน shape ทุก drawing page ลง text file
Sub dump1()
';gen data dump
Dim objshape As Visio.Shape
Dim Page1 As Visio.Page
Dim i1 As Integer
fn1 = "e:\vsd1.txt"
Open fn1 For Output As #1
For Each Page1 In Application.ActiveDocument.Pages
Print #1, "== page name " & Page1.Name
For i1 = 1 To Visio.ActivePage.Shapes.Count
Set objshape = Visio.ActivePage.Shapes(i1)
Print #1, "=== " & objshape.Name & " " & objshape.Text & vbCrLf
Set objshape = Nothing
Next i1
Next
Close #1
End Sub
1. ตัวอย่าง MS word macro ที่ช่วยนำเข้า text file ที่มีอยู่แล้ว เข้าสู่ word โดยจัด format ด้วย ตามรหัสสั้นๆที่กำกับอยู่ เช่น ถ้ามี h1: นำหน้า จะ format บรรทัดนั้นเป็น heading 1
Sub prg3()
'; rd txtfile &format by code-txt h3 h2 h1
Dim str1$
'open the export &format
Open "d:\export.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, str1
lineno = lineno + 1
If lineno Mod 50 = 0 Then DoEvents
If Left(str1, 3) = "h3:" Then
str1 = Right(str1, Len(str1) - 3)
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.TypeText Text:=str1
Selection.TypeParagraph
GoTo lbl1
End If
If Left(str1, 3) = "h2:" Then
str1 = Right(str1, Len(str1) - 3)
Selection.Style = ActiveDocument.Styles("Heading 2")
Selection.TypeText Text:=str1
Selection.TypeParagraph
GoTo lbl1
End If
If Left(str1, 3) = "h1:" Then
str1 = Right(str1, Len(str1) - 3)
Selection.Style = ActiveDocument.Styles("Heading 1")
Selection.TypeText Text:=str1
Selection.TypeParagraph
GoTo lbl1
End If
'normal txt
Selection.TypeText Text:=str1
Selection.TypeText Text:=vbLf
lbl1:
Loop
Close #1
End Sub
0. snipet2
=============== ; dgrid ; ; ===============
Sub grdDataGrid_Click()
' MsgBox grdDataGrid.Text
can show cell content but show ble action ;$arrow to mov first
=============== xl ; ; ; insert del row ===============
==Sub insrow(row1%, row2%)
' down w/ row1 then ins w/ row2
row = row + row1
Range("A" & Format(row) & ":A" & Format(row + row2 - 1)).Select
Selection.EntireRow.Insert
row = row + row2
End Sub
Columns("AE:AE").Select
Selection.Insert Shift:=xlToRight
Columns("AF:AF").Select
Selection.Delete Shift:=xlToLeft
Sub deletecol(str1$)
Columns(str1).Select
Selection.Delete Shift:=xlToLeft
End Sub
Rows(i).Select
Rows("2:2").Select
Selection.Delete Shift:=xlUp
==delete blank row
For i = row1 + 1 To r2
If Cells(i, 26).Value = "" And Cells(i, 27).Value = "" Then
'err 1004 if cell caontaint =
' Cells(i, 27).Value = Cells(i + 1, 27).Value
' Cells(i + 1, 26).Select
str1 = "Z" & Format(i) & ":AL" & Format(i)
Range(str1).Delete shift:=xlUp
End If
Next i
=============== date ; ; ; Convert a value in seconds to a formatted string ===============
SecondsToString - Convert a number of seconds into a formatted time string
Date: 8/18/2001
Versions: VB5 VB6 Level: Beginner
Author: The VB2TheMax Team
' Converts a numeric value in seconds to a string
' Example:
' MsgBox SecondsToString(3920) --> 1h.5m.20s
Function SecondsToString(ByVal Seconds As Long) As String
SecondsToString = (Seconds \ 3600) & "h." & ((Seconds \ 60) Mod 60) & "m." _
& (Seconds Mod 60) & "s."
End Function
=============== date ; ; ; Enhance the FormatDateTime function ===============
FormatDateTimeEx - Extended formatting for date and time values
Date: 8/18/2001
Versions: VB5 VB6 Level: Intermediate
Author: The VB2TheMax Team
Enum DateTimeFormat
dtGeneralDate
dtLongDate
dtMediumDate
dtShortDate
dtLongTime
dtMediumTime
dtShortTime
dtCustom
End Enum
' Enhanced VB FormatDateTime function
Function FormatDateTimeEx(newDate, Optional ByVal dtFormat As DateTimeFormat = _
dtGeneralDate, Optional FirstDayOfWeek As VbDayOfWeek = vbSunday, _
Optional FirstWeekOfYear As VbFirstWeekOfYear = vbFirstJan1)
' Select the right formatting function
Select Case dtFormat
Case dtGeneralDate
FormatDateTimeEx = FormatDateTime(newDate, vbGeneralDate)
Case dtLongDate
FormatDateTimeEx = FormatDateTime(newDate, vbLongDate)
Case dtMediumDate
FormatDateTimeEx = Format(newDate, "Medium Date", FirstDayOfWeek, _
FirstWeekOfYear)
Case dtShortDate
FormatDateTimeEx = FormatDateTime(newDate, vbShortDate)
Case dtLongTime
FormatDateTimeEx = FormatDateTime(newDate, vbLongTime)
Case dtMediumTime
FormatDateTimeEx = Format(newDate, "Medium Time", FirstDayOfWeek, _
FirstWeekOfYear)
Case dtShortTime
FormatDateTimeEx = FormatDateTime(newDate, vbShortTime)
Case dtCustom
FormatDateTimeEx = Format(newDate, "dddd d mmmm yyyy - Hh:Nn:Ss")
End Select
=============== xl ; format ; ; &chg data type in cell ===============
Format(Cells(i, 2).text, "@@@@@@@") .prn style w/ 7 char
Format(Cells(i, 7).text, "@@@@@.00")
has mm/??/yy ??
" 0.000" '3 front space ,and +/- sign at most left
Format(i, "00") if I=1 > 01
2 decimal
Range("F2").NumberFormat = "0.00
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
.ColorIndex = xlAutomatic
End With
condition formating
3case do only 1st case that true
str2 = Format(Range("AG3").Value, "d mmm") date number to day-month
str2 = Format(Range("AH3").Value, "hh:mm") time number to hour:min
==chg data type in cell
If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
findlastrow2 "f108", r2
For i = 109 To r2
Cells(i, 9) = Format(Cells(i, 9).Value, "d-mmm-yy")
Next i
=============== xl ; ; ; add comment ===============
Cells(r1, c1).AddComment
Cells(r1, c1).Comment.Visible = False
Cells(r1, c1).Comment.Text Text:=str1
? no comment chk
Selection.ClearComments
=============== ; msgbox ; ; ===============
++popup on front
MsgBox str2, vbSystemModal+vbYesNo
=============== ; ; ; gen statement format ===============
Select Case str2
Case "remi1"
Case Else
End Select
=============== xl ; graph ; ; ===============
in axis dialog cant set scale refer to cell
++chg graph scale
Sheets("his_result").Select
For i = 1 To 4
ActiveSheet.ChartObjects(i).Activate
' ActiveSheet.ChartObjects("Chart " & Format(i)).Activate
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
.MinimumScale = xmin
.MaximumScale = xmax
End With
ActiveChart.Axes(xlValue).Select
With ActiveChart.Axes(xlValue)
.MinimumScale = ymin
.MaximumScale = ymax
End With
Next i
Range("A1").Select
++set auto if=0
With ActiveChart.Axes(xlValue)
If ymin = 0 Then
.MinimumScaleIsAuto = True
Else
.MinimumScale = ymin
End If
If ymax = 0 Then
.MaximumScaleIsAuto = True
Else
.MaximumScale = ymax
End If
End With
++set auto
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
++source data
ActiveSheet.ChartObjects("Chart 10").Activate
ActiveChart.SeriesCollection(1).Select
ActiveChart.SeriesCollection(1).XValues = "=grp!R5C19:R124C19"
ActiveChart.SeriesCollection(1).Values = "=grp!R5C20:R124C20"
ActiveChart.SeriesCollection(1).Name = "=grp!R3C20"
++display which chart
For I = 3 To 6
ActiveSheet.ChartObjects(I).Select
MsgBox Format(I)
Range("G66").Select
Next I
=============== xl ; ; ; picture ===============
==++ load picture
Private Sub UserForm_Initialize()
If stra1 <> "x" Then Image1.Picture = LoadPicture(stra1)
image ctrl as embed
?slower than insert pic from file,not good zoom result
pictclip ctrl less prop than image
++ load in other wrkbook
Workbooks("ff3view.xls").Activate
ActiveSheet.Shapes(1).Delete
ActiveSheet.Pictures.Insert(str1).Select
Workbooks("ff3view.xls").Sheets("Sheet1").Range("a3").Select
Workbooks("ff3.xls").Activate
++ size border
If modestr = "scale" Then
.ShapeRange.ScaleWidth sx, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleHeight sy, msoFalse, msoScaleFromTopLeft
End If
If modestr = "size" Then
.ShapeRange.Width = 100
.ShapeRange.Height = 100
.ShapeRange.Line.Weight = 0.25 'border
.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.Style = msoLineSingle
End If
.ShapeRange.IncrementLeft x1
.ShapeRange.IncrementTop y1
=============== xl ; ; ; sort ===============
==sort
Selection.Sort Key1:=Range("C4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _ ;has header row
==++ 2key
Selection.Sort Key1:=Range("A8"), Order1:=xlDescending, Key2:=Range("D8") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
=============== xl ; ; ; filter pv ===============
==filter no prop that return how many col on filter
Selection.AutoFilter Field:=8
Selection.AutoFilter Field:=7, Criteria1:="x"
Selection.AutoFilter Field:=6
==multi cond
Selection.AutoFilter Field:=4, Criteria1:="<=1"
dt2 = Now - 4
Selection.AutoFilter Field:=5, Criteria1:="<" & Format(dt2, "short date")
str1 = "*" + Range("C2") + "*"
Selection.AutoFilter Field:=2, Criteria1:=str1, Operator:=xlOr, _
Criteria2:=str2
==filter 4 blank
Selection.AutoFilter Field:=5, Criteria1:="="
==w/ date
Selection.AutoFilter Field:=n1, Criteria1:="<" + str1 date autoconvert to str by selection.text
Sub resetfilter()
Application.ScreenUpdating = False
Range("A3").Select
For i = 1 To 9
Selection.AutoFilter Field:=i
Next i
Application.ScreenUpdating = True
End Sub
==remove filter when exist
Selection.AutoFilter
== showall
chk 1st now is filter?
If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
==select first value of result
DoEvents
sleep n1 * 1000 ';seem need screen to redraw
Range(cell2).Select
DoEvents
SendKeys "{DOWN}", True
== If Cells(i, 1).Height <> 0 Then if on filter
==adv filter
Range(rng1).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"G3:J4"), CopyToRange:=Range("G6:J6"), Unique:=False
==&2nd srch not clr previous
If Target.Column < 9 Then
'If Target.Address = "$N$31" Then
If Target.Row = 2 Then
filt1 Target.Column, Target.Text, Target.Address, "A5"
End If
If Target.Row = 3 Then
filt2 Target.Column, Target.Text, Target.Address, "A5"
ActiveWindow.LargeScroll up:=10
End If
End If
==2nd srch other sheet
If Range("D2").Value = True Then
wait3s
Sheet611.Select
filt1 2, Target.Text, "B3", "A7"
Application.Goto "R1C1", Scroll:=True
wait3s
Sheet61.Select
End If
no property that tell return 1 of n record found
==pivot
ActiveSheet.PivotTables("PivotTable1").AddFields RowFields:=Array("PROD", _
"PR4"), ColumnFields:="PR3"
With ActiveSheet.PivotTables("PivotTable1").PivotFields("PR4")
.PivotItems("(blank)").Visible = False
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("PR3")
.PivotItems("(blank)").Visible = False
End With
xl97 cant set pivot datasource by code
ActiveSheet.PivotTables("PivotTable1").RefreshTable
++arr data fld
ActiveSheet.PivotTables("PivotTable1").PivotFields("305 INLPU").Orientation = _
xlDataField
ActiveSheet.PivotTables("PivotTable1").PivotFields("Data").PivotItems( _
"Sum of 305 INLPU").Position = 3
?remov all data field loop thru collection
==chg source data from macro record
but can't at run time ;method for create new pv only$
ActiveSheet.PivotTableWizard SourceType:=xlDatabase, SourceData:= _
"Sheet1!R2C1:R153C11", TableDestination:="R1C1", TableName:="PivotTable1"
==gen pv
Sub agenpv()
Range("A2:E17").Select
str1 = Selection.Address
' ActiveSheet.PivotTableWizard SourceType:=xlDatabase, SourceData:= _
"fhf!R2C1:R17C5", TableDestination:="", TableName:="PivotTable1"
ActiveSheet.PivotTableWizard SourceType:=xlDatabase, SourceData:= _
"fhf!" & str1, TableDestination:="", TableName:="PivotTable1"
ActiveSheet.PivotTables("PivotTable1").AddFields RowFields:=Array("tnum", _
"name"), ColumnFields:="sn"
ActiveSheet.PivotTables("PivotTable1").PivotFields("fhfval").Orientation = _
xlDataField
' ActiveSheet.PivotTables("PivotTable1").PivotSelect "tnum", xlButton
'no subtotal
ActiveSheet.PivotTables("PivotTable1").PivotFields("tnum").Subtotals = Array( _
False, False, False, False, False, False, False, False, False, False, False, False)
ActiveSheet.PivotTables("PivotTable1").PivotSelect "", xlDataAndLabel
With Selection.Font
.Name = "Arial"
.Size = 10
End With
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 10
End With
[A1].Select
==pv jmp to rec
Sub a_frompv_goto_filter()
str1 = Mid(Selection.Text, 2, 10)
Sheets("orgnis").Select
[b4] = str1
End Sub
=============== xl ; graph ; ; ===============
++linear trendline
ActiveChart.SeriesCollection(1).Trendlines(1).Select
With Selection
.Type = xlLinear
.Forward = 0
.Backward = 0
.InterceptIsAuto = True
.DisplayEquation = False
.DisplayRSquared = False
.NameIsAuto = True
End With
activechart.export mygrp$,"gif" as gif
if activechart is nothing then exit sub
application.getsaveasfilename (initialfilename:= filefilter:=" ", title:=" ")
=============== ; ; ; call xp cmd ===============
i = Shell("d:\windows\system32\cmd.exe /c rd /s /q """ & path1 & """", vbNormalFocus)
/k not close cmd win after fin /c close if close this box the appl close too
Sub listfiledtl(path1$)
str1 = "d:\windows\system32\cmd.exe /c ""dir " & path1 & " >c:\t1.txt""" & " "
i1 = Shell(str1, vbNormalFocus)
procid = Shell("cmd.exe /c start """ & "D:\zip3\carnegie2_files\bye1.gif" & """", vbNormalFocus) 'cant w/ *.jpg *.
procid = Shell("start """ & "D:\zip3\carnegie2_files\bye1.gif" & """", vbNormalFocus) not know start cmd
=============== xl ; ; ; replace search find ===============
Selection.Replace What:="1951", Replacement:="2008"
Columns("e").Select
Cells.Find(What:="Title", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
True).Activate
row1 = ActiveCell.Row
rnga1 = ActiveCell.Address
'partial match
Selection.Replace What:="$", Replacement:="", LookAt _
:=xlPart, MatchCase:=False
++ Selection.Find(What:="-", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Activate
ActiveCell.Replace What:="-", Replacement:="0", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
=============== xl ; ; ; func wiz ===============
==use fn in wizard
' vba don't have floor function, so use from worksheet function
Private Function NumFloor(val)
NumFloor = Application.WorksheetFunction.Floor(val, 1)
End Function
rows columns cant
=============== xl ; ; ; url ===============
==url
str1 = Selection.Value
Set s = CreateObject("InternetExplorer.application")
s.Visible = True
s.navigate str1
'not wrk procid = Shell("iexplore " & str1, vbNormalFocus)
C:\Program Files\Internet Explorer\IEXPLORE.EXE
ActiveWorkbook.FollowHyperlink str1, "", True
seem on ie only$
++wrk
procid = Shell("EXPLORER.EXE " & [b5].Value, vbNormalFocus) .
Para=htm >call ie
"D:\Program Files\Mozilla Firefox\firefox.exe",
procid = Shell("cmd.exe /c """ & [b5].Value & """", vbNormalFocus)
can fox [via ext associate $] however cmd box is remain if close cmd child also close
shell Runs an executable program
image viewer in xp found process as explorer?!! Not found this prg in exe cpl list
++event on click url
Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
timestamp
' Beep
End Sub
==direct get page
Sheets("pad2").Select
Cells.Clear 'font reset to cordia 14
Range("A5").Select
str1 = "URL;" & url1 'http://www.pantip.com/tech/software/listSA.php"
With Selection.QueryTable
.Connection = str1
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
' merge in tadmin
' .WebFormatting = xlWebFormattingRTF no link
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.Refresh BackgroundQuery:=False
End With
++access but xl no this
Application.FollowHyperlink str1, "", True
=============== gen ; ; ; ===============
x = Val(Mid(str1, 1, j - 1))
if str is
22xxxx > correct val to 22
xx22 > got 0
=============== xl ; dialog ; ; ===============
need place ctrl on sheet ;show as embed
With Sheet212.CommonDialog1
.CancelError = False
.InitDir = [b6]
' On Error Resume Next
.flags = cdlOFNHideReadOnly
' Set filters
' CommonDialog1.Filter = "All Files (*.*)|*.*|Text Files" & _
"(*.txt)|*.txt|Batch Files (*.bat)|*.bat"
.Filter = "picture|*.jp*;*.gif;*.wm*;*.mp*;*.swf|other|*.js;*.css;*.htm*"
group of file ;cant as thumnail mode yet
' Specify default filter
.FilterIndex = 0
' Display the Open dialog box
.ShowOpen
fname = .FileName
End With
=============== xl ; ; ; format color border ===============
3 red 4 green 6 yellow
14 gray 26 pink 41 blue
50 brown
ActiveSheet.Range(Cells(i, 1), Cells(i, LastCol)). _
Interior.ColorIndex = ColorCode 'ColorCode arrives with
Next 'This For
Next does all coloring
ActiveSheet.Range(Cells(2, 1), Cells(LastRow, LastCol)).Select
With Selection.Borders(xlLeft) 'Several pieces of housekeeping
.Weight = xlThin 'to put border around every cell
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlRight)
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlTop)
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlBottom)
.Weight = xlThin
.ColorIndex = xlAutomatic 'Several pieces of housekeeping
End With 'to put border around every cell
With Selection
.BorderAround Weight:=xlThin, ColorIndex:=xlAutomatic
End With
== wrap in cell
Range("H10").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With
=============== xl ; ; ; ===============
Sheets("edit").Visible = xlSheetVisible
Sheet3.Visible = xlSheetVeryHidden
cant seen in xl , still see in vbe & by cmnd
k1 = Worksheets.Count
arr1(k) = Worksheets(k).Name
=============== xl ; ; ; text2col ===============
Sub reset_txt2col()
Range("T1").Select
Selection.Value = "aaa"
Selection.TextToColumns Destination:=Range("T1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False
Range("A1").Select
End Sub
=============== ; ; ; aa ===============
Print #2, Tab(15); stra(1); stra(2); stra(3); stra(4); '"mkdir " + dest + ":\" + path2 blnk 15 space
; will concat print out
Print #2, stra(1), stra(2), stra(3), stra(4),
, some space
=============== ; file ; ; ===============
filecopy source,desti supp \\ce1-7 style
name f as f move,rename
xl97 from work [dif w/ help]
can move file to any drive even nw map
cant move folder to nw map
see ==file system obj ms script runtime vbwww1.txt
fso.GetBaseName no ext
print fso.GetParentFolderName(fn2)
d:\zip3
print fso.GetAbsolutePathName(fn2)
D:\zip3\progress.aspx.html
Open "c:\list.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, str0: lineno = lineno + 1
If Left(str0, 1) = "$" Then
loop
close #1
==tab format
Print #2, "???"; Tab(15); "??
chr9=tab
==write csv format
" " each value
Write #1, str1, str2, n1, n2
Range("K11").Value as number
Range("K11") as str w/ quote
Input #1, str1, str2, n1, n2 'don't interpret LF CR
$$recog as str only
++can by this
input2 "scan hold :xx", Text1(1)
Sub input2(str0$, obj1 As Object)
Input #1, str0, str1, str2
obj1.Text = str1
End Sub
++cant even by this style [input2]
input2 "dim min:to level", Text1(0).Text, Text1(3).Text
input #1,"dim min:to level", Text1(0).Text, Text1(3).Text
Sub input2(str0$, ByRef str1$, ByRef str2$)
Input #1, str0, str1, str2
End Sub
=============== ; word vba ; ; ===============
==toggle state before type
Selection.Font.Bold = wdToggle
Selection.Font.Underline = wdUnderlineSingle
Selection.TypeText Text:=str2
Selection.Font.Underline = wdUnderlineNone
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=vbTab ' ^tab no tab mark at ruler change
==in cell center
Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
==can set style before type txt ;this code gen word from list.txt
Sub genreport()
Application.ScreenUpdating = False
Documents.Add Template:="Normal", NewTemplate:=False
Selection.Style = ActiveDocument.Styles("Normal")
Selection.TypeParagraph
Sleep 100
Open "c:\list.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, str0: lineno = lineno + 1
If Left(str0, 1) = "$" Then
str1 = Right(str0, Len(str0) - 1)
Selection.Style = ActiveDocument.Styles("Heading 2")
Selection.TypeText Text:=str1
Selection.TypeParagraph
' wrln
' Selection.Style = ActiveDocument.Styles("Normal")
' *** seem ok now ,can get undesire result if run from page layout view??!!
GoTo lbl1
End If
If Left(str0, 1) = "#" Then 'pic
fn = Right(str0, Len(str0) - 1)
If Dir(fn) <> "" Then
Selection.InlineShapes.AddPicture FileName:=fn, LinkToFile:= _
False, SaveWithDocument:=True
Sleep 10
' wrln 'cause normal hown in doc map!
Selection.TypeText Text:=" "
Selection.TypeParagraph
End If
Else
Selection.Style = ActiveDocument.Styles("Normal")
Selection.TypeText Text:=str0
wrln
Selection.TypeParagraph
End If
lbl1:
Loop
Close #1
=============== ; ; ; file date time ===============
==get as string
str0 = FileDateTime(fname)
==chk how many day
Case "2aweek"
n1 = DateDiff("d", Now, laststamp)
If n1 <= -14 + ofset Then flg1 = True
== '## protect
If Now > DateSerial(2009, 6, 31) Then '1st index=0
MsgBox "internal error code 101", vbCritical '.ListIndex ' **err ??*
End
' Exit Sub
End If
as in xl
date is integer +1 = plus 1 day
11/24/09 is 40141
11/25/09 40142
=============== xl-acc ; ; ; monitor instead of timer obj ===============
acc no appl.ontime
but the form has timerinterval w/ event ontimer
see htmlinfo getPT
Sub startmonitor()
flg1 = False
stop1 = False
clockup
' Application.OnTime Now + TimeSerial(0, 0, 4), "ClockUp"
End Sub
Sub aa()
Beep
End Sub
Sub stopmonitor()
stop1 = True
' Beep
' Application.OnTime Now, "ClockUp", Schedule:=False
End Sub
Sub clockup()
On Error GoTo eh1
str1 = FileDateTime("d:\word.lst")
If str1 <> keepdt1 Then
' Beep
Sheets("ui").Select
Open "d:\word.lst" For Input As #1
Line Input #1, str2
Close #1
keepdt1 = str1
[b2] = str2
End If
If flg1 Then Exit Sub
flg1 = True
' MsgBox "xx"
If Not (stop1) Then Application.OnTime Now + TimeSerial(0, 0, 4), "ClockUp"
flg1 = False
Exit Sub
eh1:
sleep 1000
Resume Next
End Sub
=============== xl ; ; ; goto ===============
Application.Goto Refence:=Workbooks("book2").Sheets("Sheet1").Range("A1")
see xltrk-k6 for some wrk
Application.Goto "R1C9"
Workbooks("multiplematch.xls").Activate
=============== acc ; ; mailarc ; dump to txt file ===============
Sub aa()
DoCmd.GoToRecord acDataForm, "form6", acFirst
Open "d:\out.txt" For Output As #1
For i = 1 To InputBox("number of record to write")
Print #1, "Date: " & Me.date
Print #1, "From: " & Me.from
Print #1, "Subj: " & Me.subj
Print #1, ""
Print #1, Me.Detail
Print #1, ""
DoCmd.GoToRecord acDataForm, "form6", acNext
Next i
Close #1
End Sub
=============== ; txtbox ; ; ===============
==sel txt when focus
Private Sub Text1_GotFocus()
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
End Sub
TextBox1.SetFocus
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1.Text)
=============== xl ; ; ; current cell ;get val ===============
i = Selection.Row: 'j = Selection.Column
sht = Cells(i, 2).Value: cell1 = Cells(i, 3).Value
Selection.End(xlUp).Select
can like sendkey ^up but better
=============== ; ; ; for ? Seem rest code ===============
Sub createlist() '
' use direct cell ref in macro!
Dim no%, str2$, str3$
str3 = ""
Sheets("sheet1").Select
For i = 4 To 22
' str2 = str2 + Format(i) + "+"
str2 = Range("i" & Format(i)).Value
If str2 = "x" Then
str3 = str3 + "K." + Range("j" & Format(i)).Value + " "
End If
Next i
Range("i24").Value = str3
' str2 = Left(str2, Len(str2) - 1)
' str2 = str2 + " aa.txt"
' Range("c2").Value = str2
End Sub
=============== vb ; ; ; connect db ===============
==ado code to dgrid
Dim db As Connection
Set db = New Connection
db.CursorLocation = adUseClient
db.Open "PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source=E:\1zx1\snipet.mdb;"
Set adoPrimaryRS = New Recordset
adoPrimaryRS.Open "select fname,modulename,subname,detail from module_csv", db, adOpenStatic, adLockOptimistic
Set grdDataGrid.DataSource = adoPrimaryRS
?requery
.close will clear db value too
=============== ; ; ; declare ===============
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
=============== xl ; ; ; link ===============
place url link in xl file [seem can by compa wrk on get m/c status]
but srch in codevba NF yet
=============== xl ; ; ; range name ===============
++' To add a range name for known range
Sub AddName1()
ActiveSheet.Names.Add Name:="MyRange1", RefersTo:="=$A$1:$B$10"
End Sub
++' To add a range name based on a selection
Sub AddName2()
ActiveSheet.Names.Add Name:="MyRange2", RefersTo:="=" & Selection.Address()
End Sub
++' To add a range name based on a selection using a variable. Note: This is a shorter version
Sub AddName3()
Dim rngSelect As String
rngSelect = Selection.Address
ActiveSheet.Names.Add Name:="MyRange3", RefersTo:="=" & rngSelect
End Sub
++' To add a range name based on a selection. (The shortest version)
Sub AddName4()
Selection.Name = "MyRange4"
End Sub
=============== xl ; ; ; command bar ===============
see list all member in
E:\1zx1\listcmdbar.xls
but not show menu item yet ,nor bookmark type ,nor in vba ide
=============== acc ; ; ; apply filter as gen sub w/ button ===============
Private Sub Command1439_Click()
q1 1
End Sub
Sub q1(choice%)
'; choice 1=dtl 2=fn or descrip 3=by obj
If Me.Text1437 <> "" Then
txta1 = ""
str1 = "'*" + Me.Text1437 + "*'"
Select Case choice
Case 1
DoCmd.ApplyFilter , "detail like " & str1 '& " Or " & "descrip like " & str1 '& " Or cmnt like " & str1
Case 2
DoCmd.ApplyFilter , "fn like " & str1 & " Or " & "descrip like " & str1 '& " Or cmnt like " & str1
Case 3
DoCmd.ApplyFilter , "object like " & str1 ' & " Or " & "descrip like " & str1 '& " Or cmnt like " & str1
Case 4
DoCmd.ApplyFilter , "path1 like " & str1
End Select
End If
Me.Text1437.SetFocus
End Sub
==style2 filter after key in
Private Sub Text26_Exit(Cancel As Integer)
If Text26 = str_tx26 Then Exit Sub
DoCmd.ApplyFilter , "name like '" & Text26 & "'" '& "descrip like " & str1 '& " Or cmnt like " & str1
'after filter call to _enter event ,still focus again text26 not left this ctrl
str_tx26 = Text26
'Beep
'Beep
End Sub
==2word &more easy!! W/ sql cmnd
DoCmd.ApplyFilter , "detail like '*top*' and detail like '*inter*'"
Case 1
txta1 = txtobj
If InStr(1, txta1, " ") > 1 Then
txta1 = Replace(txta1, " ", "*' and detail like '*")
End If
str1 = "'*" + txta1 + "*'"
DoCmd.ApplyFilter , "detail like " & str1 '& " Or " & "descrip like " & str1 '& " Or cmnt like " & str1
++ see htmlinfo see by person post w/ replace fn
=============== xl ; ; ; drawing shape on sheet ===============
==remove obj
ActiveSheet.DrawingObjects.Select
Selection.Delete
=============== xl ; ; ; ===============
Application.StatusBar = True 'show TRUE word !! 'False restore ' "ok"
MsgBox Application.StatusBar ' = "ok"
anyway cant read autofilter result
++ progress work from ptcnv
=============== acc ; ; ; event ===============
_enter when enter in ctrl
_exit exit
_change occur every chg in control ex in txtbox 2press=2 event
=============== xl ; ; ; ===============
Range(str1 & Format(i)).Hyperlinks(1).Address
err if no exist url in it , can edit by this cmnd
Selection.Hyperlinks(1).Address = "ttp:///"
if blank url need add 1st
Range("E" & Format(i1)).Select
Selection.Hyperlinks.Add Anchor:=Selection, Address:=url1
'txt color will white
=============== acc ; ; ; docmd ===============
DoCmd.RunMacro "macro1.mac1g"
fn1 = InputBox("fname to get", , fn1)
DoCmd.TransferText acImportDelim, "Module csv Import Specification", "module_csv", fn1, False true=1st row-fld name
=============== time ; ; ; Convert a value in seconds to a time value ===============
ex2 str2=num minute
addlog "c:\rcon.log", str1 _
& vbTab & str2 & vbTab & CDate(Val(str2) * 60 / 86400) & vbTab & Date$
SecondsToTime - Convert a number of seconds to a Date value
Date: 8/18/2001
Versions: VB5 VB6 Level: Beginner
Author: The VB2TheMax Team
' Converts a numeric value in seconds to a time value
' Example:
' MsgBox SecondsToTime(11120) --> 3.5.20 AM
Function SecondsToTime(ByVal Seconds As Long) As Date
SecondsToTime = CDate(Seconds / 86400)
End Function
1day=86400 sec
=============== acc ; ; ; gen ===============
add hist to listbox
at end
List720.RowSource = List720.RowSource & ";" & Me.Text1437
at top
List720.RowSource = Me.Text1437 & ";" & List720.RowSource
++ reque from list
Private Sub List720_Click() 'requery
Me.Text37 = List720.Value
Command36_Click
=============== xl ; ; ; gen ===============
Range(str2).Copy
Sheets("pad").Select
Range("d1").Select
ActiveSheet.Paste
sx = Format(i)
str1 = "a" & sx & ",f" & sx & ":i" & sx
Range(str1).Copy
Selection.PasteSpecial Paste:=xlValues
=============== xl ; ; ; av as new file ===============
Sub savtoNew(fn1$)
'
' Macro3 Macro
' Macro recorded 4/21/2009 by st
'
'
Sheets("pad2").Select
Sheets("pad2").Copy
ActiveWorkbook.SaveAs FileName:=fn1, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.Close
End Sub
=============== xl ; range ; ; ===============
==range def
Workbooks("xltrk-k6.xls").Sheets("toc").Range(str2) = str1
but macro on parent cant conti ?? But Below avail
If Sheet1.Range("UI!g18") Then
scroff
Workbooks("xltrk-k6.xls").Activate
Sheets("res").Range("G1") = Target.Text
scron
Workbooks("xlgrep.xls").Activate
End If
Range("d1").Select seem cant RC style
=============== xl ; ; ; toolbar command bar ===============
==on/off toolbar by event
Private Sub Worksheet_Activate()
Application.CommandBars("PivotTable").Visible = True
End Sub
Private Sub Worksheet_deActivate()
Application.CommandBars("PivotTable").Visible = False
End Sub
add set of toolbar see xlgrep sub a_defbutton
need ref to ms off9 obj lib else not know word commandbar
=============== xl ; ; ; open file ===============
Workbooks.OpenText FileName:="ftp://bkkn10/home/field/log2.txt", Origin:= _
xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, _
1), Array(13, 1), Array(25, 1), Array(35, 1))
=============== xl ; dde ; ; ===============
==dde wrk
sub
set dcell=activewrkbook.worhsheets("sheet1").range(a1)
dcell="hello"
cc=app.ddeinitiate("dde","form1")
app.ddepoke cc,"text1",dcell
app.ddeterminate cc
vba ??? ???? has addin dtl
running xl97 mark dodge
for in cell can
=word.document.8!'c:\whatup.doc' !'ole_link1'
=app!topic!item format
srch codevba/book
no acc link of pic?
==can not initial
dde1 = Application.DDEInitiate(app:="WinWord", _
topic:="acdsee")
Application.DDEExecute dde1, "[open-noadd("c:\images\animals\1.jpg")]"
dde1 = Application.DDEInitiate(app:="D:\appl32\ACD\ACDSee\ACDSee.exe", _
topic:="acdsee")
?? last note
++this wrk
dde1 = Application.DDEInitiate("ACDSee", _
topic:="system")
Application.DDEExecute dde1, "[open-noadd(""D:\nikon\DSCN0092.JPG"")]"
acdsee /v 1st
convert 6% as gif >xl fast to load
++not wrk
dde1 = Application.DDEInitiate("D:\appl32\ACD\ACDSee\ACDSee.exe", _
topic:="acdsee")
Application.DDEExecute dde1, "[open-noadd(""c:\images\animals\1.jpg"")]"
End
=============== xl ; ; ; module by vba? ===============
Sub DeleteAllVBA() 'Delete VBA Module
Dim VBComp As VBIDE.VBComponent
Dim VBComps As VBIDE.VBComponents
Set VBComps = ActiveWorkbook.VBProject.VBComponents
For Each VBComp In VBComps
Select Case VBComp.Type
Case vbext_ct_StdModule, vbext_ct_MSForm, _
vbext_ct_ClassModule
VBComps.Remove VBComp
Case Else
With VBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next VBComp
End Sub
=============== ; ; ; ===============
Null
=============== ; clipboard ; ; ===============
'?not eff win clipboard use win api?
Clipboard.SetText TextBox1.Text
Sleep 20
TextBox1.Copy
=============== ; ; ; convert date time ===============
++cell date string to date
n1 = InStr(1, Cells(i, 9).Value, ",")
If n1 > 0 Then Cells(i, 9).Value = CDate(Left(Cells(i, 9).Value, n1 - 1))
=============== ; ; ; promp new select cell ===============
la1:
Range(strd1).Select
str2 = InputBox("if not correct cell selected i/p new y to accept", , strd1)
If str2 = "y" Then
Else
strd1 = str2
GoTo la1
End If
=============== acc ; ; ; apply filter as gen sub w/ txtbox exit ===============
Private Sub Text23_Exit(Cancel As Integer)
genfil Text26, "path like "
End Sub
Sub genfil(obj1 As Object, param$)
'## not do if no chg
If obj1.Text = obj1.Tag Then
Exit Sub
Else
obj1.Tag = obj1.Text
str1 = "'*" + obj1.Text + "*'"
DoCmd.ApplyFilter , param & str1 '& " Or " & "descrip like " & str1 '& " Or cmnt like " & str1
obj1.SetFocus
End If
End Sub
=============== xl ; ; ; code to cut-release ===============
Sub release()
Dim Sh As Worksheet
Dim xModule As Variant
Dim MaxSheet As Worksheet, PreName As String
Set MaxSheet = Sheets(Sheets.Count)
MsgBox "sure? better step in IDE!"
For Each xModule In ThisWorkbook.VBProject.VBComponents
'Application.StatusBar = xModule.Name
If xModule.Type = 1 Then
' Debug.Print xModule.Name
If xModule.Name <> "Module5" Then _
ThisWorkbook.VBProject.VBComponents.Remove ModuleName
'xModule.Export FileName:="c:\modules\" & xModule.Name
'Set ModuleName = ThisWorkbook.VBProject.VBComponents(xModule.Name)
' remove module from thisworkbook
'
'End If
End If
Next
For Each Sh In Worksheets
'case sensitive
If Sh.Name <> "hist" Then
If Sh.Name <> "Sheet1" Then
'Debug.Print "del "; Sh.Name
Sh.Delete
End If
End If
Next
Sheet4.Select
Range("hist!a10:aa153").ClearContents
Range("hist!v1:aa153").ClearContents
Range("hist!a158:aa300").ClearContents
Range("H6:K153").ClearContents
Range("H6:K6") = "aa"
Sheet2.Select
Range("a11:ap45").ClearContents
Range("C9") = "ITD"
Range("C10") = "ESSO"
Range("ao1:bd300").Clear
Range("a51:ap300").Clear
' Range("hist!a10:aa145").ClearContents
' NowNo = Val(Mid(Sh.Name, Len(PreName) + 1))
' If MaxNo < NowNo And Left(Sh.Name, Len(PreName)) = PreName Then
' MaxNo = NowNo
' Set MaxSheet = Sh
' End If
End Sub
=============== ; ; ; gotourl ===============
Sub gotourl()
If ActiveSheet.Name = "gaf" Then
str1 = Trim(ActiveCell.Value)
str1 = Replace(str1, " ", "+")
str1 = Replace(str1, ".", "+")
'## by search
str1 = "http://www.getafreelancer.com/projects/search.php?action=search&per=50&dl=on&sort=relevance%3A2&keyword=" & str1 & "&projectStatus=open&budget_min=&budget_max=&biddingEnds="
'cant str1 = "http://www.getafreelancer.com/projects/" & str1 & ".html"
ShellExecute 263098, vbNullString, str1, vbNullString, "C:\", SW_SHOWMINNOACTIVE 'NOACTIVATE
Exit Sub
End If
If Left(ActiveSheet.Name, 2) <> "pv" Then Exit Sub
If IsNumeric(Cells(ActiveCell.Row, 5 + 4)) Then
str1 = "m" & Format(Cells(ActiveCell.Row, 5 + 4))
Range("listerI!" & str1).Value = "d" 'done flg
str1 = "e" & Format(Cells(ActiveCell.Row, 5 + 4))
str1 = Range("listerI!" & str1).Hyperlinks(1).Address
ShellExecute 263098, vbNullString, str1, vbNullString, "C:\", SW_SHOWMINNOACTIVE 'NOACTIVATE
'try various but fox alway activate??!!
AppActivate "microsoft excel"
End If