Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Aralık 2011 Salı

Writeln Web Document


'A. Available References List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\OFFICE11\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'6) Name: SHDocVw, Description: Microsoft Internet Controls, FullPath: C:\Windows\SysWOW64\ieframe.dll
'B. Available Tools List
'1) İmage1, Label1, Label2
'2) WebBrowser1
Option Explicit
Private i As Single
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Boyut As RECT
Private Eleman As Worksheet
Private hwnd As Long
Private AnimateWidth As Integer
Private AnimateHeight As Integer
Private FormWidth As Integer
Private FormHeight As Integer
Private FormLeft As Integer
Private FormTop As Integer
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Writeln Web Document"
hwnd = FindWindow(vbNullString, Me.Caption)
With Application
.Visible = False
.DisplayAlerts = False
Call Add_Web_Document_Sheet
Call Ekran_Duzenle
Call Writeln_Web_Document
Call Form_Animate
.DisplayAlerts = False
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End Sub
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 36 + 6 + 252 + 12
.Width = 6 + 372 + 6
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectFlat
With Image1
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
End With
With Label1
.Left = 36
.Top = 6
.Height = 12
.Width = 420
.Caption = "Mustafa ULUSARAÇ"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With Label2
.Left = 36
.Top = 18
.Height = 12
.Width = 420
.Caption = ""
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With WebBrowser1
.Left = 6
.Top = 36
.Height = 252
.Width = 368
.FullScreen = False
.Resizable = False
.TheaterMode = False
.Navigate "about:blank"
Do While WebBrowser1.Busy
End With
End With
End Sub
Private Sub Add_Web_Document_Sheet()
On Error Resume Next
For Each Eleman In ThisWorkbook.Sheets
If Eleman.Name = "WebDocumen" Then GoTo Devam
Next Eleman
ThisWorkbook.Sheets.Add Sheets(1)
ActiveSheet.Name = "WebDocumen"
With Sheets("WebDocumen")
Selection.Delete Shift:=xlUp
.Cells(1, 1) = "@Object Classid='Clsid:6BF52A52-394A-11d3-B153-00C04F79FAA6' Height='300' ID='Player1' Width='472'æ"
.Cells(2, 1) = "@Param Name='URL' value=''/æ"
.Cells(3, 1) = "@Param Name='volume' value='50'/æ"
.Cells(4, 1) = "@Param Name='playCount' value='2'/æ"
.Cells(5, 1) = "@Param Name='uiMode' value='mini'/æ"
.Cells(6, 1) = "@/Objectæ"
.Cells(7, 1) = "@Body Scroll='No' Style='Border-Width:0'/æ"
.Cells(8, 1) = "@Body BackGround=''/æ"
End With
Cells.Replace What:="@", Replacement:="<", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="æ", Replacement:=">", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub
Private Sub Writeln_Web_Document()
On Error Resume Next
i = 1
With ThisWorkbook.Sheets("WebDocumen")
Do While .Cells(i, 1) <> ""
WebBrowser1.Document.writeln .Cells(i, 1).Text
i = i + 1
End With
End Sub
Sub Form_Animate()
On Error Resume Next
AnimateWidth = GetSystemMetrics32(0)
AnimateHeight = GetSystemMetrics32(1)
GetWindowRect hwnd, Boyut
FormWidth = VBA.Abs(Boyut.Right - Boyut.Left)
FormHeight = VBA.Abs(Boyut.Top - Boyut.Bottom)
FormLeft = (AnimateWidth - FormWidth) / 2
FormTop = (AnimateHeight - FormHeight) / 2
SetWindowPos hwnd, 0&, FormLeft, FormTop, 0&, 0&, &H1
AnimateWindow hwnd, 800, &H10 Or &H20000
End Sub


Option Explicit
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Public Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public IPic(15) As Byte
Public Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Public Const URL1 As String = ""
Public Const URL2 As String = ""
Public URL As String
Sub Form_Aç() 'Open UserForm
On Error Resume Next
UserForm1.Show 0
End Sub
Public Function Resim(URL) As Picture 'Picture load frome web address...
On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim
End Function
'Sub References_List()
' On Error Resume Next
' Dim Eleman, No
' No = 1
' For Each Eleman In ThisWorkbook.VBProject.References
' Sheets(1).Cells(No, 1) = No & ") Name: "
' Sheets(1).Cells(No, 2) = Eleman.Name
' Sheets(1).Cells(No, 3) = ", Description: "
' Sheets(1).Cells(No, 4) = Eleman.Description
' Sheets(1).Cells(No, 5) = ", FullPath: "
' Sheets(1).Cells(No, 6) = Eleman.FullPath
' No = No + 1
' Next Eleman
'End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara


Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul