Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Eylül 2012 Cumartesi

MiDocView MODI Viewer



'UserForm1

'A 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: MODI, Description: Microsoft Office Document Imaging 11.0 Type Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\MODI\11.0\MDIVWCTL.DLL
'B Additional Tolls List
'1) Image1, Label1, label2
'2) MiDocView1
'3) CommandButton1, ComboBox1, CommandButton2, Slider1, CommandButton3, CheckBox1, Image2
Private MDVd As MODI.Document
Private MDVv As MODI.MiDocView
Private MDVi As MODI.Image
Private SourceURL As String
Private SourceFileName As String
Private TargetMDVFile As String
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] MiDocView MODI Viewer"
Call Ekran_Kur
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
MiDocView1.Filename = ""
Set MDVi = Nothing
Set MDVv = Nothing
Set MDVd = Nothing
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
MiDocView1.Filename = ""
Set MDVi = Nothing
Set MDVv = Nothing
Set MDVd = Nothing
MiDocView1.Filename = "C:\Users\MU\Documents\Fax\Inbox\WelcomeFax.tif"
Image2.Picture = LoadPicture("")
End Sub
Private Sub CommandButton2_Click()
On Error Resume Next
MiDocView1.Filename = ""
Set MDVv = New MiDocView
Set MDVd = New MODI.Document
MDVv.Document = MDVd
SourceURL = ComboBox1.List(ComboBox1.ListIndex, 1)
SourceFileName = ThisWorkbook.Path & "\MDVObject.bmp"
TargetMDVFile = ThisWorkbook.Path & "\MDVObject.tif"
Download_File SourceURL, SourceFileName
MDVd.Create SourceFileName
Set MDVi = MDVd.Images(0)
MDVi.Rotate 0
MDVi.OCR miLANG_ENGLISH
MDVd.SaveAs TargetMDVFile, miFILE_FORMAT_TIFF
MDVd.Close
MiDocView1.Filename = ""
Set MDVi = Nothing
Set MDVv = Nothing
Set MDVd = Nothing
MiDocView1.Filename = TargetMDVFile
Image2.Picture = LoadPicture(SourceFileName)
End Sub
Private Sub CommandButton3_Click()
On Error Resume Next
Set MDVv = MiDocView1
Set MDVd = MDVv.Document
Set MDVi = MDVd.Images(0)
MDVi.Rotate 90
Set MDVv = Nothing
Set MDVd = Nothing
Set MDVi = Nothing
End Sub
Private Sub Slider1_Click()
On Error Resume Next
Set MDVv = MiDocView1
Set MDVd = MDVv.Document
Set MDVi = MDVd.Images(0)
MDVv.SetScale Slider1.Value, Slider1.Value
Set MDVv = Nothing
Set MDVd = Nothing
Set MDVi = Nothing
End Sub
Private Sub CheckBox1_Click()
On Error Resume Next
Set MDVv = MiDocView1
Set MDVd = MDVv.Document
Set MDVi = MDVd.Images(0)
If CheckBox1.Value = True Then
MDVv.FitMode = miByWindow
MDVv.SetScale 0, 0
Else
MDVv.FitMode = miFree
MDVv.SetScale 1, 1
End If
Set MDVv = Nothing
Set MDVd = Nothing
Set MDVi = Nothing
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 388
.Width = 568
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
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 = 318
.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 = 318
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With MiDocView1
.Top = 36
.Left = 6
.Width = 444
.Height = 324
.Filename = ""
.DocViewMode = miDOCVIEWMODE_CONTINOUSPAGEVIEW
.FitMode = miFree
.ActionState = miASTATE_PAN
.GetScale 1, 1
End With
With CommandButton1
.Top = 36
.Left = 456
.Width = 102
.Height = 24
.Caption = "Get Modi Document"
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With ComboBox1
.Top = 66
.Left = 456
.Width = 102
.Height = 24
.ForeColor = &H808000
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectEtched
.ColumnCount = 2
.ColumnWidths = "100;1"
.AddItem "Mona Lisa": .List(0, 1) = "http://upload.wikimedia.org/wikipedia/commons/6/6a/Mona_Lisa.jpg"
.AddItem "Iron Shoes": .List(1, 1) = "http://features.cgsociety.org/stories/2005_05/girl_iron_shoes/the-girl-in-the-iron-shoes.jpg"
.AddItem "Northumberland": .List(2, 1) = "http://www.artchive.com/artchive/c/canaletto/canaletto_northumberland.jpg"
.AddItem "Canaletto": .List(3, 1) = "http://upload.wikimedia.org/wikipedia/commons/5/52/Canaletto_%28II%29_007.jpg"
.AddItem "Rembrandt 1661": .List(4, 1) = "http://www.energyenhancement.org/rembrandt_1661.jpg"
.AddItem "Frans Hals": .List(5, 1) = "http://laurashefler.net/arthistory/wp-content/uploads/2011/07/Frans_Hals_014.jpg"
.AddItem "Harmensz van Rijn": .List(6, 1) = "http://www.oceansbridge.com/paintings/german/Rembrandt_Harmensz._van_Rijn_026_OBNP2009-Y08089.jpg"
.AddItem "The Nightwatch": .List(7, 1) = "http://laurashefler.net/arthistory/wp-content/uploads/2011/07/The_Nightwatch_by_Rembrandt.jpg"
.AddItem "Galileo Galilei 1636": .List(8, 1) = "http://www.bence10.com/wp-content/uploads/2010/09/Justus_Sustermans_-_Portrait_of_Galileo_Galilei_1636.jpg"
.ListIndex = 0
End With
With CommandButton2
.Top = 96
.Left = 456
.Width = 102
.Height = 24
.Caption = "Create Modi Document"
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Slider1
.Top = 126
.Left = 456
.Width = 102
.Height = 24
.Min = 1
.Max = 10
.SmallChange = 1
.Value = 1
End With
With CommandButton3
.Top = 156
.Left = 456
.Width = 102
.Height = 24
.Caption = "Rotate 90º"
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With CheckBox1
.Top = 186
.Left = 456
.Width = 102
.Height = 24
.Caption = "FitMode = miByWindow"
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Image2
.Top = 216
.Left = 456
.Height = 144
.Width = 102
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = VBA.RGB(120, 120, 120)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeZoom
.PictureTiling = False
End With
End With
End Sub

'Module1

Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
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 = "http://2.bp.blogspot.com/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp"
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg"
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
Public Function Download_File(ByVal SourceURL As String, ByVal SourceFileName As String)
On Error Resume Next
URLDownloadToFile 0&, SourceURL, SourceFileName, 0&, 0&
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

Contributor

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