ASP.net 將動態資料寫成HTML再以JS載入

前端
--------------------------------------------------------------------------------------

'原來的跑馬燈改為以JS載入

/* 以 JS 載入 跑馬燈內容 */
$('#marqueeText').load('../Marquee.html');


後端
--------------------------------------------------------------------------------------

Protected Sub FormView1_ItemUpdated(ByVal sender As Object, ByVal e As System.Web.UI.WebControls.FormViewUpdatedEventArgs)

'只要有更新過資料，就寫入新的設定檔 990617
Dim OutPutMsg As String = ""
Dim sw As New System.IO.StreamWriter(Server.MapPath("../Marquee.html"), False, System.Text.Encoding.UTF8)

'取得SQL 資料庫內容
'***************************************************************************************************************
Dim ads As New AccessDataSource("~/App_Data/AAA.mdb", "")
Dim dv As Data.DataView
Dim sb As New StringBuilder
Dim i As Integer
Dim markS As String = " "
ads.SelectCommand = " SELECT * FROM [marquee] WHERE VIS = 1 ORDER BY CTIME DESC "
dv = ads.Select(New DataSourceSelectArguments)
If dv.Count <> 0 Then
For i = 0 To dv.Count - 1
sb.Append("" & markS & markS & "" & markS & markS & dv.Item(i).Item("marqueeText") & " ")
Next
End If
sw.WriteLine(sb.ToString)
sw.Flush()
sw.Close()
sw.Dispose()

'***************************************************************************************************************

End Sub

WORDVBA 設定文件內的圖剪裁大小

Sub getPic()


Dim objDoc As Document
Dim oPic As InlineShape

Set objDoc = ActiveDocument
Application.ScreenUpdating = True

For Each oPic In objDoc.InlineShapes

oPic.PictureFormat.CropTop = 105
oPic.PictureFormat.CropBottom = 10
'oPic.ScaleHeight = 35 ', msoFalse, msoScaleFromTopLeft

Next
MsgBox "OK"

End Sub

EXCEL VBA 輸出陣列到 WORD TABLE(月曆) 摘要

'*******************************************************************
'
' 變數資料處理完成，傳送資料到WORD應用程式。
'
'*******************************************************************
Dim Myword As New Word.Application
Dim Newdoc As Word.Document
Dim tbl As Word.Table


'Set Myword = CreateObject("Word.Application")
Myword.Caption = ""

'Myword.ActiveDocument.Path
'Myword.Visible = True

Set Newdoc = Myword.Documents.Open(ThisWorkbook.Path & "\Month.doc", , True) '設定成「唯讀」以免資料被寫入。

Newdoc.FormFields("MonthV").Range.Text = SelMonth & "月份一覽表"

'NewDoc.FormFields("pName").Range.Text = Range("E2")

'*************************************************************8
'增加表格

SelDate = DateSerial(Year(Date), SelMonth, 1)
SelDate2 = DateAdd("m", 1, SelDate)
TotalDays = DateDiff("d", SelDate, SelDate2)
' Debug.Print SelDate & " " & SelDate2
' Debug.Print TotalDays & " " & Selw

'Exit Sub

Set tbl = Newdoc.Tables(1)

Dim Rows As Integer
Rows = 2
'依照(陣列)資料輸出到表格
For i = 1 To TotalDays
SelDate2 = DateAdd("d", i - 1, SelDate)
Selw = Weekday(SelDate2, vbSunday)

tbl.Cell(Rows - 1, Selw).Range.Text = SelMonth & "/" & Day(SelDate2) & "(" & TransWeekName(Selw) & ")"
tbl.Cell(Rows, Selw).Range.Text = DayArray(i)

Debug.Print " (" & (Rows - 1) & "," & Selw & ") " & SelMonth & "/" & Day(SelDate2) & "(" & TransWeekName(Selw) & ")"
Debug.Print " (" & (Rows) & "," & Selw & ") " & SelMonth & "/" & Day(SelDate2) & "(" & TransWeekName(Selw) & ")"

If Selw = 7 Then '7星期六 1 星期日
Rows = Rows + 2
End If
Next

If Rows <= 10 Then
tbl.Rows.Last.Delete
tbl.Rows.Last.Delete
End If


'修改滑鼠游標
'Me.MousePointer = vbNormal
Dim Fn As String
Fn = Year(Date) - 1911 & "-" & Month(Date) & "-" & Day(Date) & " [ " & SelMonth & " ]月份差假表" & ".doc"

Newdoc.SaveAs ThisWorkbook.Path & "\" & Fn

'清除與WORD物件的連結。
Newdoc.Close
Myword.Quit

Set Newdoc = Nothing
Set Myword = Nothing

MsgBox "請在程式所在目錄之下尋找剛才所建立的WORD檔案！" & vbCrLf & "檔名：" & Fn

EXCEL VBA ADO CRUD的命令執行

'載入資料庫 所需引用相關變數
Dim conn2 As New ADODB.Connection
Dim rs2 As ADODB.Recordset
Dim SqlString As String
Dim i As Integer

conn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & "\holidaydb.MDB"


SqlString = " insert into [db](rank,name,class,fromwhen,towhen,Hcount) values('" & _
x1 & "','" & x2 & "','" & x3 & "','" & x4 & "','" & x5 & "'," & x6 & ")"

conn2.Execute (SqlString)



ret = MsgBox("請問是否寄信通知當事人?", vbYesNo, "提醒寄送電子郵件")

If ret = vbYes Then
' Call MailSend(Range("B16"))
MsgBox "您已成功新增一筆資料，並寄出通知信!"
Else
MsgBox "您已成功新增一筆資料!"
End If




End Sub

EXCEL VBA ADO資料操作 WHILE WEND

'載入資料庫 所需引用相關變數
Dim conn2 As New ADODB.Connection
Dim rs2 As New ADODB.Recordset
Dim SqlString As String
Dim i As Integer

conn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & "\holidaydb.MDB"

SqlString = " select * From [DB] "

rs2.Open SqlString, conn2, adOpenKeyset, adLockOptimistic

rs2.MoveLast
rs2.Delete
rs2.Update

MsgBox "您已成功刪除[剛才建立的資料]!"

>>>>>>
While not rs2.eof
xxxxxxxxxxxxx
rs2.movenext
wend

EXCEL VBA呼叫OUTLOOK寄信(單一收件者，沒附件)

'產生郵件內容!! (傳入要寄送的EmailAddress)
Sub MailSend(ByVal EmailCC As String)

Dim i As Integer
Dim MailContent As String
Dim MySubject As String

'依照個人訊息決定的動態郵件內容
Dim MailComboMsg As String

Dim SenderEml As String '副本接收者

MySubject = Sheets("mailContent").Range("B1")
MailContent = Sheets("mailContent").Range("B2")
SenderEml = Sheets("mailContent").Range("B3")


'MailContent = Replace(MailContent, "", Sheets("input").Range("C5"))
'MailContent = Replace(MailContent, "", Sheets("input").Range("E5"))
'MailContent = Replace(MailContent, "", Sheets("input").Range("B7"))
'MailContent = Replace(MailContent, "", Sheets("input").Range("B13"))
'MailContent = Replace(MailContent, "", Sheets("input").Range("B14"))
'MailContent = Replace(MailContent, "", Sheets("input").Range("B15"))
'MsgBox MailContent
'Exit Sub

Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim newMail As Outlook.MailItem

Dim k As String
'目前清單的範圍



'同一個人代為聯絡的數量
Dim nCount As Integer
'Set fso = CreateObject("Scripting.FileSystemObject")

Set ol = New Outlook.Application
'Return a reference to the MAPI layer.
'-------------------------------------------------------------------------------------------------

'準備寫入郵件！
'******************************************************************************************
Set ns = ol.GetNamespace("MAPI")
ns.Logon
'Create a new mail message item.
Set newMail = ol.CreateItem(olMailItem)

With newMail

'Add the subject of the mail message.
.Subject = MySubject

'Create some body text.

'Add a recipient and CC and test to make sure that the
'addresses are valid using the Resolve method.
'郵件位址 判斷 使用者 是要使用 字串 或是 清單

'MsgBox "收件者：" & X.Value

With .Recipients.Add(EmailCC)

.Type = olTo

If Not .Resolve Then
MsgBox "Unable to resolve address: TO", vbInformation
Exit Sub
End If
End With


With .Recipients.Add(SenderEml)
.Type = olBCC
If Not .Resolve Then
MsgBox "Unable to resolve address: Bcc", vbInformation
Exit Sub
End If
End With

'.Body = txtContentString.Text
'"nnn@email.ccc.tw"

MailContent = Replace(MailContent, "", Sheets("input").Range("C5"))
MailContent = Replace(MailContent, "", Sheets("input").Range("E5"))
MailContent = Replace(MailContent, "", Sheets("input").Range("B7"))
MailContent = Replace(MailContent, "", Sheets("input").Range("B13"))
MailContent = Replace(MailContent, "", Sheets("input").Range("B14"))
MailContent = Replace(MailContent, "", Sheets("input").Range("B15"))

.Body = MailContent
'.Attachments.Add (ThisWorkbook.Path & "\xxxx.doc")
'.Attachments.Add (ThisWorkbook.Path & "\" & num1 & "文章.doc")

'Send the mail message.
.Send

End With

ns.Logoff

Set ns = Nothing
Set newMail = Nothing

'----------------------------------------------------------------------------------------------------
'Release memory.
Set ol = Nothing
'MsgBox "寄送完成"

End Sub

EXCEL VBA壓縮ACCESS資料庫(版本2003)

先在【專案】【設定引用項目】中加入 Microsoft Jet and Replication Objects X.X library

有密碼的版本
jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txt1.Text & ";Jet OLEDB:Database Password=" & txt2.Text, _
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txt3.Text & ";Jet OLEDB:Engine Type=5;Jet OLEDB:Database Password=" & txt4.Text
壓縮時，可同時改MDB的密碼


Public Sub CompactJetDatabase()
Dim ret

ret = MsgBox("請問是否進行資料壓縮?", vbYesNo, "資料庫壓縮")


If ret = vbNo Then
Exit Sub
End If


Dim SelDB As String
Dim SelDB2 As String
SelDB = ThisWorkbook.Path & "\" & "A1.mdb"
SelDB2 = ThisWorkbook.Path & "\" & "A2.mdb"



Dim jro As jro.JetEngine
Set jro = New jro.JetEngine

'引擎版本號
'Jet OLEDB:Engine Type -> Jet x.x Format MDB Files
'1 -> JET10
'2 -> JET11
'3 -> JET2X
'4 -> JET3X
'5 -> JET4X

jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & A1 , "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & A2 & ";Jet OLEDB:Engine Type=5"

Kill A1 '刪除舊的
Name A2 As A1 '變更名稱

MsgBox "壓縮/修復 成功!"




End Sub

EXCEL 計算 文字的ASCII碼

Sub cal()

'計算 文字的ASCII碼
Application.ScreenUpdating = False
Dim MyRng As Range
Dim x As Range
Dim i As Integer
Dim p As Integer

Dim cnt As Double


Set MyRng = Range("C2:C" & Range("C65535").End(xlUp).Row)

For Each x In MyRng

p = Len(x.Value)

For i = 1 To p
cnt = cnt + Asc(Mid(x.Value, i, 1))

Next
x.Offset(0, 1).Value = cnt
cnt = 0
Next

MsgBox "SUCCESS"

End Sub

[野生動物保育法]筆記：非業者賣放生鳥的法律責任(純屬個人見解)

Q 路邊販賣放生鳥(非保育類)的人，有無法律責任，目前找的資料參考如下


第三十六條
以營利為目的，經營野生動物之飼養、繁殖、買賣、加工、進口或出口者，應先向直轄市、縣 (市) 主管機關申請許可，並依法領得營業證照，方得為之。
野生動物之飼養、繁殖、管理辦法，由中央主管機關定之。



第四十九條
有下列情形之一，處新台幣六萬元以上三十萬元以下罰鍰：
一、違反第十七條第一項或第二項管制事項者。
二、違反第十九條第一項規定，使用禁止之方式，獵捕一般類野生動物者。
三、違反第十九條第二項或第三十三條規定，規避、拒絕或妨礙者。
四、違反第二十七條第一項規定者。
五、違反第三十四條規定，其場所及設備不符合標準者。
六、違反第十八條第二項或第三十六條規定，未申請許可者。
違反第十七條第一項、第二項或第十九條第一項規定，該管直轄市、縣 (市) 主管機關得撤銷其許可證。


Q 抓放生鳥的方法(不得以下列方法為之)


第十九條
獵捕野生動物，不得以下列方法為之：
一、使用炸藥或其他爆裂物。
二、使用毒物。
三、使用電氣、麻醉物或麻痺之方法。
四、架設網具。
五、使用獵槍以外之其他種類槍械。
六、使用陷阱、獸鋏或特殊獵捕工具。
七、其他經主管機關公告禁止之方法。
未經許可擅自設置網具、陷阱、獸鋏或其他獵具，主管機關得逕予拆除並銷毀之。土地所有人、使用人或管理人不得規避、拒絕或妨礙。

WPF 圖檔與設定至SHAPE

'宣告陣列，將陣列值加入LIST控件中
Dim ss() As String = {"hills.jpg", "Suns.jpg", "lilies.jpg", "Wins.jpg"}
Lst_Img.Items.Add(ss(0))
Lst_Img.Items.Add(ss(1))
Lst_Img.Items.Add(ss(2))
Lst_Img.Items.Add(ss(3))

'插入圖片
Private Function ImgAddIn() As Boolean

Dim Imgbmp As BitmapImage = New BitmapImage() '圖片物件
Dim ImgBrh As ImageBrush = New ImageBrush() '影像筆刷

'BitmapImage
Imgbmp = New BitmapImage(New Uri(sAdImg, UriKind.RelativeOrAbsolute))
ImgBrh.ImageSource = Imgbmp '影像控件 載入 圖片

Dim res As Boolean
'只有圓,矩形,橢圓可以設定圖檔
Select Case SelNm.Substring(0, 2)
Case "Ci"
Canvas_Draw.Children(SelNo).SetValue(Ellipse.FillProperty, ImgBrh)
res = True
Case "Re"
Canvas_Draw.Children(SelNo).SetValue(Rectangle.FillProperty, ImgBrh)
res = True
Case "Ep"
Canvas_Draw.Children(SelNo).SetValue(Ellipse.FillProperty, ImgBrh)
res = True
End Select
Return res
End Function

WPF 刪除物件

'找出選取物件
If Canvas_Draw.FindName("Rec" + RecRec(0).ToString()) IsNot Nothing Then
Canvas_Draw.Children.RemoveAt(RecRec(0))
AllNo = AllNo - 1
End If
If Canvas_Draw.FindName("Rec" + RecRec(1).ToString()) IsNot Nothing Then
Canvas_Draw.Children.RemoveAt(RecRec(1) - 1)
AllNo = AllNo - 1
End If


'刪除選取的元件
Dim Rs As MessageBoxResult
Rs = MessageBox.Show("確定要刪除" + SelNm + "嗎?", "刪除元件", MessageBoxButton.OKCancel)
If Rs.ToString() = "OK" Then
Canvas_Draw.Children.RemoveAt(SelNo)
End If
Bdel = False

WPF 計算移動量

Public Sub EpsAdj(ByVal adjN)
Dim w1, h1, dx, dy As Double
'上方,垂直調整
If adjN = 0 Then

'計算垂直移動量
dy = CurPos.Y - Atp

If Math.Abs(dy) < h1 =" Math.Abs(Ahh"> Ahh Then
h1 = Math.Abs(Ahh + dy)
End If

If h1 > 0.0 Then
Canvas_Draw.Children(SelNo).SetValue(Canvas.LeftProperty, Alf)
Canvas_Draw.Children(SelNo).SetValue(Canvas.TopProperty, CurPos.Y)
Canvas_Draw.Children(SelNo).SetValue(Ellipse.WidthProperty, Aww)
Canvas_Draw.Children(SelNo).SetValue(Ellipse.HeightProperty, h1)
End If
ElseIf adjN = 1 Then
'計算垂直移動量
dx = CurPos.X - OldPos.X
If Math.Abs(dy) < w1 =" Math.Abs(Aww"> Aww Then
w1 = Math.Abs(Aww + dx)
End If
If w1 > 0.0 Then
Canvas_Draw.Children(SelNo).SetValue(Canvas.LeftProperty, Alf)
Canvas_Draw.Children(SelNo).SetValue(Canvas.TopProperty, Atp)
Canvas_Draw.Children(SelNo).SetValue(Ellipse.WidthProperty, w1)
Canvas_Draw.Children(SelNo).SetValue(Ellipse.HeightProperty, Ahh)
End If
ElseIf adjN = 2 Then

'計算垂直移動量
dy = CurPos.Y - OldPos.Y
If Math.Abs(dy) < h1 =" Math.Abs(Ahh"> Ahh Then
h1 = Math.Abs(Ahh - dy)
End If


End Sub

WPF 取得Children下的屬性

SelNo是先前取得的位置，若物件有增刪，就要重新取得
GetValue還要看物件是哪一種，再確認

Mh = Canvas_Draw.Children(SelNo).GetValue(Ellipse.HeightProperty)
Mw = Canvas_Draw.Children(SelNo).GetValue(Line.X2Property)

WPF 選取物件範例

Public Sub SelObj(ByVal e As System.Windows.Input.MouseEventArgs)
Dim OPos As Point = e.GetPosition(Me.Canvas_Draw)
Dim i As Integer
Dim s1 As String = ""
Dim sObj As String = ""
Dim x11, ww, y11, hh As Double

'找出選取物件
For i = 0 To Canvas_Draw.Children.Count - 1
s1 = Canvas_Draw.Children(i).GetValue(NameProperty)
Select Case s1.Substring(0, 2)
Case "Pt"
x11 = Canvas_Draw.Children(i).GetValue(Canvas.LeftProperty)
ww = x11 + Canvas_Draw.Children(i).GetValue(Canvas.WidthProperty)
y11 = Canvas_Draw.Children(i).GetValue(Canvas.TopProperty)
hh = y11 + Canvas_Draw.Children(i).GetValue(Canvas.HeightProperty)
If ((x11 <> OPos.X) And (y11 <> OPos.Y)) Then
sObj = i.ToString() + ","
SelNo = i
SelNm = s1
End If
Case "Ln"
x11 = Canvas_Draw.Children(i).GetValue(Canvas.LeftProperty)
ww = x11 + Canvas_Draw.Children(i).GetValue(Line.X2Property)
y11 = Canvas_Draw.Children(i).GetValue(Canvas.TopProperty)
hh = y11 + Canvas_Draw.Children(i).GetValue(Line.Y2Property)
If ((x11 <> OPos.X) And (y11 <> OPos.Y)) Or _
((x11 <> OPos.X) And (y11 > OPos.Y And hh <> OPos.X And ww <> OPos.Y)) Or _
((x11 > OPos.X And ww <> OPos.Y And hh < sobj =" i.ToString()" selno =" i" selnm =" s1" x11 =" Canvas_Draw.Children(i).GetValue(Canvas.LeftProperty)" ww =" x11" y11 =" Canvas_Draw.Children(i).GetValue(Canvas.TopProperty)" hh =" y11"> OPos.X) And (y11 <> OPos.Y)) Then
sObj = i.ToString() + ","
SelNo = i
SelNm = s1
End If
Case "Ep"
x11 = Canvas_Draw.Children(i).GetValue(Canvas.LeftProperty)
ww = x11 + Canvas_Draw.Children(i).GetValue(Canvas.WidthProperty)
y11 = Canvas_Draw.Children(i).GetValue(Canvas.TopProperty)
hh = y11 + Canvas_Draw.Children(i).GetValue(Canvas.HeightProperty)
If ((x11 <> OPos.X) And (y11 <> OPos.Y)) Then
sObj = i.ToString() + ","
SelNo = i
SelNm = s1
End If
Case "Re"
x11 = Canvas_Draw.Children(i).GetValue(Canvas.LeftProperty)
ww = x11 + Canvas_Draw.Children(i).GetValue(Canvas.WidthProperty)
y11 = Canvas_Draw.Children(i).GetValue(Canvas.TopProperty)
hh = y11 + Canvas_Draw.Children(i).GetValue(Canvas.HeightProperty)
If ((x11 <> OPos.X) And (y11 <> OPos.Y)) Then
sObj = i.ToString() + ","
SelNo = i
SelNm = s1
End If
End Select
Next
'如果多個被選取,取出距離最小
If sObj <> "" Then
sObj = sObj.Substring(0, sObj.Length - 1)
Dim ss1() As String
ss1 = sObj.Split(",")
Dim xc() As Double = New Double(ss1.Count) {}
Dim yc() As Double = New Double(ss1.Count) {}
Dim Lst1 As New List(Of Double)
Dim Lst2 As New List(Of Double)
Dim Lst3 As New List(Of Integer)
Dim minV As Double = 0

'判定被選取物件
For i = 0 To ss1.Count - 1
Dim nn As Integer = CInt(ss1(i))
Lst3.Add(nn)
Select Case SelNm.Substring(0, 2)
Case "Pt"
xc(i) = (Canvas_Draw.Children(nn).GetValue(Canvas.LeftProperty) + Canvas_Draw.Children(nn).GetValue(Canvas.WidthProperty)) / 2
yc(i) = (Canvas_Draw.Children(nn).GetValue(Canvas.TopProperty) + Canvas_Draw.Children(nn).GetValue(Canvas.HeightProperty)) / 2
Dim dd As Double = System.Math.Sqrt((OPos.X - xc(i)) * (OPos.X - xc(i)) + (OPos.Y - yc(i)) * (OPos.Y - yc(i)))
Lst1.Add(dd)
Lst2.Add(dd)
Case "Ln"
xc(i) = Canvas_Draw.Children(nn).GetValue(Line.X1Property) + Canvas_Draw.Children(nn).GetValue(Line.X2Property) / 2
yc(i) = Canvas_Draw.Children(nn).GetValue(Line.Y1Property) + Canvas_Draw.Children(nn).GetValue(Line.Y2Property) / 2
Dim dd As Double = System.Math.Sqrt((OPos.X - xc(i)) * (OPos.X - xc(i)) + (OPos.Y - yc(i)) * (OPos.Y - yc(i)))
Lst1.Add(dd)
Lst2.Add(dd)
Case "Ci"
xc(i) = (Canvas_Draw.Children(nn).GetValue(Canvas.LeftProperty) + Canvas_Draw.Children(nn).GetValue(Canvas.WidthProperty)) / 2
yc(i) = (Canvas_Draw.Children(nn).GetValue(Canvas.TopProperty) + Canvas_Draw.Children(nn).GetValue(Canvas.HeightProperty)) / 2
Dim dd As Double = System.Math.Sqrt((OPos.X - xc(i)) * (OPos.X - xc(i)) + (OPos.Y - yc(i)) * (OPos.Y - yc(i)))
Lst1.Add(dd)
Lst2.Add(dd)
Case "Ep"
xc(i) = (Canvas_Draw.Children(nn).GetValue(Canvas.LeftProperty) + Canvas_Draw.Children(nn).GetValue(Canvas.WidthProperty)) / 2
yc(i) = (Canvas_Draw.Children(nn).GetValue(Canvas.TopProperty) + Canvas_Draw.Children(nn).GetValue(Canvas.HeightProperty)) / 2
Dim dd As Double = System.Math.Sqrt((OPos.X - xc(i)) * (OPos.X - xc(i)) + (OPos.Y - yc(i)) * (OPos.Y - yc(i)))
Lst1.Add(dd)
Lst2.Add(dd)
Case "Re"
xc(i) = (Canvas_Draw.Children(nn).GetValue(Canvas.LeftProperty) + Canvas_Draw.Children(nn).GetValue(Canvas.WidthProperty)) / 2
yc(i) = (Canvas_Draw.Children(nn).GetValue(Canvas.TopProperty) + Canvas_Draw.Children(nn).GetValue(Canvas.HeightProperty)) / 2
Dim dd As Double = System.Math.Sqrt((OPos.X - xc(i)) * (OPos.X - xc(i)) + (OPos.Y - yc(i)) * (OPos.Y - yc(i)))
Lst1.Add(dd)
Lst2.Add(dd)
End Select


Next
'排序
Lst1.Sort()
Dim n0 As Integer = Lst2.IndexOf(Lst1(0))
'取出物件號碼
Dim n1 As Integer = Lst3(n0)
'設定被選取物件為紅色
For i = 0 To Canvas_Draw.Children.Count - 1
If i <> n1 Then
Dim s7 As String = Canvas_Draw.Children(i).GetValue(NameProperty)
Select Case s7.Substring(0, 2)
Case "Pt"
Canvas_Draw.Children(i).SetValue(Ellipse.FillProperty, Ys)
Canvas_Draw.Children(i).SetValue(Ellipse.StrokeProperty, Ys)
Case "Ln"
Canvas_Draw.Children(i).SetValue(Line.StrokeProperty, Ys)
Case "Ci"
Canvas_Draw.Children(i).SetValue(Ellipse.StrokeProperty, Ys)
Case "Ep"
Canvas_Draw.Children(i).SetValue(Ellipse.StrokeProperty, Ys)
Case "Re"
Canvas_Draw.Children(i).SetValue(Rectangle.StrokeProperty, Ys)
End Select
Else
Select Case SelNm.Substring(0, 2)
Case "Pt"
Canvas_Draw.Children(i).SetValue(Ellipse.FillProperty, Rs)
Canvas_Draw.Children(i).SetValue(Ellipse.StrokeProperty, Rs)
Case "Ln"
Canvas_Draw.Children(i).SetValue(Line.StrokeProperty, Rs)
Case "Ci"
Canvas_Draw.Children(i).SetValue(Ellipse.StrokeProperty, Rs)
Case "Ep"
Canvas_Draw.Children(i).SetValue(Ellipse.StrokeProperty, Rs)
Case "Re"
Canvas_Draw.Children(i).SetValue(Rectangle.StrokeProperty, Rs)
End Select

End If
Next
End If
End Sub

WPF 遍歷 與 FindName

Try
'滑鼠水平移動量
Dim dx As Double = e.GetPosition(Me.Canvas_Draw).X - OldPos.X
'滑鼠垂直移動量
Dim dy As Double = e.GetPosition(Me.Canvas_Draw).Y - OldPos.Y
'計算圓半徑
Dim rr As Double = System.Math.Abs(System.Math.Sqrt(dx * dx + dy * dy))

'判定圓名稱是否不存在
If Me.Canvas_Draw.FindName("Cir" + CirNo.ToString()) Is Nothing Then
'建立新圓
Dim Cir As New Ellipse
Dim x1 As Double = OldPos.X - rr
Dim y1 As Double = OldPos.Y - rr
'設定名稱
Cir.SetValue(NameProperty, "Cir" + CirNo.ToString())
'設定圓左邊屬性
Cir.SetValue(Canvas.LeftProperty, x1)
'設定圓上邊屬性
Cir.SetValue(Canvas.TopProperty, y1)
'設定圓寬度屬性
Cir.Width = 2 * rr
'設定圓高度屬性
Cir.Height = 2 * rr
'設定顏色屬性
Cir.Stroke = Ys
'加入繪圖區
Me.Canvas_Draw.Children.Add(Cir)
txtInfo.Text = " 建立圓: Cir" + CirNo.ToString()
Else
'搜尋繪圖區所有元件
For i = 0 To Canvas_Draw.Children.Count - 1
'判定圓是否存在
If Canvas_Draw.Children(i).GetValue(NameProperty) = "Cir" + CirNo.ToString() Then
'改變圓寬度
Canvas_Draw.Children(i).SetValue(Ellipse.WidthProperty, rr)
'改變圓高度
Canvas_Draw.Children(i).SetValue(Ellipse.HeightProperty, rr)
End If
Next
End If
Catch e1 As Exception
'發生錯誤,布林參數設為false
Bcir = False
'圓號碼減一
CirNo = CirNo - 1
End Try

WPF 滑鼠座標 ELLIPSE

Dim OldPos, CurPos As Point
Dim cy As Color = Color.FromArgb(255, 255, 255, 0)
Dim Ys As Brush = New SolidColorBrush(cy)

'取得線第一點座標
OldPos = e.GetPosition(Me.Canvas_Draw)


Try
'取得滑鼠按下座標
p1 = e.GetPosition(Me.Canvas_Draw)
'建立一個橢圓物件,繪圓是用橢圓來表示
Dim pt1 = New Ellipse
'設定橢圓的名稱屬性
pt1.SetValue(NameProperty, "pt" + ptNo.ToString())
'設定橢圓的寬度屬性
pt1.SetValue(WidthProperty, 5.0)

'設定橢圓要填滿的顏色
pt1.Fill = Ys
'將元件加入繪圖區裡
Me.Canvas_Draw.Children.Add(pt1)

'顯示點座標資訊
Me.txtInfo.Text = "點" + ptNo.ToString() + "座標X=" + p1.X.ToString() + ",Y=" + p1.Y.ToString()
Catch e1 As Exception
MessageBox.Show("點錯誤" + e1.Message.ToString() & vbCrLf)
End Try

VB.net 呼叫 WORD code

'開啟 WORD 文件 '*************************************************************************************************** '別忘記新增 參考 WORD 11
Dim objWord As Object = CreateObject("Word.Application") '使用完後 就釋放資源 故使用Using
Dim objDoc
Dim objSelection
objWord.Visible = False
objDoc = objWord.Documents.Open(My.Application.Info.DirectoryPath & "\UserData.doc")
'objDoc = objWord.Documents.Add()
objSelection = objWord.Selection

'選擇題輸出
If chkopS.Checked = True Then
objSelection.TypeText("※ 科目:" & selSubject)
objSelection.TypeParagraph()
'objSelection.TypeText(DashLine)
'objSelection.TypeParagraph()
objSelection.TypeText(Sv(0))
objSelection.TypeParagraph()
End If

'取代特殊字串!
Const wdReplaceAll = 2
'取代1
objSelection.WholeStory()
objSelection.Find.ClearFormatting()
objSelection.Find.Replacement.ClearFormatting()
With objSelection.Find
.Text = "<---><---><--->"
.Replacement.Text = "^l"
.Forward = True
'.Wrap = objSelection.wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
objSelection.Find.Execute(Replace:=wdReplaceAll)



'objDoc = objWord.Documents.Open("c:\scripts\test.rtf")
objDoc.SaveAs(My.Application.Info.DirectoryPath & "\" & FN)
objDoc = Nothing
objWord.Quit()
objWord = Nothing
GC.Collect()

xml parsercode 資料庫(單純取得數量)ExecuteScalar(執行)ExecuteNonQuery

Dim xmlFile As String = MyFn
Dim MYsettings As New XmlReaderSettings '宣告 設定
MYsettings.IgnoreWhitespace = True '忽略空白
MYsettings.IgnoreProcessingInstructions = True '忽略前置處理指令
Dim Reader As XmlReader = XmlReader.Create(xmlFile, MYsettings)


While Reader.Read
'針對節點(Element)來做處理
Select Case Reader.NodeType
Case XmlNodeType.Element
'Reader.NodeType = XmlNodeType.Element
'Response.Write(Reader.Depth & " " & Reader.Name)
'************************************************************************************************************************************************** ' ' 只要有屬性擷取的問題時，都必須在此做處理！，不能跑到更內層去！ ' ' '************************************************************************************************************************************************** '取得 公司 '處理是否有[屬性值] 若有循序讀出
Dim Sn As String = Reader.Name
If Reader.HasAttributes Then
'MsgBox("進入屬性")
For i = 0 To Reader.AttributeCount - 1
Reader.MoveToAttribute(i)
'MsgBox(i & " " & Reader.ToString)
If Reader.Name = "電信業者" Then
If Sn = "目標電話" Then
Sv(8) = Reader.Value
Exit For
Else
Sv(9) = Reader.Value
Exit For
End If
End If
Next
Reader.MoveToElement() '返回到節點(Element)上
End If 'MsgBox(Sv(8)) 'Exit Sub


Select Case Reader.Depth '針對不同階層處理。
Case 1 '單號
RowDepth = True
GetReadn = Reader.Name
Select Case GetReadn
Case "文號", "業者"
MyC = Reader.ReadString
If Len(MyC) <> 0 Then
MyCCnt = MyCCnt & MyC & "_"
End If
Case "查詢日期"

********************************略過

'先取得單號
Dim SQL As String = "SELECT max(oid) as maxR FROM [OrderNo] " Dim cmd As OleDbCommand = New OleDbCommand(SQL, conn) '誇號裡的第一個是SQL的字串,第二個是資料庫的聯結=OleDbConnection
Dim v As Integer = CInt(cmd.ExecuteScalar)
Glo_Oid = v '記錄目前單號
'若找不到記錄，就自動重新產生！


SQL = "INSERT INTO [a1] ([a2], [a3] , [a4], [a5], [a6], [a7],[a8], [a9], [a10], [a11], [a12], [a13],[a14],[a15] ) " & _ " VALUES ('" & Sv(0) & "','" & Sv(1) & "','" & Sv(2) & "','" & Sv(3) & "','" & Sv(4) & "','" & Sv(5) & _ "','" & Sv(6) & "','" & Sv(7) & "','" & Sv(8) & "','" & Sv(9) & "','" & Sv(10) & "','" & Sv(11) & "','" & Sv(12) & "'," & MyC & ") "
'MsgBox(SQL)
cmd = New OleDbCommand(SQL, conn) '誇號裡的第一個是SQL的字串,第二個是資料庫的聯結=OleDbConnection
cmd.ExecuteNonQuery() '執行SQL

Mdi程式 切換表單

MDI主表單 Public Class MDIParent1
--------------------------------------------------------------
Private Sub ToolStripMenuItem_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles 地圖查詢ToolStripMenuItem.Click
Form3.MdiParent = Me
Form3.Show()
End Sub

VB.net 呼叫EXCEL CODE

'開啟EXCEL文件 '*************************************************************************************************** '別忘記新增 參考 EXCEL 11
Dim objExcel As Object = CreateObject("Excel.Application") '使用完後 就釋放資源 故使用Using Dim objBook As Object
objBook = objExcel.Workbooks.Open(My.Application.Info.DirectoryPath & "\output.xlt")

With objExcel
'.Visible = True
'.DisplayAlerts = False
'MsgBox(My.Application.Info.DirectoryPath)
End With


With objExcel.sheets("sheet1")
.Range("A1").offset(n, 0).Value =N
End With



Dim Ts As String = DateAndTime.Now.ToString()
Ts = Replace(Ts, "/", "-")
Ts = Replace(Ts, ":", "-")
Dim FN As String = "基本資料_" & Ts & ".xls" '建議電話只取前30個字以避免錯誤!

'Save the Workbook and quit Excel.
'objBook.SaveAs(My.Application.Info.DirectoryPath & "\" & DateAndTime.Year(Now) & "_" & DateAndTime.Month(Now) & "_" & DateAndTime.Day(Now) & ".xls")
objBook.SaveAs(My.Application.Info.DirectoryPath & "\" & FN)
objBook = Nothing
objExcel.Quit()
objExcel = Nothing
GC.Collect()

唯讀 ExecuteReader

'載入資料庫 '*************************************************************************************************** '資料庫指令!

Dim Str As String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=123.mdb"

Dim conn As OleDbConnection = New OleDbConnection(Str)

Dim dr As OleDbDataReader

conn.Open()
'組合要輸出的參數！ '取得要輸出的號碼

Dim SQL As String = ""

SQL += "SELECT * "

*******************略過

Dim cmd As OleDbCommand = New OleDbCommand(SQL, conn) '誇號裡的第一個是SQL的字串,第二個是資料庫的聯結=OleDbConnection

dr = cmd.ExecuteReader '執行SQL

While dr.Read
N= dr(0).ToString

End While

CheckedBox 全選/全不選

'全選"
For itm = 0 To CLBxmllist.Items.Count - 1
CLBxmllist.SetItemChecked(itm, True)
'CLBxmllist.SetSelected(itm, True) '設定取得 (現在用不著)
Next
'全不選"

For itm = 0 To CLBxmllist.Items.Count - 1
CLBxmllist.SetItemChecked(itm, False)
Next

資料庫刪除TABLE(Delete )

Me.Cursor = Cursors.WaitCursor

'資料庫指令!

Dim Str As String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=123.mdb"

Dim conn As OleDbConnection = New OleDbConnection(Str)

'刪除表1

conn.Open()

Dim SQL As String = "Delete * from OrderNo "

Dim cmd As OleDbCommand = New OleDbCommand(SQL, conn)

'誇號裡的第一個是SQL的字串,第二個是資料庫的聯結=OleDbConnection cmd.ExecuteNonQuery() '執行SQL

conn.Close()

'刪除表2

conn.Open()

*************略過

conn.Close()

Me.Cursor = Cursors.Default

載入某一個目錄下的檔案

'動態載入XML檔案
Dim mydir As String
mydir = My.Application.Info.DirectoryPath

'只顯示XML檔案
Dim TheDir As New DirectoryInfo(mydir)
Dim arrFiles() As FileInfo

arrFiles = TheDir.GetFiles
For Each arrfile As FileInfo In arrFiles
'If InStr(arrfile.ToString, ".xml", CompareMethod.Text) > 0 And InStr(arrfile.ToString, "WindowsA", CompareMethod.Text) = 0 Then

If InStr(arrfile.ToString, ".xml", CompareMethod.Text) > 0 And InStr(Mid(arrfile.ToString, 1, 1), "I", CompareMethod.Text) > 0 Then
'If InStr(arrfile.ToString, ".xml", CompareMethod.Text) > 0 Then CLBxmllist.Items.Add(arrfile.ToString) '取得 欄位值！
End If

Next

VB.net CheckedBox 遍覽

Dim hasChk 'ParseXML

For Each hasChk In CLBxmllist.CheckedIndices '將已核取的項目加入 分析

OutputTelno += CLBxmllist.Items(hasChk) & vbCrLf

Call ParseXML(CLBxmllist.Items(hasChk))

i += 1

Next

email code2

' 兩個收件人：GetMail1@gmail.com和GetMail2@gmail.com

Dim To_Address As String = "a.tw@gmail.com;b@yahoo.com.tw"
' 設定SMTPserver
Dim SMTP_Server As New System.Net.Mail.SmtpClient("smtp.sig.com")
Dim Mailmsg As New System.Net.Mail.MailMessage Dim MailBodyHtml As String

' 設定一個信件的附檔
Dim mail_attachment As New System.Net.Mail.Attachment("C:\test1.txt")

Mailmsg.IsBodyHtml = True ' 為html內容格式

' 此信的寄件人 Mailmsg.From = New Net.Mail.MailAddress(b@sig.com., "寄件人")
Mailmsg.Subject = "peterlion_主旨"
MailBodyHtml = "peterlion_Mail Message First"
MailBodyHtml &= "Mail Message Second"
Mailmsg.Body = MailBodyHtml
' 把附檔加入到Mail Mailmsg.Attachments.Add(mail_attachment)
' 將字串裡的;分為多個收件人

For Each MA As String In To_Address.Split(";")
Mailmsg.To.Add(New Net.Mail.MailAddress(MA, "收件人"))
Next

' 密件副本收件人 'Mailmsg.Bcc.Add(New Net.Mail.MailAddress("GetMail3@gmail.com", "密件副本")) Mailmsg.Priority = Net.Mail.MailPriority.High

' Smtp(Server) 的帳號與密碼 SMTP_Server.Credentials = New System.Net.NetworkCredential("username", "pwd")

'如果 SMTP 主機需要認證，必須先設定認證後才能呼叫這個方法。若要指定認證，請使用 UseDefaultCredentials 或 Credentials 屬性。
SMTP_Server.Send(Mailmsg)
MsgBox("OK")

mail code

Dim newMail As New System.Net.Mail.MailMessage
Dim ToAddress(,) As String = {{"a@yahoo.com.tw", "to"}, {"a.tw@gmail.com", "to"}}
'Dim CCAddress(,) As String = {{"cc@yahoo.com.tw", "cc"}, {"cc@msa.hinet.net", "cc"}}
'Dim BccAddress(,) As String = {{"bcc@yahoo.com.tw", "bcc"}, {"bcc@msa.hinet.net", "bcc"}}

Dim AttachFile() As String = {"C:\test1.txt", "C:\test2.txt"}
Dim smtpMail As New System.Net.Mail.SmtpClient
With newMail .From = New System.Net.Mail.MailAddress(a@sig.com, "from")
'寄件者 .Body = "Hello Every Body!!"
'內文 .Subject = "測試資料!!"
'主旨 .BodyEncoding = System.Text.Encoding.GetEncoding("BIG5") '編碼方式

For i As Int32 = 0 To ToAddress.GetUpperBound(1)
'收信人 .To.Add(New System.Net.Mail.MailAddress(ToAddress(i, 0), ToAddress(i, 1)))
Next

'For i As Int32 = 0 To CCAddress.GetUpperBound(1)
'副本 '.CC.Add(New System.Net.Mail.MailAddress(CCAddress(i, 0), CCAddress(i, 1)))
'Next
'For i As Int32 = 0 To BccAddress.GetUpperBound(1) '密件副本 '.Bcc.Add(New System.Net.Mail.MailAddress(BccAddress(i, 0), BccAddress(i, 1)))
'Next
'For i As Int32 = 0 To BccAddress.GetUpperBound(1) '夾檔 For i As Int32 = 0 To ToAddress.GetUpperBound(1) '收信人 .Attachments.Add(New System.Net.Mail.Attachment(AttachFile(i))) Next .IsBodyHtml = False ' True
'是否為HTML格式 .Priority = Net.Mail.MailPriority.Normal
'優先權 End With
Try
smtpMail.Host = "smtp.sig.com.tw"
smtpMail.SendAsync(newMail, "TEST") Catch ex As Exception MsgBox(ex.InnerException)
End Try
'My.Computer.Info. MsgBox("ok mailed")